diff options
| -rw-r--r-- | bytecomp/translclass.ml | 16 | ||||
| -rw-r--r-- | bytecomp/translobj.ml | 2 | ||||
| -rw-r--r-- | bytecomp/translobj.mli | 2 | ||||
| -rw-r--r-- | driver/optcompile.ml | 6 | ||||
| -rw-r--r-- | ocamlbuild/Makefile | 2 | ||||
| -rw-r--r-- | otherlibs/bigarray/bigarray.mli | 36 | ||||
| -rw-r--r-- | otherlibs/threads/Makefile | 4 | ||||
| -rw-r--r-- | parsing/lexer.mll | 8 | ||||
| -rw-r--r-- | stdlib/lexing.mli | 7 | ||||
| -rw-r--r-- | stdlib/string.mli | 82 | ||||
| -rw-r--r-- | typing/ctype.ml | 40 | ||||
| -rw-r--r-- | typing/oprint.ml | 14 | ||||
| -rw-r--r-- | typing/typemod.ml | 2 | ||||
| -rw-r--r-- | win32caml/inria.h | 2 |
14 files changed, 138 insertions, 85 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index d186bdebf..cf5783a97 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -607,12 +607,20 @@ let transl_class ids cl_id arity pub_meths cl vflag = let meth_ids = get_class_meths cl in let subst env lam i0 new_ids' = let fv = free_variables lam in + (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (IdentSet.elements fv); *) let fv = List.fold_right IdentSet.remove !new_ids' fv in - let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in - (* need to handle methods specially (PR#3576) *) - let fm = IdentSet.diff (free_methods lam) meth_ids in - let fv = IdentSet.union fv fm in + (* We need to handle method ids specially, as they do not appear + in the typing environment (PR#3576, PR#4560) *) + (* very hacky: we add and remove free method ids on the fly, + depending on the visit order... *) + method_ids := + IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids; + (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids); + prerr_ids "method_ids =" (IdentSet.elements !method_ids); *) + let new_ids = List.fold_right IdentSet.add new_ids !method_ids in + let fv = IdentSet.inter fv new_ids in new_ids' := !new_ids' @ IdentSet.elements fv; + (* prerr_ids "new_ids' =" !new_ids'; *) let i = ref (i0-1) in List.fold_left (fun subst id -> diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 9899e44b3..e97fbfc13 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -123,6 +123,7 @@ let transl_store_label_init glob size f arg = let wrapping = ref false let top_env = ref Env.empty let classes = ref [] +let method_ids = ref IdentSet.empty let oo_add_class id = classes := id :: !classes; @@ -138,6 +139,7 @@ let oo_wrap env req f x = cache_required := req; top_env := env; classes := []; + method_ids := IdentSet.empty; let lambda = f x in let lambda = List.fold_left diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index d6e432da5..26fa504b4 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -24,5 +24,7 @@ val transl_label_init: lambda -> lambda val transl_store_label_init: Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda +val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) + val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 0aa947953..240427ca3 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -113,6 +113,8 @@ let implementation ppf sourcefile outputprefix = let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; + let cmxfile = outputprefix ^ ".cmx" in + let objfile = outputprefix ^ ext_obj in try if !Clflags.print_types then ignore( Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number @@ -129,11 +131,13 @@ let implementation ppf sourcefile outputprefix = +++ Simplif.simplify_lambda +++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Asmgen.compile_implementation outputprefix ppf; - Compilenv.save_unit_info (outputprefix ^ ".cmx"); + Compilenv.save_unit_info cmxfile; end; Warnings.check_fatal (); Pparse.remove_preprocessed inputfile with x -> + remove_file objfile; + remove_file cmxfile; Pparse.remove_preprocessed_if_ast inputfile; raise x diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index 66166c34f..84dcc47be 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -43,7 +43,7 @@ ppcache: $(OCAMLBUILD) ppcache.byte ppcache.native doc: $(OCAMLBUILD) ocamlbuild.docdir/index.html - ln -sf $(BUILDDIR)/ocamlbuild.docdir doc + ln -s -f $(BUILDDIR)/ocamlbuild.docdir doc else all byte native: ocamlbuild.byte.start mkdir -p boot diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 8c681351e..a49923ae2 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -227,7 +227,7 @@ module Genarray : Big arrays returned by [Genarray.create] are not initialized: the initial values of array elements is unspecified. - [Genarray.create] raises [Invalid_arg] if the number of dimensions + [Genarray.create] raises [Invalid_argument] if the number of dimensions is not in the range 1 to 16 inclusive, or if one of the dimensions is negative. *) @@ -243,7 +243,7 @@ module Genarray : big array [a]. The first dimension corresponds to [n = 0]; the second dimension corresponds to [n = 1]; the last dimension, to [n = Genarray.num_dims a - 1]. - Raise [Invalid_arg] if [n] is less than 0 or greater or equal than + Raise [Invalid_argument] if [n] is less than 0 or greater or equal than [Genarray.num_dims a]. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" @@ -262,7 +262,7 @@ module Genarray : and strictly less than the corresponding dimensions of [a]. If [a] has Fortran layout, the coordinates must be greater or equal than 1 and less or equal than the corresponding dimensions of [a]. - Raise [Invalid_arg] if the array [a] does not have exactly [N] + Raise [Invalid_argument] if the array [a] does not have exactly [N] dimensions, or if the coordinates are outside the array bounds. If [N > 3], alternate syntax is provided: you can write @@ -280,7 +280,7 @@ module Genarray : The array [a] must have exactly [N] dimensions, and all coordinates must lie inside the array bounds, as described for [Genarray.get]; - otherwise, [Invalid_arg] is raised. + otherwise, [Invalid_argument] is raised. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN} <- v] instead of @@ -304,7 +304,7 @@ module Genarray : array [a]. [Genarray.sub_left] applies only to big arrays in C layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate + Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 0], or [len < 0], or [ofs + len > Genarray.nth_dim a 0]. *) @@ -324,7 +324,7 @@ module Genarray : array [a]. [Genarray.sub_right] applies only to big arrays in Fortran layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate + Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *) @@ -343,7 +343,7 @@ module Genarray : the original array share the same storage space. [Genarray.slice_left] applies only to big arrays in C layout. - Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]] + Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external slice_right: @@ -361,7 +361,7 @@ module Genarray : the original array share the same storage space. [Genarray.slice_right] applies only to big arrays in Fortran layout. - Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]] + Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit @@ -458,14 +458,14 @@ module Array1 : sig [x] must be greater or equal than [0] and strictly less than [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, [x] must be greater or equal than [1] and less or equal than - [Array1.dim a]. Otherwise, [Invalid_arg] is raised. *) + [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" (** [Array1.set a x v], also written [a.{x} <- v], stores the value [v] at index [x] in [a]. [x] must be inside the bounds of [a] as described in {!Bigarray.Array1.get}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" @@ -539,14 +539,14 @@ module Array2 : returns the element of [a] at coordinates ([x], [y]). [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], stores the value [v] at coordinates ([x], [y]) in [a]. [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" @@ -645,7 +645,7 @@ module Array3 : returns the element of [a] at coordinates ([x], [y], [z]). [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_set_3" @@ -653,7 +653,7 @@ module Array3 : stores the value [v] at coordinates ([x], [y], [z]) in [a]. [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" @@ -754,17 +754,17 @@ external genarray_of_array3 : val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t (** Return the one-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly one dimension. *) val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t (** Return the two-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly two dimensions. *) val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t (** Return the three-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly three dimensions. *) @@ -784,7 +784,7 @@ val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t The returned big array must have exactly the same number of elements as the original big array [b]. That is, the product of the dimensions of [b] must be equal to [i1 * ... * iN]. - Otherwise, [Invalid_arg] is raised. *) + Otherwise, [Invalid_argument] is raised. *) val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t (** Specialized version of {!Bigarray.reshape} for reshaping to diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 6a060ba18..0e6ef86ff 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -84,10 +84,10 @@ marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi unix.mli: $(UNIXLIB)/unix.mli - ln -sf $(UNIXLIB)/unix.mli unix.mli + ln -s -f $(UNIXLIB)/unix.mli unix.mli unix.cmi: $(UNIXLIB)/unix.cmi - ln -sf $(UNIXLIB)/unix.cmi unix.cmi + ln -s -f $(UNIXLIB)/unix.cmi unix.cmi unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml diff --git a/parsing/lexer.mll b/parsing/lexer.mll index d856efff4..c2e693dc4 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -136,9 +136,11 @@ let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - if (c < 0 || c > 255) && not (in_comment ()) - then raise (Error(Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else raise (Error(Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) else Char.chr c let char_for_hexadecimal_code lexbuf i = diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 1868825ce..884bf3844 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -62,10 +62,11 @@ type lexbuf = The lexer buffer holds the current state of the scanner, plus a function to refill the buffer from the input. - Note that the lexing engine will only change the [pos_cnum] field + At each token, the lexing engine will copy [lex_curr_p] to + [lex_start_p], then change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read - since the start of the [lexbuf]. The other fields are copied - without change by the lexing engine. In order to keep them + since the start of the [lexbuf]. The other fields are left + unchanged by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the lexbuf, and updated by the relevant lexer actions (i.e. at each end of line -- see also [new_line]). diff --git a/stdlib/string.mli b/stdlib/string.mli index 203d42d12..21bfb7c0e 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -13,37 +13,47 @@ (* $Id$ *) -(** String operations. *) +(** String operations. + Given a string [s] of length [l], we call character number in [s] + the index of a character in [s]. Indexes start at [0], and we will + call a character number valid in [s] if it falls within the range + [[0...l-1]]. A position is the point between two characters or at + the beginning or end of the string. We call a position valid + in [s] if it falls within the range [[0...l]]. Note that character + number [n] is between positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. - The first character is character number 0. - The last character is character number [String.length s - 1]. You can also write [s.[n]] instead of [String.get s n]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) + Raise [Invalid_argument] if [n] not a valid character number in [s]. *) external set : string -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) + + Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. -*) + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string @@ -51,16 +61,16 @@ val copy : string -> string val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], - containing the characters number [start] to [start + len - 1] - of string [s]. + containing the substring of [s] that starts at position [start] and + has length [len]. + Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]; that is, if [start < 0], - or [len < 0], or [start + len > ]{!String.length}[ s]. *) + designate a valid substring of [s]. *) val fill : string -> int -> int -> char -> unit (** [String.fill s start len c] modifies string [s] in place, - replacing the characters number [start] to [start + len - 1] - by [c]. + replacing [len] characters by [c], starting at [start]. + Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) @@ -69,7 +79,8 @@ val blit : string -> int -> string -> int -> int -> unit from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same string, - and the source and destination chunks overlap. + and the source and destination intervals overlap. + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) @@ -91,25 +102,33 @@ val escaped : string -> string not a copy. *) val index : string -> char -> int -(** [String.index s c] returns the position of the leftmost +(** [String.index s c] returns the character number of the first occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int -(** [String.rindex s c] returns the position of the rightmost +(** [String.rindex s c] returns the character number of the last occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int -(** Same as {!String.index}, but start - searching at the character position given as second argument. - [String.index s c] is equivalent to [String.index_from s 0 c].*) +(** [String.index_from s i c] returns the character number of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int -(** Same as {!String.rindex}, but start - searching at the character position given as second argument. +(** [String.rindex_from s i c] returns the character number of the + last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. *) + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] @@ -117,15 +136,18 @@ val contains : string -> char -> bool val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] - appears in the substring of [s] starting from [start] to the end - of [s]. - Raise [Invalid_argument] if [start] is not a valid index of [s]. *) + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] - appears in the substring of [s] starting from the beginning - of [s] to index [stop]. - Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters diff --git a/typing/ctype.ml b/typing/ctype.ml index 8a4fb9bbf..21a898a98 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1471,6 +1471,9 @@ let mkvariant fields closed = {row_fields = fields; row_closed = closed; row_more = newvar(); row_bound = (); row_fixed = false; row_name = None }) +(* force unification in Reither when one side has as non-conjunctive type *) +let rigid_variants = ref false + (**** Unification ****) (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) @@ -1819,7 +1822,8 @@ and unify_row_field env fixed1 fixed2 l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2) && + (m1 || m2 || + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> if c1 || c2 then raise (Unify []); @@ -2241,6 +2245,12 @@ let matches env ty ty' = (* Equivalence between parameterized types *) (*********************************************) +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head_unif env ty in + rigid_variants := old; ty' + let normalize_subst subst = if List.exists (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) @@ -2265,8 +2275,8 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> - let t1' = expand_head_unif env t1 in - let t2' = expand_head_unif env t2 in + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else @@ -2320,10 +2330,9 @@ and eqtype_list rename type_pairs subst env tl1 tl2 = and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields2, rest2) = flatten_fields ty2 in (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env rest2 with + match expand_head_rigid env rest2 with {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; @@ -2346,10 +2355,9 @@ and eqtype_kind k1 k2 = and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env (row_more row2) with + match expand_head_rigid env (row_more row2) with {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if row1.row_closed <> row2.row_closed @@ -2790,6 +2798,10 @@ let rec build_subtype env visited loops posi level t = ty1, tl1 | _ -> raise Not_found in + (* Fix PR4505: do not set ty to Tvar when it appears in tl1, + as this occurence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; ty.desc <- Tvar; let t'' = newvar () in let loops = (ty, t'') :: loops in @@ -3168,8 +3180,8 @@ let rec normalize_type_rec env ty = | Tvariant row -> let row = row_repr row in let fields = List.map - (fun (l,f) -> - let f = row_field_repr f in l, + (fun (l,f0) -> + let f = row_field_repr f0 in l, match f with Reither(b, ty::(_::_ as tyl), m, e) -> let tyl' = List.fold_left @@ -3178,10 +3190,8 @@ let rec normalize_type_rec env ty = then tyl else ty::tyl) [ty] tyl in - if List.length tyl' <= List.length tyl then - let f = Reither(b, List.rev tyl', m, ref None) in - set_row_field e f; - f + if f != f0 || List.length tyl' < List.length tyl then + Reither(b, List.rev tyl', m, e) else f | _ -> f) row.row_fields in diff --git a/typing/oprint.ml b/typing/oprint.ml index 819489750..e1c617ef1 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -55,11 +55,13 @@ let float_repres f = | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then valid_float_lexeme s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then valid_float_lexeme s2 else - Printf.sprintf "%.18g" f + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; @@ -340,7 +342,7 @@ and print_out_sig_item ppf = | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s :@ %a@]" + fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with Orec_not -> "module" | Orec_first -> "module rec" | Orec_next -> "and") diff --git a/typing/typemod.ml b/typing/typemod.ml index c0714ada8..d931a1692 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -888,7 +888,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (str, coercion) end else begin check_nongen_schemes finalenv str; - normalize_signature finalenv sg; + normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg "(inferred signature)" simple_sg in diff --git a/win32caml/inria.h b/win32caml/inria.h index 8b0ad2262..095cbcc75 100644 --- a/win32caml/inria.h +++ b/win32caml/inria.h @@ -63,7 +63,7 @@ #include "editbuffer.h" #include "history.h" -#if _MSC_VER <= 1200 +#if _MSC_VER <= 1200 && !defined(__MINGW32__) #define GetWindowLongPtr GetWindowLong #define SetWindowLongPtr SetWindowLong #define DWLP_USER DWL_USER |