Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions src/fsharp/TastPickle.fs
Original file line number Diff line number Diff line change
Expand Up @@ -2018,15 +2018,16 @@ and u_attribs_ext extraf st = u_list_ext extraf u_attrib st
and u_unioncase_spec st =
let a = u_rfield_table st
let b = u_ty st
let c = u_string st

// The union case compiled name is now computed from Id field when needed and is not stored in UnionCase record.
let _c = u_string st
let d = u_ident st
// The XmlDoc is only present in the extended in-memory format. We detect its presence using a marker bit here
let xmldoc, e = u_attribs_ext u_xmldoc st
let f = u_string st
let i = u_access st
{ FieldTable=a
ReturnType=b
CompiledName=c
Id=d
Attribs=e
XmlDoc= defaultArg xmldoc XmlDoc.Empty
Expand Down
33 changes: 15 additions & 18 deletions src/fsharp/TypeChecker.fs
Original file line number Diff line number Diff line change
Expand Up @@ -12254,11 +12254,15 @@ module TcRecdUnionAndEnumDeclarations = begin
// Bind other elements of type definitions (constructors etc.)
//-------------------------------------------------------------------------

let CheckUnionCaseName cenv realUnionCaseName m =
CheckNamespaceModuleOrTypeName cenv.g (mkSynId m realUnionCaseName)
if not (String.isUpper realUnionCaseName) && realUnionCaseName <> opNameCons && realUnionCaseName <> opNameNil then
errorR(NotUpperCaseConstructor(m))

let CheckUnionCaseName cenv (id: Ident) =
let name = id.idText
if name = "Tags" then
errorR(Error(FSComp.SR.tcUnionCaseNameConflictsWithGeneratedType(name, "Tags"), id.idRange))

CheckNamespaceModuleOrTypeName cenv.g id
if not (String.isUpper name) && name <> opNameCons && name <> opNameNil then
errorR(NotUpperCaseConstructor(id.idRange))

let ValidateFieldNames (synFields : SynField list, tastFields : RecdField list) =
let seen = Dictionary()
for (sf, f) in List.zip synFields tastFields do
Expand All @@ -12278,16 +12282,9 @@ module TcRecdUnionAndEnumDeclarations = begin
let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs // the attributes of a union case decl get attached to the generated "static factory" method
let vis, _ = ComputeAccessAndCompPath env None m vis None parent
let vis = CombineReprAccess parent vis
let realUnionCaseName =
if id.idText = opNameCons then "Cons"
elif id.idText = opNameNil then "Empty"
else id.idText

if realUnionCaseName = "Tags" then
errorR(Error(FSComp.SR.tcUnionCaseNameConflictsWithGeneratedType(realUnionCaseName, "Tags"), m))

CheckUnionCaseName cenv realUnionCaseName id.idRange


CheckUnionCaseName cenv id

let mkName nFields i = if nFields <= 1 then "Item" else "Item"+string (i+1)
let rfields, recordTy =
match args with
Expand All @@ -12311,7 +12308,7 @@ module TcRecdUnionAndEnumDeclarations = begin
if not (typeEquiv cenv.g recordTy thisTy) then
error(Error(FSComp.SR.tcReturnTypesForUnionMustBeSameAsType(), m))
rfields, recordTy
NewUnionCase id realUnionCaseName rfields recordTy attrs (xmldoc.ToXmlDoc()) vis
NewUnionCase id rfields recordTy attrs (xmldoc.ToXmlDoc()) vis


let TcUnionCaseDecls cenv env parent (thisTy : TType) tpenv unionCases =
Expand Down Expand Up @@ -15538,8 +15535,8 @@ module EstablishTypeDefinitionCores =

structLayoutAttributeCheck(false)
noAllowNullLiteralAttributeCheck()
TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName.idText unionCaseName.idRange
let unionCase = NewUnionCase unionCaseName unionCaseName.idText [] thisTy [] XmlDoc.Empty tycon.Accessibility
TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName
let unionCase = NewUnionCase unionCaseName [] thisTy [] XmlDoc.Empty tycon.Accessibility
writeFakeUnionCtorsToSink [ unionCase ]
MakeUnionRepr [ unionCase ], None, NoSafeInitInfo

Expand Down
13 changes: 8 additions & 5 deletions src/fsharp/tast.fs
Original file line number Diff line number Diff line change
Expand Up @@ -1580,9 +1580,6 @@ and
/// Return type constructed by the case. Normally exactly the type of the enclosing type, sometimes an abbreviation of it
ReturnType: TType

/// Name of the case in generated IL code
CompiledName: string

/// Documentation for the case
XmlDoc : XmlDoc

Expand Down Expand Up @@ -1618,6 +1615,13 @@ and

member uc.DisplayName = uc.Id.idText

/// Name of the case in generated IL code.
member uc.CompiledName =
let idText = uc.Id.idText
if idText = opNameCons then "Cons"
elif idText = opNameNil then "Empty"
else idText

member uc.RecdFieldsArray = uc.FieldTable.FieldsByIndex

member uc.RecdFields = uc.FieldTable.FieldsByIndex |> Array.toList
Expand Down Expand Up @@ -5618,9 +5622,8 @@ let NewTypar (kind,rigid,Typar(id,staticReq,isCompGen),isFromError,dynamicReq,at

let NewRigidTypar nm m = NewTypar (TyparKind.Type,TyparRigidity.Rigid,Typar(mkSynId m nm,NoStaticReq,true),false,TyparDynamicReq.Yes,[],false,false)

let NewUnionCase id nm tys rty attribs docOption access : UnionCase =
let NewUnionCase id tys rty attribs docOption access : UnionCase =
{ Id=id
CompiledName=nm
XmlDoc=docOption
XmlDocSig=""
Accessibility=access
Expand Down
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
// #Conformance #TypesAndModules #Unions
// RegressionTest for bug 6308
//<Expects status="error" id="FS1219" span="(7,7-7,19)">The union case named 'Tags' conflicts with the generated type 'Tags'</Expects>
//<Expects status="error" id="FS1219" span="(7,7-7,11)">The union case named 'Tags' conflicts with the generated type 'Tags'</Expects>
[<DefaultAugmentation(false)>]
type BigUnion2 =
| Case0
Expand Down
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
// #Conformance #TypesAndModules #Unions
// RegressionTest for bug 6308
//<Expects status="error" id="FS1219" span="(9,7-9,19)">The union case named 'Tags' conflicts with the generated type 'Tags'</Expects>
//<Expects status="error" id="FS1219" span="(9,7-9,11)">The union case named 'Tags' conflicts with the generated type 'Tags'</Expects>
//<Expects status="notin" id="FS0023" span="(21,14-21,17)">The member 'Tag' can not be defined because the name 'Tag' clashes with the generated property 'Tag' in this type or module</Expects>

[<DefaultAugmentation(true)>]
Expand Down