@@ -139,6 +139,8 @@ type type_mismatch =
139139 | Record_representation of record_representation * record_representation
140140 | Unboxed_representation of bool (* true means second one is unboxed *)
141141 | Immediate
142+ | Tag_name
143+ | Variant_representation of Ident .t
142144
143145let report_type_mismatch0 first second decl ppf err =
144146 let pr fmt = Format. fprintf ppf fmt in
@@ -183,6 +185,9 @@ let report_type_mismatch0 first second decl ppf err =
183185 (if b then second else first) decl
184186 " uses unboxed representation"
185187 | Immediate -> pr " %s is not an immediate type" first
188+ | Tag_name -> pr " Their @tag annotations differ"
189+ | Variant_representation s ->
190+ pr " The internal representations for case %s are not equal" (Ident. name s)
186191
187192let report_type_mismatch first second decl ppf =
188193 List. iter
@@ -232,6 +237,17 @@ and compare_variants ~loc env params1 params2 n
232237 compare_constructor_arguments ~loc env cd1.cd_id
233238 params1 params2 cd1.cd_args cd2.cd_args
234239 in
240+ let r =
241+ if r <> [] then r
242+ else match Ast_untagged_variants. is_nullary_variant cd1.cd_args with
243+ | true ->
244+ let tag_type1 = Ast_untagged_variants. process_tag_type cd1.cd_attributes in
245+ let tag_type2 = Ast_untagged_variants. process_tag_type cd2.cd_attributes in
246+ if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id]
247+ else []
248+ | false ->
249+ r
250+ in
235251 if r <> [] then r
236252 else compare_variants ~loc env params1 params2 (n+ 1 ) rem1 rem2
237253 end
@@ -320,8 +336,14 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
320336 | _ -> []
321337 in
322338 if err <> [] then err else
339+ let err =
340+ let tag1 = Ast_untagged_variants. process_tag_name decl1.type_attributes in
341+ let tag2 = Ast_untagged_variants. process_tag_name decl2.type_attributes in
342+ if tag1 <> tag2 then [Tag_name ] else err in
343+ if err <> [] then err else
323344 let err = match (decl1.type_kind, decl2.type_kind) with
324345 (_ , Type_abstract) -> []
346+ (* XXX *)
325347 | (Type_variant cstrs1 , Type_variant cstrs2 ) ->
326348 let mark cstrs usage name decl =
327349 List. iter
0 commit comments