From 3e7a5220b9d8ba8fca841cec8156d9f160df3fa0 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 10 Aug 2022 20:12:45 +0200 Subject: [PATCH 01/16] Merge? --- src/Compiler/AbstractIL/il.fs | 12 +- src/Compiler/AbstractIL/il.fsi | 6 +- ...shCompare.fs => AugmentTypeDefinitions.fs} | 87 +++-- ...Compare.fsi => AugmentTypeDefinitions.fsi} | 6 +- src/Compiler/Checking/CheckDeclarations.fs | 351 ++++++++++-------- src/Compiler/Checking/CheckExpressions.fs | 9 +- src/Compiler/Checking/CheckExpressions.fsi | 3 + src/Compiler/Checking/ConstraintSolver.fs | 4 +- src/Compiler/Checking/MethodOverrides.fs | 4 +- src/Compiler/Checking/NameResolution.fs | 8 +- src/Compiler/Checking/NicePrint.fs | 8 +- src/Compiler/Checking/PostInferenceChecks.fs | 2 +- src/Compiler/Checking/infos.fs | 14 + src/Compiler/Checking/infos.fsi | 6 + src/Compiler/CodeGen/EraseUnions.fs | 4 +- src/Compiler/Driver/CompilerImports.fs | 2 +- src/Compiler/FSComp.txt | 1 + src/Compiler/Facilities/LanguageFeatures.fs | 3 + src/Compiler/Facilities/LanguageFeatures.fsi | 1 + src/Compiler/Symbols/Symbols.fs | 7 + src/Compiler/Symbols/Symbols.fsi | 3 + src/Compiler/TypedTree/TcGlobals.fs | 16 +- src/Compiler/TypedTree/TypedTree.fs | 16 +- src/Compiler/TypedTree/TypedTreeOps.fs | 20 + src/Compiler/TypedTree/TypedTreeOps.fsi | 5 + .../FSharp.Compiler.ComponentTests.fsproj | 1 + .../Language/DiscriminatedUnionTests.fs | 73 ++++ ...erService.SurfaceArea.netstandard.expected | 2 + tests/fsharp/core/namespaces/test.fs | 19 +- tests/fsharp/core/namespaces/test.fsi | 10 + tests/fsharp/core/namespaces/test2.fs | 7 + tests/fsharp/tests.fs | 10 +- 32 files changed, 516 insertions(+), 204 deletions(-) rename src/Compiler/Checking/{AugmentWithHashCompare.fs => AugmentTypeDefinitions.fs} (95%) rename src/Compiler/Checking/{AugmentWithHashCompare.fsi => AugmentTypeDefinitions.fsi} (87%) create mode 100644 tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index c0104807dcc..a7e81bf97ff 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -20,6 +20,7 @@ open System.Text open System.Threading open FSharp.Compiler.AbstractIL.Diagnostics +open FSharp.Compiler.Features open Internal.Utilities.Library open Internal.Utilities @@ -3335,7 +3336,8 @@ type ILGlobals ( primaryScopeRef: ILScopeRef, assembliesThatForwardToPrimaryAssembly: ILAssemblyRef list, - fsharpCoreAssemblyScopeRef: ILScopeRef + fsharpCoreAssemblyScopeRef: ILScopeRef, + langVersion: LanguageVersion ) = let assembliesThatForwardToPrimaryAssembly = @@ -3397,14 +3399,16 @@ type ILGlobals || assembliesThatForwardToPrimaryAssembly |> Array.exists aref.EqualsIgnoringVersion + member _.langVersion = langVersion + /// For debugging [] member x.DebugText = x.ToString() override x.ToString() = "" -let mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) = - ILGlobals(primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) +let mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef, langVersion) = + ILGlobals(primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef, langVersion) let mkNormalCall mspec = I_call(Normalcall, mspec, None) @@ -4702,7 +4706,7 @@ let DummyFSharpCoreScopeRef = ILScopeRef.Assembly asmRef let PrimaryAssemblyILGlobals = - mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef) + mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef, LanguageVersion("default")) let rec decodeCustomAttrElemType bytes sigptr x = match x with diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 32528348907..6f3709124f3 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -1830,6 +1830,8 @@ type internal ILGlobals = member fsharpCoreAssemblyScopeRef: ILScopeRef + member langVersion: LanguageVersion + /// Is the given assembly possibly a primary assembly? /// In practice, a primary assembly is an assembly that contains the System.Object type definition /// and has no referenced assemblies. @@ -1844,7 +1846,8 @@ type internal ILGlobals = val internal mkILGlobals: primaryScopeRef: ILScopeRef * assembliesThatForwardToPrimaryAssembly: ILAssemblyRef list * - fsharpCoreAssemblyScopeRef: ILScopeRef -> + fsharpCoreAssemblyScopeRef: ILScopeRef * + langVersion: LanguageVersion -> ILGlobals val internal PrimaryAssemblyILGlobals: ILGlobals @@ -1918,6 +1921,7 @@ val internal mkILNonGenericStaticMethSpecInTy: ILType * string * ILType list * I /// Construct references to constructors. val internal mkILCtorMethSpecForTy: ILType * ILType list -> ILMethodSpec +val internal mkILNonGenericCtorMethSpec: ILTypeRef * ILType list -> ILMethodSpec /// Construct references to fields. val internal mkILFieldRef: ILTypeRef * string * ILType -> ILFieldRef diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentTypeDefinitions.fs similarity index 95% rename from src/Compiler/Checking/AugmentWithHashCompare.fs rename to src/Compiler/Checking/AugmentTypeDefinitions.fs index 59d74eb0335..2e6548158ac 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// Generate the hash/compare functions we add to user-defined types by default. -module internal FSharp.Compiler.AugmentWithHashCompare +module internal FSharp.Compiler.AugmentTypeDefinitions open Internal.Utilities.Library open FSharp.Compiler.AbstractIL.IL @@ -61,6 +61,8 @@ let mkHashTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g let mkHashWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty) +let mkIsCaseTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.bool_ty) + //------------------------------------------------------------------------- // Polymorphic comparison //------------------------------------------------------------------------- @@ -861,14 +863,14 @@ let slotImplMethod (final, c, slotsig) : ValMemberInfo = IsImplemented=false ApparentEnclosingEntity=c} -let nonVirtualMethod c : ValMemberInfo = +let nonVirtualMethod mk c : ValMemberInfo = { ImplementedSlotSigs=[] MemberFlags={ IsInstance=true IsDispatchSlot=false IsFinal=false IsOverrideOrExplicitImpl=false GetterOrSetterIsCompilerGenerated=false - MemberKind=SynMemberKind.Member + MemberKind=mk Trivia=SynMemberFlagsTrivia.Zero} IsImplemented=false ApparentEnclosingEntity=c} @@ -879,35 +881,45 @@ let unaryArg = [ ValReprInfo.unnamedTopArg ] let tupArg = [ [ ValReprInfo.unnamedTopArg1; ValReprInfo.unnamedTopArg1 ] ] -let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData = - let m = tcref.Range +let mkValSpecAux g m (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter isCompGen = let tps = tcref.Typars m - let membInfo = - match slotsig with - | None -> nonVirtualMethod tcref - | Some slotsig -> - let final = isUnionTy g ty || isRecdTy g ty || isStructTy g ty + let membInfo = + match slotsig with + | None -> + let mk = if isGetter then SynMemberKind.PropertyGet else SynMemberKind.Member + nonVirtualMethod mk tcref + | Some slotsig -> + let final = isUnionTy g ty || isRecdTy g ty || isStructTy g ty slotImplMethod(final, tcref, slotsig) let inl = ValInline.Optional let args = ValReprInfo.unnamedTopArg :: argData - let valReprInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) - Construct.NewVal (methn, m, None, valTy, Immutable, true, valReprInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref) + let valReprInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) + Construct.NewVal (methn, m, None, valTy, Immutable, isCompGen, valReprInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref) + +let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter = + mkValSpecAux g tcref.Range tcref ty vis slotsig methn valTy argData isGetter true + +// Unlike other generated items, the 'IsABC' propeties are visible, not considered compiler-generated +let mkImpliedValSpec g m tcref ty vis slotsig methn valTy argData isGetter = + let v = mkValSpecAux g m tcref ty vis slotsig methn valTy argData isGetter false + v.SetIsImplied() + v -let MakeValsForCompareAugmentation g (tcref: TyconRef) = +let MakeValsForCompareAugmentation g (tcref: TyconRef) = let m = tcref.Range let _, ty = mkMinimalTy g tcref let tps = tcref.Typars m let vis = tcref.TypeReprAccessibility - mkValSpec g tcref ty vis (Some(mkIComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareObjTy g ty)) unaryArg, - mkValSpec g tcref ty vis (Some(mkGenericIComparableCompareToSlotSig g ty)) "CompareTo" (tps +-> (mkCompareTy g ty)) unaryArg - + mkValSpec g tcref ty vis (Some(mkIComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareObjTy g ty)) unaryArg false, + mkValSpec g tcref ty vis (Some(mkGenericIComparableCompareToSlotSig g ty)) "CompareTo" (tps +-> (mkCompareTy g ty)) unaryArg false + let MakeValsForCompareWithComparerAugmentation g (tcref: TyconRef) = let m = tcref.Range let _, ty = mkMinimalTy g tcref let tps = tcref.Typars m let vis = tcref.TypeReprAccessibility - mkValSpec g tcref ty vis (Some(mkIStructuralComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareWithComparerTy g ty)) tupArg + mkValSpec g tcref ty vis (Some(mkIStructuralComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareWithComparerTy g ty)) tupArg false let MakeValsForEqualsAugmentation g (tcref: TyconRef) = let m = tcref.Range @@ -915,17 +927,17 @@ let MakeValsForEqualsAugmentation g (tcref: TyconRef) = let vis = tcref.TypeReprAccessibility let tps = tcref.Typars m - let objEqualsVal = mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg - let nocEqualsVal = mkValSpec g tcref ty vis (if tcref.Deref.IsFSharpException then None else Some(mkGenericIEquatableEqualsSlotSig g ty)) "Equals" (tps +-> (mkEqualsTy g ty)) unaryArg + let objEqualsVal = mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg false + let nocEqualsVal = mkValSpec g tcref ty vis (if tcref.Deref.IsFSharpException then None else Some(mkGenericIEquatableEqualsSlotSig g ty)) "Equals" (tps +-> (mkEqualsTy g ty)) unaryArg false objEqualsVal, nocEqualsVal - + let MakeValsForEqualityWithComparerAugmentation g (tcref: TyconRef) = let _, ty = mkMinimalTy g tcref let vis = tcref.TypeReprAccessibility let tps = tcref.Typars tcref.Range - let objGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg - let withcGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashWithComparerTy g ty)) unaryArg - let withcEqualsVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg + let objGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg false + let withcGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashWithComparerTy g ty)) unaryArg false + let withcEqualsVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg false objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal let MakeBindingsForCompareAugmentation g (tycon: Tycon) = @@ -1094,3 +1106,32 @@ let rec TypeDefinitelyHasEquality g ty = (tinst, tcref.TyparsNoRange) ||> List.lengthsEqAndForall2 (fun ty tp -> not tp.EqualityConditionalOn || TypeDefinitelyHasEquality g ty) | _ -> false + +let MakeValsForUnionAugmentation g (tcref: TyconRef) = + let m = tcref.Range + let _, tmty = mkMinimalTy g tcref + let vis = tcref.TypeReprAccessibility + let tps = tcref.Typars m + + tcref.UnionCasesAsList + |> List.map (fun uc -> + // Unlike other generated items, the 'IsABC' propeties are visible, not considered compiler-generated + let v = mkImpliedValSpec g uc.Range tcref tmty vis None ("get_Is" + uc.CompiledName) (tps +-> (mkIsCaseTy g tmty)) unitArg true + g.AddValGeneratedAttributes v m + v + ) + +let MakeBindingsForUnionAugmentation g (tycon: Tycon) (vals: ValRef list) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + let tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty + + (tcref.UnionCasesAsRefList, vals) + ||> List.map2 (fun ucr v -> + let isdata = mkUnionCaseTest g (thise, ucr, tinst, m) + let expr = mkLambdas g m tps [thisv;unitv] (isdata, g.bool_ty) + mkCompGenBind v.Deref expr + ) \ No newline at end of file diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fsi b/src/Compiler/Checking/AugmentTypeDefinitions.fsi similarity index 87% rename from src/Compiler/Checking/AugmentWithHashCompare.fsi rename to src/Compiler/Checking/AugmentTypeDefinitions.fsi index ea991b0340d..5fa185c0460 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fsi +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fsi @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// Generate the hash/compare functions we add to user-defined types by default. -module internal FSharp.Compiler.AugmentWithHashCompare +module internal FSharp.Compiler.AugmentTypeDefinitions open FSharp.Compiler open FSharp.Compiler.TypedTree @@ -34,3 +34,7 @@ val MakeBindingsForEqualityWithComparerAugmentation: TcGlobals -> Tycon -> Bindi /// This predicate can be used once type inference is complete, before then it is an approximation /// that doesn't assert any new constraints val TypeDefinitelyHasEquality: TcGlobals -> TType -> bool + +val MakeValsForUnionAugmentation: TcGlobals -> TyconRef -> Val list + +val MakeBindingsForUnionAugmentation: TcGlobals -> Tycon -> ValRef list -> Binding list diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 23b08bd45ee..1e76f7fbcfb 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -686,7 +686,7 @@ let TcOpenDecl (cenv: cenv) mOpenDecl scopem env target = | SynOpenDeclTarget.Type (synType, m) -> TcOpenTypeDecl cenv mOpenDecl scopem env (synType, m) - + let MakeSafeInitField (g: TcGlobals) env m isStatic = let id = // Ensure that we have an g.CompilerGlobalState @@ -695,6 +695,140 @@ let MakeSafeInitField (g: TcGlobals) env m isStatic = let taccess = TAccess [env.eAccessPath] Construct.NewRecdField isStatic None id false g.int_ty true true [] [] XmlDoc.Empty taccess true +//------------------------------------------------------------------------- +// Build augmentation declarations +//------------------------------------------------------------------------- + +module AddAugmentationDeclarations = + let tcaugHasNominalInterface g (tcaug: TyconAugmentation) tcref = + tcaug.tcaug_interfaces |> List.exists (fun (x, _, _) -> + match tryTcrefOfAppTy g x with + | ValueSome tcref2 when tyconRefEq g tcref2 tcref -> true + | _ -> false) + + let AddGenericCompareDeclarations (cenv: cenv) (env: TcEnv) (scSet: Set) (tycon: Tycon) = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon && scSet.Contains tycon.Stamp then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let ty = if tcref.Deref.IsExceptionDecl then g.exn_ty else generalizedTyconRef g tcref + let m = tycon.Range + let genericIComparableTy = mkAppTy g.system_GenericIComparable_tcref [ty] + + + let hasExplicitIComparable = tycon.HasInterface g g.mk_IComparable_ty + let hasExplicitGenericIComparable = tcaugHasNominalInterface g tcaug g.system_GenericIComparable_tcref + let hasExplicitIStructuralComparable = tycon.HasInterface g g.mk_IStructuralComparable_ty + + if hasExplicitIComparable then + errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName), m)) + + elif hasExplicitGenericIComparable then + errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName), m)) + elif hasExplicitIStructuralComparable then + errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName), m)) + else + let hasExplicitGenericIComparable = tycon.HasInterface g genericIComparableTy + let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref + let cvspec3 = AugmentTypeDefinitions.MakeValsForCompareWithComparerAugmentation g tcref + + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralComparable_ty + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IComparable_ty + if not tycon.IsExceptionDecl && not hasExplicitGenericIComparable then + PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy + tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2) + tcaug.SetCompareWith (mkLocalValRef cvspec3) + PublishValueDefn cenv env ModuleOrMemberBinding cvspec1 + PublishValueDefn cenv env ModuleOrMemberBinding cvspec2 + PublishValueDefn cenv env ModuleOrMemberBinding cvspec3 + + let AddGenericEqualityWithComparerDeclarations (cenv: cenv) (env: TcEnv) (seSet: Set) (tycon: Tycon) = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon && seSet.Contains tycon.Stamp then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let m = tycon.Range + + let hasExplicitIStructuralEquatable = tycon.HasInterface g g.mk_IStructuralEquatable_ty + + if hasExplicitIStructuralEquatable then + errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName), m)) + else + let evspec1, evspec2, evspec3 = AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralEquatable_ty + tcaug.SetHashAndEqualsWith (mkLocalValRef evspec1, mkLocalValRef evspec2, mkLocalValRef evspec3) + PublishValueDefn cenv env ModuleOrMemberBinding evspec1 + PublishValueDefn cenv env ModuleOrMemberBinding evspec2 + PublishValueDefn cenv env ModuleOrMemberBinding evspec3 + + let AddGenericCompareBindings (cenv: cenv) (tycon: Tycon) = + if (* AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare cenv.g tycon && *) Option.isSome tycon.GeneratedCompareToValues then + AugmentTypeDefinitions.MakeBindingsForCompareAugmentation cenv.g tycon + else + [] + + let AddGenericCompareWithComparerBindings (cenv: cenv) (tycon: Tycon) = + if (* AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare cenv.g tycon && *) Option.isSome tycon.GeneratedCompareToWithComparerValues then + (AugmentTypeDefinitions.MakeBindingsForCompareWithComparerAugmentation cenv.g tycon) + else + [] + + let AddGenericEqualityWithComparerBindings (cenv: cenv) (tycon: Tycon) = + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals cenv.g tycon && Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then + (AugmentTypeDefinitions.MakeBindingsForEqualityWithComparerAugmentation cenv.g tycon) + else + [] + + let AddGenericHashAndComparisonDeclarations (cenv: cenv) (env: TcEnv) scSet seSet tycon = + AddGenericCompareDeclarations cenv env scSet tycon + AddGenericEqualityWithComparerDeclarations cenv env seSet tycon + + let AddGenericHashAndComparisonBindings cenv tycon = + AddGenericCompareBindings cenv tycon @ AddGenericCompareWithComparerBindings cenv tycon @ AddGenericEqualityWithComparerBindings cenv tycon + + // We can only add the Equals override after we've done the augmentation because we have to wait until + // tycon.HasOverride can give correct results + let AddGenericEqualityBindings (cenv: cenv) (env: TcEnv) tycon = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let ty = if tcref.Deref.IsExceptionDecl then g.exn_ty else generalizedTyconRef g tcref + let m = tycon.Range + + // Note: tycon.HasOverride only gives correct results after we've done the type augmentation + let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] + let hasExplicitGenericIEquatable = tcaugHasNominalInterface g tcaug g.system_GenericIEquatable_tcref + + if hasExplicitGenericIEquatable then + errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName), m)) + + // Note: only provide the equals method if Equals is not implemented explicitly, and + // we're actually generating Hash/Equals for this type + if not hasExplicitObjectEqualsOverride && + Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then + + let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref + tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2) + if not tycon.IsExceptionDecl then + PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy g.system_GenericIEquatable_tcref [ty]) + PublishValueDefn cenv env ModuleOrMemberBinding vspec1 + PublishValueDefn cenv env ModuleOrMemberBinding vspec2 + AugmentTypeDefinitions.MakeBindingsForEqualsAugmentation g tycon + else [] + else [] + + let ShouldAugmentUnion (g: TcGlobals) (tycon: Tycon) = + g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible && + HasDefaultAugmentationAttribute g (mkLocalTyconRef tycon) + + let AddUnionAugmentationValues (cenv: cenv) (env: TcEnv) tycon = + let tcref = mkLocalTyconRef tycon + let vals = AugmentTypeDefinitions.MakeValsForUnionAugmentation cenv.g tcref + for v in vals do + PublishValueDefnMaybeInclCompilerGenerated cenv env true ModuleOrMemberBinding v + vals + // Checking of mutually recursive types, members and 'let' bindings in classes // // Technique: multiple passes. @@ -1734,133 +1868,6 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env with exn -> errorRecovery exn scopem; [], envMutRec -//------------------------------------------------------------------------- -// Build augmentation declarations -//------------------------------------------------------------------------- - -module AddAugmentationDeclarations = - let tcaugHasNominalInterface g (tcaug: TyconAugmentation) tcref = - tcaug.tcaug_interfaces |> List.exists (fun (x, _, _) -> - match tryTcrefOfAppTy g x with - | ValueSome tcref2 when tyconRefEq g tcref2 tcref -> true - | _ -> false) - - let AddGenericCompareDeclarations (cenv: cenv) (env: TcEnv) (scSet: Set) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && scSet.Contains tycon.Stamp then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref - let m = tycon.Range - let genericIComparableTy = mkAppTy g.system_GenericIComparable_tcref [ty] - - - let hasExplicitIComparable = tycon.HasInterface g g.mk_IComparable_ty - let hasExplicitGenericIComparable = tcaugHasNominalInterface g tcaug g.system_GenericIComparable_tcref - let hasExplicitIStructuralComparable = tycon.HasInterface g g.mk_IStructuralComparable_ty - - if hasExplicitIComparable then - errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName), m)) - - elif hasExplicitGenericIComparable then - errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName), m)) - elif hasExplicitIStructuralComparable then - errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName), m)) - else - let hasExplicitGenericIComparable = tycon.HasInterface g genericIComparableTy - let cvspec1, cvspec2 = AugmentWithHashCompare.MakeValsForCompareAugmentation g tcref - let cvspec3 = AugmentWithHashCompare.MakeValsForCompareWithComparerAugmentation g tcref - - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralComparable_ty - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IComparable_ty - if not tycon.IsFSharpException && not hasExplicitGenericIComparable then - PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy - tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2) - tcaug.SetCompareWith (mkLocalValRef cvspec3) - PublishValueDefn cenv env ModuleOrMemberBinding cvspec1 - PublishValueDefn cenv env ModuleOrMemberBinding cvspec2 - PublishValueDefn cenv env ModuleOrMemberBinding cvspec3 - - let AddGenericEqualityWithComparerDeclarations (cenv: cenv) (env: TcEnv) (seSet: Set) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && seSet.Contains tycon.Stamp then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let m = tycon.Range - - let hasExplicitIStructuralEquatable = tycon.HasInterface g g.mk_IStructuralEquatable_ty - - if hasExplicitIStructuralEquatable then - errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName), m)) - else - let evspec1, evspec2, evspec3 = AugmentWithHashCompare.MakeValsForEqualityWithComparerAugmentation g tcref - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralEquatable_ty - tcaug.SetHashAndEqualsWith (mkLocalValRef evspec1, mkLocalValRef evspec2, mkLocalValRef evspec3) - PublishValueDefn cenv env ModuleOrMemberBinding evspec1 - PublishValueDefn cenv env ModuleOrMemberBinding evspec2 - PublishValueDefn cenv env ModuleOrMemberBinding evspec3 - - let AddGenericCompareBindings (cenv: cenv) (tycon: Tycon) = - if (* AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && *) Option.isSome tycon.GeneratedCompareToValues then - AugmentWithHashCompare.MakeBindingsForCompareAugmentation cenv.g tycon - else - [] - - let AddGenericCompareWithComparerBindings (cenv: cenv) (tycon: Tycon) = - let g = cenv.g - if Option.isSome tycon.GeneratedCompareToWithComparerValues then - AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon - else - [] - - let AddGenericEqualityWithComparerBindings (cenv: cenv) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then - (AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon) - else - [] - - let AddGenericHashAndComparisonDeclarations (cenv: cenv) (env: TcEnv) scSet seSet tycon = - AddGenericCompareDeclarations cenv env scSet tycon - AddGenericEqualityWithComparerDeclarations cenv env seSet tycon - - let AddGenericHashAndComparisonBindings cenv tycon = - AddGenericCompareBindings cenv tycon @ AddGenericCompareWithComparerBindings cenv tycon @ AddGenericEqualityWithComparerBindings cenv tycon - - // We can only add the Equals override after we've done the augmentation because we have to wait until - // tycon.HasOverride can give correct results - let AddGenericEqualityBindings (cenv: cenv) (env: TcEnv) tycon = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref - let m = tycon.Range - - // Note: tycon.HasOverride only gives correct results after we've done the type augmentation - let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] - let hasExplicitGenericIEquatable = tcaugHasNominalInterface g tcaug g.system_GenericIEquatable_tcref - - if hasExplicitGenericIEquatable then - errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName), m)) - - // Note: only provide the equals method if Equals is not implemented explicitly, and - // we're actually generating Hash/Equals for this type - if not hasExplicitObjectEqualsOverride && - Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then - - let vspec1, vspec2 = AugmentWithHashCompare.MakeValsForEqualsAugmentation g tcref - tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2) - if not tycon.IsFSharpException then - PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy g.system_GenericIEquatable_tcref [ty]) - PublishValueDefn cenv env ModuleOrMemberBinding vspec1 - PublishValueDefn cenv env ModuleOrMemberBinding vspec2 - AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon - else [] - else [] - - - /// Infer 'comparison' and 'equality' constraints from type definitions module TyconConstraintInference = @@ -1873,7 +1880,7 @@ module TyconConstraintInference = // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = set [ for tycon, _ in tyconsWithStructuralTypes do - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon then yield tycon.Stamp ] // Initially, don't assume that the equality relation is dependent on any type variables @@ -1937,8 +1944,8 @@ module TyconConstraintInference = assumedTycons |> Set.filter (fun tyconStamp -> let tycon, structuralTypes = tab[tyconStamp] - if g.compilingFSharpCore && - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && + if cenv.g.compilingFSharpCore && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon && not (HasFSharpAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoComparisonAttribute tycon.Attribs) then errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(), tycon.Range)) @@ -2004,7 +2011,7 @@ module TyconConstraintInference = // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = set [ for tycon, _ in tyconsWithStructuralTypes do - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then yield tycon.Stamp ] // Initially, don't assume that the equality relation is dependent on any type variables @@ -2043,7 +2050,7 @@ module TyconConstraintInference = | AppTy g (tcref, tinst) -> (if initialAssumedTycons.Contains tcref.Stamp then assumedTycons.Contains tcref.Stamp - elif AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tcref.Deref then + elif AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref then Option.isSome tcref.GeneratedHashAndEqualsWithComparerValues else true) @@ -2065,8 +2072,8 @@ module TyconConstraintInference = let tycon, structuralTypes = tab[tyconStamp] - if g.compilingFSharpCore && - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && + if cenv.g.compilingFSharpCore && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon && not (HasFSharpAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoEqualityAttribute tycon.Attribs) then errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(), tycon.Range)) @@ -2078,7 +2085,7 @@ module TyconConstraintInference = if not res then match TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs with | Some true -> - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsEquality tycon >> not) with | None -> assert false @@ -2093,7 +2100,7 @@ module TyconConstraintInference = | Some false -> () | None -> - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsEquality tycon >> not) with | None -> assert false @@ -3666,7 +3673,7 @@ module EstablishTypeDefinitionCores = // Build the initial Tycon for each type definition (fun (innerParent, _, envForDecls) (typeDefCore, tyconMemberInfo) -> - let (MutRecDefnsPhase1DataForTycon(_, _, _, _, _, isAtOriginalTyconDefn)) = typeDefCore + let (MutRecDefnsPhase1DataForTycon(isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = typeDefCore let tyconOpt = if isAtOriginalTyconDefn then Some (TcTyconDefnCore_Phase1A_BuildInitialTycon cenv envForDecls innerParent typeDefCore) @@ -3801,8 +3808,22 @@ module EstablishTypeDefinitionCores = // REVIEW: checking for cyclic inheritance is happening too late. See note above. TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons + // Generate the union augmentation values for all tycons. + let withBaseValsAndSafeInitInfosAndUnionValues = + (envMutRecPrelim, withBaseValsAndSafeInitInfos) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconOpt, fixupFinalAttrs, info) -> + let (tyconCore, _, _) = origInfo + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore + let vspecs = + match tyconOpt with + | Some tycon when isAtOriginalTyconDefn -> + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion cenv.g tycon then + AddAugmentationDeclarations.AddUnionAugmentationValues cenv envForDecls tycon + else + [] + | _ -> [] + (origInfo, tyconOpt, fixupFinalAttrs, info, vspecs)) - (tycons, envMutRecPrelim, withBaseValsAndSafeInitInfos) + (tycons, envMutRecPrelim, withBaseValsAndSafeInitInfosAndUnionValues) /// Bind declarations in implementation and signature files @@ -4149,9 +4170,14 @@ module TcDeclarations = cenv envInitial parent typeNames false tpenv m scopem mutRecNSInfo mutRecDefnsAfterSplit // Package up the phase two information for processing members. - let mutRecDefnsAfterPrep = + let unionValsLookup = Dictionary() + let mutRecDefnsAfterPrep = (envMutRecPrelim, mutRecDefnsAfterCore) - ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls ((typeDefnCore, members, innerParent), tyconOpt, fixupFinalAttrs, (baseValOpt, safeInitInfo)) -> + ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls ((typeDefnCore, members, innerParent), tyconOpt, fixupFinalAttrs, (baseValOpt, safeInitInfo), unionVals) -> + match tyconOpt with + | Some tycon when not unionVals.IsEmpty -> unionValsLookup.Add(tycon.Stamp, unionVals) + | _ -> () + let (MutRecDefnsPhase1DataForTycon(synTyconInfo, _, _, _, _, isAtOriginalTyconDefn)) = typeDefnCore let tyDeclRange = synTyconInfo.Range let (SynComponentInfo(_, TyparsAndConstraints (typars, cs1), cs2, longPath, _, _, _, _)) = synTyconInfo @@ -4189,7 +4215,6 @@ module TcDeclarations = // Check the members and decide on representations for types with implicit constructors. let withBindings, envFinal = TcMutRecDefns_Phase2 cenv envInitial m scopem mutRecNSInfo envMutRecPrelimWithReprs withEnvs - // Generate the hash/compare/equality bindings for all tycons. // // Note: generating these bindings must come after generating the members, since some in the case of structs some fields @@ -4204,7 +4229,16 @@ module TcDeclarations = // in, and there are code generation tests to check that. let binds = AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv tycon let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv envForDecls tycon - binds, binds3) + let binds4 = + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion g tycon then + let unionVals = + match unionValsLookup.TryGetValue(tycon.Stamp) with + | false, _ -> [] + | true, vs -> vs + AugmentTypeDefinitions.MakeBindingsForUnionAugmentation g tycon (List.map mkLocalValRef unionVals) + else + [] + binds@binds4, binds3) // Check for cyclic structs and inheritance all over again, since we may have added some fields to the struct when generating the implicit construction syntax EstablishTypeDefinitionCores.TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons @@ -4259,19 +4293,20 @@ module TcDeclarations = // 'type X with ...' in a signature is always interpreted as an extrinsic extension. // Representation-hidden types with members and interfaces are written 'type X = ...' - | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _ as r, _) when not (isNil extraMembers) -> + | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _ as repr, _) when not (isNil extraMembers) -> let isAtOriginalTyconDefn = false - let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + let repr = SynTypeDefnSimpleRepr.Exception exnRepr + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) tyconCore, (synTyconInfo, extraMembers) - | SynTypeDefnSigRepr.Exception r -> + | SynTypeDefnSigRepr.Exception exnRepr -> let isAtOriginalTyconDefn = true - let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, SynTypeDefnSimpleRepr.Exception r, implements1, false, false, isAtOriginalTyconDefn) + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, SynTypeDefnSimpleRepr.Exception exnRepr, implements1, false, false, isAtOriginalTyconDefn) core, (synTyconInfo, extraMembers) - | SynTypeDefnSigRepr.Simple(r, _) -> + | SynTypeDefnSigRepr.Simple(repr, _) -> let isAtOriginalTyconDefn = true - let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) tyconCore, (synTyconInfo, extraMembers) @@ -4279,9 +4314,9 @@ module TcDeclarations = let g = cenv.g (envMutRec, mutRecDefns) ||> MutRecShapes.mapWithEnv // Do this for the members in each 'type' declaration - (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _) -> + (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _, extraValSpecs) -> let tpenv = emptyUnscopedTyparEnv - let (MutRecDefnsPhase1DataForTycon (_, _, _, _, _, isAtOriginalTyconDefn)) = tyconCore + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore let (SynComponentInfo(_, TyparsAndConstraints (typars, cs1), cs2, longPath, _, _, _, m)) = synTyconInfo let cs = cs1 @ cs2 let declKind, tcref, declaredTyconTypars = ComputeTyconDeclKind cenv envForDecls tyconOpt isAtOriginalTyconDefn true m typars cs longPath @@ -4290,7 +4325,7 @@ module TcDeclarations = let envForTycon = MakeInnerEnvForTyconRef envForTycon tcref (declKind = ExtrinsicExtensionBinding) TcTyconMemberSpecs cenv envForTycon (TyconContainerInfo(innerParent, tcref, declaredTyconTypars, NoSafeInitInfo)) declKind tpenv members) - + // Do this for each 'val' declaration in a module (fun envForDecls (containerInfo, valSpec) -> let tpenv = emptyUnscopedTyparEnv @@ -4321,7 +4356,7 @@ module TcDeclarations = let envMutRecPrelimWithReprs, withEnvs = (envInitial, MutRecShapes.dropEnvs mutRecDefnsAfterCore) ||> MutRecBindingChecking.TcMutRecDefns_ComputeEnvs - (fun (_, tyconOpt, _, _) -> tyconOpt) + (fun (_, tyconOpt, _, _, _) -> tyconOpt) (fun _binds -> [ (* no values are available yet *) ]) cenv true scopem m @@ -4330,6 +4365,16 @@ module TcDeclarations = // Updates the types of the modules to contain the contents so far, which now includes values and members MutRecBindingChecking.TcMutRecDefns_UpdateModuleContents mutRecNSInfo mutRecDefnsAfterVals + // Generate the union augmentation values for all tycons. + (envMutRec, mutRecDefnsAfterCore) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls ((tyconCore, _, _), tyconOpt, _, _, _) -> + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore + match tyconOpt with + | Some tycon when isAtOriginalTyconDefn -> + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion cenv.g tycon then + let vspecs = AddAugmentationDeclarations.AddUnionAugmentationValues cenv envForDecls tycon + ignore vspecs + | _ -> ()) + envMutRec //------------------------------------------------------------------------- diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 8f034836dd9..61d374d4c6d 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -1395,14 +1395,14 @@ let PublishValueDefnPrim cenv env (vspec: Val) = UpdateAccModuleOrNamespaceType cenv env (fun _ mty -> mty.AddVal vspec) -let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = +let PublishValueDefnMaybeInclCompilerGenerated (cenv: cenv) env inclCompilerGenerated declKind (vspec: Val) = let g = cenv.g let isNamespace = let kind = (GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind match kind with | Namespace _ -> true | _ -> false - + if (declKind = ModuleOrMemberBinding) && isNamespace && (Option.isNone vspec.MemberInfo) then @@ -1421,7 +1421,7 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = match vspec.MemberInfo with | Some _ when - (not vspec.IsCompilerGenerated && + ((not vspec.IsCompilerGenerated || inclCompilerGenerated) && // Extrinsic extensions don't get added to the tcaug not (declKind = ExtrinsicExtensionBinding)) -> // // Static initializers don't get published to the tcaug @@ -1433,6 +1433,9 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = tcaug.tcaug_adhoc_list.Add (ValRefIsExplicitImpl g vref, vref) | _ -> () +let PublishValueDefn cenv env declKind vspec = + PublishValueDefnMaybeInclCompilerGenerated cenv env false declKind vspec + let CombineVisibilityAttribs vis1 vis2 m = match vis1 with | Some _ -> diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index f7a7fc217bd..95ee51bbc4e 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -853,6 +853,9 @@ val PublishTypeDefn: cenv: TcFileState -> env: TcEnv -> mspec: Tycon -> unit /// Publish a value definition to the module/namespace type accumulator. val PublishValueDefn: cenv: TcFileState -> env: TcEnv -> declKind: DeclKind -> vspec: Val -> unit +/// Publish a value definition to the module/namespace type accumulator. +val PublishValueDefnMaybeInclCompilerGenerated: cenv: TcFileState -> env: TcEnv -> inclCompilerGenerated: bool -> declKind: DeclKind -> vspec: Val -> unit + /// Mark a typar as no longer being an inference type variable val SetTyparRigid: DisplayEnv -> range -> Typar -> unit diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 77b3cb3486a..92a1302c415 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -2345,7 +2345,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Give a good error for structural types excluded from the comparison relation because of their fields elif (isAppTy g ty && let tcref = tcrefOfAppTy g ty - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && Option.isNone tcref.GeneratedCompareToWithComparerValues) then ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison3(NicePrint.minimalStringOfType denv ty), m, m2)) @@ -2375,7 +2375,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = match ty with | AppTy g (tcref, tinst) -> // Give a good error for structural types excluded from the equality relation because of their fields - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues then ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality3(NicePrint.minimalStringOfType denv ty), m, m2)) diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index e317772dac4..a24998318f1 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -886,12 +886,12 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv not tycon.IsFSharpInterfaceTycon then (* Warn when we're doing this for class types *) - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName), tycon.Range)) else warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName), tycon.Range)) - AugmentWithHashCompare.CheckAugmentationAttribs isImplementation g amap tycon + AugmentTypeDefinitions.CheckAugmentationAttribs isImplementation g amap tycon // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation if isImplementation #if !NO_TYPEPROVIDERS diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 56002f6e0e9..03ec230616a 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -3985,7 +3985,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso not minfo.IsExtensionMember && match minfo.LogicalName with | "GetType" -> false - | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) | "ToString" -> false | "Equals" -> if not (isObjTy g minfo.ApparentEnclosingType) then @@ -3993,7 +3993,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso false elif minfo.IsInstance then // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true - not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) else // System.Object has only one static Equals method and we always want to suppress it true @@ -4721,7 +4721,7 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( not minfo.IsExtensionMember && match minfo.LogicalName with | "GetType" -> false - | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) | "ToString" -> false | "Equals" -> if not (isObjTy g minfo.ApparentEnclosingType) then @@ -4729,7 +4729,7 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( false elif minfo.IsInstance then // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true - not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) else // System.Object has only one static Equals method and we always want to suppress it true diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index ed7e92bf0ef..aba4053d501 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1813,6 +1813,9 @@ module TastDefinitionPrinting = let props = GetImmediateIntrinsicPropInfosOfType (None, ad) g amap m ty |> List.filter (fun pinfo -> shouldShow pinfo.ArbitraryValRef) + // Filter out 'IsA' properties which are implied by the union cases since they don't need to be displayed + // in any printed outputs + |> List.filter (fun prop -> not prop.IsUnionCaseTester) let events = infoReader.GetEventInfosOfType(None, ad, m, ty) @@ -1840,7 +1843,8 @@ module TastDefinitionPrinting = IsMethInfoAccessible amap m ad minfo && // Discard method impls such as System.IConvertible.ToBoolean not (minfo.IsILMethod && minfo.DisplayName.Contains(".")) && - not (minfo.DisplayName.Split('.') |> Array.exists (fun part -> isDiscard part))) + not (minfo.DisplayName.Split('.') |> Array.exists (fun part -> isDiscard part)) && + not minfo.IsUnionCaseTester) let ilFields = infoReader.GetILFieldInfosOfType (None, ad, m, ty) @@ -1897,7 +1901,7 @@ module TastDefinitionPrinting = let instanceValLs = instanceVals |> List.map (fun f -> layoutRecdField (fun l -> WordL.keywordVal ^^ l) true denv infoReader tcref f) - + let propLs = props |> List.map (fun x -> (true, x.IsStatic, x.PropertyName, 0, 0), layoutPropInfo denv infoReader m x) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 031c5ae7991..184de1fa2f3 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2186,7 +2186,7 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // Default augmentation contains the nasty 'Is' etc. let prefix = "Is" - if nm.StartsWithOrdinal prefix && hasDefaultAugmentation then + if not v.IsImplied && nm.StartsWithOrdinal prefix && hasDefaultAugmentation then match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(), uc.DisplayName, uc.Range)) | None -> () diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs index 1c0612eb611..edceea231c8 100644 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -803,6 +803,15 @@ type MethInfo = | ProvidedMeth(_, mi, _, m) -> [mi.PUntaint((fun mi -> mi.GetParameters().Length), m)] // Why is this a list? Answer: because the method might be curried #endif + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member x.IsUnionCaseTester = + let tcref = x.ApparentEnclosingTyconRef + tcref.IsUnionTycon && + x.LogicalName.StartsWith("get_Is") && + match x.ArbitraryValRef with + | Some v -> v.IsImplied + | None -> false + member x.IsCurried = x.NumArgs.Length > 1 /// Does the method appear to the user as an instance method? @@ -1986,6 +1995,11 @@ type PropInfo = #endif | _ -> false + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member x.IsUnionCaseTester = + x.HasGetter && + x.GetterMethod.IsUnionCaseTester + /// Calculates a hash code of property info. Must be compatible with ItemsAreEffectivelyEqual relation. member pi.ComputeHashCode() = match pi with diff --git a/src/Compiler/Checking/infos.fsi b/src/Compiler/Checking/infos.fsi index 63a24eb6502..ed573b3ca68 100644 --- a/src/Compiler/Checking/infos.fsi +++ b/src/Compiler/Checking/infos.fsi @@ -420,6 +420,9 @@ type MethInfo = /// Indicates if this is an IL method. member IsILMethod: bool + /// Indicates if the method is a get_IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Does the method appear to the user as an instance method? member IsInstance: bool @@ -818,6 +821,9 @@ type PropInfo = member ImplementedSlotSignatures: SlotSig list + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Indicates if this property is marked 'override' and thus definitely overrides another property. member IsDefiniteFSharpOverride: bool diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 626ddd49758..17a4095527d 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -6,6 +6,7 @@ module internal FSharp.Compiler.AbstractIL.ILX.EraseUnions open System.Collections.Generic open System.Reflection open Internal.Utilities.Library +open FSharp.Compiler.Features open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types @@ -826,7 +827,8 @@ let convAlternativeDef | SpecialFSharpListHelpers -> let baseTesterMeths, baseTesterProps = - if cud.UnionCases.Length <= 1 then + if ilg.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible && cud.HasHelpers = AllHelpers then [], [] + elif cud.UnionCases.Length <= 1 then [], [] elif repr.RepresentOneAlternativeAsNull info then [], [] diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 60722df6c9d..3a1f5443f78 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -2399,7 +2399,7 @@ and [] TcImports sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu path typeName) let ilGlobals = - mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) + mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef, tcConfig.langVersion) // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals let tcGlobals = diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 19f7d040b46..38fb870de12 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1235,6 +1235,7 @@ featurePrintfBinaryFormat,"binary formatting for integers" featureIndexerNotationWithoutDot,"expr[idx] notation for indexing and slicing" featureRefCellNotationInformationals,"informational messages related to reference cells" featureDiscardUseValue,"discard pattern in use binding" +featureUnionIsPropertiesVisible,"visible union case test properties" featureNonVariablePatternsToRightOfAsPatterns,"non-variable patterns to the right of 'as' patterns" featureAttributesToRightOfModuleKeyword,"attributes to the right of the 'module' keyword" featureMLCompatRevisions,"ML compatibility revisions" diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 683dddd2e4f..9761a2386f0 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -42,6 +42,7 @@ type LanguageFeature = | IndexerNotationWithoutDot | RefCellNotationInformationals | UseBindingValueDiscard + | UnionIsPropertiesVisible | NonVariablePatternsToRightOfAsPatterns | AttributesToRightOfModuleKeyword | MLCompatRevisions @@ -112,6 +113,7 @@ type LanguageVersion(versionText) = // F# preview LanguageFeature.FromEndSlicing, previewVersion + LanguageFeature.UnionIsPropertiesVisible, previewVersion LanguageFeature.MLCompatRevisions, previewVersion LanguageFeature.BetterExceptionPrinting, previewVersion LanguageFeature.ReallyLongLists, previewVersion @@ -213,6 +215,7 @@ type LanguageVersion(versionText) = | LanguageFeature.IndexerNotationWithoutDot -> FSComp.SR.featureIndexerNotationWithoutDot () | LanguageFeature.RefCellNotationInformationals -> FSComp.SR.featureRefCellNotationInformationals () | LanguageFeature.UseBindingValueDiscard -> FSComp.SR.featureDiscardUseValue () + | LanguageFeature.UnionIsPropertiesVisible -> FSComp.SR.featureUnionIsPropertiesVisible() | LanguageFeature.NonVariablePatternsToRightOfAsPatterns -> FSComp.SR.featureNonVariablePatternsToRightOfAsPatterns () | LanguageFeature.AttributesToRightOfModuleKeyword -> FSComp.SR.featureAttributesToRightOfModuleKeyword () | LanguageFeature.MLCompatRevisions -> FSComp.SR.featureMLCompatRevisions () diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index 71673cb05e3..0a30e7f4ba8 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -32,6 +32,7 @@ type LanguageFeature = | IndexerNotationWithoutDot | RefCellNotationInformationals | UseBindingValueDiscard + | UnionIsPropertiesVisible | NonVariablePatternsToRightOfAsPatterns | AttributesToRightOfModuleKeyword | MLCompatRevisions diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index ec343ad2a8d..353cc81531a 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -1729,6 +1729,13 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | P p -> mkMethSym p.SetterMethod | E _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated setter method" + member _.IsUnionCaseTester = + checkIsResolved() + match d with + | P p -> p.IsUnionCaseTester + | M m -> m.IsUnionCaseTester + | E _ | C _ | V _ -> invalidOp "the value or member is not a property" + member _.EventAddMethod = checkIsResolved() match d with diff --git a/src/Compiler/Symbols/Symbols.fsi b/src/Compiler/Symbols/Symbols.fsi index 024448bf170..1b5e4b514b0 100644 --- a/src/Compiler/Symbols/Symbols.fsi +++ b/src/Compiler/Symbols/Symbols.fsi @@ -822,6 +822,9 @@ type FSharpMemberOrFunctionOrValue = /// Get an associated setter method of the property member SetterMethod: FSharpMemberOrFunctionOrValue + /// Indicates if the property or getter method is part of a IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Get an associated add method of an event member EventAddMethod: FSharpMemberOrFunctionOrValue diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index a38d87199e0..4a6ad87863e 100755 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -805,13 +805,17 @@ type TcGlobals( let v_check_this_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "CheckThis" , None , None , [vara], ([[varaTy]], varaTy)) let v_quote_to_linq_lambda_info = makeIntrinsicValRef(fslib_MFLinqRuntimeHelpersQuotationConverter_nleref, "QuotationToLambdaExpression" , None , None , [vara], ([[mkQuotedExprTy varaTy]], mkLinqExpressionTy varaTy)) + let tref_DebuggerNonUserCodeAttribute = findSysILTypeRef tname_DebuggerNonUserCodeAttribute + let v_DebuggerNonUserCodeAttribute_tcr = splitILTypeName tname_DebuggerNonUserCodeAttribute ||> findSysTyconRef + let tref_DebuggableAttribute = findSysILTypeRef tname_DebuggableAttribute let tref_CompilerGeneratedAttribute = findSysILTypeRef tname_CompilerGeneratedAttribute + let v_CompilerGeneratedAttribute_tcr = splitILTypeName tname_CompilerGeneratedAttribute ||> findSysTyconRef let tref_InternalsVisibleToAttribute = findSysILTypeRef tname_InternalsVisibleToAttribute let mutable generatedAttribsCache = [] let mutable debuggerBrowsableNeverAttributeCache = None - let mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute (findSysILTypeRef tname_DebuggerNonUserCodeAttribute, [], [], []) + let mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute (tref_DebuggerNonUserCodeAttribute, [], [], []) let mkCompilerGeneratedAttribute () = mkILCustomAttribute (tref_CompilerGeneratedAttribute, [], [], []) let compilerGlobalState = CompilerGlobalState() @@ -829,6 +833,14 @@ type TcGlobals( | res -> res mkILCustomAttrs (attrs.AsList() @ attribs) + let addValGeneratedAttrs (v: Val) m = + if not noDebugAttributes then + v.SetAttribs ([ + Attrib(v_CompilerGeneratedAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_CompilerGeneratedAttribute, [])).MethodRef), [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_DebuggerNonUserCodeAttribute, [])).MethodRef), [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_DebuggerNonUserCodeAttribute, [])).MethodRef), [], [], true, None, m) + ] @ v.Attribs) + let addMethodGeneratedAttrs (mdef:ILMethodDef) = mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) @@ -1727,6 +1739,8 @@ type TcGlobals( member _.TryFindSysAttrib nm = tryFindSysAttrib nm + member _.AddValGeneratedAttributes v = addValGeneratedAttrs v + member _.AddMethodGeneratedAttributes mdef = addMethodGeneratedAttrs mdef member _.AddPropertyGeneratedAttributes mdef = addPropertyGeneratedAttrs mdef diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 39d09093916..ca3f4db338d 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -232,9 +232,13 @@ type ValFlags(flags: int64) = member x.WithIgnoresByrefScope = ValFlags(flags ||| 0b10000000000000000000L) member x.InlineIfLambda = (flags &&& 0b100000000000000000000L) <> 0L - + member x.WithInlineIfLambda = ValFlags(flags ||| 0b100000000000000000000L) + member x.IsImplied = (flags &&& 0b1000000000000000000000L) <> 0L + + member x.WithIsImplied = ValFlags(flags ||| 0b1000000000000000000000L) + /// Get the flags as included in the F# binary metadata member x.PickledBits = // Clear the RecursiveValInfo, only used during inference and irrelevant across assembly boundaries @@ -2792,6 +2796,9 @@ type Val = /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member x.InlineIfLambda = x.val_flags.InlineIfLambda + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member x.IsImplied = x.val_flags.IsImplied + /// Indicates whether the inline declaration for the value indicate that the value must be inlined? member x.MustInline = x.InlineInfo.MustInline @@ -2803,7 +2810,7 @@ type Val = /// Indicates that this value's getter or setter are generated by the compiler member x.GetterOrSetterIsCompilerGenerated = x.MemberInfo |> Option.exists (fun m -> m.MemberFlags.GetterOrSetterIsCompilerGenerated = true) - + /// Get the declared attributes for the value member x.Attribs = match x.val_opt_data with @@ -3026,6 +3033,8 @@ type Val = member x.SetInlineIfLambda() = x.val_flags <- x.val_flags.WithInlineIfLambda + member x.SetIsImplied() = x.val_flags <- x.val_flags.WithIsImplied + member x.SetValReprInfo info = match x.val_opt_data with | Some optData -> optData.val_repr_info <- info @@ -3918,6 +3927,9 @@ type ValRef = /// Get the inline declaration on the value member x.InlineInfo = x.Deref.InlineInfo + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member x.IsImplied = x.Deref.IsImplied + /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member x.InlineIfLambda = x.Deref.InlineIfLambda diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 608ca6e86e5..41ad8407a85 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -3488,6 +3488,14 @@ let TyconRefHasAttribute g m attribSpec tcref = (fun _ -> Some ()) |> Option.isSome +let HasDefaultAugmentationAttribute g (tcref: TyconRef) = + match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with + | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> b + | Some (Attrib(_, _, _, _, _, _, m)) -> + errorR(Error(FSComp.SR.ilDefaultAugmentationAttributeCouldNotBeDecoded(), m)) + true + | _ -> true + /// Check if a type definition has an attribute with a specific full name let TyconRefHasAttributeByName (m: range) attrFullName (tcref: TyconRef) = ignore m @@ -9007,6 +9015,18 @@ let mkIsInstConditional g m tgtTy vinputExpr v e2 e3 = let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) expr +(* match inp with DU(_) -> true | _ -> false *) +let mkUnionCaseTest (g: TcGlobals) (e1, cref: UnionCaseRef, tinst, m) = + let mbuilder = new MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let tg2 = mbuilder.AddResultTarget(Expr.Const(Const.Bool true, m, g.bool_ty)) + let tg3 = mbuilder.AddResultTarget(Expr.Const(Const.Bool false, m, g.bool_ty)) + let dtree = TDSwitch(e1, [TCase(DecisionTreeTest.UnionCase(cref, tinst), tg2)], Some tg3, m) + let expr = mbuilder.Close(dtree, m, g.bool_ty) + expr + +// Null tests are generated by +// 1. The compilation of array patterns in the pattern match compiler +// 2. The compilation of string patterns in the pattern match compiler // Called for when creating compiled form of 'let fixed ...'. // // No sequence point is generated for this expression form as this function is only diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 62f76df7e64..d3718573bc5 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -312,6 +312,9 @@ val mkRecdFieldSetViaExprAddr: Expr * RecdFieldRef * TypeInst * Expr * range -> /// Make an expression that gets the tag of a union value (via the address of the value if it is a struct) val mkUnionCaseTagGetViaExprAddr: Expr * TyconRef * TypeInst * range -> Expr +/// Make an expression which tests that a union value is of a particular union case. +val mkUnionCaseTest: TcGlobals -> Expr * UnionCaseRef * TypeInst * range -> Expr + /// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) val mkUnionCaseProof: Expr * UnionCaseRef * TypeInst * range -> Expr @@ -2612,6 +2615,8 @@ val TryBindTyconRefAttribute: f3: (obj option list * (string * obj option) list -> 'a option) -> 'a option +val HasDefaultAugmentationAttribute: g: TcGlobals -> tcref: TyconRef -> bool + val (|ResumableCodeInvoke|_|): g: TcGlobals -> expr: Expr -> (Expr * Expr * Expr list * range * (Expr * Expr list -> Expr)) option diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 5935d322ccf..637ae6032cb 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -159,6 +159,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs new file mode 100644 index 00000000000..41988c5559c --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -0,0 +1,73 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.ComponentTests.Language + +open Xunit +open FSharp.Test.Compiler + +#if NETCOREAPP +module DiscriminatedUnionTests = + + [] + let ``Simple Is* discriminated union properties are visible, proper values are returned`` () = + Fsx """ +type Foo = | Foo of string | Bar +let foo = Foo.Foo "hi" +if not foo.IsFoo then failwith "Should be Foo" +if foo.IsBar then failwith "Should not be Bar" + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, before the definition`` () = + FSharp """ +namespace rec Hello + +module Main = + [] + let main _ = + let foo = Foo.Foo "hi" + if not foo.IsFoo then failwith "Should be Foo" + if foo.IsBar then failwith "Should not be Bar" + 0 + +[] +type Foo = + | Foo of string + | Bar + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + + [] + let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, in SRTP`` () = + FSharp """ +namespace Hello + +[] +type Foo = + | Foo of string + | Bar + +module Main = + + let inline (|HasIsFoo|) x = fun () -> (^a : (member IsFoo: bool) x) + let inline (|HasIsBar|) x = fun () -> (^a : (member IsBar: bool) x) + let getIsFooIsBar (HasIsFoo isFoo & HasIsBar isBar) = (isFoo(), isBar()) + + [] + let main _ = + let foo = Foo.Foo "hi" + let (isFoo, isBar) = getIsFooIsBar foo + if not isFoo then failwith "Should be Foo" + if isBar then failwith "Should not be Bar" + 0 + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed +#endif \ No newline at end of file diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected index c9f58e3ca78..d2a6620574f 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected @@ -4867,6 +4867,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsProperty FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertyGetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertySetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsTypeFunction +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnionCaseTester FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnresolved FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValCompiledAsMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValue @@ -4898,6 +4899,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsProperty() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertyGetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertySetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsTypeFunction() +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnionCaseTester() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnresolved() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValCompiledAsMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValue() diff --git a/tests/fsharp/core/namespaces/test.fs b/tests/fsharp/core/namespaces/test.fs index 39ab9b066b4..8ef39158533 100644 --- a/tests/fsharp/core/namespaces/test.fs +++ b/tests/fsharp/core/namespaces/test.fs @@ -23,7 +23,17 @@ namespace Hello.Goodbye module X = let x = 1 - + type UnionTypeHiddenWithDiscriminatorsPartlyRevealed = + | A1 + | B1 + | C1 + + module M = + let v = A1.IsA1 + type UnionTypeHiddenWithDiscriminatorsFullyRevealed = + | A1 + | B1 + | C1 namespace Hello.Beatles @@ -135,6 +145,13 @@ namespace rec CheckRecursiveNameResolution4 do Hello.Goodbye.Utils.test "test292jwf" (Test.N.x.V = 4) + module UnionTestsWithSignature = + // Check accessing the *.Is* properties of unions not through a signature + let a = Hello.Goodbye.A + + Hello.Goodbye.Utils.test "vwehlevw1a" a.IsA + Hello.Goodbye.Utils.test "vwehlevw2a" (not a.IsB) + Hello.Goodbye.Utils.test "vwehlevw3a" (not a.IsC) namespace rec CheckRecursiveNameResolution5 diff --git a/tests/fsharp/core/namespaces/test.fsi b/tests/fsharp/core/namespaces/test.fsi index b5c691f5b9e..18e379d8525 100644 --- a/tests/fsharp/core/namespaces/test.fsi +++ b/tests/fsharp/core/namespaces/test.fsi @@ -4,6 +4,16 @@ namespace Hello.Goodbye type A = A | B | C +[] +type UnionTypeHiddenWithDiscriminatorsPartlyRevealed = + member IsA1: bool + +[] +type UnionTypeHiddenWithDiscriminatorsFullyRevealed = + member IsA1: bool + member IsB1: bool + member IsC1: bool + module Utils = begin val failures : string list ref val report_failure : string -> unit diff --git a/tests/fsharp/core/namespaces/test2.fs b/tests/fsharp/core/namespaces/test2.fs index 19d215d4a00..8e06924cc86 100644 --- a/tests/fsharp/core/namespaces/test2.fs +++ b/tests/fsharp/core/namespaces/test2.fs @@ -11,6 +11,13 @@ module M = type C() = member x.P = C() +module UnionTestsWithSignature = + // Check accessing the *.Is* properties of unions through a signature + let a = Hello.Goodbye.A + + Hello.Goodbye.Utils.test "vwehlevw1" a.IsA + Hello.Goodbye.Utils.test "vwehlevw2" (not a.IsB) + Hello.Goodbye.Utils.test "vwehlevw3" (not a.IsC) #if TESTS_AS_APP let RUN() = !failures diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 3422922c449..5748785b899 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -158,17 +158,23 @@ module CoreTests = let ``namespaceAttributes-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/namespaces" FSC_OPTIMIZED [] - let ``unicode2-FSC_DEBUG`` () = singleTestBuildAndRun "core/unicode" FSC_DEBUG // TODO: fails on coreclr + let ``namespaces-FSC_DEBUG`` () = singleTestBuildAndRunVersion "core/namespaces" FSC_DEBUG "preview" [] - let ``unicode2-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/unicode" FSC_OPTIMIZED // TODO: fails on coreclr + let ``namespaces-FSC_OPTIMIZED`` () = singleTestBuildAndRunVersion "core/namespaces" FSC_OPTIMIZED "preview" [] let ``unicode2-FSI`` () = singleTestBuildAndRun "core/unicode" FSI + [] + let ``unicode2-FSC_DEBUG`` () = singleTestBuildAndRun "core/unicode" FSC_DEBUG + [] let ``lazy test-FSC_DEBUG`` () = singleTestBuildAndRun "core/lazy" FSC_DEBUG + [] + let ``unicode2-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/unicode" FSC_OPTIMIZED + [] let ``lazy test-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/lazy" FSC_OPTIMIZED From ba0a7447768be039830f81c5dec2088f8072f291 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 10 Aug 2022 20:15:58 +0200 Subject: [PATCH 02/16] Fantomas --- src/Compiler/Checking/CheckExpressions.fsi | 3 ++- src/Compiler/CodeGen/EraseUnions.fs | 6 +++++- src/Compiler/TypedTree/TypedTreeOps.fsi | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index 95ee51bbc4e..dce7ff52e92 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -854,7 +854,8 @@ val PublishTypeDefn: cenv: TcFileState -> env: TcEnv -> mspec: Tycon -> unit val PublishValueDefn: cenv: TcFileState -> env: TcEnv -> declKind: DeclKind -> vspec: Val -> unit /// Publish a value definition to the module/namespace type accumulator. -val PublishValueDefnMaybeInclCompilerGenerated: cenv: TcFileState -> env: TcEnv -> inclCompilerGenerated: bool -> declKind: DeclKind -> vspec: Val -> unit +val PublishValueDefnMaybeInclCompilerGenerated: + cenv: TcFileState -> env: TcEnv -> inclCompilerGenerated: bool -> declKind: DeclKind -> vspec: Val -> unit /// Mark a typar as no longer being an inference type variable val SetTyparRigid: DisplayEnv -> range -> Typar -> unit diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 17a4095527d..0ee3d2f77ff 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -827,7 +827,11 @@ let convAlternativeDef | SpecialFSharpListHelpers -> let baseTesterMeths, baseTesterProps = - if ilg.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible && cud.HasHelpers = AllHelpers then [], [] + if + ilg.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible + && cud.HasHelpers = AllHelpers + then + [], [] elif cud.UnionCases.Length <= 1 then [], [] elif repr.RepresentOneAlternativeAsNull info then diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index d3718573bc5..898ba3f41e3 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -313,7 +313,7 @@ val mkRecdFieldSetViaExprAddr: Expr * RecdFieldRef * TypeInst * Expr * range -> val mkUnionCaseTagGetViaExprAddr: Expr * TyconRef * TypeInst * range -> Expr /// Make an expression which tests that a union value is of a particular union case. -val mkUnionCaseTest: TcGlobals -> Expr * UnionCaseRef * TypeInst * range -> Expr +val mkUnionCaseTest: TcGlobals -> Expr * UnionCaseRef * TypeInst * range -> Expr /// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) val mkUnionCaseProof: Expr * UnionCaseRef * TypeInst * range -> Expr From a7e8f23ba639b872f26dad89dc528e02d7d5ce51 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 10 Aug 2022 20:26:07 +0200 Subject: [PATCH 03/16] Fix naming --- src/Compiler/CodeGen/IlxGen.fs | 16 ++++++++-------- src/Compiler/FSharp.Compiler.Service.fsproj | 4 ++-- .../FCSBenchmarks/FCSSourceFiles/Program.fs | 4 ++-- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 753e7772676..1c26138fb4b 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2197,15 +2197,15 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu (mkAppTy g.system_GenericIEquatable_tcref [ ty ], true, m) ] - let vspec1, vspec2 = AugmentWithHashCompare.MakeValsForEqualsAugmentation g tcref + let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref let evspec1, evspec2, evspec3 = - AugmentWithHashCompare.MakeValsForEqualityWithComparerAugmentation g tcref + AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref - let cvspec1, cvspec2 = AugmentWithHashCompare.MakeValsForCompareAugmentation g tcref + let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref let cvspec3 = - AugmentWithHashCompare.MakeValsForCompareWithComparerAugmentation g tcref + AugmentTypeDefinitions.MakeValsForCompareWithComparerAugmentation g tcref tcaug.SetCompare(mkLocalValRef cvspec1, mkLocalValRef cvspec2) tcaug.SetCompareWith(mkLocalValRef cvspec3) @@ -2248,10 +2248,10 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu let extraBindings = [ - yield! AugmentWithHashCompare.MakeBindingsForCompareAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForCompareAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForCompareWithComparerAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForEqualityWithComparerAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForEqualsAugmentation g tycon ] let optimizedExtraBindings = diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 36f0a788a6a..c8a5bd1ad84 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -308,8 +308,8 @@ - - + + diff --git a/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs b/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs index 8c21e2dafc3..136897e081b 100644 --- a/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs +++ b/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs @@ -618,8 +618,8 @@ module Project = __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\InfoReader.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NicePrint.fsi" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NicePrint.fs" - __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentWithHashCompare.fsi" - __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentWithHashCompare.fs" + __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentTypeDefinitions.fsi" + __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentTypeDefinitions.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NameResolution.fsi" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NameResolution.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\SignatureConformance.fsi" From 808d5b4e3e7601ed8810b32227f9d275047a7c70 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Thu, 11 Aug 2022 14:12:43 +0200 Subject: [PATCH 04/16] fixes --- src/Compiler/AbstractIL/il.fsi | 1 + src/Compiler/Checking/CheckDeclarations.fs | 16 ++++++++-------- src/Compiler/TypedTree/TypedTree.fsi | 12 ++++++++++++ 3 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 6f3709124f3..e9db5bb1cbb 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -4,6 +4,7 @@ module rec FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.Features open FSharp.Compiler.IO open System.Collections.Generic open System.Reflection diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 1e76f7fbcfb..607edfa5773 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -711,7 +711,7 @@ module AddAugmentationDeclarations = if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon && scSet.Contains tycon.Stamp then let tcref = mkLocalTyconRef tycon let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsExceptionDecl then g.exn_ty else generalizedTyconRef g tcref + let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref let m = tycon.Range let genericIComparableTy = mkAppTy g.system_GenericIComparable_tcref [ty] @@ -734,7 +734,7 @@ module AddAugmentationDeclarations = PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralComparable_ty PublishInterface cenv env.DisplayEnv tcref m true g.mk_IComparable_ty - if not tycon.IsExceptionDecl && not hasExplicitGenericIComparable then + if not tycon.IsFSharpException && not hasExplicitGenericIComparable then PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2) tcaug.SetCompareWith (mkLocalValRef cvspec3) @@ -793,7 +793,7 @@ module AddAugmentationDeclarations = if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then let tcref = mkLocalTyconRef tycon let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsExceptionDecl then g.exn_ty else generalizedTyconRef g tcref + let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref let m = tycon.Range // Note: tycon.HasOverride only gives correct results after we've done the type augmentation @@ -810,7 +810,7 @@ module AddAugmentationDeclarations = let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2) - if not tycon.IsExceptionDecl then + if not tycon.IsFSharpException then PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy g.system_GenericIEquatable_tcref [ty]) PublishValueDefn cenv env ModuleOrMemberBinding vspec1 PublishValueDefn cenv env ModuleOrMemberBinding vspec2 @@ -4295,13 +4295,13 @@ module TcDeclarations = // Representation-hidden types with members and interfaces are written 'type X = ...' | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _ as repr, _) when not (isNil extraMembers) -> let isAtOriginalTyconDefn = false - let repr = SynTypeDefnSimpleRepr.Exception exnRepr let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) tyconCore, (synTyconInfo, extraMembers) - + | SynTypeDefnSigRepr.Exception exnRepr -> let isAtOriginalTyconDefn = true - let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, SynTypeDefnSimpleRepr.Exception exnRepr, implements1, false, false, isAtOriginalTyconDefn) + let repr = SynTypeDefnSimpleRepr.Exception exnRepr + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) core, (synTyconInfo, extraMembers) | SynTypeDefnSigRepr.Simple(repr, _) -> @@ -4314,7 +4314,7 @@ module TcDeclarations = let g = cenv.g (envMutRec, mutRecDefns) ||> MutRecShapes.mapWithEnv // Do this for the members in each 'type' declaration - (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _, extraValSpecs) -> + (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _, _extraValSpecs) -> let tpenv = emptyUnscopedTyparEnv let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore let (SynComponentInfo(_, TyparsAndConstraints (typars, cs1), cs2, longPath, _, _, _, m)) = synTyconInfo diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 2487daf3517..5461930cfdd 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -109,6 +109,8 @@ type ValFlags = member InlineInfo: ValInline + member IsImplied: bool + member IsCompiledAsStaticPropertyWithoutField: bool member IsCompilerGenerated: bool @@ -142,6 +144,8 @@ type ValFlags = member WithInlineIfLambda: ValFlags + member WithIsImplied: ValFlags + member WithIsCompiledAsStaticPropertyWithoutField: ValFlags member WithIsFixed: ValFlags @@ -1893,6 +1897,8 @@ type Val = member SetInlineIfLambda: unit -> unit + member SetIsImplied: unit -> unit + member SetIsCompiledAsStaticPropertyWithoutField: unit -> unit member SetIsCompilerGenerated: v: bool -> unit @@ -2001,6 +2007,9 @@ type Val = /// Get the inline declaration on the value member InlineInfo: ValInline + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member IsImplied: bool + /// Indicates if this is a 'base' value? member IsBaseVal: bool @@ -2728,6 +2737,9 @@ type ValRef = /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member InlineIfLambda: bool + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member IsImplied: bool + /// Get the inline declaration on the value member InlineInfo: ValInline From 1c176fa4406a429207ba863a1c2e6c57352f7d99 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Thu, 11 Aug 2022 18:58:03 +0200 Subject: [PATCH 05/16] Translations + tests fixes --- src/Compiler/xlf/FSComp.txt.cs.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.de.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.es.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.fr.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.it.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.ja.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.ko.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.pl.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.ru.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.tr.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 5 +++++ src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 5 +++++ tests/service/ExprTests.fs | 16 ++++++++++++--- tests/service/ProjectAnalysisTests.fs | 27 +++++++++++++++++-------- 15 files changed, 97 insertions(+), 11 deletions(-) diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index e712bcb1297..5cc647c0692 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -297,6 +297,11 @@ reprezentace struktury aktivních vzorů + + visible union case test properties + visible union case test properties + + wild card in for loop zástupný znak ve smyčce for diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index ffe291bbca1..be33c743920 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -297,6 +297,11 @@ Strukturdarstellung für aktive Muster + + visible union case test properties + visible union case test properties + + wild card in for loop Platzhalter in for-Schleife diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 459051b3ef0..d6016e379d8 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -297,6 +297,11 @@ representación de struct para modelos activos + + visible union case test properties + visible union case test properties + + wild card in for loop carácter comodín en bucle for diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 1f669e7d4ae..15b1c8f5952 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -297,6 +297,11 @@ représentation de structure pour les modèles actifs + + visible union case test properties + visible union case test properties + + wild card in for loop caractère générique dans une boucle for diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index aed66eb98cc..75d02c2a17c 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -297,6 +297,11 @@ rappresentazione struct per criteri attivi + + visible union case test properties + visible union case test properties + + wild card in for loop carattere jolly nel ciclo for diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index a718b4ec986..7c1ac376ecc 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -297,6 +297,11 @@ アクティブなパターンの構造体表現 + + visible union case test properties + visible union case test properties + + wild card in for loop for ループのワイルド カード diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 4c651461002..c940a0eda8b 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -297,6 +297,11 @@ 활성 패턴에 대한 구조체 표현 + + visible union case test properties + visible union case test properties + + wild card in for loop for 루프의 와일드카드 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 3fe6c74d31a..d70cccfcfdd 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -297,6 +297,11 @@ reprezentacja struktury aktywnych wzorców + + visible union case test properties + visible union case test properties + + wild card in for loop symbol wieloznaczny w pętli for diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 6823a8b62c4..f3d641b90dc 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -297,6 +297,11 @@ representação estrutural para padrões ativos + + visible union case test properties + visible union case test properties + + wild card in for loop curinga para loop diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index babbf9d24d8..08383148dbc 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -297,6 +297,11 @@ представление структуры для активных шаблонов + + visible union case test properties + visible union case test properties + + wild card in for loop подстановочный знак в цикле for diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 89d55c0c123..5fe0cf2d28d 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -297,6 +297,11 @@ etkin desenler için yapı gösterimi + + visible union case test properties + visible union case test properties + + wild card in for loop for döngüsünde joker karakter diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index c5c09c1a656..293f06f73fa 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -297,6 +297,11 @@ 活动模式的结构表示形式 + + visible union case test properties + visible union case test properties + + wild card in for loop for 循环中的通配符 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 1a9b21cff11..60285ac11e3 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -297,6 +297,11 @@ 現用模式的結構表示法 + + visible union case test properties + visible union case test properties + + wild card in for loop for 迴圈中的萬用字元 diff --git a/tests/service/ExprTests.fs b/tests/service/ExprTests.fs index 69b4cf1fcb3..b7b65e8f9c8 100644 --- a/tests/service/ExprTests.fs +++ b/tests/service/ExprTests.fs @@ -774,7 +774,11 @@ let ``Test Unoptimized Declarations Project1`` () = "let downwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (79,16--79,17)"; "let quotationTest1(unitVar0) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),1,1)) @ (83,24--83,35)"; "let quotationTest2(v) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),ExtraTopLevelOperators.SpliceExpression (v),1)) @ (84,24--84,36)"; - "type RecdType"; "type UnionType"; "type ClassWithEventsAndProperties"; + "type RecdType"; "type UnionType"; + "member get_IsCase1(this) (unitArg) = (if this.IsCase1 then True else False) @ (87,5--87,14)"; + "member get_IsCase2(this) (unitArg) = (if this.IsCase2 then True else False) @ (87,5--87,14)"; + "member get_IsCase3(this) (unitArg) = (if this.IsCase3 then True else False) @ (87,5--87,14)"; + "type ClassWithEventsAndProperties"; "member .ctor(unitVar0) = (new Object(); (this.ev <- new FSharpEvent`1(()); ())) @ (89,5--89,33)"; "member .cctor(unitVar) = (sev <- new FSharpEvent`1(()); ()) @ (91,11--91,35)"; "member get_InstanceProperty(x) (unitVar1) = (x.ev.Trigger(1); 1) @ (92,32--92,48)"; @@ -909,7 +913,11 @@ let ``Test Optimized Declarations Project1`` () = "let downwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (79,16--79,17)"; "let quotationTest1(unitVar0) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),1,1)) @ (83,24--83,35)"; "let quotationTest2(v) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),ExtraTopLevelOperators.SpliceExpression (v),1)) @ (84,24--84,36)"; - "type RecdType"; "type UnionType"; "type ClassWithEventsAndProperties"; + "type RecdType"; "type UnionType"; + "member get_IsCase1(this) (unitArg) = (if this.IsCase1 then True else False) @ (87,5--87,14)"; + "member get_IsCase2(this) (unitArg) = (if this.IsCase2 then True else False) @ (87,5--87,14)"; + "member get_IsCase3(this) (unitArg) = (if this.IsCase3 then True else False) @ (87,5--87,14)"; + "type ClassWithEventsAndProperties"; "member .ctor(unitVar0) = (new Object(); (this.ev <- new FSharpEvent`1(()); ())) @ (89,5--89,33)"; "member .cctor(unitVar) = (sev <- new FSharpEvent`1(()); ()) @ (91,11--91,35)"; "member get_InstanceProperty(x) (unitVar1) = (x.ev.Trigger(1); 1) @ (92,32--92,48)"; @@ -3408,7 +3416,9 @@ let ``Test ProjectForWitnesses2`` () = "member get_Zero(unitVar0) = {x = 0; y = 0} @ (6,25--6,37)"; "member Neg(p) = {x = Operators.op_UnaryNegation (fun arg0_0 -> LanguagePrimitives.UnaryNegationDynamic (arg0_0),p.x); y = Operators.op_UnaryNegation (fun arg0_0 -> LanguagePrimitives.UnaryNegationDynamic (arg0_0),p.y)} @ (7,34--7,56)"; "member op_Addition(p1,p2) = {x = Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),p1.x,p2.x); y = Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),p1.y,p2.y)} @ (8,33--8,68)"; - "type MyNumber"; "member get_Zero(unitVar0) = MyNumber(0) @ (12,25--12,35)"; + "type MyNumber"; + "member get_IsMyNumber(this) (unitArg) = (if this.IsMyNumber then True else False) @ (10,5--10,13)"; + "member get_Zero(unitVar0) = MyNumber(0) @ (12,25--12,35)"; "member op_Addition(_arg1,_arg2) = let x: Microsoft.FSharp.Core.int = _arg1.Item in let y: Microsoft.FSharp.Core.int = _arg2.Item in MyNumber(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),x,y)) @ (13,23--13,33)"; "member DivideByInt(_arg3,i) = let x: Microsoft.FSharp.Core.int = _arg3.Item in MyNumber(Operators.op_Division (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.DivisionDynamic (arg0_0,arg1_0),x,i)) @ (15,31--15,41)"; "type MyNumberWrapper"] diff --git a/tests/service/ProjectAnalysisTests.fs b/tests/service/ProjectAnalysisTests.fs index 0c343ee58c4..9160187d06c 100644 --- a/tests/service/ProjectAnalysisTests.fs +++ b/tests/service/ProjectAnalysisTests.fs @@ -707,14 +707,17 @@ let ``Test project2 all symbols in signature`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project2.options) |> Async.RunImmediate let allSymbols = allSymbolsInEntities true wholeProjectResults.AssemblySignature.Entities - [ for x in allSymbols -> x.ToString() ] - |> shouldEqual - ["M"; "val c"; "val GenericFunction"; "generic parameter T"; - "DUWithNormalFields"; "DU1"; "field Item1"; "field Item2"; "DU2"; - "field Item1"; "field Item2"; "D"; "field Item1"; "field Item2"; - "DUWithNamedFields"; "DU"; "field x"; "field y"; "GenericClass`1"; - "generic parameter T"; "member .ctor"; "member GenericMethod"; - "generic parameter U"] + let r = [ for x in allSymbols -> x.ToString() ] |> List.sort + + let e = ["M"; "val c"; "val GenericFunction"; "generic parameter T"; + "DUWithNormalFields"; "member get_IsD"; "member get_IsDU1"; "member get_IsDU2"; + "property IsD"; "property IsDU1"; "property IsDU2"; "DU1"; "field Item1"; + "field Item2"; "DU2"; "field Item1"; "field Item2"; "D"; "field Item1"; + "field Item2"; "DUWithNamedFields"; "member get_IsDU"; "property IsDU"; "DU"; + "field x"; "field y"; "GenericClass`1"; "generic parameter T"; "member .ctor"; + "member GenericMethod"; "generic parameter U"] |> List.sort + + shouldEqual e r [] let ``Test project2 all uses of all signature symbols`` () = @@ -732,6 +735,14 @@ let ``Test project2 all uses of all signature symbols`` () = ("generic parameter T", [("file1", ((22, 23), (22, 25))); ("file1", ((22, 30), (22, 32))); ("file1", ((22, 45), (22, 47))); ("file1", ((22, 50), (22, 52)))]); + ("member get_IsD", []); + ("member get_IsDU", []); + ("member get_IsDU1", []); + ("member get_IsDU2", []); + ("property IsD", []); + ("property IsDU", []); + ("property IsDU1", []); + ("property IsDU2", []); ("DUWithNormalFields", [("file1", ((3, 5), (3, 23)))]); ("DU1", [("file1", ((4, 6), (4, 9))); ("file1", ((8, 8), (8, 11)))]); ("field Item1", []); ("field Item2", []); From de5dd73b98fbcbddbd0fe786b51ea79e85849909 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Mon, 15 Aug 2022 10:46:50 +0200 Subject: [PATCH 06/16] Fixed tests --- tests/fsharp/tests.fs | 6 ------ tests/service/Common.fs | 2 +- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 5748785b899..5052c0d8a4e 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -151,12 +151,6 @@ module CoreTests = [] let ``innerpoly-FSI`` () = singleTestBuildAndRun "core/innerpoly" FSI - [] - let ``namespaceAttributes-FSC_DEBUG`` () = singleTestBuildAndRun "core/namespaces" FSC_DEBUG - - [] - let ``namespaceAttributes-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/namespaces" FSC_OPTIMIZED - [] let ``namespaces-FSC_DEBUG`` () = singleTestBuildAndRunVersion "core/namespaces" FSC_DEBUG "preview" diff --git a/tests/service/Common.fs b/tests/service/Common.fs index b683dd9dce1..7526638c15e 100644 --- a/tests/service/Common.fs +++ b/tests/service/Common.fs @@ -85,8 +85,8 @@ let mkProjectCommandLineArgsSilent (dllName, fileNames) = yield "--define:DEBUG" #if NETCOREAPP yield "--targetprofile:netcore" - yield "--langversion:preview" #endif + yield "--langversion:preview" yield "--optimize-" yield "--out:" + dllName yield "--doc:test.xml" From 453b79bd40761911d2086889d6906041ddc2bc0a Mon Sep 17 00:00:00 2001 From: Alex Corrado Date: Sat, 20 May 2023 23:40:55 +0100 Subject: [PATCH 07/16] Fix code formatting --- .../Checking/AugmentTypeDefinitions.fs | 1844 +++++++++++------ src/Compiler/Facilities/LanguageFeatures.fs | 2 +- 2 files changed, 1162 insertions(+), 684 deletions(-) diff --git a/src/Compiler/Checking/AugmentTypeDefinitions.fs b/src/Compiler/Checking/AugmentTypeDefinitions.fs index 7c812893cec..0a21aa7ffbb 100644 --- a/src/Compiler/Checking/AugmentTypeDefinitions.fs +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fs @@ -2,7 +2,7 @@ /// Generate the hash/compare functions we add to user-defined types by default. module internal FSharp.Compiler.AugmentTypeDefinitions - + open Internal.Utilities.Library open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.DiagnosticsLogger @@ -14,689 +14,1013 @@ open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypeHierarchy -let mkIComparableCompareToSlotSig (g: TcGlobals) = - TSlotSig("CompareTo", g.mk_IComparable_ty, [], [], [[TSlotParam(Some("obj"), g.obj_ty, false, false, false, [])]], Some g.int_ty) - +let mkIComparableCompareToSlotSig (g: TcGlobals) = + TSlotSig("CompareTo", g.mk_IComparable_ty, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty, false, false, false, []) ] ], Some g.int_ty) + let mkGenericIComparableCompareToSlotSig (g: TcGlobals) ty = - TSlotSig("CompareTo", (mkAppTy g.system_GenericIComparable_tcref [ty]), [], [], [[TSlotParam(Some("obj"), ty, false, false, false, [])]], Some g.int_ty) - + TSlotSig( + "CompareTo", + (mkAppTy g.system_GenericIComparable_tcref [ ty ]), + [], + [], + [ [ TSlotParam(Some("obj"), ty, false, false, false, []) ] ], + Some g.int_ty + ) + let mkIStructuralComparableCompareToSlotSig (g: TcGlobals) = - TSlotSig("CompareTo", g.mk_IStructuralComparable_ty, [], [], [[TSlotParam(None, (mkRefTupledTy g [g.obj_ty ; g.IComparer_ty]), false, false, false, [])]], Some g.int_ty) - + TSlotSig( + "CompareTo", + g.mk_IStructuralComparable_ty, + [], + [], + [ + [ + TSlotParam(None, (mkRefTupledTy g [ g.obj_ty; g.IComparer_ty ]), false, false, false, []) + ] + ], + Some g.int_ty + ) + let mkGenericIEquatableEqualsSlotSig (g: TcGlobals) ty = - TSlotSig("Equals", (mkAppTy g.system_GenericIEquatable_tcref [ty]), [], [], [[TSlotParam(Some("obj"), ty, false, false, false, [])]], Some g.bool_ty) - + TSlotSig( + "Equals", + (mkAppTy g.system_GenericIEquatable_tcref [ ty ]), + [], + [], + [ [ TSlotParam(Some("obj"), ty, false, false, false, []) ] ], + Some g.bool_ty + ) + let mkIStructuralEquatableEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.mk_IStructuralEquatable_ty, [], [], [[TSlotParam(None, (mkRefTupledTy g [g.obj_ty ; g.IEqualityComparer_ty]), false, false, false, [])]], Some g.bool_ty) + TSlotSig( + "Equals", + g.mk_IStructuralEquatable_ty, + [], + [], + [ + [ + TSlotParam(None, (mkRefTupledTy g [ g.obj_ty; g.IEqualityComparer_ty ]), false, false, false, []) + ] + ], + Some g.bool_ty + ) let mkIStructuralEquatableGetHashCodeSlotSig (g: TcGlobals) = - TSlotSig("GetHashCode", g.mk_IStructuralEquatable_ty, [], [], [[TSlotParam(None, g.IEqualityComparer_ty, false, false, false, [])]], Some g.int_ty) - -let mkGetHashCodeSlotSig (g: TcGlobals) = - TSlotSig("GetHashCode", g.obj_ty, [], [], [[]], Some g.int_ty) + TSlotSig( + "GetHashCode", + g.mk_IStructuralEquatable_ty, + [], + [], + [ [ TSlotParam(None, g.IEqualityComparer_ty, false, false, false, []) ] ], + Some g.int_ty + ) + +let mkGetHashCodeSlotSig (g: TcGlobals) = + TSlotSig("GetHashCode", g.obj_ty, [], [], [ [] ], Some g.int_ty) -let mkEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.obj_ty, [], [], [[TSlotParam(Some("obj"), g.obj_ty, false, false, false, [])]], Some g.bool_ty) +let mkEqualsSlotSig (g: TcGlobals) = + TSlotSig("Equals", g.obj_ty, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty, false, false, false, []) ] ], Some g.bool_ty) //------------------------------------------------------------------------- // Helpers associated with code-generation of comparison/hash augmentations -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let mkThisTy g ty = if isStructTy g ty then mkByrefTy g ty else ty +let mkThisTy g ty = + if isStructTy g ty then mkByrefTy g ty else ty -let mkCompareObjTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.int_ty) +let mkCompareObjTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.int_ty) -let mkCompareTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.int_ty) +let mkCompareTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.int_ty) -let mkCompareWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [g.obj_ty ; g.IComparer_ty]) g.int_ty) +let mkCompareWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [ g.obj_ty; g.IComparer_ty ]) g.int_ty) -let mkEqualsObjTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.bool_ty) +let mkEqualsObjTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.bool_ty) -let mkEqualsTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.bool_ty) +let mkEqualsTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.bool_ty) -let mkEqualsWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [g.obj_ty ; g.IEqualityComparer_ty]) g.bool_ty) +let mkEqualsWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [ g.obj_ty; g.IEqualityComparer_ty ]) g.bool_ty) -let mkHashTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.int_ty) +let mkHashTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.int_ty) -let mkHashWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty) +let mkHashWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty) -let mkIsCaseTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.bool_ty) +let mkIsCaseTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.bool_ty) //------------------------------------------------------------------------- // Polymorphic comparison -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let mkRelBinOp (g: TcGlobals) op m e1 e2 = mkAsmExpr ([ op ], [], [e1; e2], [g.bool_ty], m) +let mkRelBinOp (g: TcGlobals) op m e1 e2 = + mkAsmExpr ([ op ], [], [ e1; e2 ], [ g.bool_ty ], m) -let mkClt g m e1 e2 = mkRelBinOp g AI_clt m e1 e2 +let mkClt g m e1 e2 = mkRelBinOp g AI_clt m e1 e2 let mkCgt g m e1 e2 = mkRelBinOp g AI_cgt m e1 e2 //------------------------------------------------------------------------- // REVIEW: make this a .constrained call, not a virtual call. -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -// for creating and using GenericComparer objects and for creating and using +// for creating and using GenericComparer objects and for creating and using // IStructuralComparable objects (Eg, Calling CompareTo(obj o, IComparer comp)) -let mkILLangPrimTy (g: TcGlobals) = mkILNonGenericBoxedTy g.tcref_LanguagePrimitives.CompiledRepresentationForNamedType +let mkILLangPrimTy (g: TcGlobals) = + mkILNonGenericBoxedTy g.tcref_LanguagePrimitives.CompiledRepresentationForNamedType + +let mkILCallGetComparer (g: TcGlobals) m = + let ty = + mkILNonGenericBoxedTy g.tcref_System_Collections_IComparer.CompiledRepresentationForNamedType + + let mspec = + mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericComparer", [], ty) + + mkAsmExpr ([ mkNormalCall mspec ], [], [], [ g.IComparer_ty ], m) + +let mkILCallGetEqualityComparer (g: TcGlobals) m = + let ty = + mkILNonGenericBoxedTy g.tcref_System_Collections_IEqualityComparer.CompiledRepresentationForNamedType -let mkILCallGetComparer (g: TcGlobals) m = - let ty = mkILNonGenericBoxedTy g.tcref_System_Collections_IComparer.CompiledRepresentationForNamedType - let mspec = mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericComparer", [], ty) - mkAsmExpr ([mkNormalCall mspec], [], [], [g.IComparer_ty], m) + let mspec = + mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericEqualityComparer", [], ty) -let mkILCallGetEqualityComparer (g: TcGlobals) m = - let ty = mkILNonGenericBoxedTy g.tcref_System_Collections_IEqualityComparer.CompiledRepresentationForNamedType - let mspec = mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericEqualityComparer", [], ty) - mkAsmExpr ([mkNormalCall mspec], [], [], [g.IEqualityComparer_ty], m) + mkAsmExpr ([ mkNormalCall mspec ], [], [], [ g.IEqualityComparer_ty ], m) -let mkThisVar g m ty = mkCompGenLocal m "this" (mkThisTy g ty) +let mkThisVar g m ty = mkCompGenLocal m "this" (mkThisTy g ty) -let mkShl g m acce n = mkAsmExpr ([ AI_shl ], [], [acce; mkInt g m n], [g.int_ty], m) +let mkShl g m acce n = + mkAsmExpr ([ AI_shl ], [], [ acce; mkInt g m n ], [ g.int_ty ], m) -let mkShr g m acce n = mkAsmExpr ([ AI_shr ], [], [acce; mkInt g m n], [g.int_ty], m) +let mkShr g m acce n = + mkAsmExpr ([ AI_shr ], [], [ acce; mkInt g m n ], [ g.int_ty ], m) + +let mkAdd (g: TcGlobals) m e1 e2 = + mkAsmExpr ([ AI_add ], [], [ e1; e2 ], [ g.int_ty ], m) -let mkAdd (g: TcGlobals) m e1 e2 = mkAsmExpr ([ AI_add ], [], [e1;e2], [g.int_ty], m) - let mkAddToHashAcc g m e accv acce = - mkValSet m accv - (mkAdd g m (mkInt g m 0x9e3779b9) - (mkAdd g m e - (mkAdd g m (mkShl g m acce 6) (mkShr g m acce 2)))) - + mkValSet m accv (mkAdd g m (mkInt g m 0x9e3779b9) (mkAdd g m e (mkAdd g m (mkShl g m acce 6) (mkShr g m acce 2)))) + let mkCombineHashGenerators g m exprs accv acce = - (acce, exprs) ||> List.fold (fun tm e -> mkCompGenSequential m (mkAddToHashAcc g m e accv acce) tm) + (acce, exprs) + ||> List.fold (fun tm e -> mkCompGenSequential m (mkAddToHashAcc g m e accv acce) tm) //------------------------------------------------------------------------- // Build comparison functions for union, record and exception types. -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) +let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) -let mkThatAddrLocalIfNeeded g m tcve ty = - if isStructTy g ty then - let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) +let mkThatAddrLocalIfNeeded g m tcve ty = + if isStructTy g ty then + let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) Some thataddrv, thataddre - else None, tcve - + else + None, tcve + let mkThisVarThatVar g m ty = let thisv, thise = mkThisVar g m ty let thataddrv, thataddre = mkThatAddrLocal g m ty thisv, thataddrv, thise, thataddre -let mkThatVarBind g m ty thataddrv expr = - if isStructTy g ty then - let thatv2, _ = mkMutableCompGenLocal m "obj" ty - thatv2, mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv2)) expr - else thataddrv, expr +let mkThatVarBind g m ty thataddrv expr = + if isStructTy g ty then + let thatv2, _ = mkMutableCompGenLocal m "obj" ty + thatv2, mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv2)) expr + else + thataddrv, expr let mkBindThatAddr g m ty thataddrv thatv thate expr = if isStructTy g ty then // let thataddrv = &thatv - mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr + mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr else // let thataddrv = that - mkCompGenLet m thataddrv thate expr + mkCompGenLet m thataddrv thate expr let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = - match thataddrvOpt with + match thataddrvOpt with | None -> expr | Some thataddrv -> // let thataddrv = &thatv - mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr + mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr let mkCompareTestConjuncts g m exprs = - match List.tryFrontAndBack exprs with + match List.tryFrontAndBack exprs with | None -> mkZero g m - | Some (a,b) -> - (a, b) ||> List.foldBack (fun e acc -> + | Some (a, b) -> + (a, b) + ||> List.foldBack (fun e acc -> let nv, ne = mkCompGenLocal m "n" g.int_ty - mkCompGenLet m nv e - (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkClt g m ne (mkZero g m)) - ne - (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkCgt g m ne (mkZero g m)) + + mkCompGenLet + m + nv + e + (mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkClt g m ne (mkZero g m)) ne - acc))) + (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty (mkCgt g m ne (mkZero g m)) ne acc))) let mkEqualsTestConjuncts g m exprs = - match List.tryFrontAndBack exprs with + match List.tryFrontAndBack exprs with | None -> mkOne g m - | Some (a,b) -> - List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b + | Some (a, b) -> List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b -let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = - if tcref.Deref.IsFSharpException then [], g.exn_ty - else generalizeTyconRef g tcref +let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = + if tcref.Deref.IsFSharpException then + [], g.exn_ty + else + generalizeTyconRef g tcref // check for nulls -let mkBindNullComparison g m thise thate expr = - let expr = mkNonNullCond g m g.int_ty thate expr (mkOne g m) - let expr = mkNonNullCond g m g.int_ty thise expr (mkNonNullCond g m g.int_ty thate (mkMinusOne g m) (mkZero g m) ) +let mkBindNullComparison g m thise thate expr = + let expr = mkNonNullCond g m g.int_ty thate expr (mkOne g m) + + let expr = + mkNonNullCond g m g.int_ty thise expr (mkNonNullCond g m g.int_ty thate (mkMinusOne g m) (mkZero g m)) + expr -let mkBindThisNullEquals g m thise thate expr = - let expr = mkNonNullCond g m g.bool_ty thise expr (mkNonNullCond g m g.int_ty thate (mkFalse g m) (mkTrue g m) ) +let mkBindThisNullEquals g m thise thate expr = + let expr = + mkNonNullCond g m g.bool_ty thise expr (mkNonNullCond g m g.int_ty thate (mkFalse g m) (mkTrue g m)) + expr -let mkBindThatNullEquals g m thise thate expr = - let expr = mkNonNullCond g m g.bool_ty thate expr (mkFalse g m) +let mkBindThatNullEquals g m thise thate expr = + let expr = mkNonNullCond g m g.bool_ty thate expr (mkFalse g m) let expr = mkBindThisNullEquals g m thise thate expr expr - -let mkBindNullHash g m thise expr = + +let mkBindNullHash g m thise expr = let expr = mkNonNullCond g m g.int_ty thise expr (mkZero g m) expr -/// Build the comparison implementation for a record type -let mkRecdCompare g tcref (tycon: Tycon) = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList +/// Build the comparison implementation for a record type +let mkRecdCompare g tcref (tycon: Tycon) = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty let compe = mkILCallGetComparer g m - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericComparisonWithComparerOuter g m fspec.FormalType - compe - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericComparisonWithComparerOuter + g + m + fspec.FormalType + compe + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkCompareTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thataddre expr let thatv, expr = mkThatVarBind g m ty thataddrv expr thisv, thatv, expr /// Build the comparison implementation for a record type when parameterized by a comparer -let mkRecdCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_, thate) compe = - let m = tycon.Range +let mkRecdCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_, thate) compe = + let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst, ty = mkMinimalTy g tcref - let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = thate - let thataddrv, thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct - - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericComparisonWithComparerOuter g m fspec.FormalType - compe - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr + let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = thate + let thataddrv, thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct + + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericComparisonWithComparerOuter + g + m + fspec.FormalType + compe + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkCompareTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thate expr let expr = mkBindThatAddr g m ty thataddrv tcv tce expr // will be optimized away if not necessary let expr = mkCompGenLet m tcv thate expr - expr + expr -/// Build the .Equals(that) equality implementation wrapper for a record type -let mkRecdEquality g tcref (tycon: Tycon) = +/// Build the .Equals(that) equality implementation wrapper for a record type +let mkRecdEquality g tcref (tycon: Tycon) = let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList + let fields = tycon.AllInstanceFieldsAsList let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericEqualityEROuter g m fspec.FormalType - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericEqualityEROuter + g + m + fspec.FormalType + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThatNullEquals g m thise thataddre expr let thatv, expr = mkThatVarBind g m ty thataddrv expr thisv, thatv, expr - + /// Build the equality implementation for a record type when parameterized by a comparer let mkRecdEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst, ty = mkMinimalTy g tcref let thataddrv, thataddre = mkThatAddrLocal g m ty - + let mkTest (fspec: RecdField) = let fref = tcref.MakeNestedRecdFieldRef fspec let m = fref.Range - - mkCallGenericEqualityWithComparerOuter g m fspec.FormalType + + mkCallGenericEqualityWithComparerOuter + g + m + fspec.FormalType compe (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) let expr = mkBindThatAddr g m ty thataddrv thatv thate expr // will be optimized away if not necessary let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr expr - + /// Build the equality implementation for an exception definition -let mkExnEquality (g: TcGlobals) exnref (exnc: Tycon) = - let m = exnc.Range - let thatv, thate = mkCompGenLocal m "obj" g.exn_ty - let thisv, thise = mkThisVar g m g.exn_ty - let mkTest i (rfield: RecdField) = - mkCallGenericEqualityEROuter g m rfield.FormalType - (mkExnCaseFieldGet(thise, exnref, i, m)) - (mkExnCaseFieldGet(thate, exnref, i, m)) - let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) +let mkExnEquality (g: TcGlobals) exnref (exnc: Tycon) = + let m = exnc.Range + let thatv, thate = mkCompGenLocal m "obj" g.exn_ty + let thisv, thise = mkThisVar g m g.exn_ty + + let mkTest i (rfield: RecdField) = + mkCallGenericEqualityEROuter + g + m + rfield.FormalType + (mkExnCaseFieldGet (thise, exnref, i, m)) + (mkExnCaseFieldGet (thate, exnref, i, m)) + + let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) + let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let cases = - [ mkCase(DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), - mbuilder.AddResultTarget(expr)) ] + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let cases = + [ + mkCase (DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), mbuilder.AddResultTarget(expr)) + ] + let dflt = Some(mbuilder.AddResultTarget(mkFalse g m)) let dtree = TDSwitch(thate, cases, dflt, m) mbuilder.Close(dtree, m, g.bool_ty) let expr = mkBindThatNullEquals g m thise thate expr thisv, thatv, expr - + /// Build the equality implementation for an exception definition when parameterized by a comparer -let mkExnEqualityWithComparer g exnref (exnc: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = +let mkExnEqualityWithComparer g exnref (exnc: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = let m = exnc.Range - let thataddrv, thataddre = mkThatAddrLocal g m g.exn_ty - let mkTest i (rfield: RecdField) = - mkCallGenericEqualityWithComparerOuter g m rfield.FormalType - compe - (mkExnCaseFieldGet(thise, exnref, i, m)) - (mkExnCaseFieldGet(thataddre, exnref, i, m)) - let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) + let thataddrv, thataddre = mkThatAddrLocal g m g.exn_ty + + let mkTest i (rfield: RecdField) = + mkCallGenericEqualityWithComparerOuter + g + m + rfield.FormalType + compe + (mkExnCaseFieldGet (thise, exnref, i, m)) + (mkExnCaseFieldGet (thataddre, exnref, i, m)) + + let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) + let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let cases = - [ mkCase(DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), - mbuilder.AddResultTarget(expr)) ] + [ + mkCase (DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), mbuilder.AddResultTarget(expr)) + ] + let dflt = mbuilder.AddResultTarget(mkFalse g m) let dtree = TDSwitch(thate, cases, Some dflt, m) mbuilder.Close(dtree, m, g.bool_ty) + let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr let expr = mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) - let expr = if exnc.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr + + let expr = + if exnc.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr + expr /// Build the comparison implementation for a union type -let mkUnionCompare g tcref (tycon: Tycon) = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList +let mkUnionCompare g tcref (tycon: Tycon) = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty let compe = mkILCallGetComparer g m - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - let rfields = ucase.RecdFields - if isNil rfields then None else - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericComparisonWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericComparisonWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkZero g m + else + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionCompare") + + let dflt = + if isNil nullary then + None else - let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkZero g m else - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionCompare") - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.int_ty) + Some(mbuilder.AddResultTarget(mkZero g m)) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.int_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkILAsmCeq g m thistage thattage) + expr + (mkAsmExpr ([ AI_sub ], [], [ thistage; thattage ], [ g.int_ty ], m)) in + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkAsmExpr ([ AI_sub ], [], [thistage; thattage], [g.int_ty], m))in - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thataddre expr + let thatv, expr = mkThatVarBind g m ty thataddrv expr thisv, thatv, expr - /// Build the comparison implementation for a union type when parameterized by a comparer -let mkUnionCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_thatobjv, thatcaste) compe = - let m = tycon.Range +let mkUnionCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_thatobjv, thatcaste) compe = + let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst, ty = mkMinimalTy g tcref - let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) + let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) let thataddrvOpt, thataddre = mkThatAddrLocalIfNeeded g m tce ty // let thataddrv = &tcv if struct, otherwise thataddre is just tce - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - let rfields = ucase.RecdFields - if isNil rfields then None else - - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericComparisonWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericComparisonWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = + mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + + let thatucv, thatucve = + mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkZero g m + else + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionCompare") + + let dflt = + if isNil nullary then + None else - let thisucv, thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkZero g m else - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionCompare") - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.int_ty) + Some(mbuilder.AddResultTarget(mkZero g m)) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.int_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkILAsmCeq g m thistage thattage) + expr + (mkAsmExpr ([ AI_sub ], [], [ thistage; thattage ], [ g.int_ty ], m)) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkAsmExpr ([ AI_sub ], [], [thistage; thattage], [g.int_ty], m)) - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste expr + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thatcaste expr + let expr = mkBindThatAddrIfNeeded m thataddrvOpt tcv expr let expr = mkCompGenLet m tcv thatcaste expr expr - - + /// Build the equality implementation for a union type -let mkUnionEquality g tcref (tycon: Tycon) = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList +let mkUnionEquality g tcref (tycon: Tycon) = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range let rfields = ucase.RecdFields - if isNil rfields then None else - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericEqualityEROuter g m fld.FormalType - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericEqualityEROuter + g + m + fld.FormalType + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkTrue g m + else + let cases = + List.map + (function + | Some c -> c + | None -> failwith "mkUnionEquality") + nonNullary + + let dflt = + (if isNil nullary then + None + else + Some(mbuilder.AddResultTarget(mkTrue g m))) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) - else - let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkTrue g m else - let cases = List.map (function Some c -> c | None -> failwith "mkUnionEquality") nonNullary - let dflt = (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m))) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty - (mkILAsmCeq g m thistage thattage) + if List.isSingleton ucases then expr - (mkFalse g m) + else - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) + let tagsEqTested = + mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty (mkILAsmCeq g m thistage thattage) expr (mkFalse g m) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) let thatv, expr = mkThatVarBind g m ty thataddrv expr - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThatNullEquals g m thise thataddre expr + thisv, thatv, expr /// Build the equality implementation for a union type when parameterized by a comparer let mkUnionEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = - let m = tycon.Range + let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst, ty = mkMinimalTy g tcref - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty let thataddrv, thataddre = mkThatAddrLocal g m ty - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range let rfields = ucase.RecdFields - if isNil rfields then None else - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericEqualityWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericEqualityWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = + mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + + let thatucv, thatucve = + mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkTrue g m + else + let cases = + List.map + (function + | Some c -> c + | None -> failwith "mkUnionEquality") + nonNullary + + let dflt = + if isNil nullary then + None else - let thisucv, thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget (test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkTrue g m else - let cases = List.map (function Some c -> c | None -> failwith "mkUnionEquality") nonNullary - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - - let expr = - if List.isSingleton ucases then expr else + Some(mbuilder.AddResultTarget(mkTrue g m)) - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty - (mkILAsmCeq g m thistage thattage) + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) + + let expr = + if List.isSingleton ucases then expr - (mkFalse g m) + else + + let tagsEqTested = + mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty (mkILAsmCeq g m thistage thattage) expr (mkFalse g m) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) let expr = mkBindThatAddr g m ty thataddrv thatv thate expr let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr + expr //------------------------------------------------------------------------- // Build hashing functions for union, record and exception types. // Hashing functions must respect the "=" and comparison operators. -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -/// Structural hash implementation for record types when parameterized by a comparer -let mkRecdHashWithComparer g tcref (tycon: Tycon) compe = - let m = tycon.Range +/// Structural hash implementation for record types when parameterized by a comparer +let mkRecdHashWithComparer g tcref (tycon: Tycon) compe = + let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst, ty = mkMinimalTy g tcref let thisv, thise = mkThisVar g m ty - let mkFieldHash (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range + + let mkFieldHash (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range let e = mkRecdFieldGetViaExprAddr (thise, fref, tinst, m) - + mkCallGenericHashWithComparerOuter g m fspec.FormalType compe e - - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let stmt = mkCombineHashGenerators g m (List.map mkFieldHash fields) (mkLocalValRef accv) acce - let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr + + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let stmt = + mkCombineHashGenerators g m (List.map mkFieldHash fields) (mkLocalValRef accv) acce + + let expr = mkCompGenLet m accv (mkZero g m) stmt + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullHash g m thise expr + thisv, expr /// Structural hash implementation for exception types when parameterized by a comparer -let mkExnHashWithComparer g exnref (exnc: Tycon) compe = +let mkExnHashWithComparer g exnref (exnc: Tycon) compe = let m = exnc.Range let thisv, thise = mkThisVar g m g.exn_ty - - let mkHash i (rfield: RecdField) = - let e = mkExnCaseFieldGet(thise, exnref, i, m) - + + let mkHash i (rfield: RecdField) = + let e = mkExnCaseFieldGet (thise, exnref, i, m) + mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e - - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let stmt = mkCombineHashGenerators g m (List.mapi mkHash exnc.AllInstanceFieldsAsList) (mkLocalValRef accv) acce - let expr = mkCompGenLet m accv (mkZero g m) stmt + + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let stmt = + mkCombineHashGenerators g m (List.mapi mkHash exnc.AllInstanceFieldsAsList) (mkLocalValRef accv) acce + + let expr = mkCompGenLet m accv (mkZero g m) stmt let expr = mkBindNullHash g m thise expr thisv, expr -/// Structural hash implementation for union types when parameterized by a comparer +/// Structural hash implementation for union types when parameterized by a comparer let mkUnionHashWithComparer g tcref (tycon: Tycon) compe = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst, ty = mkMinimalTy g tcref let thisv, thise = mkThisVar g m ty - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let mkCase i ucase1 = - let c1ref = tcref.MakeNestedUnionCaseRef ucase1 - let m = c1ref.Range - if ucase1.IsNullary then None + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let mkCase i ucase1 = + let c1ref = tcref.MakeNestedUnionCaseRef ucase1 + let m = c1ref.Range + + if ucase1.IsNullary then + None else - let mkHash thise j (rfield: RecdField) = + let mkHash thise j (rfield: RecdField) = let e = mkUnionCaseFieldGetProvenViaExprAddr (thise, c1ref, tinst, j, m) mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e - let test = - if tycon.IsStructOrEnumTycon then - mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + let test = + if tycon.IsStructOrEnumTycon then + mkCompGenSequential + m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) (mkCombineHashGenerators g m (List.mapi (mkHash thise) ucase1.RecdFields) (mkLocalValRef accv) acce) else let ucv, ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) - mkCompGenLet m ucv + + mkCompGenLet + m + ucv (mkUnionCaseProof (thise, c1ref, tinst, m)) - (mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCompGenSequential + m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) (mkCombineHashGenerators g m (List.mapi (mkHash ucve) ucase1.RecdFields) (mkLocalValRef accv) acce)) - Some(mkCase(DecisionTreeTest.UnionCase(c1ref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = ucases - |> List.mapi mkCase - |> List.partition (fun i -> i.IsNone) - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionHash") - let dflt = if isNil nullary then None - else - let tag = mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m) - Some(mbuilder.AddResultTarget(tag)) + + Some(mkCase (DecisionTreeTest.UnionCase(c1ref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = + ucases |> List.mapi mkCase |> List.partition (fun i -> i.IsNone) + + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionHash") + + let dflt = + if isNil nullary then + None + else + let tag = mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m) + Some(mbuilder.AddResultTarget(tag)) + let dtree = TDSwitch(thise, cases, dflt, m) let stmt = mbuilder.Close(dtree, m, g.int_ty) - let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr - thisv, expr + let expr = mkCompGenLet m accv (mkZero g m) stmt + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullHash g m thise expr + thisv, expr //------------------------------------------------------------------------- -// The predicate that determines which types implement the +// The predicate that determines which types implement the // pre-baked IStructuralHash and IComparable semantics associated with F# -// types. Note abstract types are not _known_ to implement these interfaces, +// types. Note abstract types are not _known_ to implement these interfaces, // though the interfaces may be discoverable via type tests. -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let isNominalExnc (exnc: Tycon) = - match exnc.ExceptionInfo with - | TExnAbbrevRepr _ | TExnNone | TExnAsmRepr _ -> false +let isNominalExnc (exnc: Tycon) = + match exnc.ExceptionInfo with + | TExnAbbrevRepr _ + | TExnNone + | TExnAsmRepr _ -> false | TExnFresh _ -> true -let isTrueFSharpStructTycon _g (tycon: Tycon) = - (tycon.IsFSharpStructOrEnumTycon && not tycon.IsFSharpEnumTycon) - -let canBeAugmentedWithEquals g (tycon: Tycon) = - tycon.IsUnionTycon || - tycon.IsRecordTycon || - (tycon.IsFSharpException && isNominalExnc tycon) || - isTrueFSharpStructTycon g tycon - -let canBeAugmentedWithCompare g (tycon: Tycon) = - tycon.IsUnionTycon || - tycon.IsRecordTycon || - isTrueFSharpStructTycon g tycon - -let getAugmentationAttribs g (tycon: Tycon) = - canBeAugmentedWithEquals g tycon, - canBeAugmentedWithCompare g tycon, - TryFindFSharpBoolAttribute g g.attrib_NoEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_CustomEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_ReferenceEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_NoComparisonAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_CustomComparisonAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs - -let CheckAugmentationAttribs isImplementation g amap (tycon: Tycon) = +let isTrueFSharpStructTycon _g (tycon: Tycon) = + (tycon.IsFSharpStructOrEnumTycon && not tycon.IsFSharpEnumTycon) + +let canBeAugmentedWithEquals g (tycon: Tycon) = + tycon.IsUnionTycon + || tycon.IsRecordTycon + || (tycon.IsFSharpException && isNominalExnc tycon) + || isTrueFSharpStructTycon g tycon + +let canBeAugmentedWithCompare g (tycon: Tycon) = + tycon.IsUnionTycon || tycon.IsRecordTycon || isTrueFSharpStructTycon g tycon + +let getAugmentationAttribs g (tycon: Tycon) = + canBeAugmentedWithEquals g tycon, + canBeAugmentedWithCompare g tycon, + TryFindFSharpBoolAttribute g g.attrib_NoEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_CustomEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_ReferenceEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_NoComparisonAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_CustomComparisonAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs + +let CheckAugmentationAttribs isImplementation g amap (tycon: Tycon) = let m = tycon.Range let attribs = getAugmentationAttribs g tycon - match attribs with - - // THESE ARE THE LEGITIMATE CASES + + match attribs with + + // THESE ARE THE LEGITIMATE CASES // [< >] on anything | _, _, None, None, None, None, None, None, None @@ -705,168 +1029,171 @@ let CheckAugmentationAttribs isImplementation g amap (tycon: Tycon) = | true, _, None, Some true, None, None, None, Some true, None // [] on union/record/struct - | true, _, None, Some true, None, None, Some true, None, None -> - () + | true, _, None, Some true, None, None, Some true, None, None -> () // [] on union/record/struct | true, _, None, None, Some true, None, Some true, None, None // [] on union/record/struct | true, _, None, None, Some true, None, None, None, None -> - if isTrueFSharpStructTycon g tycon then - errorR(Error(FSComp.SR.augNoRefEqualsOnStruct(), m)) - else () + if isTrueFSharpStructTycon g tycon then + errorR (Error(FSComp.SR.augNoRefEqualsOnStruct (), m)) + else + () // [] on union/record/struct - | true, true, None, None, None, Some true, None, None, Some true + | true, true, None, None, None, Some true, None, None, Some true - // [] + // [] | true, _, None, None, None, Some true, Some true, None, None - // [] + // [] | true, _, None, None, None, Some true, None, Some true, None // [] on anything - | _, _, None, None, None, None, Some true, None, None + | _, _, None, None, None, None, Some true, None, None // [] on anything - | _, _, Some true, None, None, None, Some true, None, None -> - () + | _, _, Some true, None, None, None, Some true, None, None -> () // THESE ARE THE ERROR CASES - // [] - | _, _, Some true, _, _, _, None, _, _ -> - errorR(Error(FSComp.SR.augNoEqualityNeedsNoComparison(), m)) + // [] + | _, _, Some true, _, _, _, None, _, _ -> errorR (Error(FSComp.SR.augNoEqualityNeedsNoComparison (), m)) - // [] - | true, true, _, _, _, None, _, _, Some true -> - errorR(Error(FSComp.SR.augStructCompNeedsStructEquality(), m)) - // [] - | true, _, _, _, _, Some true, None, _, None -> - errorR(Error(FSComp.SR.augStructEqNeedsNoCompOrStructComp(), m)) + // [] + | true, true, _, _, _, None, _, _, Some true -> errorR (Error(FSComp.SR.augStructCompNeedsStructEquality (), m)) + // [] + | true, _, _, _, _, Some true, None, _, None -> errorR (Error(FSComp.SR.augStructEqNeedsNoCompOrStructComp (), m)) - // [] - | true, _, _, Some true, _, _, None, None, _ -> - errorR(Error(FSComp.SR.augCustomEqNeedsNoCompOrCustomComp(), m)) + // [] + | true, _, _, Some true, _, _, None, None, _ -> errorR (Error(FSComp.SR.augCustomEqNeedsNoCompOrCustomComp (), m)) - // [] + // [] | true, _, _, _, Some true, Some true, _, _, _ - // [] - | true, _, _, _, Some true, _, _, _, Some true -> - errorR(Error(FSComp.SR.augTypeCantHaveRefEqAndStructAttrs(), m)) + // [] + | true, _, _, _, Some true, _, _, _, Some true -> errorR (Error(FSComp.SR.augTypeCantHaveRefEqAndStructAttrs (), m)) - // non augmented type, [] - // non augmented type, [] - // non augmented type, [] + // non augmented type, [] + // non augmented type, [] + // non augmented type, [] | false, _, _, _, Some true, _, _, _, _ - | false, _, _, _, _, Some true, _, _, _ - | false, _, _, _, _, _, _, _, Some true -> - errorR(Error(FSComp.SR.augOnlyCertainTypesCanHaveAttrs(), m)) + | false, _, _, _, _, Some true, _, _, _ + | false, _, _, _, _, _, _, _, Some true -> errorR (Error(FSComp.SR.augOnlyCertainTypesCanHaveAttrs (), m)) // All other cases - | _ -> - errorR(Error(FSComp.SR.augInvalidAttrs(), m)) - + | _ -> errorR (Error(FSComp.SR.augInvalidAttrs (), m)) + let hasNominalInterface tcref = let ty = generalizedTyconRef g (mkLocalTyconRef tycon) ExistsHeadTypeInEntireHierarchy g amap tycon.Range ty tcref - let hasExplicitICompare = - hasNominalInterface g.tcref_System_IStructuralComparable || - hasNominalInterface g.tcref_System_IComparable + let hasExplicitICompare = + hasNominalInterface g.tcref_System_IStructuralComparable + || hasNominalInterface g.tcref_System_IComparable - let hasExplicitIGenericCompare = - hasNominalInterface g.system_GenericIComparable_tcref + let hasExplicitIGenericCompare = + hasNominalInterface g.system_GenericIComparable_tcref - let hasExplicitEquals = - tycon.HasOverride g "Equals" [g.obj_ty] || - hasNominalInterface g.tcref_System_IStructuralEquatable + let hasExplicitEquals = + tycon.HasOverride g "Equals" [ g.obj_ty ] + || hasNominalInterface g.tcref_System_IStructuralEquatable - let hasExplicitGenericEquals = - hasNominalInterface g.system_GenericIEquatable_tcref + let hasExplicitGenericEquals = hasNominalInterface g.system_GenericIEquatable_tcref - match attribs with + match attribs with // [] + any equality semantics - | _, _, Some true, _, _, _, _, _, _ when (hasExplicitEquals || hasExplicitGenericEquals) -> - warning(Error(FSComp.SR.augNoEqNeedsNoObjEquals(), m)) + | _, _, Some true, _, _, _, _, _, _ when (hasExplicitEquals || hasExplicitGenericEquals) -> + warning (Error(FSComp.SR.augNoEqNeedsNoObjEquals (), m)) // [] + any comparison semantics - | _, _, _, _, _, _, Some true, _, _ when (hasExplicitICompare || hasExplicitIGenericCompare) -> - warning(Error(FSComp.SR.augNoCompCantImpIComp(), m)) + | _, _, _, _, _, _, Some true, _, _ when (hasExplicitICompare || hasExplicitIGenericCompare) -> + warning (Error(FSComp.SR.augNoCompCantImpIComp (), m)) // [] + no explicit override Object.Equals + no explicit IStructuralEquatable - | _, _, _, Some true, _, _, _, _, _ when isImplementation && not hasExplicitEquals && not hasExplicitGenericEquals-> - errorR(Error(FSComp.SR.augCustomEqNeedsObjEquals(), m)) + | _, _, _, Some true, _, _, _, _, _ when isImplementation && not hasExplicitEquals && not hasExplicitGenericEquals -> + errorR (Error(FSComp.SR.augCustomEqNeedsObjEquals (), m)) // [] + no explicit IComparable + no explicit IStructuralComparable - | _, _, _, _, _, _, _, Some true, _ when isImplementation && not hasExplicitICompare && not hasExplicitIGenericCompare -> - errorR(Error(FSComp.SR.augCustomCompareNeedsIComp(), m)) + | _, _, _, _, _, _, _, Some true, _ when isImplementation && not hasExplicitICompare && not hasExplicitIGenericCompare -> + errorR (Error(FSComp.SR.augCustomCompareNeedsIComp (), m)) // [] + any equality semantics - | _, _, _, _, Some true, _, _, _, _ when (hasExplicitEquals || hasExplicitIGenericCompare) -> - errorR(Error(FSComp.SR.augRefEqCantHaveObjEquals(), m)) + | _, _, _, _, Some true, _, _, _, _ when (hasExplicitEquals || hasExplicitIGenericCompare) -> + errorR (Error(FSComp.SR.augRefEqCantHaveObjEquals (), m)) - | _ -> - () + | _ -> () -let TyconIsCandidateForAugmentationWithCompare (g: TcGlobals) (tycon: Tycon) = +let TyconIsCandidateForAugmentationWithCompare (g: TcGlobals) (tycon: Tycon) = // This type gets defined in prim-types, before we can add attributes to F# type definitions let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" - not isUnit && - not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) && - match getAugmentationAttribs g tycon with - // [< >] - | true, true, None, None, None, None, None, None, None - // [] - | true, true, None, None, None, Some true, None, None, Some true - // [] - | true, true, None, None, None, None, None, None, Some true -> true - // other cases - | _ -> false -let TyconIsCandidateForAugmentationWithEquals (g: TcGlobals) (tycon: Tycon) = + not isUnit + && not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) + && match getAugmentationAttribs g tycon with + // [< >] + | true, true, None, None, None, None, None, None, None + // [] + | true, true, None, None, None, Some true, None, None, Some true + // [] + | true, true, None, None, None, None, None, None, Some true -> true + // other cases + | _ -> false + +let TyconIsCandidateForAugmentationWithEquals (g: TcGlobals) (tycon: Tycon) = // This type gets defined in prim-types, before we can add attributes to F# type definitions let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" - not isUnit && - not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) && - match getAugmentationAttribs g tycon with - // [< >] + not isUnit + && not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) + && + + match getAugmentationAttribs g tycon with + // [< >] | true, _, None, None, None, None, _, _, _ - // [] - // [] + // [] + // [] | true, _, None, None, None, Some true, _, _, _ -> true - // other cases + // other cases | _ -> false -let TyconIsCandidateForAugmentationWithHash g tycon = TyconIsCandidateForAugmentationWithEquals g tycon - +let TyconIsCandidateForAugmentationWithHash g tycon = + TyconIsCandidateForAugmentationWithEquals g tycon + +//------------------------------------------------------------------------- +// Make values that represent the implementations of the +// IComparable semantics associated with F# types. //------------------------------------------------------------------------- -// Make values that represent the implementations of the -// IComparable semantics associated with F# types. -//------------------------------------------------------------------------- - -let slotImplMethod (final, c, slotsig) : ValMemberInfo = - { ImplementedSlotSigs=[slotsig] - MemberFlags= - { IsInstance=true - IsDispatchSlot=false - IsFinal=final - IsOverrideOrExplicitImpl=true - GetterOrSetterIsCompilerGenerated=false - MemberKind=SynMemberKind.Member } - IsImplemented=false - ApparentEnclosingEntity=c} - -let nonVirtualMethod mk c : ValMemberInfo = - { ImplementedSlotSigs=[] - MemberFlags={ IsInstance=true - IsDispatchSlot=false - IsFinal=false - IsOverrideOrExplicitImpl=false - GetterOrSetterIsCompilerGenerated=false - MemberKind=mk } - IsImplemented=false - ApparentEnclosingEntity=c} + +let slotImplMethod (final, c, slotsig) : ValMemberInfo = + { + ImplementedSlotSigs = [ slotsig ] + MemberFlags = + { + IsInstance = true + IsDispatchSlot = false + IsFinal = final + IsOverrideOrExplicitImpl = true + GetterOrSetterIsCompilerGenerated = false + MemberKind = SynMemberKind.Member + } + IsImplemented = false + ApparentEnclosingEntity = c + } + +let nonVirtualMethod mk c : ValMemberInfo = + { + ImplementedSlotSigs = [] + MemberFlags = + { + IsInstance = true + IsDispatchSlot = false + IsFinal = false + IsOverrideOrExplicitImpl = false + GetterOrSetterIsCompilerGenerated = false + MemberKind = mk + } + IsImplemented = false + ApparentEnclosingEntity = c + } let unitArg = ValReprInfo.unitArgData @@ -876,18 +1203,51 @@ let tupArg = [ [ ValReprInfo.unnamedTopArg1; ValReprInfo.unnamedTopArg1 ] ] let mkValSpecAux g m (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter isCompGen = let tps = tcref.Typars m + let membInfo = match slotsig with | None -> - let mk = if isGetter then SynMemberKind.PropertyGet else SynMemberKind.Member + let mk = + if isGetter then + SynMemberKind.PropertyGet + else + SynMemberKind.Member + nonVirtualMethod mk tcref | Some slotsig -> let final = isUnionTy g ty || isRecdTy g ty || isStructTy g ty - slotImplMethod(final, tcref, slotsig) + slotImplMethod (final, tcref, slotsig) + let inl = ValInline.Optional let args = ValReprInfo.unnamedTopArg :: argData - let valReprInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) - Construct.NewVal (methn, m, None, valTy, Immutable, isCompGen, valReprInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref) + + let valReprInfo = + Some(ValReprInfo(ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) + + Construct.NewVal( + methn, + m, + None, + valTy, + Immutable, + isCompGen, + valReprInfo, + vis, + ValNotInRecScope, + Some membInfo, + NormalVal, + [], + inl, + XmlDoc.Empty, + true, + false, + false, + false, + false, + false, + None, + Parent tcref + ) let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter = mkValSpecAux g tcref.Range tcref ty vis slotsig methn valTy argData isGetter true @@ -912,65 +1272,119 @@ let MakeValsForCompareWithComparerAugmentation g (tcref: TyconRef) = let _, ty = mkMinimalTy g tcref let tps = tcref.Typars m let vis = tcref.TypeReprAccessibility - mkValSpec g tcref ty vis (Some(mkIStructuralComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareWithComparerTy g ty)) tupArg false -let MakeValsForEqualsAugmentation g (tcref: TyconRef) = + mkValSpec + g + tcref + ty + vis + (Some(mkIStructuralComparableCompareToSlotSig g)) + "CompareTo" + (tps +-> (mkCompareWithComparerTy g ty)) + tupArg + false + +let MakeValsForEqualsAugmentation g (tcref: TyconRef) = let m = tcref.Range let _, ty = mkMinimalTy g tcref let vis = tcref.TypeReprAccessibility let tps = tcref.Typars m - let objEqualsVal = mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg false - let nocEqualsVal = mkValSpec g tcref ty vis (if tcref.Deref.IsFSharpException then None else Some(mkGenericIEquatableEqualsSlotSig g ty)) "Equals" (tps +-> (mkEqualsTy g ty)) unaryArg false + let objEqualsVal = + mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg false + + let nocEqualsVal = + mkValSpec + g + tcref + ty + vis + (if tcref.Deref.IsFSharpException then + None + else + Some(mkGenericIEquatableEqualsSlotSig g ty)) + "Equals" + (tps +-> (mkEqualsTy g ty)) + unaryArg + false + objEqualsVal, nocEqualsVal let MakeValsForEqualityWithComparerAugmentation g (tcref: TyconRef) = let _, ty = mkMinimalTy g tcref let vis = tcref.TypeReprAccessibility let tps = tcref.Typars tcref.Range - let objGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg false - let withcGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashWithComparerTy g ty)) unaryArg false - let withcEqualsVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg false + + let objGetHashCodeVal = + mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg false + + let withcGetHashCodeVal = + mkValSpec + g + tcref + ty + vis + (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) + "GetHashCode" + (tps +-> (mkHashWithComparerTy g ty)) + unaryArg + false + + let withcEqualsVal = + mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg false + objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal -let MakeBindingsForCompareAugmentation g (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon +let MakeBindingsForCompareAugmentation g (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon let m = tycon.Range let tps = tycon.Typars m + let mkCompare comparef = - match tycon.GeneratedCompareToValues with - | None -> [] - | Some (vref1, vref2) -> + match tycon.GeneratedCompareToValues with + | None -> [] + | Some (vref1, vref2) -> let vspec1 = vref1.Deref let vspec2 = vref2.Deref (* this is the body of the override *) - let rhs1 = - let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let comparee = - if isUnitTy g ty then mkZero g m else - let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) - - mkApps g ((exprForValRef m vref2, vref2.Type), (if isNil tinst then [] else [tinst]), [thise;thate], m) - - mkLambdas g m tps [thisv; thatobjv] (comparee, g.int_ty) - let rhs2 = - let thisv, thatv, comparee = comparef g tcref tycon - mkLambdas g m tps [thisv; thatv] (comparee, g.int_ty) + let rhs1 = + let tinst, ty = mkMinimalTy g tcref + + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + + let comparee = + if isUnitTy g ty then + mkZero g m + else + let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) + + mkApps g ((exprForValRef m vref2, vref2.Type), (if isNil tinst then [] else [ tinst ]), [ thise; thate ], m) + + mkLambdas g m tps [ thisv; thatobjv ] (comparee, g.int_ty) + + let rhs2 = + let thisv, thatv, comparee = comparef g tcref tycon + mkLambdas g m tps [ thisv; thatv ] (comparee, g.int_ty) + [ // This one must come first because it may be inlined into the second - mkCompGenBind vspec2 rhs2 - mkCompGenBind vspec1 rhs1; ] - if tycon.IsUnionTycon then mkCompare mkUnionCompare - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkCompare mkRecdCompare - else [] - + mkCompGenBind vspec2 rhs2 + mkCompGenBind vspec1 rhs1 + ] + + if tycon.IsUnionTycon then + mkCompare mkUnionCompare + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkCompare mkRecdCompare + else + [] + let MakeBindingsForCompareWithComparerAugmentation g (tycon: Tycon) = let tcref = mkLocalTyconRef tycon let m = tycon.Range let tps = tycon.Typars m - let mkCompare comparef = + + let mkCompare comparef = match tycon.GeneratedCompareToWithComparerValues with | None -> [] | Some vref -> @@ -986,128 +1400,192 @@ let MakeBindingsForCompareWithComparerAugmentation g (tycon: Tycon) = let rhs = let comparee = comparef g tcref tycon (thisv, thise) (thatobjv, thate) compe let comparee = if isUnitTy g ty then mkZero g m else comparee - mkMultiLambdas g m tps [[thisv]; [thatobjv; compv]] (comparee, g.int_ty) - [mkCompGenBind vspec rhs] - if tycon.IsUnionTycon then mkCompare mkUnionCompareWithComparer - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkCompare mkRecdCompareWithComparer - else [] - + mkMultiLambdas g m tps [ [ thisv ]; [ thatobjv; compv ] ] (comparee, g.int_ty) + + [ mkCompGenBind vspec rhs ] + + if tycon.IsUnionTycon then + mkCompare mkUnionCompareWithComparer + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkCompare mkRecdCompareWithComparer + else + [] + let MakeBindingsForEqualityWithComparerAugmentation (g: TcGlobals) (tycon: Tycon) = let tcref = mkLocalTyconRef tycon let m = tycon.Range let tps = tycon.Typars m + let mkStructuralEquatable hashf equalsf = match tycon.GeneratedHashAndEqualsWithComparerValues with | None -> [] | Some (objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal) -> - + // build the hash rhs let withcGetHashCodeExpr = let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty // Special case List type to avoid StackOverflow exception , call custom hash code instead - let thisv,hashe = - if tyconRefEq g tcref g.list_tcr_canon && tycon.HasMember g "CustomHashCode" [g.IEqualityComparer_ty] then - let customCodeVal = (tycon.TryGetMember g "CustomHashCode" [g.IEqualityComparer_ty]).Value + let thisv, hashe = + if + tyconRefEq g tcref g.list_tcr_canon + && tycon.HasMember g "CustomHashCode" [ g.IEqualityComparer_ty ] + then + let customCodeVal = + (tycon.TryGetMember g "CustomHashCode" [ g.IEqualityComparer_ty ]).Value + let tinst, ty = mkMinimalTy g tcref - let thisv, thise = mkThisVar g m ty - thisv,mkApps g ((exprForValRef m customCodeVal, customCodeVal.Type), (if isNil tinst then [] else [tinst]), [thise; compe], m) - else + let thisv, thise = mkThisVar g m ty + + thisv, + mkApps + g + ((exprForValRef m customCodeVal, customCodeVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; compe ], + m) + else hashf g tcref tycon compe - mkLambdas g m tps [thisv; compv] (hashe, g.int_ty) - + + mkLambdas g m tps [ thisv; compv ] (hashe, g.int_ty) + // build the equals rhs let withcEqualsExpr = let _tinst, ty = mkMinimalTy g tcref let thisv, thise = mkThisVar g m ty let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let thatv, thate = mkCompGenLocal m "that" ty + let thatv, thate = mkCompGenLocal m "that" ty let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty let equalse = equalsf g tcref tycon (thisv, thise) thatobje (thatv, thate) compe - mkMultiLambdas g m tps [[thisv];[thatobjv; compv]] (equalse, g.bool_ty) + mkMultiLambdas g m tps [ [ thisv ]; [ thatobjv; compv ] ] (equalse, g.bool_ty) - let objGetHashCodeExpr = + let objGetHashCodeExpr = let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty + + let thisv, thise = mkThisVar g m ty let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty - let hashe = - if isUnitTy g ty then mkZero g m else - - let compe = mkILCallGetEqualityComparer g m - mkApps g ((exprForValRef m withcGetHashCodeVal, withcGetHashCodeVal.Type), (if isNil tinst then [] else [tinst]), [thise; compe], m) - - mkLambdas g m tps [thisv; unitv] (hashe, g.int_ty) - - [(mkCompGenBind withcGetHashCodeVal.Deref withcGetHashCodeExpr) - (mkCompGenBind objGetHashCodeVal.Deref objGetHashCodeExpr) - (mkCompGenBind withcEqualsVal.Deref withcEqualsExpr)] - if tycon.IsUnionTycon then mkStructuralEquatable mkUnionHashWithComparer mkUnionEqualityWithComparer - elif (tycon.IsRecordTycon || tycon.IsStructOrEnumTycon) then mkStructuralEquatable mkRecdHashWithComparer mkRecdEqualityWithComparer - elif tycon.IsFSharpException then mkStructuralEquatable mkExnHashWithComparer mkExnEqualityWithComparer - else [] - -let MakeBindingsForEqualsAugmentation (g: TcGlobals) (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon - let m = tycon.Range + + let hashe = + if isUnitTy g ty then + mkZero g m + else + + let compe = mkILCallGetEqualityComparer g m + + mkApps + g + ((exprForValRef m withcGetHashCodeVal, withcGetHashCodeVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; compe ], + m) + + mkLambdas g m tps [ thisv; unitv ] (hashe, g.int_ty) + + [ + (mkCompGenBind withcGetHashCodeVal.Deref withcGetHashCodeExpr) + (mkCompGenBind objGetHashCodeVal.Deref objGetHashCodeExpr) + (mkCompGenBind withcEqualsVal.Deref withcEqualsExpr) + ] + + if tycon.IsUnionTycon then + mkStructuralEquatable mkUnionHashWithComparer mkUnionEqualityWithComparer + elif (tycon.IsRecordTycon || tycon.IsStructOrEnumTycon) then + mkStructuralEquatable mkRecdHashWithComparer mkRecdEqualityWithComparer + elif tycon.IsFSharpException then + mkStructuralEquatable mkExnHashWithComparer mkExnEqualityWithComparer + else + [] + +let MakeBindingsForEqualsAugmentation (g: TcGlobals) (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range let tps = tycon.Typars m + let mkEquals equalsf = - match tycon.GeneratedHashAndEqualsValues with - | None -> [] - | Some (objEqualsVal, nocEqualsVal) -> - // this is the body of the real strongly typed implementation - let nocEqualsExpr = - let thisv, thatv, equalse = equalsf g tcref tycon - mkLambdas g m tps [thisv;thatv] (equalse, g.bool_ty) - - // this is the body of the override - let objEqualsExpr = - let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let equalse = - if isUnitTy g ty then mkTrue g m else - - let thatv, thate = mkCompGenLocal m "that" ty - mkIsInstConditional g m ty thatobje thatv - (mkApps g ((exprForValRef m nocEqualsVal, nocEqualsVal.Type), (if isNil tinst then [] else [tinst]), [thise;thate], m)) - (mkFalse g m) - - mkLambdas g m tps [thisv;thatobjv] (equalse, g.bool_ty) - - [ mkCompGenBind nocEqualsVal.Deref nocEqualsExpr - mkCompGenBind objEqualsVal.Deref objEqualsExpr ] - if tycon.IsFSharpException then mkEquals mkExnEquality - elif tycon.IsUnionTycon then mkEquals mkUnionEquality - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkEquals mkRecdEquality - else [] + match tycon.GeneratedHashAndEqualsValues with + | None -> [] + | Some (objEqualsVal, nocEqualsVal) -> + // this is the body of the real strongly typed implementation + let nocEqualsExpr = + let thisv, thatv, equalse = equalsf g tcref tycon + mkLambdas g m tps [ thisv; thatv ] (equalse, g.bool_ty) + + // this is the body of the override + let objEqualsExpr = + let tinst, ty = mkMinimalTy g tcref + + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + + let equalse = + if isUnitTy g ty then + mkTrue g m + else + + let thatv, thate = mkCompGenLocal m "that" ty + + mkIsInstConditional + g + m + ty + thatobje + thatv + (mkApps + g + ((exprForValRef m nocEqualsVal, nocEqualsVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; thate ], + m)) + (mkFalse g m) + + mkLambdas g m tps [ thisv; thatobjv ] (equalse, g.bool_ty) + + [ + mkCompGenBind nocEqualsVal.Deref nocEqualsExpr + mkCompGenBind objEqualsVal.Deref objEqualsExpr + ] + + if tycon.IsFSharpException then + mkEquals mkExnEquality + elif tycon.IsUnionTycon then + mkEquals mkUnionEquality + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkEquals mkRecdEquality + else + [] let rec TypeDefinitelyHasEquality g ty = let appTy = tryAppTy g ty + match appTy with - | ValueSome(tcref,_) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> - false + | ValueSome (tcref, _) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> false | _ -> - if isTyparTy g ty && - (destTyparTy g ty).Constraints |> List.exists (function TyparConstraint.SupportsEquality _ -> true | _ -> false) then + if + isTyparTy g ty + && (destTyparTy g ty).Constraints + |> List.exists (function + | TyparConstraint.SupportsEquality _ -> true + | _ -> false) + then true - else - match ty with - | SpecialEquatableHeadType g tinst -> - tinst |> List.forall (TypeDefinitelyHasEquality g) - | SpecialNotEquatableHeadType g _ -> - false - | _ -> - // The type is equatable because it has Object.Equals(...) - match appTy with - | ValueSome(tcref,tinst) -> - // Give a good error for structural types excluded from the equality relation because of their fields - not (TyconIsCandidateForAugmentationWithEquals g tcref.Deref && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues) && - // Check the (possibly inferred) structural dependencies - (tinst, tcref.TyparsNoRange) - ||> List.lengthsEqAndForall2 (fun ty tp -> not tp.EqualityConditionalOn || TypeDefinitelyHasEquality g ty) - | _ -> false + else + match ty with + | SpecialEquatableHeadType g tinst -> tinst |> List.forall (TypeDefinitelyHasEquality g) + | SpecialNotEquatableHeadType g _ -> false + | _ -> + // The type is equatable because it has Object.Equals(...) + match appTy with + | ValueSome (tcref, tinst) -> + // Give a good error for structural types excluded from the equality relation because of their fields + not ( + TyconIsCandidateForAugmentationWithEquals g tcref.Deref + && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues + ) + && + // Check the (possibly inferred) structural dependencies + (tinst, tcref.TyparsNoRange) + ||> List.lengthsEqAndForall2 (fun ty tp -> not tp.EqualityConditionalOn || TypeDefinitelyHasEquality g ty) + | _ -> false let MakeValsForUnionAugmentation g (tcref: TyconRef) = let m = tcref.Range @@ -1118,10 +1596,11 @@ let MakeValsForUnionAugmentation g (tcref: TyconRef) = tcref.UnionCasesAsList |> List.map (fun uc -> // Unlike other generated items, the 'IsABC' propeties are visible, not considered compiler-generated - let v = mkImpliedValSpec g uc.Range tcref tmty vis None ("get_Is" + uc.CompiledName) (tps +-> (mkIsCaseTy g tmty)) unitArg true + let v = + mkImpliedValSpec g uc.Range tcref tmty vis None ("get_Is" + uc.CompiledName) (tps +-> (mkIsCaseTy g tmty)) unitArg true + g.AddValGeneratedAttributes v m - v - ) + v) let MakeBindingsForUnionAugmentation g (tycon: Tycon) (vals: ValRef list) = let tcref = mkLocalTyconRef tycon @@ -1134,6 +1613,5 @@ let MakeBindingsForUnionAugmentation g (tycon: Tycon) (vals: ValRef list) = (tcref.UnionCasesAsRefList, vals) ||> List.map2 (fun ucr v -> let isdata = mkUnionCaseTest g (thise, ucr, tinst, m) - let expr = mkLambdas g m tps [thisv;unitv] (isdata, g.bool_ty) - mkCompGenBind v.Deref expr - ) \ No newline at end of file + let expr = mkLambdas g m tps [ thisv; unitv ] (isdata, g.bool_ty) + mkCompGenBind v.Deref expr) diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 62f2f110b8e..da4b7ac3b0a 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -254,7 +254,7 @@ type LanguageVersion(versionText) = | LanguageFeature.IndexerNotationWithoutDot -> FSComp.SR.featureIndexerNotationWithoutDot () | LanguageFeature.RefCellNotationInformationals -> FSComp.SR.featureRefCellNotationInformationals () | LanguageFeature.UseBindingValueDiscard -> FSComp.SR.featureDiscardUseValue () - | LanguageFeature.UnionIsPropertiesVisible -> FSComp.SR.featureUnionIsPropertiesVisible() + | LanguageFeature.UnionIsPropertiesVisible -> FSComp.SR.featureUnionIsPropertiesVisible () | LanguageFeature.NonVariablePatternsToRightOfAsPatterns -> FSComp.SR.featureNonVariablePatternsToRightOfAsPatterns () | LanguageFeature.AttributesToRightOfModuleKeyword -> FSComp.SR.featureAttributesToRightOfModuleKeyword () | LanguageFeature.MLCompatRevisions -> FSComp.SR.featureMLCompatRevisions () From fd23df78d8912fbbfa9b1b0d12fa21c02c0c23c9 Mon Sep 17 00:00:00 2001 From: Alex Corrado Date: Sun, 21 May 2023 21:15:15 +0100 Subject: [PATCH 08/16] Fix the build --- src/Compiler/CodeGen/EraseUnions.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 18b1c7622bd..35ca89b367f 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -829,7 +829,7 @@ let convAlternativeDef let baseTesterMeths, baseTesterProps = if - ilg.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible + g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible && cud.HasHelpers = AllHelpers then [], [] From c46df5e19659c9d1c7b79f3215097c618e657dfa Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 12:25:26 +0100 Subject: [PATCH 09/16] Add backticks test --- .../Language/DiscriminatedUnionTests.fs | 30 +++++++++++++------ 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs index 41988c5559c..797b6ed353c 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -1,14 +1,11 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -namespace FSharp.Compiler.ComponentTests.Language +namespace Language -open Xunit open FSharp.Test.Compiler -#if NETCOREAPP module DiscriminatedUnionTests = - - [] + [] let ``Simple Is* discriminated union properties are visible, proper values are returned`` () = Fsx """ type Foo = | Foo of string | Bar @@ -20,7 +17,23 @@ if foo.IsBar then failwith "Should not be Bar" |> compileExeAndRun |> shouldSucceed - [] + [] + let ``Is* discriminated union properties with backticks are visible, proper values are returned`` () = + Fsx """ +type Foo = | Foo of string | ``Mars Bar`` +let foo = Foo.Foo "hi" +if not foo.IsFoo then failwith "Should be Foo" +if foo.``IsMars Bar`` then failwith "Should not be ``Mars Bar``" + +let marsbar = ``Mars Bar`` +if marsbar.IsFoo then failwith "Should not be Foo" +if not marsbar.``IsMars Bar`` then failwith "Should be ``Mars Bar``" + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + [] let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, before the definition`` () = FSharp """ namespace rec Hello @@ -43,7 +56,7 @@ type Foo = |> shouldSucceed - [] + [] let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, in SRTP`` () = FSharp """ namespace Hello @@ -69,5 +82,4 @@ module Main = """ |> withLangVersionPreview |> compileExeAndRun - |> shouldSucceed -#endif \ No newline at end of file + |> shouldSucceed \ No newline at end of file From c03e3cf6be69061729c1fdf9317254fa831f0406 Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 12:35:42 +0100 Subject: [PATCH 10/16] Remove unused code --- src/Compiler/AbstractIL/il.fs | 12 ++++-------- src/Compiler/AbstractIL/il.fsi | 4 +--- src/Compiler/Driver/CompilerImports.fs | 2 +- 3 files changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 1740f9f4665..7692ab5d66b 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -21,7 +21,6 @@ open System.Text open System.Threading open FSharp.Compiler.AbstractIL.Diagnostics -open FSharp.Compiler.Features open Internal.Utilities.Library open Internal.Utilities @@ -3416,8 +3415,7 @@ type ILGlobals ( primaryScopeRef: ILScopeRef, equivPrimaryAssemblyRefs: ILAssemblyRef list, - fsharpCoreAssemblyScopeRef: ILScopeRef, - langVersion: LanguageVersion + fsharpCoreAssemblyScopeRef: ILScopeRef ) = let equivPrimaryAssemblyRefs = Array.ofList equivPrimaryAssemblyRefs @@ -3483,16 +3481,14 @@ type ILGlobals aref.EqualsIgnoringVersion x.primaryAssemblyRef || equivPrimaryAssemblyRefs |> Array.exists aref.EqualsIgnoringVersion - member _.langVersion = langVersion - /// For debugging [] member x.DebugText = x.ToString() override x.ToString() = "" -let mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, langVersion) = - ILGlobals(primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, langVersion) +let mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) = + ILGlobals(primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) let mkNormalCall mspec = I_call(Normalcall, mspec, None) @@ -4750,7 +4746,7 @@ let DummyFSharpCoreScopeRef = ILScopeRef.Assembly asmRef let PrimaryAssemblyILGlobals = - mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef, LanguageVersion("default")) + mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef) let rec decodeCustomAttrElemType bytes sigptr x = match x with diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 9b4b89f91f9..e672ffc2c5a 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -1878,7 +1878,6 @@ type internal ILGlobals = member primaryAssemblyRef: ILAssemblyRef member primaryAssemblyName: string member fsharpCoreAssemblyScopeRef: ILScopeRef - member langVersion: LanguageVersion member typ_Attribute: ILType member typ_Enum: ILType @@ -1920,8 +1919,7 @@ type internal ILGlobals = val internal mkILGlobals: primaryScopeRef: ILScopeRef * equivPrimaryAssemblyRefs: ILAssemblyRef list * - fsharpCoreAssemblyScopeRef: ILScopeRef * - langVersion: LanguageVersion -> + fsharpCoreAssemblyScopeRef: ILScopeRef -> ILGlobals val internal PrimaryAssemblyILGlobals: ILGlobals diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 82d793fe39c..e828863c3a8 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -2483,7 +2483,7 @@ and [] TcImports sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu path typeName publicOnly) let ilGlobals = - mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, tcConfig.langVersion) + mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals let tcGlobals = From 13891f074fa3efad2da1faba04a55fde408b3727 Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 12:37:24 +0100 Subject: [PATCH 11/16] Format --- src/Compiler/AbstractIL/il.fs | 7 +------ src/Compiler/AbstractIL/il.fsi | 5 +---- src/Compiler/Checking/AugmentTypeDefinitions.fs | 14 +++++++------- 3 files changed, 9 insertions(+), 17 deletions(-) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 7692ab5d66b..5e475d96193 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -3411,12 +3411,7 @@ let tname_UIntPtr = "System.UIntPtr" let tname_TypedReference = "System.TypedReference" [] -type ILGlobals - ( - primaryScopeRef: ILScopeRef, - equivPrimaryAssemblyRefs: ILAssemblyRef list, - fsharpCoreAssemblyScopeRef: ILScopeRef - ) = +type ILGlobals(primaryScopeRef: ILScopeRef, equivPrimaryAssemblyRefs: ILAssemblyRef list, fsharpCoreAssemblyScopeRef: ILScopeRef) = let equivPrimaryAssemblyRefs = Array.ofList equivPrimaryAssemblyRefs diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index e672ffc2c5a..5ba803fb757 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -4,7 +4,6 @@ module rec FSharp.Compiler.AbstractIL.IL -open FSharp.Compiler.Features open FSharp.Compiler.IO open System.Collections.Generic open System.Reflection @@ -1917,9 +1916,7 @@ type internal ILGlobals = /// primaryScopeRef is the primary assembly we are emitting /// equivPrimaryAssemblyRefs are ones regarded as equivalent val internal mkILGlobals: - primaryScopeRef: ILScopeRef * - equivPrimaryAssemblyRefs: ILAssemblyRef list * - fsharpCoreAssemblyScopeRef: ILScopeRef -> + primaryScopeRef: ILScopeRef * equivPrimaryAssemblyRefs: ILAssemblyRef list * fsharpCoreAssemblyScopeRef: ILScopeRef -> ILGlobals val internal PrimaryAssemblyILGlobals: ILGlobals diff --git a/src/Compiler/Checking/AugmentTypeDefinitions.fs b/src/Compiler/Checking/AugmentTypeDefinitions.fs index 0a21aa7ffbb..d3e9fb1d42d 100644 --- a/src/Compiler/Checking/AugmentTypeDefinitions.fs +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fs @@ -215,7 +215,7 @@ let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = let mkCompareTestConjuncts g m exprs = match List.tryFrontAndBack exprs with | None -> mkZero g m - | Some (a, b) -> + | Some(a, b) -> (a, b) ||> List.foldBack (fun e acc -> let nv, ne = mkCompGenLocal m "n" g.int_ty @@ -235,7 +235,7 @@ let mkCompareTestConjuncts g m exprs = let mkEqualsTestConjuncts g m exprs = match List.tryFrontAndBack exprs with | None -> mkOne g m - | Some (a, b) -> List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b + | Some(a, b) -> List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = if tcref.Deref.IsFSharpException then @@ -1343,7 +1343,7 @@ let MakeBindingsForCompareAugmentation g (tycon: Tycon) = let mkCompare comparef = match tycon.GeneratedCompareToValues with | None -> [] - | Some (vref1, vref2) -> + | Some(vref1, vref2) -> let vspec1 = vref1.Deref let vspec2 = vref2.Deref (* this is the body of the override *) @@ -1419,7 +1419,7 @@ let MakeBindingsForEqualityWithComparerAugmentation (g: TcGlobals) (tycon: Tycon let mkStructuralEquatable hashf equalsf = match tycon.GeneratedHashAndEqualsWithComparerValues with | None -> [] - | Some (objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal) -> + | Some(objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal) -> // build the hash rhs let withcGetHashCodeExpr = @@ -1504,7 +1504,7 @@ let MakeBindingsForEqualsAugmentation (g: TcGlobals) (tycon: Tycon) = let mkEquals equalsf = match tycon.GeneratedHashAndEqualsValues with | None -> [] - | Some (objEqualsVal, nocEqualsVal) -> + | Some(objEqualsVal, nocEqualsVal) -> // this is the body of the real strongly typed implementation let nocEqualsExpr = let thisv, thatv, equalse = equalsf g tcref tycon @@ -1558,7 +1558,7 @@ let rec TypeDefinitelyHasEquality g ty = let appTy = tryAppTy g ty match appTy with - | ValueSome (tcref, _) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> false + | ValueSome(tcref, _) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> false | _ -> if isTyparTy g ty @@ -1575,7 +1575,7 @@ let rec TypeDefinitelyHasEquality g ty = | _ -> // The type is equatable because it has Object.Equals(...) match appTy with - | ValueSome (tcref, tinst) -> + | ValueSome(tcref, tinst) -> // Give a good error for structural types excluded from the equality relation because of their fields not ( TyconIsCandidateForAugmentationWithEquals g tcref.Deref From de1b8a1d81336d495c7b7b877f3e7cde00d5d132 Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 13:58:34 +0100 Subject: [PATCH 12/16] Fix test --- src/Compiler/TypedTree/TypedTree.fs | 2 +- .../Miscellaneous/MigratedCoreTests.fs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index e6a284978c8..a0665d32212 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2905,7 +2905,7 @@ type Val = /// Indicates that this value's getter or setter are generated by the compiler member x.GetterOrSetterIsCompilerGenerated = x.MemberInfo |> Option.exists (fun m -> m.MemberFlags.GetterOrSetterIsCompilerGenerated) - + /// Get the declared attributes for the value member x.Attribs = match x.val_opt_data with diff --git a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedCoreTests.fs b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedCoreTests.fs index 9776b41b8d7..6ff282164e5 100644 --- a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedCoreTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedCoreTests.fs @@ -121,10 +121,10 @@ let ``innerpoly-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/innerpoly" FSC_ let ``innerpoly-FSI`` () = singleTestBuildAndRun "core/innerpoly" FSI [] -let ``namespaceAttributes-FSC_DEBUG`` () = singleTestBuildAndRun "core/namespaces" COMPILED_EXE_APP +let ``namespaceAttributes-FSC_DEBUG`` () = singleTestBuildAndRunVersion "core/namespaces" COMPILED_EXE_APP LangVersion.Preview [] -let ``namespaceAttributes-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/namespaces" COMPILED_EXE_APP +let ``namespaceAttributes-FSC_OPTIMIZED`` () = singleTestBuildAndRunVersion "core/namespaces" COMPILED_EXE_APP LangVersion.Preview [] let ``unicode2-FSC_DEBUG`` () = singleTestBuildAndRun "core/unicode" FSC_DEBUG // TODO: fails on coreclr From 2b18f4fc554631bb7706fcb5ceb45d45c0ddf9c9 Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 14:40:55 +0100 Subject: [PATCH 13/16] Fix surface area --- ...Sharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl index 5ac7347ed49..d8bb82e6ec1 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl @@ -5080,6 +5080,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertySetterM FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsRefCell FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsReferencedValue FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsTypeFunction +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnionCaseTester FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnresolved FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValCompiledAsMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValue @@ -5114,6 +5115,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertySet FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsRefCell() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsReferencedValue() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsTypeFunction() +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnionCaseTester() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnresolved() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValCompiledAsMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValue() From a504fa5f93f5e3e5e53a1adc225059379a17a0fe Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 25 Nov 2023 16:26:03 +0100 Subject: [PATCH 14/16] Add more tests --- .../Language/DiscriminatedUnionTests.fs | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs index 797b6ed353c..8019be57d4e 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -17,6 +17,38 @@ if foo.IsBar then failwith "Should not be Bar" |> compileExeAndRun |> shouldSucceed + [] + let ``Simple Is* discriminated union property satisfies SRTP constraint`` () = + Fsx """ +type X = + | A of string + | B + +let inline test<'a when 'a: (member IsA: bool)> (v: 'a) = + if not v.IsA then failwith "Should be A" + +X.A "a" |> test + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Lowercase Is* discriminated union properties are visible, proper values are returned`` () = + Fsx """ +[] +type X = + | A + | a of int + +let foo = X.a 1 +if not foo.Isa then failwith "Should be a" +if foo.IsA then failwith "Should not be A" + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + [] let ``Is* discriminated union properties with backticks are visible, proper values are returned`` () = Fsx """ From c5f8ee0fe4d137e0727f9366e5b0b78b7c1b0217 Mon Sep 17 00:00:00 2001 From: kerams Date: Wed, 29 Nov 2023 20:55:35 +0100 Subject: [PATCH 15/16] Revert rename --- .../{AugmentTypeDefinitions.fs => AugmentWithHashCompare.fs} | 0 ...{AugmentTypeDefinitions.fsi => AugmentWithHashCompare.fsi} | 0 src/Compiler/FSharp.Compiler.Service.fsproj | 4 ++-- 3 files changed, 2 insertions(+), 2 deletions(-) rename src/Compiler/Checking/{AugmentTypeDefinitions.fs => AugmentWithHashCompare.fs} (100%) rename src/Compiler/Checking/{AugmentTypeDefinitions.fsi => AugmentWithHashCompare.fsi} (100%) diff --git a/src/Compiler/Checking/AugmentTypeDefinitions.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs similarity index 100% rename from src/Compiler/Checking/AugmentTypeDefinitions.fs rename to src/Compiler/Checking/AugmentWithHashCompare.fs diff --git a/src/Compiler/Checking/AugmentTypeDefinitions.fsi b/src/Compiler/Checking/AugmentWithHashCompare.fsi similarity index 100% rename from src/Compiler/Checking/AugmentTypeDefinitions.fsi rename to src/Compiler/Checking/AugmentWithHashCompare.fsi diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 7da855b727f..687bc269233 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -319,8 +319,8 @@ - - + + From 3323fd7f62e4592a79e0aa6bf692d8fcd016de48 Mon Sep 17 00:00:00 2001 From: kerams Date: Fri, 1 Dec 2023 13:47:47 +0100 Subject: [PATCH 16/16] Add more tests --- .../Language/DiscriminatedUnionTests.fs | 45 ++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs index 8019be57d4e..abd5fb6e3b6 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -114,4 +114,47 @@ module Main = """ |> withLangVersionPreview |> compileExeAndRun - |> shouldSucceed \ No newline at end of file + |> shouldSucceed + + [] + let ``Is* discriminated union properties are unavailable with DefaultAugmentation(false)`` () = + Fsx """ +[] +type Foo = | Foo of string | Bar +let foo = Foo.Foo "hi" +let isFoo = foo.IsFoo + """ + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withErrorMessage "The type 'Foo' does not define the field, constructor or member 'IsFoo'. Maybe you want one of the following: + Foo" + + [] + let ``Is* discriminated union properties are unavailable on voption`` () = + Fsx """ +let x = (ValueSome 1).IsSome +let y = ValueOption.None.IsValueNone + """ + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withErrorMessage "The type 'ValueOption<_>' does not define the field, constructor or member 'IsValueNone'. Maybe you want one of the following: + ValueNone" + + [] + let ``Is* discriminated union properties work with UseNullAsTrueValue`` () = + Fsx """ +[] +type T<'T> = + | Z + | X of 'T + +[] +let giveMeZ () = Z + +if giveMeZ().IsX then failwith "Should not be X" + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed