diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 2f243889eee..c2d05769fb0 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -8005,592 +8005,634 @@ and TcLongIdentThen cenv (overallTy: OverallTy) env tpenv (LongIdentWithDots(lon //------------------------------------------------------------------------- // Typecheck "item+projections" //------------------------------------------------------------------------- *) + // mItem is the textual range covered by the long identifiers that make up the item and TcItemThen cenv (overallTy: OverallTy) env tpenv (tinstEnclosing, item, mItem, rest, afterResolution) delayed = - let g = cenv.g let delayed = delayRest rest mItem delayed - let ad = env.eAccessRights match item with // x where x is a union case or active pattern result tag. | Item.UnionCase _ | Item.ExnCase _ | Item.ActivePatternResult _ as item -> - // ucaseAppTy is the type of the union constructor applied to its (optional) argument - let ucaseAppTy = NewInferenceType () - let mkConstrApp, argTys, argNames = - match item with - | Item.ActivePatternResult(apinfo, _apOverallTy, n, _) -> - let aparity = apinfo.Names.Length - match aparity with - | 0 | 1 -> - let mkConstrApp _mArgs = function [arg] -> arg | _ -> error(InternalError("ApplyUnionCaseOrExn", mItem)) - mkConstrApp, [ucaseAppTy], [ for s, m in apinfo.ActiveTagsWithRanges -> mkSynId m s ] - | _ -> - let ucref = mkChoiceCaseRef g mItem aparity n - let _, _, tinst, _ = FreshenTyconRef2 mItem ucref.TyconRef - let ucinfo = UnionCaseInfo (tinst, ucref) - ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) - | _ -> - ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy item - let numArgTys = List.length argTys - - // Subsumption at data constructions if argument type is nominal prior to equations for any arguments or return types - let flexes = argTys |> List.map (isTyparTy g >> not) - - let (|FittedArgs|_|) arg = - match arg with - | SynExprParen(SynExpr.Tuple (false, args, _, _), _, _, _) - | SynExpr.Tuple (false, args, _, _) when numArgTys > 1 -> Some args - | SynExprParen(arg, _, _, _) - | arg when numArgTys = 1 -> Some [arg] - | _ -> None + TcUnionCaseOrExnCaseOrActivePatternResultItemThen cenv overallTy env item tpenv mItem delayed - match delayed with - // This is where the constructor is applied to an argument - | DelayedApp (atomicFlag, _, _, (FittedArgs args as origArg), mExprAndArg) :: otherDelayed -> - // assert the overall result type if possible - if isNil otherDelayed then - UnifyOverallType cenv env mExprAndArg overallTy ucaseAppTy - - let numArgs = List.length args - UnionCaseOrExnCheck env numArgTys numArgs mExprAndArg - - // if we manage to get here - number of formal arguments = number of actual arguments - // apply named parameters - let args = - // GetMethodArgs checks that no named parameters are located before positional - let unnamedArgs, namedCallerArgs = GetMethodArgs origArg - match namedCallerArgs with - | [] -> - args - | _ -> - let fittedArgs = Array.zeroCreate numArgTys + | Item.Types(nm, ty :: _) -> + TcTypeItemThen cenv overallTy env nm ty tpenv mItem tinstEnclosing delayed - // first: put all positional arguments - let mutable currentIndex = 0 - for arg in unnamedArgs do - fittedArgs.[currentIndex] <- arg - currentIndex <- currentIndex + 1 + | Item.MethodGroup (methodName, minfos, _) -> + TcMethodItemThen cenv overallTy env item methodName minfos tpenv mItem afterResolution delayed - let SEEN_NAMED_ARGUMENT = -1 + | Item.CtorGroup(nm, minfos) -> + TcCtorItemThen cenv overallTy env item nm minfos tinstEnclosing tpenv mItem afterResolution delayed - // dealing with named arguments is a bit tricky since prior to these changes we have an ambiguous situation: - // regular notation for named parameters Some(Value = 5) can mean either 1) create option with value - result of equality operation or 2) create option using named arg syntax. - // so far we've used 1) so we cannot immediately switch to 2) since it will be a definite breaking change. + | Item.FakeInterfaceCtor _ -> + error(Error(FSComp.SR.tcInvalidUseOfInterfaceType(), mItem)) - for _, id, arg in namedCallerArgs do - match argNames |> List.tryFindIndex (fun id2 -> id.idText = id2.idText) with - | Some i -> - if isNull(box fittedArgs.[i]) then - fittedArgs.[i] <- arg - let argItem = - match item with - | Item.UnionCase (uci, _) -> Item.UnionCaseField (uci, i) - | Item.ExnCase tref -> Item.RecdField (RecdFieldInfo ([], RecdFieldRef (tref, id.idText))) - | _ -> failwithf "Expecting union case or exception item, got: %O" item - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, argItem, emptyTyparInst, ItemOccurence.Use, ad) - else error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange)) - currentIndex <- SEEN_NAMED_ARGUMENT - | None -> - // ambiguity may appear only when if argument is boolean\generic. - // if - // - we didn't find argument with specified name AND - // - we have not seen any named arguments so far AND - // - type of current argument is bool\generic - // then we'll favor old behavior and treat current argument as positional. - let isSpecialCaseForBackwardCompatibility = - (currentIndex <> SEEN_NAMED_ARGUMENT) && - (currentIndex < numArgTys) && - match stripTyEqns g argTys.[currentIndex] with - | TType_app(tcref, _) -> tyconRefEq g g.bool_tcr tcref || tyconRefEq g g.system_Bool_tcref tcref - | TType_var _ -> true - | _ -> false - - if isSpecialCaseForBackwardCompatibility then - assert (isNull(box fittedArgs.[currentIndex])) - fittedArgs.[currentIndex] <- List.item currentIndex args // grab original argument, not item from the list of named parameters - currentIndex <- currentIndex + 1 - else - match item with - | Item.UnionCase(uci, _) -> - error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(uci.DisplayName, id.idText), id.idRange)) - | Item.ExnCase tcref -> - error(Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName(tcref.DisplayName, id.idText), id.idRange)) - | Item.ActivePatternResult _ -> - error(Error(FSComp.SR.tcActivePatternsDoNotHaveFields(), id.idRange)) - | _ -> - error(Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName(id.idText), id.idRange)) - - assert (Seq.forall (box >> ((<>) null) ) fittedArgs) - List.ofArray fittedArgs - - let args', tpenv = TcExprsWithFlexes cenv env mExprAndArg tpenv flexes argTys args - PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg args')) ucaseAppTy atomicFlag otherDelayed - - | DelayedTypeApp (_x, mTypeArgs, _mExprAndTypeArgs) :: _delayed' -> - error(Error(FSComp.SR.tcUnexpectedTypeArguments(), mTypeArgs)) - | _ -> - // Work out how many syntactic arguments we really expect. Also return a function that builds the overall - // expression, but don't apply this function until after we've checked that the number of arguments is OK - // (or else we would be building an invalid expression) + | Item.ImplicitOp(id, sln) -> + TcImplicitOpItemThen cenv overallTy env id sln tpenv mItem delayed - // Unit-taking active pattern result can be applied to no args - let numArgs, mkExpr = - // This is where the constructor is an active pattern result applied to no argument - // Unit-taking active pattern result can be applied to no args - if (numArgTys = 1 && match item with Item.ActivePatternResult _ -> true | _ -> false) then - UnifyTypes cenv env mItem (List.head argTys) g.unit_ty - 1, (fun () -> mkConstrApp mItem [mkUnit g mItem]) - - // This is where the constructor expects no arguments and is applied to no argument - elif numArgTys = 0 then - 0, (fun () -> mkConstrApp mItem []) - else - // This is where the constructor expects arguments but is not applied to arguments, hence build a lambda - numArgTys, - (fun () -> - let vs, args = argTys |> List.mapi (fun i ty -> mkCompGenLocal mItem ("arg" + string i) ty) |> List.unzip - let constrApp = mkConstrApp mItem args - let lam = mkMultiLambda mItem vs (constrApp, tyOfExpr g constrApp) - lam) - UnionCaseOrExnCheck env numArgTys numArgs mItem - let expr = mkExpr() - let exprTy = tyOfExpr g expr - PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.Atomic delayed + | Item.DelegateCtor ty -> + TcDelegateCtorItemThen cenv overallTy env ty tinstEnclosing tpenv mItem delayed - | Item.Types(nm, ty :: _) -> + | Item.Value vref -> + TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed - match delayed with - | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: DelayedDotLookup (longId, mLongId) :: otherDelayed -> - // If Item.Types is returned then the ty will be of the form TType_app(tcref, genericTyargs) where tyargs - // is a fresh instantiation for tcref. TcNestedTypeApplication will chop off precisely #genericTyargs args - // and replace them by 'tyargs' - let ty, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs ty tinstEnclosing tyargs - - // Report information about the whole expression including type arguments to VS - let item = Item.Types(nm, [ty]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - let typeNameResInfo = GetLongIdentTypeNameInfo otherDelayed - let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver (unionRanges mExprAndTypeArgs mLongId) ad env.eNameResEnv ty longId typeNameResInfo IgnoreOverrides true - TcItemThen cenv overallTy env tpenv ((argsOfAppTy g ty), item, mItem, rest, afterResolution) otherDelayed - - | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: _delayed' -> - // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! - let ty, _ = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs ty tinstEnclosing tyargs - let item = Item.Types(nm, [ty]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - - // Same error as in the following case - error(Error(FSComp.SR.tcInvalidUseOfTypeName(), mItem)) + | Item.Property (nm, pinfos) -> + TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem afterResolution delayed + | Item.ILField finfo -> + TcILFieldItemThen cenv overallTy env finfo tpenv mItem delayed + + | Item.RecdField rfinfo -> + TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem delayed + + | Item.Event einfo -> + TcEventItemThen cenv overallTy env tpenv mItem mItem None einfo delayed + + | Item.CustomOperation (nm, usageTextOpt, _) -> + // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body + RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed + match usageTextOpt() with + | None -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly nm, mItem)) + | Some usageText -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly2(nm, usageText), mItem)) + + | _ -> error(Error(FSComp.SR.tcLookupMayNotBeUsedHere(), mItem)) + +/// Type check the application of a union case. Also used to cover constructions of F# exception values, and +/// applications of active pattern result labels. +// +// NOTE: the code for this is all a bit convoluted and should really be simplified/regularized. +and TcUnionCaseOrExnCaseOrActivePatternResultItemThen cenv overallTy env item tpenv mItem delayed = + let g = cenv.g + let ad = env.eAccessRights + // ucaseAppTy is the type of the union constructor applied to its (optional) argument + let ucaseAppTy = NewInferenceType () + let mkConstrApp, argTys, argNames = + match item with + | Item.ActivePatternResult(apinfo, _apOverallTy, n, _) -> + let aparity = apinfo.Names.Length + match aparity with + | 0 | 1 -> + let mkConstrApp _mArgs = function [arg] -> arg | _ -> error(InternalError("ApplyUnionCaseOrExn", mItem)) + mkConstrApp, [ucaseAppTy], [ for s, m in apinfo.ActiveTagsWithRanges -> mkSynId m s ] + | _ -> + let ucref = mkChoiceCaseRef g mItem aparity n + let _, _, tinst, _ = FreshenTyconRef2 mItem ucref.TyconRef + let ucinfo = UnionCaseInfo (tinst, ucref) + ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) | _ -> - // In this case the type is not generic, and indeed we should never have returned Item.Types. - // That's because ResolveTypeNamesToCtors should have been set at the original - // call to ResolveLongIdentAsExprAndComputeRange - error(Error(FSComp.SR.tcInvalidUseOfTypeName(), mItem)) + ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy item + let numArgTys = List.length argTys - | Item.MethodGroup (methodName, minfos, _) -> - // Static method calls Type.Foo(arg1, ..., argn) - let meths = List.map (fun minfo -> minfo, None) minfos - match delayed with - | DelayedApp (atomicFlag, _, _, arg, mExprAndArg) :: otherDelayed -> - TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndArg mItem methodName ad NeverMutates false meths afterResolution NormalValUse [arg] atomicFlag otherDelayed + // Subsumption at data constructions if argument type is nominal prior to equations for any arguments or return types + let flexes = argTys |> List.map (isTyparTy g >> not) - | DelayedTypeApp(tys, mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> + let (|FittedArgs|_|) arg = + match arg with + | SynExprParen(SynExpr.Tuple (false, args, _, _), _, _, _) + | SynExpr.Tuple (false, args, _, _) when numArgTys > 1 -> Some args + | SynExprParen(arg, _, _, _) + | arg when numArgTys = 1 -> Some [arg] + | _ -> None -#if !NO_EXTENSIONTYPING - match TryTcMethodAppToStaticConstantArgs cenv env tpenv (minfos, Some (tys, mTypeArgs), mExprAndTypeArgs, mItem) with - | Some minfoAfterStaticArguments -> + match delayed with + // This is where the constructor is applied to an argument + | DelayedApp (atomicFlag, _, _, (FittedArgs args as origArg), mExprAndArg) :: otherDelayed -> + // assert the overall result type if possible + if isNil otherDelayed then + UnifyOverallType cenv env mExprAndArg overallTy ucaseAppTy + + let numArgs = List.length args + UnionCaseOrExnCheck env numArgTys numArgs mExprAndArg + + // if we manage to get here - number of formal arguments = number of actual arguments + // apply named parameters + let args = + // GetMethodArgs checks that no named parameters are located before positional + let unnamedArgs, namedCallerArgs = GetMethodArgs origArg + match namedCallerArgs with + | [] -> + args + | _ -> + let fittedArgs = Array.zeroCreate numArgTys - // Replace the resolution including the static parameters, plus the extra information about the original method info - let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) - CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, [], ItemOccurence.Use, env.eAccessRights) + // first: put all positional arguments + let mutable currentIndex = 0 + for arg in unnamedArgs do + fittedArgs.[currentIndex] <- arg + currentIndex <- currentIndex + 1 - match otherDelayed with - | DelayedApp(atomicFlag, _, _, arg, mExprAndArg) :: otherDelayed -> - TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndArg mItem methodName ad NeverMutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse [arg] atomicFlag otherDelayed - | _ -> - TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndTypeArgs mItem methodName ad NeverMutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse [] ExprAtomicFlag.Atomic otherDelayed + let SEEN_NAMED_ARGUMENT = -1 - | None -> -#endif + // dealing with named arguments is a bit tricky since prior to these changes we have an ambiguous situation: + // regular notation for named parameters Some(Value = 5) can mean either 1) create option with value - result of equality operation or 2) create option using named arg syntax. + // so far we've used 1) so we cannot immediately switch to 2) since it will be a definite breaking change. - let tyargs, tpenv = TcTypesOrMeasures None cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mTypeArgs + for _, id, arg in namedCallerArgs do + match argNames |> List.tryFindIndex (fun id2 -> id.idText = id2.idText) with + | Some i -> + if isNull(box fittedArgs.[i]) then + fittedArgs.[i] <- arg + let argItem = + match item with + | Item.UnionCase (uci, _) -> Item.UnionCaseField (uci, i) + | Item.ExnCase tref -> Item.RecdField (RecdFieldInfo ([], RecdFieldRef (tref, id.idText))) + | _ -> failwithf "Expecting union case or exception item, got: %O" item + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, argItem, emptyTyparInst, ItemOccurence.Use, ad) + else error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange)) + currentIndex <- SEEN_NAMED_ARGUMENT + | None -> + // ambiguity may appear only when if argument is boolean\generic. + // if + // - we didn't find argument with specified name AND + // - we have not seen any named arguments so far AND + // - type of current argument is bool\generic + // then we'll favor old behavior and treat current argument as positional. + let isSpecialCaseForBackwardCompatibility = + (currentIndex <> SEEN_NAMED_ARGUMENT) && + (currentIndex < numArgTys) && + match stripTyEqns g argTys.[currentIndex] with + | TType_app(tcref, _) -> tyconRefEq g g.bool_tcr tcref || tyconRefEq g g.system_Bool_tcref tcref + | TType_var _ -> true + | _ -> false + + if isSpecialCaseForBackwardCompatibility then + assert (isNull(box fittedArgs.[currentIndex])) + fittedArgs.[currentIndex] <- List.item currentIndex args // grab original argument, not item from the list of named parameters + currentIndex <- currentIndex + 1 + else + match item with + | Item.UnionCase(uci, _) -> + error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(uci.DisplayName, id.idText), id.idRange)) + | Item.ExnCase tcref -> + error(Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName(tcref.DisplayName, id.idText), id.idRange)) + | Item.ActivePatternResult _ -> + error(Error(FSComp.SR.tcActivePatternsDoNotHaveFields(), id.idRange)) + | _ -> + error(Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName(id.idText), id.idRange)) + + assert (Seq.forall (box >> ((<>) null) ) fittedArgs) + List.ofArray fittedArgs + + let args', tpenv = TcExprsWithFlexes cenv env mExprAndArg tpenv flexes argTys args + PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg args')) ucaseAppTy atomicFlag otherDelayed + + | DelayedTypeApp (_x, mTypeArgs, _mExprAndTypeArgs) :: _delayed' -> + error(Error(FSComp.SR.tcUnexpectedTypeArguments(), mTypeArgs)) + | _ -> + // Work out how many syntactic arguments we really expect. Also return a function that builds the overall + // expression, but don't apply this function until after we've checked that the number of arguments is OK + // (or else we would be building an invalid expression) + + // Unit-taking active pattern result can be applied to no args + let numArgs, mkExpr = + // This is where the constructor is an active pattern result applied to no argument + // Unit-taking active pattern result can be applied to no args + if (numArgTys = 1 && match item with Item.ActivePatternResult _ -> true | _ -> false) then + UnifyTypes cenv env mItem (List.head argTys) g.unit_ty + 1, (fun () -> mkConstrApp mItem [mkUnit g mItem]) + + // This is where the constructor expects no arguments and is applied to no argument + elif numArgTys = 0 then + 0, (fun () -> mkConstrApp mItem []) + else + // This is where the constructor expects arguments but is not applied to arguments, hence build a lambda + numArgTys, + (fun () -> + let vs, args = argTys |> List.mapi (fun i ty -> mkCompGenLocal mItem ("arg" + string i) ty) |> List.unzip + let constrApp = mkConstrApp mItem args + let lam = mkMultiLambda mItem vs (constrApp, tyOfExpr g constrApp) + lam) + UnionCaseOrExnCheck env numArgTys numArgs mItem + let expr = mkExpr() + let exprTy = tyOfExpr g expr + PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.Atomic delayed + +and TcTypeItemThen cenv overallTy env nm ty tpenv mItem tinstEnclosing delayed = + let g = cenv.g + let ad = env.eAccessRights + match delayed with + | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: DelayedDotLookup (longId, mLongId) :: otherDelayed -> + // If Item.Types is returned then the ty will be of the form TType_app(tcref, genericTyargs) where tyargs + // is a fresh instantiation for tcref. TcNestedTypeApplication will chop off precisely #genericTyargs args + // and replace them by 'tyargs' + let ty, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs ty tinstEnclosing tyargs + + // Report information about the whole expression including type arguments to VS + let item = Item.Types(nm, [ty]) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + let typeNameResInfo = GetLongIdentTypeNameInfo otherDelayed + let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver (unionRanges mExprAndTypeArgs mLongId) ad env.eNameResEnv ty longId typeNameResInfo IgnoreOverrides true + TcItemThen cenv overallTy env tpenv ((argsOfAppTy g ty), item, mItem, rest, afterResolution) otherDelayed + + | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: _delayed' -> + // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! + let ty, _ = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs ty tinstEnclosing tyargs + let item = Item.Types(nm, [ty]) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + + // Same error as in the following case + error(Error(FSComp.SR.tcInvalidUseOfTypeName(), mItem)) + + | _ -> + // In this case the type is not generic, and indeed we should never have returned Item.Types. + // That's because ResolveTypeNamesToCtors should have been set at the original + // call to ResolveLongIdentAsExprAndComputeRange + error(Error(FSComp.SR.tcInvalidUseOfTypeName(), mItem)) + +and TcMethodItemThen cenv overallTy env item methodName minfos tpenv mItem afterResolution delayed = + let ad = env.eAccessRights + // Static method calls Type.Foo(arg1, ..., argn) + let meths = List.map (fun minfo -> minfo, None) minfos + match delayed with + | DelayedApp (atomicFlag, _, _, arg, mExprAndArg) :: otherDelayed -> + TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndArg mItem methodName ad NeverMutates false meths afterResolution NormalValUse [arg] atomicFlag otherDelayed - // FUTURE: can we do better than emptyTyparInst here, in order to display instantiations - // of type variables in the quick info provided in the IDE? But note we haven't yet even checked if the - // number of type arguments is correct... - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + | DelayedTypeApp(tys, mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> + +#if !NO_EXTENSIONTYPING + match TryTcMethodAppToStaticConstantArgs cenv env tpenv (minfos, Some (tys, mTypeArgs), mExprAndTypeArgs, mItem) with + | Some minfoAfterStaticArguments -> + + // Replace the resolution including the static parameters, plus the extra information about the original method info + let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) + CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, [], ItemOccurence.Use, env.eAccessRights) match otherDelayed with | DelayedApp(atomicFlag, _, _, arg, mExprAndArg) :: otherDelayed -> - TcMethodApplicationThen cenv env overallTy None tpenv (Some tyargs) [] mExprAndArg mItem methodName ad NeverMutates false meths afterResolution NormalValUse [arg] atomicFlag otherDelayed + TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndArg mItem methodName ad NeverMutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse [arg] atomicFlag otherDelayed | _ -> - TcMethodApplicationThen cenv env overallTy None tpenv (Some tyargs) [] mExprAndTypeArgs mItem methodName ad NeverMutates false meths afterResolution NormalValUse [] ExprAtomicFlag.Atomic otherDelayed + TcMethodApplicationThen cenv env overallTy None tpenv None [] mExprAndTypeArgs mItem methodName ad NeverMutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse [] ExprAtomicFlag.Atomic otherDelayed - | _ -> -#if !NO_EXTENSIONTYPING - if not minfos.IsEmpty && minfos.[0].ProvidedStaticParameterInfo.IsSome then - error(Error(FSComp.SR.etMissingStaticArgumentsToMethod(), mItem)) + | None -> #endif - TcMethodApplicationThen cenv env overallTy None tpenv None [] mItem mItem methodName ad NeverMutates false meths afterResolution NormalValUse [] ExprAtomicFlag.Atomic delayed - | Item.CtorGroup(nm, minfos) -> - let objTy = - match minfos with - | minfo :: _ -> minfo.ApparentEnclosingType - | [] -> error(Error(FSComp.SR.tcTypeHasNoAccessibleConstructor(), mItem)) - match delayed with - | DelayedApp(_, _, _, arg, mExprAndArg) :: otherDelayed -> + let tyargs, tpenv = TcTypesOrMeasures None cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mTypeArgs - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.eAccessRights) - TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [arg] mExprAndArg otherDelayed (Some afterResolution) + // FUTURE: can we do better than emptyTyparInst here, in order to display instantiations + // of type variables in the quick info provided in the IDE? But note we haven't yet even checked if the + // number of type arguments is correct... + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: DelayedApp(_, _, _, arg, mExprAndArg) :: otherDelayed -> + match otherDelayed with + | DelayedApp(atomicFlag, _, _, arg, mExprAndArg) :: otherDelayed -> + TcMethodApplicationThen cenv env overallTy None tpenv (Some tyargs) [] mExprAndArg mItem methodName ad NeverMutates false meths afterResolution NormalValUse [arg] atomicFlag otherDelayed + | _ -> + TcMethodApplicationThen cenv env overallTy None tpenv (Some tyargs) [] mExprAndTypeArgs mItem methodName ad NeverMutates false meths afterResolution NormalValUse [] ExprAtomicFlag.Atomic otherDelayed - let objTyAfterTyArgs, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tinstEnclosing tyargs - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.eAccessRights) - let itemAfterTyArgs, minfosAfterTyArgs = + | _ -> #if !NO_EXTENSIONTYPING - // If the type is provided and took static arguments then the constructor will have changed - // to a provided constructor on the statically instantiated type. Re-resolve that constructor. - match objTyAfterTyArgs with - | AppTy g (tcref, _) when tcref.Deref.IsProvided -> - let newItem = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mExprAndArg ad objTyAfterTyArgs) - match newItem with - | Item.CtorGroup(_, newMinfos) -> newItem, newMinfos - | _ -> item, minfos - | _ -> + if not minfos.IsEmpty && minfos.[0].ProvidedStaticParameterInfo.IsSome then + error(Error(FSComp.SR.etMissingStaticArgumentsToMethod(), mItem)) #endif - item, minfos + TcMethodApplicationThen cenv env overallTy None tpenv None [] mItem mItem methodName ad NeverMutates false meths afterResolution NormalValUse [] ExprAtomicFlag.Atomic delayed - minfosAfterTyArgs |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.ApparentEnclosingType objTyAfterTyArgs) - TcCtorCall true cenv env tpenv overallTy objTyAfterTyArgs (Some mExprAndTypeArgs) itemAfterTyArgs false [arg] mExprAndArg otherDelayed (Some afterResolution) - - | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> +and TcCtorItemThen cenv overallTy env item nm minfos tinstEnclosing tpenv mItem afterResolution delayed = + let g = cenv.g + let ad = env.eAccessRights + let objTy = + match minfos with + | minfo :: _ -> minfo.ApparentEnclosingType + | [] -> error(Error(FSComp.SR.tcTypeHasNoAccessibleConstructor(), mItem)) + match delayed with + | DelayedApp(_, _, _, arg, mExprAndArg) :: otherDelayed -> - let objTy, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tinstEnclosing tyargs + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.eAccessRights) + TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [arg] mExprAndArg otherDelayed (Some afterResolution) - // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! - let resolvedItem = Item.Types(nm, [objTy]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: DelayedApp(_, _, _, arg, mExprAndArg) :: otherDelayed -> - minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.ApparentEnclosingType objTy) - TcCtorCall true cenv env tpenv overallTy objTy (Some mExprAndTypeArgs) item false [] mExprAndTypeArgs otherDelayed (Some afterResolution) + let objTyAfterTyArgs, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tinstEnclosing tyargs + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.eAccessRights) + let itemAfterTyArgs, minfosAfterTyArgs = +#if !NO_EXTENSIONTYPING + // If the type is provided and took static arguments then the constructor will have changed + // to a provided constructor on the statically instantiated type. Re-resolve that constructor. + match objTyAfterTyArgs with + | AppTy g (tcref, _) when tcref.Deref.IsProvided -> + let newItem = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mExprAndArg ad objTyAfterTyArgs) + match newItem with + | Item.CtorGroup(_, newMinfos) -> newItem, newMinfos + | _ -> item, minfos + | _ -> +#endif + item, minfos - | _ -> + minfosAfterTyArgs |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.ApparentEnclosingType objTyAfterTyArgs) + TcCtorCall true cenv env tpenv overallTy objTyAfterTyArgs (Some mExprAndTypeArgs) itemAfterTyArgs false [arg] mExprAndArg otherDelayed (Some afterResolution) - TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [] mItem delayed (Some afterResolution) + | DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> - | Item.FakeInterfaceCtor _ -> - error(Error(FSComp.SR.tcInvalidUseOfInterfaceType(), mItem)) + let objTy, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tinstEnclosing tyargs - | Item.ImplicitOp(id, sln) -> + // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! + let resolvedItem = Item.Types(nm, [objTy]) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - let isPrefix = IsPrefixOperator id.idText - let isTernary = IsTernaryOperator id.idText - - let argData = - if isPrefix then - [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] - elif isTernary then - [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) - SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) - SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] - else - [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) - SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] - - let retTyData = SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) - let argTypars = argData |> List.map (fun d -> Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, d, false, TyparDynamicReq.Yes, [], false, false)) - let retTypar = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, retTyData, false, TyparDynamicReq.Yes, [], false, false) - let argTys = argTypars |> List.map mkTyparTy - let retTy = mkTyparTy retTypar - - let vs, ves = argTys |> List.mapi (fun i ty -> mkCompGenLocal mItem ("arg" + string i) ty) |> List.unzip - - let memberFlags = StaticMemberFlags SynMemberKind.Member - let logicalCompiledName = ComputeLogicalName id memberFlags - let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln) - - let expr = Expr.Op (TOp.TraitCall traitInfo, [], ves, mItem) - let expr = mkLambdas mItem [] vs (expr, retTy) - - let rec isSimpleArgument e = - match e with - | SynExpr.New (_, _, synExpr, _) - | SynExpr.Paren (synExpr, _, _, _) - | SynExpr.Typed (synExpr, _, _) - | SynExpr.TypeApp (synExpr, _, _, _, _, _, _) - | SynExpr.TypeTest (synExpr, _, _) - | SynExpr.Upcast (synExpr, _, _) - | SynExpr.DotGet (synExpr, _, _, _) - | SynExpr.Downcast (synExpr, _, _) - | SynExpr.InferredUpcast (synExpr, _) - | SynExpr.InferredDowncast (synExpr, _) - | SynExpr.AddressOf (_, synExpr, _, _) - | SynExpr.Quote (_, _, synExpr, _, _) -> isSimpleArgument synExpr - - | SynExpr.InterpolatedString _ - | SynExpr.Null _ - | SynExpr.Ident _ - | SynExpr.Const _ - | SynExpr.LongIdent _ -> true - - | SynExpr.Tuple (_, synExprs, _, _) - | SynExpr.ArrayOrList (_, synExprs, _) -> synExprs |> List.forall isSimpleArgument - | SynExpr.Record (copyInfo=copyOpt; recordFields=fields) -> copyOpt |> Option.forall (fst >> isSimpleArgument) && fields |> List.forall ((fun (SynExprRecordField(expr=e)) -> e) >> Option.forall isSimpleArgument) - | SynExpr.App (_, _, synExpr, synExpr2, _) -> isSimpleArgument synExpr && isSimpleArgument synExpr2 - | SynExpr.IfThenElse (_, _, synExpr, _, synExpr2, _, synExprOpt, _, _, _, _) -> isSimpleArgument synExpr && isSimpleArgument synExpr2 && Option.forall isSimpleArgument synExprOpt - | SynExpr.DotIndexedGet (synExpr, _, _, _) -> isSimpleArgument synExpr - | SynExpr.ObjExpr _ - | SynExpr.AnonRecd _ - | SynExpr.While _ - | SynExpr.For _ - | SynExpr.ForEach _ - | SynExpr.ArrayOrListComputed _ - | SynExpr.ComputationExpr _ - | SynExpr.Lambda _ - | SynExpr.MatchLambda _ - | SynExpr.Match _ - | SynExpr.Do _ - | SynExpr.Assert _ - | SynExpr.Fixed _ - | SynExpr.TryWith _ - | SynExpr.TryFinally _ - | SynExpr.Lazy _ - | SynExpr.Sequential _ - | SynExpr.SequentialOrImplicitYield _ - | SynExpr.LetOrUse _ - | SynExpr.DotSet _ - | SynExpr.DotIndexedSet _ - | SynExpr.LongIdentSet _ - | SynExpr.Set _ - | SynExpr.JoinIn _ - | SynExpr.NamedIndexedPropertySet _ - | SynExpr.DotNamedIndexedPropertySet _ - | SynExpr.LibraryOnlyILAssembly _ - | SynExpr.LibraryOnlyStaticOptimization _ - | SynExpr.LibraryOnlyUnionCaseFieldGet _ - | SynExpr.LibraryOnlyUnionCaseFieldSet _ - | SynExpr.ArbitraryAfterError _ - | SynExpr.FromParseError _ - | SynExpr.DiscardAfterMissingQualificationAfterDot _ - | SynExpr.ImplicitZero _ - | SynExpr.YieldOrReturn _ - | SynExpr.YieldOrReturnFrom _ - | SynExpr.MatchBang _ - | SynExpr.LetOrUseBang _ - | SynExpr.DoBang _ - | SynExpr.TraitCall _ - | SynExpr.IndexFromEnd _ - | SynExpr.IndexRange _ - -> false - - // Propagate the known application structure into function types - Propagate cenv overallTy env tpenv (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) delayed - - // Take all simple arguments and process them before applying the constraint. - let delayed1, delayed2 = - let pred = (function DelayedApp (_, _, _, arg, _) -> isSimpleArgument arg | _ -> false) - List.takeWhile pred delayed, List.skipWhile pred delayed - - let intermediateTy = if isNil delayed2 then overallTy.Commit else NewInferenceType () - - let resultExpr, tpenv = TcDelayed cenv (MustEqual intermediateTy) env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 - - // Add the constraint after the application arguments have been checked to allow annotations to kick in on rigid type parameters - AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo - - // Process all remaining arguments after the constraint is asserted - let resultExpr2, tpenv2 = TcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv resultExpr) intermediateTy ExprAtomicFlag.NonAtomic delayed2 - resultExpr2, tpenv2 + minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.ApparentEnclosingType objTy) + TcCtorCall true cenv env tpenv overallTy objTy (Some mExprAndTypeArgs) item false [] mExprAndTypeArgs otherDelayed (Some afterResolution) + | _ -> - | Item.DelegateCtor ty -> - match delayed with - | DelayedApp (atomicFlag, _, _, arg, mItemAndArg) :: otherDelayed -> - TcNewDelegateThen cenv overallTy env tpenv mItem mItemAndArg ty arg atomicFlag otherDelayed - | DelayedTypeApp(tyargs, _mTypeArgs, mItemAndTypeArgs) :: DelayedApp (atomicFlag, _, _, arg, mItemAndArg) :: otherDelayed -> - let ty, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mItemAndTypeArgs ty tinstEnclosing tyargs - - // Report information about the whole expression including type arguments to VS - let item = Item.DelegateCtor ty - CallNameResolutionSink cenv.tcSink (mItemAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - TcNewDelegateThen cenv overallTy env tpenv mItem mItemAndArg ty arg atomicFlag otherDelayed - | _ -> - error(Error(FSComp.SR.tcInvalidUseOfDelegate(), mItem)) + TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [] mItem delayed (Some afterResolution) - | Item.Value vref -> +and TcImplicitOpItemThen cenv overallTy env id sln tpenv mItem delayed = + let g = cenv.g + let isPrefix = IsPrefixOperator id.idText + let isTernary = IsTernaryOperator id.idText + + let argData = + if isPrefix then + [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] + elif isTernary then + [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) + SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) + SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] + else + [ SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) + SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) ] + + let retTyData = SynTypar(mkSynId mItem (cenv.synArgNameGenerator.New()), TyparStaticReq.HeadType, true) + let argTypars = argData |> List.map (fun d -> Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, d, false, TyparDynamicReq.Yes, [], false, false)) + let retTypar = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, retTyData, false, TyparDynamicReq.Yes, [], false, false) + let argTys = argTypars |> List.map mkTyparTy + let retTy = mkTyparTy retTypar + + let vs, ves = argTys |> List.mapi (fun i ty -> mkCompGenLocal mItem ("arg" + string i) ty) |> List.unzip + + let memberFlags = StaticMemberFlags SynMemberKind.Member + let logicalCompiledName = ComputeLogicalName id memberFlags + let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln) + + let expr = Expr.Op (TOp.TraitCall traitInfo, [], ves, mItem) + let expr = mkLambdas mItem [] vs (expr, retTy) + + let rec isSimpleArgument e = + match e with + | SynExpr.New (_, _, synExpr, _) + | SynExpr.Paren (synExpr, _, _, _) + | SynExpr.Typed (synExpr, _, _) + | SynExpr.TypeApp (synExpr, _, _, _, _, _, _) + | SynExpr.TypeTest (synExpr, _, _) + | SynExpr.Upcast (synExpr, _, _) + | SynExpr.DotGet (synExpr, _, _, _) + | SynExpr.Downcast (synExpr, _, _) + | SynExpr.InferredUpcast (synExpr, _) + | SynExpr.InferredDowncast (synExpr, _) + | SynExpr.AddressOf (_, synExpr, _, _) + | SynExpr.Quote (_, _, synExpr, _, _) -> isSimpleArgument synExpr + + | SynExpr.InterpolatedString _ + | SynExpr.Null _ + | SynExpr.Ident _ + | SynExpr.Const _ + | SynExpr.LongIdent _ -> true + + | SynExpr.Tuple (_, synExprs, _, _) + | SynExpr.ArrayOrList (_, synExprs, _) -> synExprs |> List.forall isSimpleArgument + | SynExpr.Record (copyInfo=copyOpt; recordFields=fields) -> copyOpt |> Option.forall (fst >> isSimpleArgument) && fields |> List.forall ((fun (SynExprRecordField(expr=e)) -> e) >> Option.forall isSimpleArgument) + | SynExpr.App (_, _, synExpr, synExpr2, _) -> isSimpleArgument synExpr && isSimpleArgument synExpr2 + | SynExpr.IfThenElse (_, _, synExpr, _, synExpr2, _, synExprOpt, _, _, _, _) -> isSimpleArgument synExpr && isSimpleArgument synExpr2 && Option.forall isSimpleArgument synExprOpt + | SynExpr.DotIndexedGet (synExpr, _, _, _) -> isSimpleArgument synExpr + | SynExpr.ObjExpr _ + | SynExpr.AnonRecd _ + | SynExpr.While _ + | SynExpr.For _ + | SynExpr.ForEach _ + | SynExpr.ArrayOrListComputed _ + | SynExpr.ComputationExpr _ + | SynExpr.Lambda _ + | SynExpr.MatchLambda _ + | SynExpr.Match _ + | SynExpr.Do _ + | SynExpr.Assert _ + | SynExpr.Fixed _ + | SynExpr.TryWith _ + | SynExpr.TryFinally _ + | SynExpr.Lazy _ + | SynExpr.Sequential _ + | SynExpr.SequentialOrImplicitYield _ + | SynExpr.LetOrUse _ + | SynExpr.DotSet _ + | SynExpr.DotIndexedSet _ + | SynExpr.LongIdentSet _ + | SynExpr.Set _ + | SynExpr.JoinIn _ + | SynExpr.NamedIndexedPropertySet _ + | SynExpr.DotNamedIndexedPropertySet _ + | SynExpr.LibraryOnlyILAssembly _ + | SynExpr.LibraryOnlyStaticOptimization _ + | SynExpr.LibraryOnlyUnionCaseFieldGet _ + | SynExpr.LibraryOnlyUnionCaseFieldSet _ + | SynExpr.ArbitraryAfterError _ + | SynExpr.FromParseError _ + | SynExpr.DiscardAfterMissingQualificationAfterDot _ + | SynExpr.ImplicitZero _ + | SynExpr.YieldOrReturn _ + | SynExpr.YieldOrReturnFrom _ + | SynExpr.MatchBang _ + | SynExpr.LetOrUseBang _ + | SynExpr.DoBang _ + | SynExpr.TraitCall _ + | SynExpr.IndexFromEnd _ + | SynExpr.IndexRange _ + -> false + + // Propagate the known application structure into function types + Propagate cenv overallTy env tpenv (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) delayed + + // Take all simple arguments and process them before applying the constraint. + let delayed1, delayed2 = + let pred = (function DelayedApp (_, _, _, arg, _) -> isSimpleArgument arg | _ -> false) + List.takeWhile pred delayed, List.skipWhile pred delayed + + let intermediateTy = if isNil delayed2 then overallTy.Commit else NewInferenceType () + + let resultExpr, tpenv = TcDelayed cenv (MustEqual intermediateTy) env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 + + // Add the constraint after the application arguments have been checked to allow annotations to kick in on rigid type parameters + AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo + + // Process all remaining arguments after the constraint is asserted + let resultExpr2, tpenv2 = TcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv resultExpr) intermediateTy ExprAtomicFlag.NonAtomic delayed2 + resultExpr2, tpenv2 + +and TcDelegateCtorItemThen cenv overallTy env ty tinstEnclosing tpenv mItem delayed = + match delayed with + | DelayedApp (atomicFlag, _, _, arg, mItemAndArg) :: otherDelayed -> + TcNewDelegateThen cenv overallTy env tpenv mItem mItemAndArg ty arg atomicFlag otherDelayed + | DelayedTypeApp(tyargs, _mTypeArgs, mItemAndTypeArgs) :: DelayedApp (atomicFlag, _, _, arg, mItemAndArg) :: otherDelayed -> + let ty, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mItemAndTypeArgs ty tinstEnclosing tyargs + + // Report information about the whole expression including type arguments to VS + let item = Item.DelegateCtor ty + CallNameResolutionSink cenv.tcSink (mItemAndTypeArgs, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + TcNewDelegateThen cenv overallTy env tpenv mItem mItemAndArg ty arg atomicFlag otherDelayed + | _ -> + error(Error(FSComp.SR.tcInvalidUseOfDelegate(), mItem)) - match delayed with - // Mutable value set: 'v <- e' - | DelayedSet(e2, mStmt) :: otherDelayed -> - if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) - UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty - vref.Deref.SetHasBeenReferenced() - CheckValAccessible mItem env.AccessRights vref - CheckValAttributes g vref mItem |> CommitOperationResult - let vty = vref.Type - let vty2 = - if isByrefTy g vty then - destByrefTy g vty - else - if not vref.IsMutable then - errorR (ValNotMutable (env.DisplayEnv, vref, mStmt)) - vty - // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false vty2 env tpenv e2 - let vexp = - if isInByrefTy g vty then - errorR(Error(FSComp.SR.writeToReadOnlyByref(), mStmt)) - mkAddrSet mStmt vref e2' - elif isByrefTy g vty then - mkAddrSet mStmt vref e2' - else - mkValSet mStmt vref e2' - - PropagateThenTcDelayed cenv overallTy env tpenv mStmt (MakeApplicableExprNoFlex cenv vexp) (tyOfExpr g vexp) ExprAtomicFlag.NonAtomic otherDelayed - - // Value instantiation: v ... - | DelayedTypeApp(tys, _mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> - // Note: we know this is a NormalValUse or PossibleConstrainedCall because: - // - it isn't a CtorValUsedAsSuperInit - // - it isn't a CtorValUsedAsSelfInit - // - it isn't a VSlotDirectCall (uses of base values do not take type arguments - // Allow `nameof<'T>` for a generic parameter - match vref with - | _ when isNameOfValRef cenv.g vref && cenv.g.langVersion.SupportsFeature LanguageFeature.NameOf -> - match tys with - | [SynType.Var(SynTypar(id, _, false) as tp, _m)] -> - let _tp', tpenv = TcTyparOrMeasurePar None cenv env ImplicitlyBoundTyparsAllowed.NoNewTypars tpenv tp - let vexp = TcNameOfExprResult cenv id mExprAndTypeArgs - let vexpFlex = MakeApplicableExprNoFlex cenv vexp - PropagateThenTcDelayed cenv overallTy env tpenv mExprAndTypeArgs vexpFlex cenv.g.string_ty ExprAtomicFlag.Atomic otherDelayed - | _ -> - error (Error(FSComp.SR.expressionHasNoName(), mExprAndTypeArgs)) +and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed = + let g = cenv.g + match delayed with + // Mutable value set: 'v <- e' + | DelayedSet(e2, mStmt) :: otherDelayed -> + if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty + vref.Deref.SetHasBeenReferenced() + CheckValAccessible mItem env.AccessRights vref + CheckValAttributes g vref mItem |> CommitOperationResult + let vty = vref.Type + let vty2 = + if isByrefTy g vty then + destByrefTy g vty + else + if not vref.IsMutable then + errorR (ValNotMutable (env.DisplayEnv, vref, mStmt)) + vty + // Always allow subsumption on assignment to fields + let e2', tpenv = TcExprFlex cenv true false vty2 env tpenv e2 + let vexp = + if isInByrefTy g vty then + errorR(Error(FSComp.SR.writeToReadOnlyByref(), mStmt)) + mkAddrSet mStmt vref e2' + elif isByrefTy g vty then + mkAddrSet mStmt vref e2' + else + mkValSet mStmt vref e2' + + PropagateThenTcDelayed cenv overallTy env tpenv mStmt (MakeApplicableExprNoFlex cenv vexp) (tyOfExpr g vexp) ExprAtomicFlag.NonAtomic otherDelayed + + // Value instantiation: v ... + | DelayedTypeApp(tys, _mTypeArgs, mExprAndTypeArgs) :: otherDelayed -> + // Note: we know this is a NormalValUse or PossibleConstrainedCall because: + // - it isn't a CtorValUsedAsSuperInit + // - it isn't a CtorValUsedAsSelfInit + // - it isn't a VSlotDirectCall (uses of base values do not take type arguments + // Allow `nameof<'T>` for a generic parameter + match vref with + | _ when isNameOfValRef cenv.g vref && cenv.g.langVersion.SupportsFeature LanguageFeature.NameOf -> + match tys with + | [SynType.Var(SynTypar(id, _, false) as tp, _m)] -> + let _tp', tpenv = TcTyparOrMeasurePar None cenv env ImplicitlyBoundTyparsAllowed.NoNewTypars tpenv tp + let vexp = TcNameOfExprResult cenv id mExprAndTypeArgs + let vexpFlex = MakeApplicableExprNoFlex cenv vexp + PropagateThenTcDelayed cenv overallTy env tpenv mExprAndTypeArgs vexpFlex cenv.g.string_ty ExprAtomicFlag.Atomic otherDelayed | _ -> - let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mItem - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem + error (Error(FSComp.SR.expressionHasNoName(), mExprAndTypeArgs)) + | _ -> + let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem - let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) - // We need to eventually record the type resolution for an expression, but this is done - // inside PropagateThenTcDelayed, so we don't have to explicitly call 'CallExprHasTypeSink' here - PropagateThenTcDelayed cenv overallTy env tpenv mExprAndTypeArgs vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic otherDelayed + let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) + // We need to eventually record the type resolution for an expression, but this is done + // inside PropagateThenTcDelayed, so we don't have to explicitly call 'CallExprHasTypeSink' here + PropagateThenTcDelayed cenv overallTy env tpenv mExprAndTypeArgs vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic otherDelayed - // Value get - | _ -> - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref None (Some afterResolution) mItem - let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) - PropagateThenTcDelayed cenv overallTy env tpenv mItem vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic delayed + // Value get + | _ -> + let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref None (Some afterResolution) mItem + let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) + PropagateThenTcDelayed cenv overallTy env tpenv mItem vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic delayed - | Item.Property (nm, pinfos) -> - if isNil pinfos then error (InternalError ("Unexpected error: empty property list", mItem)) - // if there are both intrinsics and extensions in pinfos, intrinsics will be listed first. - // by looking at List.Head we are letting the intrinsics determine indexed/non-indexed - let pinfo = List.head pinfos - let _, tyargsOpt, args, delayed, tpenv = - if pinfo.IsIndexer - then GetMemberApplicationArgs delayed cenv env tpenv - else ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv - if not pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItem)) - match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> - if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) - // Static Property Set (possibly indexer) - UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty - let meths = pinfos |> SettersOfPropInfos - if meths.IsEmpty then - let meths = pinfos |> GettersOfPropInfos - let isByrefMethReturnSetter = meths |> List.exists (function _,Some pinfo -> isByrefTy g (pinfo.GetPropertyType(cenv.amap,mItem)) | _ -> false) - if not isByrefMethReturnSetter then - errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) - // x.P <- ... byref setter - if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItem)) - TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mItem mItem nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic delayed - else - let args = if pinfo.IsIndexer then args else [] - if isNil meths then - errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) - // Note: static calls never mutate a struct object argument - TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mStmt mItem nm ad NeverMutates true meths afterResolution NormalValUse (args@[e2]) ExprAtomicFlag.NonAtomic otherDelayed - | _ -> - // Static Property Get (possibly indexer) +and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem afterResolution delayed = + let g = cenv.g + let ad = env.eAccessRights + if isNil pinfos then error (InternalError ("Unexpected error: empty property list", mItem)) + // if there are both intrinsics and extensions in pinfos, intrinsics will be listed first. + // by looking at List.Head we are letting the intrinsics determine indexed/non-indexed + let pinfo = List.head pinfos + let _, tyargsOpt, args, delayed, tpenv = + if pinfo.IsIndexer + then GetMemberApplicationArgs delayed cenv env tpenv + else ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv + if not pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItem)) + match delayed with + | DelayedSet(e2, mStmt) :: otherDelayed -> + if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) + // Static Property Set (possibly indexer) + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty + let meths = pinfos |> SettersOfPropInfos + if meths.IsEmpty then let meths = pinfos |> GettersOfPropInfos + let isByrefMethReturnSetter = meths |> List.exists (function _,Some pinfo -> isByrefTy g (pinfo.GetPropertyType(cenv.amap,mItem)) | _ -> false) + if not isByrefMethReturnSetter then + errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) + // x.P <- ... byref setter if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItem)) - // Note: static calls never mutate a struct object argument TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mItem mItem nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic delayed + else + let args = if pinfo.IsIndexer then args else [] + if isNil meths then + errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) + // Note: static calls never mutate a struct object argument + TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mStmt mItem nm ad NeverMutates true meths afterResolution NormalValUse (args@[e2]) ExprAtomicFlag.NonAtomic otherDelayed + | _ -> + // Static Property Get (possibly indexer) + let meths = pinfos |> GettersOfPropInfos + if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItem)) + // Note: static calls never mutate a struct object argument + TcMethodApplicationThen cenv env overallTy None tpenv tyargsOpt [] mItem mItem nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic delayed - | Item.ILField finfo -> +and TcILFieldItemThen cenv overallTy env finfo tpenv mItem delayed = + let g = cenv.g + let ad = env.eAccessRights + ILFieldStaticChecks g cenv.amap cenv.infoReader ad mItem finfo + let fref = finfo.ILFieldRef + let exprty = finfo.FieldType(cenv.amap, mItem) + match delayed with + | DelayedSet(e2, mStmt) :: _delayed' -> + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty + // Always allow subsumption on assignment to fields + let e2', tpenv = TcExprFlex cenv true false exprty env tpenv e2 + let expr = BuildILStaticFieldSet mStmt finfo e2' + expr, tpenv + | _ -> + // Get static IL field + let expr = + match finfo.LiteralValue with + | Some lit -> + Expr.Const (TcFieldInit mItem lit, mItem, exprty) + | None -> + let isValueType = finfo.IsValueType + let valu = if isValueType then AsValue else AsObject - ILFieldStaticChecks g cenv.amap cenv.infoReader ad mItem finfo - let fref = finfo.ILFieldRef - let exprty = finfo.FieldType(cenv.amap, mItem) - match delayed with - | DelayedSet(e2, mStmt) :: _delayed' -> - UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty - // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false exprty env tpenv e2 - let expr = BuildILStaticFieldSet mStmt finfo e2' - expr, tpenv - | _ -> - // Get static IL field - let expr = - match finfo.LiteralValue with - | Some lit -> - Expr.Const (TcFieldInit mItem lit, mItem, exprty) - | None -> - let isValueType = finfo.IsValueType - let valu = if isValueType then AsValue else AsObject + // The empty instantiation on the fspec is OK, since we make the correct fspec in IlxGen.GenAsm + // This ensures we always get the type instantiation right when doing this from + // polymorphic code, after inlining etc. + let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) - // The empty instantiation on the fspec is OK, since we make the correct fspec in IlxGen.GenAsm - // This ensures we always get the type instantiation right when doing this from - // polymorphic code, after inlining etc. - let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) + // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr. + mkAsmExpr ([ mkNormalLdsfld fspec ] @ (if finfo.IsInitOnly then [ AI_nop ] else []), finfo.TypeInst, [], [exprty], mItem) + PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprWithFlex cenv env expr) exprty ExprAtomicFlag.Atomic delayed - // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr. - mkAsmExpr ([ mkNormalLdsfld fspec ] @ (if finfo.IsInitOnly then [ AI_nop ] else []), finfo.TypeInst, [], [exprty], mItem) - PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprWithFlex cenv env expr) exprty ExprAtomicFlag.Atomic delayed +and TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem delayed = + let g = cenv.g + let ad = env.eAccessRights + // Get static F# field or literal + CheckRecdFieldInfoAccessible cenv.amap mItem ad rfinfo + if not rfinfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), mItem)) + CheckRecdFieldInfoAttributes g rfinfo mItem |> CommitOperationResult + let fref = rfinfo.RecdFieldRef + let fieldTy = rfinfo.FieldType + match delayed with + | DelayedSet(e2, mStmt) :: otherDelayed -> + if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) - | Item.RecdField rfinfo -> - // Get static F# field or literal - CheckRecdFieldInfoAccessible cenv.amap mItem ad rfinfo - if not rfinfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), mItem)) - CheckRecdFieldInfoAttributes g rfinfo mItem |> CommitOperationResult - let fref = rfinfo.RecdFieldRef + // Set static F# field + CheckRecdFieldMutation mItem env.DisplayEnv rfinfo + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty let fieldTy = rfinfo.FieldType - match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> - if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) - - // Set static F# field - CheckRecdFieldMutation mItem env.DisplayEnv rfinfo - UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty - let fieldTy = rfinfo.FieldType - // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 - let expr = mkStaticRecdFieldSet (rfinfo.RecdFieldRef, rfinfo.TypeInst, e2', mStmt) - expr, tpenv - | _ -> - let exprty = fieldTy - let expr = - match rfinfo.LiteralValue with - // Get literal F# field - | Some lit -> Expr.Const (lit, mItem, exprty) - // Get static F# field - | None -> mkStaticRecdFieldGet (fref, rfinfo.TypeInst, mItem) - PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprWithFlex cenv env expr) exprty ExprAtomicFlag.Atomic delayed - - | Item.Event einfo -> - // Instance IL event (fake up event-as-value) - TcEventValueThen cenv overallTy env tpenv mItem mItem None einfo delayed - - | Item.CustomOperation (nm, usageTextOpt, _) -> - // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed - match usageTextOpt() with - | None -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly nm, mItem)) - | Some usageText -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly2(nm, usageText), mItem)) - | _ -> error(Error(FSComp.SR.tcLookupMayNotBeUsedHere(), mItem)) - + // Always allow subsumption on assignment to fields + let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 + let expr = mkStaticRecdFieldSet (rfinfo.RecdFieldRef, rfinfo.TypeInst, e2', mStmt) + expr, tpenv + | _ -> + let exprty = fieldTy + let expr = + match rfinfo.LiteralValue with + // Get literal F# field + | Some lit -> Expr.Const (lit, mItem, exprty) + // Get static F# field + | None -> mkStaticRecdFieldGet (fref, rfinfo.TypeInst, mItem) + PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprWithFlex cenv env expr) exprty ExprAtomicFlag.Atomic delayed //------------------------------------------------------------------------- // Typecheck "expr.A.B.C ... " constructs @@ -8754,12 +8796,12 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | Item.Event einfo -> // Instance IL event (fake up event-as-value) - TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem (Some(objExpr, objExprTy)) einfo delayed + TcEventItemThen cenv overallTy env tpenv mItem mExprAndItem (Some(objExpr, objExprTy)) einfo delayed | Item.FakeInterfaceCtor _ | Item.DelegateCtor _ -> error (Error (FSComp.SR.tcConstructorsCannotBeFirstClassValues(), mItem)) | _ -> error (Error (FSComp.SR.tcSyntaxFormUsedOnlyWithRecordLabelsPropertiesAndFields(), mItem)) -and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einfo: EventInfo) delayed = +and TcEventItemThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einfo: EventInfo) delayed = // Instance IL event (fake up event-as-value) let nm = einfo.EventName let ad = env.eAccessRights diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 479964041ee..dd3bcb7fc65 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1129,103 +1129,26 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi CheckValUse cenv env (vref, vFlags, m) context | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> - CheckExprNoByrefs cenv {env with quote=true} ast - if cenv.reportErrors then - cenv.usesQuotations <- true - - // Translate the quotation to quotation data - try - let doData suppressWitnesses = - let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) - let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast - let typeDefs, spliceTypes, spliceExprs = qscope.Close() - typeDefs, List.map fst spliceTypes, List.map fst spliceExprs, qdata - - let data1 = doData true - let data2 = doData false - match savedConv.Value with - | None -> - savedConv.Value <- Some (data1, data2) - | Some _ -> - () - with QuotationTranslator.InvalidQuotedTerm e -> - errorRecovery e m - - CheckTypeNoByrefs cenv env m ty - NoLimit + CheckQuoteExpr cenv env (ast, savedConv, m, ty) - | StructStateMachineExpr g (_dataTy, - (moveNextThisVar, moveNextExpr), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), - (afterCodeThisVar, afterCodeBody)) -> - if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then - error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) - - BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } moveNextExpr - CheckExprNoByrefs cenv env setStateMachineBody - CheckExprNoByrefs cenv env afterCodeBody - NoLimit + | StructStateMachineExpr g info -> + CheckStructStateMachineExpr cenv env expr info | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckExprNoByrefs cenv env superInitCall - CheckMethods cenv env basev (ty, overrides) - CheckInterfaceImpls cenv env basev iimpls - CheckTypeNoByrefs cenv env m ty - - let interfaces = - [ if isInterfaceTy g ty then - yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty - for ty, _ in iimpls do - yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty ] - |> List.filter (isInterfaceTy g) - - CheckMultipleInterfaceInstantiations cenv ty interfaces true m - NoLimit + CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) when ((match vFlags with VSlotDirectCall -> true | _ -> false) && baseVal.IsBaseVal) -> - let memberInfo = Option.get v.MemberInfo - if memberInfo.MemberFlags.IsDispatchSlot then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName), m)) - NoLimit - else - let env = { env with isInAppExpr = true } - let returnTy = tyOfExpr g expr - - CheckValRef cenv env v m PermitByRefExpr.No - CheckValRef cenv env baseVal m PermitByRefExpr.No - CheckTypeInstNoByrefs cenv env m tyargs - CheckTypeNoInnerByrefs cenv env m returnTy - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) + CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) // Allow base calls to IL methods | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), tyargs, Expr.Val (baseVal, _, _) :: rest, m) when not isVirtual && baseVal.IsBaseVal -> - // Disallow calls to abstract base methods on IL types. - match tryTcrefOfAppTy g baseVal.Type with - | ValueSome tcref when tcref.IsILTycon -> - try - // This is awkward - we have to explicitly re-resolve back to the IL metadata to determine if the method is abstract. - // We believe this may be fragile in some situations, since we are using the Abstract IL code to compare - // type equality, and it would be much better to remove any F# dependency on that implementation of IL type - // equality. It would be better to make this check in tc.fs when we have the Abstract IL metadata for the method to hand. - let mdef = resolveILMethodRef tcref.ILTyconRawMetadata ilMethRef - if mdef.IsAbstract then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(mdef.Name), m)) - with _ -> () // defensive coding - | _ -> () - - CheckTypeInstNoByrefs cenv env m tyargs - CheckTypeInstNoByrefs cenv env m enclTypeInst - CheckTypeInstNoByrefs cenv env m methInst - CheckTypeInstNoByrefs cenv env m retTypes - CheckValRef cenv env baseVal m PermitByRefExpr.No - CheckExprsPermitByRefLike cenv env rest + CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv env (op, tyargs, args, m) context expr @@ -1240,48 +1163,17 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi // Allow '%expr' in quotations | Expr.App (Expr.Val (vref, _, _), _, tinst, [arg], m) when isSpliceOperator g vref && env.quote -> - CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed - CheckExprNoByrefs cenv env arg - NoLimit + CheckSpliceApplication cenv env (tinst, arg, m) // Check an application | Expr.App (f, _fty, tyargs, argsl, m) -> - match expr with - | ResumableCodeInvoke g _ -> - warning(Error(FSComp.SR.tcResumableCodeInvocation(), m)) - | _ -> () - - let returnTy = tyOfExpr g expr - - // This is to handle recursive cases. Don't check 'returnTy' again if we are still inside a app expression. - if not env.isInAppExpr then - CheckTypeNoInnerByrefs cenv env m returnTy + CheckApplication cenv env expr (f, tyargs, argsl, m) context - let env = { env with isInAppExpr = true } - - CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env f - - let hasReceiver = - match f with - | Expr.Val (vref, _, _) when vref.IsInstanceMember && not argsl.IsEmpty -> true - | _ -> false - - let contexts = mkArgsForAppliedExpr false argsl f - if hasReceiver then - CheckCallWithReceiver cenv env m returnTy argsl contexts context - else - CheckCall cenv env m returnTy argsl contexts context - - | Expr.Lambda (_, _ctorThisValOpt, _baseValOpt, argvs, _, m, rty) -> - let topValInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) - let ty = mkMultiLambdaTy m argvs rty in - CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes + | Expr.Lambda (_, _, _, argvs, _, m, rty) -> + CheckLambda cenv env expr (argvs, m, rty) | Expr.TyLambda (_, tps, _, m, rty) -> - let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps rty in - CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes + CheckTyLambda cenv env expr (tps, m, rty) | Expr.TyChoose (tps, e1, _) -> let env = BindTypars g env tps @@ -1289,26 +1181,13 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi NoLimit | Expr.Match (_, _, dtree, targets, m, ty) -> - CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch - CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets context + CheckMatch cenv env context (dtree, targets, m, ty) - | Expr.LetRec (binds, e, _, _) -> - BindVals cenv env (valsOfBinds binds) - CheckBindings cenv env binds - CheckExprNoByrefs cenv env e - NoLimit + | Expr.LetRec (binds, bodyExpr, _, _) -> + CheckLetRec cenv env (binds, bodyExpr) | Expr.StaticOptimization (constraints, e2, e3, m) -> - CheckExprNoByrefs cenv env e2 - CheckExprNoByrefs cenv env e3 - constraints |> List.iter (function - | TTyconEqualsTycon(ty1, ty2) -> - CheckTypeNoByrefs cenv env m ty1 - CheckTypeNoByrefs cenv env m ty2 - | TTyconIsStruct ty1 -> - CheckTypeNoByrefs cenv env m ty1) - NoLimit + CheckStaticOptimization cenv env (constraints, e2, e3, m) | Expr.WitnessArg _ -> NoLimit @@ -1316,6 +1195,172 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi | Expr.Link _ -> failwith "Unexpected reclink" +and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = + let g = cenv.g + CheckExprNoByrefs cenv {env with quote=true} ast + if cenv.reportErrors then + cenv.usesQuotations <- true + + // Translate the quotation to quotation data + try + let doData suppressWitnesses = + let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) + let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast + let typeDefs, spliceTypes, spliceExprs = qscope.Close() + typeDefs, List.map fst spliceTypes, List.map fst spliceExprs, qdata + + let data1 = doData true + let data2 = doData false + match savedConv.Value with + | None -> + savedConv.Value <- Some (data1, data2) + | Some _ -> + () + with QuotationTranslator.InvalidQuotedTerm e -> + errorRecovery e m + + CheckTypeNoByrefs cenv env m ty + NoLimit + +and CheckStructStateMachineExpr cenv env expr info = + + let g = cenv.g + let (_dataTy, + (moveNextThisVar, moveNextExpr), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + (afterCodeThisVar, afterCodeBody)) = info + + if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then + error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) + + BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } moveNextExpr + CheckExprNoByrefs cenv env setStateMachineBody + CheckExprNoByrefs cenv env afterCodeBody + NoLimit + +and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = + let g = cenv.g + CheckExprNoByrefs cenv env superInitCall + CheckMethods cenv env basev (ty, overrides) + CheckInterfaceImpls cenv env basev iimpls + CheckTypeNoByrefs cenv env m ty + + let interfaces = + [ if isInterfaceTy g ty then + yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty + for ty, _ in iimpls do + yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty ] + |> List.filter (isInterfaceTy g) + + CheckMultipleInterfaceInstantiations cenv ty interfaces true m + NoLimit + +and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = + let g = cenv.g + let memberInfo = Option.get v.MemberInfo + if memberInfo.MemberFlags.IsDispatchSlot then + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName), m)) + NoLimit + else + let env = { env with isInAppExpr = true } + let returnTy = tyOfExpr g expr + + CheckValRef cenv env v m PermitByRefExpr.No + CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeNoInnerByrefs cenv env m returnTy + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) + +and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = + let g = cenv.g + // Disallow calls to abstract base methods on IL types. + match tryTcrefOfAppTy g baseVal.Type with + | ValueSome tcref when tcref.IsILTycon -> + try + // This is awkward - we have to explicitly re-resolve back to the IL metadata to determine if the method is abstract. + // We believe this may be fragile in some situations, since we are using the Abstract IL code to compare + // type equality, and it would be much better to remove any F# dependency on that implementation of IL type + // equality. It would be better to make this check in tc.fs when we have the Abstract IL metadata for the method to hand. + let mdef = resolveILMethodRef tcref.ILTyconRawMetadata ilMethRef + if mdef.IsAbstract then + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(mdef.Name), m)) + with _ -> () // defensive coding + | _ -> () + + CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeInstNoByrefs cenv env m enclTypeInst + CheckTypeInstNoByrefs cenv env m methInst + CheckTypeInstNoByrefs cenv env m retTypes + CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckExprsPermitByRefLike cenv env rest + +and CheckSpliceApplication cenv env (tinst, arg, m) = + CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed + CheckExprNoByrefs cenv env arg + NoLimit + +and CheckApplication cenv env expr (f, tyargs, argsl, m) context = + let g = cenv.g + match expr with + | ResumableCodeInvoke g _ -> + warning(Error(FSComp.SR.tcResumableCodeInvocation(), m)) + | _ -> () + + let returnTy = tyOfExpr g expr + + // This is to handle recursive cases. Don't check 'returnTy' again if we are still inside a app expression. + if not env.isInAppExpr then + CheckTypeNoInnerByrefs cenv env m returnTy + + let env = { env with isInAppExpr = true } + + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprNoByrefs cenv env f + + let hasReceiver = + match f with + | Expr.Val (vref, _, _) when vref.IsInstanceMember && not argsl.IsEmpty -> true + | _ -> false + + let contexts = mkArgsForAppliedExpr false argsl f + if hasReceiver then + CheckCallWithReceiver cenv env m returnTy argsl contexts context + else + CheckCall cenv env m returnTy argsl contexts context + +and CheckLambda cenv env expr (argvs, m, rty) = + let topValInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) + let ty = mkMultiLambdaTy m argvs rty in + CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes + +and CheckTyLambda cenv env expr (tps, m, rty) = + let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + let ty = mkForallTyIfNeeded tps rty in + CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes + +and CheckMatch cenv env context (dtree, targets, m, ty) = + CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch + CheckDecisionTree cenv env dtree + CheckDecisionTreeTargets cenv env targets context + +and CheckLetRec cenv env (binds, bodyExpr) = + BindVals cenv env (valsOfBinds binds) + CheckBindings cenv env binds + CheckExprNoByrefs cenv env bodyExpr + NoLimit + +and CheckStaticOptimization cenv env (constraints, e2, e3, m) = + CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs cenv env e3 + constraints |> List.iter (function + | TTyconEqualsTycon(ty1, ty2) -> + CheckTypeNoByrefs cenv env m ty1 + CheckTypeNoByrefs cenv env m ty2 + | TTyconIsStruct ty1 -> + CheckTypeNoByrefs cenv env m ty1) + NoLimit + and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty)