diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index cef784733d5..5ba803fb757 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -1990,6 +1990,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/AugmentWithHashCompare.fs index 63ba529b220..d3e9fb1d42d 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ b/src/Compiler/Checking/AugmentWithHashCompare.fs @@ -1,8 +1,8 @@ // 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 open FSharp.Compiler.DiagnosticsLogger @@ -14,687 +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 mkEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.obj_ty, [], [], [[TSlotParam(Some("obj"), g.obj_ty, false, false, false, [])]], Some g.bool_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) //------------------------------------------------------------------------- // 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) //------------------------------------------------------------------------- // 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 tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste 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 + 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 + + 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 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 dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty - (mkILAsmCeq g m thistage thattage) + 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 @@ -703,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 c : ValMemberInfo = - { ImplementedSlotSigs=[] - MemberFlags={ IsInstance=true - IsDispatchSlot=false - IsFinal=false - IsOverrideOrExplicitImpl=false - GetterOrSetterIsCompilerGenerated=false - MemberKind=SynMemberKind.Member } - 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 @@ -872,93 +1201,190 @@ 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 - slotImplMethod(final, tcref, slotsig) + + 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 MakeValsForCompareAugmentation g (tcref: TyconRef) = + 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 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 -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 - 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) = - 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 -> @@ -974,125 +1400,218 @@ 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) -> - + | 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 + 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) diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fsi b/src/Compiler/Checking/AugmentWithHashCompare.fsi index ea991b0340d..5fa185c0460 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fsi +++ b/src/Compiler/Checking/AugmentWithHashCompare.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 5d87cbc7fe2..632708a4464 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -733,6 +733,140 @@ let MakeSafeInitField (cenv: cenv) env m isStatic = let taccess = TAccess [env.eAccessPath] Construct.NewRecdField isStatic None id false cenv.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.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 = 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.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 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.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 = AugmentTypeDefinitions.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 + 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. @@ -1934,133 +2068,6 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env with RecoverableException 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 = @@ -2073,7 +2080,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 @@ -2137,8 +2144,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)) @@ -2204,7 +2211,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 @@ -2243,7 +2250,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) @@ -2265,8 +2272,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)) @@ -2278,7 +2285,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 @@ -2293,7 +2300,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 @@ -3902,7 +3909,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) @@ -4037,8 +4044,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 @@ -4431,9 +4452,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 @@ -4530,7 +4556,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 @@ -4585,19 +4620,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 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 repr = SynTypeDefnSimpleRepr.Exception exnRepr + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, 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) @@ -4605,9 +4641,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 @@ -4616,7 +4652,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 @@ -4647,7 +4683,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 @@ -4656,6 +4692,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 ade040f1ed6..6f169d474a8 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -1090,14 +1090,14 @@ let PublishValueDefnPrim (cenv: 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 @@ -1116,7 +1116,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 declKind <> ExtrinsicExtensionBinding) -> // // Static initializers don't get published to the tcaug @@ -1128,6 +1128,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 0ecc045f05d..16a759c2e3d 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -578,6 +578,10 @@ 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 e552cb3e993..3c0f68c2859 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -2359,7 +2359,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)) @@ -2389,7 +2389,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 53f40ba7ce2..5abf08578fb 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -901,12 +901,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 fd6550983c5..358e698f011 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -4317,7 +4317,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 @@ -4325,7 +4325,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 @@ -5017,7 +5017,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 @@ -5025,7 +5025,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 12587b22aac..d3d2ca9c590 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1933,6 +1933,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) @@ -1960,6 +1963,7 @@ module TastDefinitionPrinting = IsMethInfoAccessible amap m ad minfo && // Discard method impls such as System.IConvertible.ToBoolean not (minfo.IsILMethod && minfo.DisplayName.Contains(".")) && + not minfo.IsUnionCaseTester && not (minfo.DisplayName.Split('.') |> Array.exists isDiscard)) let ilFields = @@ -2017,7 +2021,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.collect (fun x -> diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 62c5a2f5f11..c60fb146d54 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2178,8 +2178,8 @@ 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 - match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with + 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 05f361c1f81..56bb6d953c8 100644 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -808,6 +808,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? @@ -2016,6 +2025,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 041c652650a..7e1ee813ca8 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 @@ -821,6 +824,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 0400585ca56..e21f76b3071 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -8,6 +8,7 @@ open FSharp.Compiler.IlxGenSupport open System.Collections.Generic open System.Reflection open Internal.Utilities.Library +open FSharp.Compiler.Features open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types @@ -843,7 +844,12 @@ let convAlternativeDef | SpecialFSharpListHelpers -> let baseTesterMeths, baseTesterProps = - if cud.UnionCases.Length <= 1 then + if + g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible + && cud.HasHelpers = AllHelpers + then + [], [] + elif cud.UnionCases.Length <= 1 then [], [] elif repr.RepresentOneAlternativeAsNull info then [], [] diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 08661366b35..540b9695201 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2140,15 +2140,15 @@ type AnonTypeGenerationTable() = (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) @@ -2191,10 +2191,10 @@ type AnonTypeGenerationTable() = 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/FSComp.txt b/src/Compiler/FSComp.txt index e2aaa935a92..5ed130ecdff 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1591,6 +1591,7 @@ featurePreferStringGetPinnableReference,"prefer String.GetPinnableReference in f featurePreferExtensionMethodOverPlainProperty,"prefer extension method over plain property" featureWarningIndexedPropertiesGetSetSameType,"Indexed properties getter and setter must have the same type" featureChkTailCallAttrOnNonRec,"Raises warnings if the 'TailCall' attribute is used on non-recursive functions." +featureUnionIsPropertiesVisible,"Union case test properties" 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3355,tcNotAnIndexerNamedIndexingNotYetEnabled,"The value '%s' is not a function and does not support index notation." diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 47c99af3ba7..643224b904a 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -43,6 +43,7 @@ type LanguageFeature = | IndexerNotationWithoutDot | RefCellNotationInformationals | UseBindingValueDiscard + | UnionIsPropertiesVisible | NonVariablePatternsToRightOfAsPatterns | AttributesToRightOfModuleKeyword | MLCompatRevisions @@ -193,6 +194,7 @@ type LanguageVersion(versionText) = LanguageFeature.PreferExtensionMethodOverPlainProperty, previewVersion LanguageFeature.WarningIndexedPropertiesGetSetSameType, previewVersion LanguageFeature.WarningWhenTailCallAttrOnNonRec, previewVersion + LanguageFeature.UnionIsPropertiesVisible, previewVersion ] static let defaultLanguageVersion = LanguageVersion("default") @@ -289,6 +291,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 f444db4bb4f..7af2317e3c3 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -33,6 +33,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 ae8ce6b2500..e405ded53e5 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -1766,6 +1766,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 919bb485ee3..4050073c704 100644 --- a/src/Compiler/Symbols/Symbols.fsi +++ b/src/Compiler/Symbols/Symbols.fsi @@ -835,6 +835,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 old mode 100755 new mode 100644 index e754a5ad4ae..4755bd6c915 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -878,11 +878,15 @@ 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 tref_CompilerGeneratedAttribute = findSysILTypeRef tname_CompilerGeneratedAttribute + let v_CompilerGeneratedAttribute_tcr = splitILTypeName tname_CompilerGeneratedAttribute ||> findSysTyconRef let tref_InternalsVisibleToAttribute = findSysILTypeRef tname_InternalsVisibleToAttribute - let debuggerNonUserCodeAttribute = mkILCustomAttribute (findSysILTypeRef tname_DebuggerNonUserCodeAttribute, [], [], []) + let debuggerNonUserCodeAttribute = mkILCustomAttribute (tref_DebuggerNonUserCodeAttribute, [], [], []) let compilerGeneratedAttribute = mkILCustomAttribute (tref_CompilerGeneratedAttribute, [], [], []) let generatedAttributes = if noDebugAttributes then [||] else [| compilerGeneratedAttribute; debuggerNonUserCodeAttribute |] let compilerGlobalState = CompilerGlobalState() @@ -896,6 +900,18 @@ type TcGlobals( | [||] -> mkILCustomAttrsFromArray generatedAttributes | attrs -> mkILCustomAttrsFromArray (Array.append attrs generatedAttributes) + let addValGeneratedAttrs (v: Val) m = + if not noDebugAttributes then + let attrs = [ + Attrib(v_CompilerGeneratedAttribute_tcr, ILAttrib compilerGeneratedAttribute.Method.MethodRef, [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, [], [], true, None, m) + ] + + match v.Attribs with + | [] -> v.SetAttribs attrs + | _ -> v.SetAttribs (attrs @ v.Attribs) + let addMethodGeneratedAttrs (mdef:ILMethodDef) = mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) @@ -1819,6 +1835,8 @@ type TcGlobals( member _.AddGeneratedAttributes attrs = addGeneratedAttrs attrs + 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 30fd48aecd7..a0665d32212 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 @@ -2887,6 +2891,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 @@ -2898,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 @@ -3127,6 +3134,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 @@ -4037,6 +4046,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/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 3d1db9912b3..61674b35fa1 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 @@ -1921,6 +1925,8 @@ type Val = member SetInlineIfLambda: unit -> unit + member SetIsImplied: unit -> unit + member SetIsCompiledAsStaticPropertyWithoutField: unit -> unit member SetIsCompilerGenerated: v: bool -> unit @@ -2033,6 +2039,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 @@ -2768,6 +2777,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 diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index a3b987f46f6..221e094fc9b 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -3527,6 +3527,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 @@ -9040,6 +9048,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 7cc531b71c7..ce48b8894a6 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 @@ -2651,6 +2654,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/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index a55e3597c88..8bf44cb36b5 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -502,6 +502,11 @@ reprezentace struktury aktivních vzorů + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Podpora try-with ve výrazech pořadí diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 61ba65dcc1e..82bcec890bc 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -502,6 +502,11 @@ Strukturdarstellung für aktive Muster + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Unterstützung für "try-with" in Sequenzausdrücken diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 3b2dd6ee6a7..853606ddcd9 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -502,6 +502,11 @@ representación de struct para modelos activos + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Compatibilidad con try-with en expresiones secuenciales diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 7857228abf6..4dc6c00838f 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -502,6 +502,11 @@ représentation de structure pour les modèles actifs + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Prise en charge de try-with dans les expressions de séquence diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 134e094dffd..5aa897e5536 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -502,6 +502,11 @@ rappresentazione struct per criteri attivi + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Supporto per try-with nelle espressioni di sequenza diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index f5a0d7e0573..32df5de1c35 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -502,6 +502,11 @@ アクティブなパターンの構造体表現 + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions シーケンス式内の try-with のサポート diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 7d68a8d3b73..5d5a0a55250 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -502,6 +502,11 @@ 활성 패턴에 대한 구조체 표현 + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions 시퀀스 식에서 try-with 지원 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 4a768bb43a3..3fbdf712c2d 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -502,6 +502,11 @@ reprezentacja struktury aktywnych wzorców + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Obsługa instrukcji try-with w wyrażeniach sekwencji diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index b44ad46613e..d9971ebe6d9 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -502,6 +502,11 @@ representação estrutural para padrões ativos + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Suporte para try-with em expressões de sequência diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 55a7fa70adf..0f9f053c4cb 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -502,6 +502,11 @@ представление структуры для активных шаблонов + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Поддержка try-with в выражениях последовательности diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index b1f1ba766fa..b91e3532c44 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -502,6 +502,11 @@ etkin desenler için yapı gösterimi + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions Dizi ifadelerinde try-with desteği diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 7b87a733430..456a1708682 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -502,6 +502,11 @@ 活动模式的结构表示形式 + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions 支持在序列表达式中试用 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index cc69cca8708..5d085912626 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -502,6 +502,11 @@ 現用模式的結構表示法 + + Union case test properties + Union case test properties + + Support for try-with in sequence expressions 支援循序運算式中的 try-with diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index b04d4a9a5ec..70221cde693 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -209,6 +209,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..abd5fb6e3b6 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -0,0 +1,160 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Language + +open FSharp.Test.Compiler + +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 ``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 """ +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 + +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 + + [] + 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 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 diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl index 5ac7347ed49..d8bb82e6ec1 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.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() 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() 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" 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 230ffcca48b..4ad843fb442 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() = !Hello.Goodbye.Utils.failures diff --git a/tests/service/Common.fs b/tests/service/Common.fs index 4f24b831d2c..a8d4782de0d 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" diff --git a/tests/service/ExprTests.fs b/tests/service/ExprTests.fs index 8c8128eca18..662a60edc80 100644 --- a/tests/service/ExprTests.fs +++ b/tests/service/ExprTests.fs @@ -783,7 +783,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)"; @@ -918,7 +922,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)"; @@ -3419,7 +3427,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 d6211dda1dc..dab349fd0ab 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", []);