Permalink
executable file 16943 lines (14082 sloc) 944 KB
// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information.
/// The typechecker. Left-to-right constrained type checking
/// with generalization at appropriate points.
module internal Microsoft.FSharp.Compiler.TypeChecker
open System
open System.Collections.Generic
open Internal.Utilities
open Internal.Utilities.Collections
open Microsoft.FSharp.Compiler.AbstractIL
open Microsoft.FSharp.Compiler.AbstractIL.IL
open Microsoft.FSharp.Compiler.AbstractIL.Internal
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library.ResultOrException
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
open Microsoft.FSharp.Compiler
open Microsoft.FSharp.Compiler.Range
open Microsoft.FSharp.Compiler.Rational
open Microsoft.FSharp.Compiler.Ast
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Tast
open Microsoft.FSharp.Compiler.Tastops
open Microsoft.FSharp.Compiler.Tastops.DebugPrint
open Microsoft.FSharp.Compiler.PatternMatchCompilation
open Microsoft.FSharp.Compiler.TcGlobals
open Microsoft.FSharp.Compiler.Lib
open Microsoft.FSharp.Compiler.Layout
open Microsoft.FSharp.Compiler.Infos
open Microsoft.FSharp.Compiler.AccessibilityLogic
open Microsoft.FSharp.Compiler.AttributeChecking
open Microsoft.FSharp.Compiler.TypeRelations
open Microsoft.FSharp.Compiler.MethodCalls
open Microsoft.FSharp.Compiler.MethodOverrides
open Microsoft.FSharp.Compiler.ConstraintSolver
open Microsoft.FSharp.Compiler.NameResolution
open Microsoft.FSharp.Compiler.PrettyNaming
open Microsoft.FSharp.Compiler.InfoReader
#if EXTENSIONTYPING
open Microsoft.FSharp.Compiler.ExtensionTyping
#endif
//-------------------------------------------------------------------------
// Helpers that should be elsewhere
//-------------------------------------------------------------------------
let isThreadOrContextStatic g attrs =
HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute attrs ||
HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute attrs
let mkNilListPat (g: TcGlobals) m ty = TPat_unioncase(g.nil_ucref,[ty],[],m)
let mkConsListPat (g: TcGlobals) ty ph pt = TPat_unioncase(g.cons_ucref,[ty],[ph;pt],unionRanges ph.Range pt.Range)
let mkCompGenLetIn m nm ty e f =
let v,ve = mkCompGenLocal m nm ty
mkCompGenLet m v e (f (v,ve))
let mkUnitDelayLambda (g: TcGlobals) m e =
let uv,_ = mkCompGenLocal m "unitVar" g.unit_ty
mkLambda m uv (e,tyOfExpr g e)
//-------------------------------------------------------------------------
// Errors.
//-------------------------------------------------------------------------
exception BakedInMemberConstraintName of string * range
exception FunctionExpected of DisplayEnv * TType * range
exception NotAFunction of DisplayEnv * TType * range * range
exception Recursion of DisplayEnv * Ident * TType * TType * range
exception RecursiveUseCheckedAtRuntime of DisplayEnv * ValRef * range
exception LetRecEvaluatedOutOfOrder of DisplayEnv * ValRef * ValRef * range
exception LetRecCheckedAtRuntime of range
exception LetRecUnsound of DisplayEnv * ValRef list * range
exception TyconBadArgs of DisplayEnv * TyconRef * int * range
exception UnionCaseWrongArguments of DisplayEnv * int * int * range
exception UnionCaseWrongNumberOfArgs of DisplayEnv * int * int * range
exception FieldsFromDifferentTypes of DisplayEnv * RecdFieldRef * RecdFieldRef * range
exception FieldGivenTwice of DisplayEnv * Tast.RecdFieldRef * range
exception MissingFields of string list * range
exception FunctionValueUnexpected of DisplayEnv * TType * range
exception UnitTypeExpected of DisplayEnv * TType * range
exception UnitTypeExpectedWithEquality of DisplayEnv * TType * range
exception UnitTypeExpectedWithPossibleAssignment of DisplayEnv * TType * bool * string * range
exception UnitTypeExpectedWithPossiblePropertySetter of DisplayEnv * TType * string * string * range
exception UnionPatternsBindDifferentNames of range
exception VarBoundTwice of Ident
exception ValueRestriction of DisplayEnv * bool * Val * Typar * range
exception FieldNotMutable of DisplayEnv * Tast.RecdFieldRef * range
exception ValNotMutable of DisplayEnv * ValRef * range
exception ValNotLocal of DisplayEnv * ValRef * range
exception InvalidRuntimeCoercion of DisplayEnv * TType * TType * range
exception IndeterminateRuntimeCoercion of DisplayEnv * TType * TType * range
exception IndeterminateStaticCoercion of DisplayEnv * TType * TType * range
exception RuntimeCoercionSourceSealed of DisplayEnv * TType * range
exception CoercionTargetSealed of DisplayEnv * TType * range
exception UpcastUnnecessary of range
exception TypeTestUnnecessary of range
exception StaticCoercionShouldUseBox of DisplayEnv * TType * TType * range
exception SelfRefObjCtor of bool * range
exception VirtualAugmentationOnNullValuedType of range
exception NonVirtualAugmentationOnNullValuedType of range
exception UseOfAddressOfOperator of range
exception DeprecatedThreadStaticBindingWarning of range
exception IntfImplInIntrinsicAugmentation of range
exception IntfImplInExtrinsicAugmentation of range
exception OverrideInIntrinsicAugmentation of range
exception OverrideInExtrinsicAugmentation of range
exception NonUniqueInferredAbstractSlot of TcGlobals * DisplayEnv * string * MethInfo * MethInfo * range
exception StandardOperatorRedefinitionWarning of string * range
exception InvalidInternalsVisibleToAssemblyName of (*badName*)string * (*fileName option*) string option
// Identify any security attributes
let IsSecurityAttribute (g: TcGlobals) amap (casmap : Dictionary<Stamp,bool>) (Attrib(tcref,_,_,_,_,_,_)) m =
// There's no CAS on Silverlight, so we have to be careful here
match g.attrib_SecurityAttribute with
| None -> false
| Some attr ->
match attr.TyconRef.TryDeref with
| Some _ ->
let tcs = tcref.Stamp
if casmap.ContainsKey(tcs) then
casmap.[tcs]
else
let exists = ExistsInEntireHierarchyOfType (fun t -> typeEquiv g t (mkAppTy attr.TyconRef [])) g amap m AllowMultiIntfInstantiations.Yes (mkAppTy tcref [])
casmap.[tcs] <- exists
exists
| _ -> false
let IsSecurityCriticalAttribute g (Attrib(tcref,_,_,_,_,_,_)) =
(tyconRefEq g tcref g.attrib_SecurityCriticalAttribute.TyconRef || tyconRefEq g tcref g.attrib_SecuritySafeCriticalAttribute.TyconRef)
let RecdFieldInstanceChecks g amap ad m (rfinfo:RecdFieldInfo) =
if rfinfo.IsStatic then error (Error (FSComp.SR.tcStaticFieldUsedWhenInstanceFieldExpected(),m))
CheckRecdFieldInfoAttributes g rfinfo m |> CommitOperationResult
CheckRecdFieldInfoAccessible amap m ad rfinfo
let ILFieldInstanceChecks g amap ad m (finfo :ILFieldInfo) =
if finfo.IsStatic then error (Error (FSComp.SR.tcStaticFieldUsedWhenInstanceFieldExpected(),m))
CheckILFieldInfoAccessible g amap m ad finfo
CheckILFieldAttributes g finfo m
let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo:MethInfo) =
if minfo.IsInstance <> isInstance then
if isInstance then
error (Error (FSComp.SR.csMethodIsNotAnInstanceMethod(minfo.LogicalName),m))
else
error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName),m))
// keep the original accessibility domain to determine type accessibility
let adOriginal = ad
// Eliminate the 'protected' portion of the accessibility domain for instance accesses
let ad =
match objArgs,ad with
| [objArg],AccessibleFrom(paths,Some tcref) ->
let objArgTy = tyOfExpr g objArg
let ty = generalizedTyconRef tcref
// We get to keep our rights if the type we're in subsumes the object argument type
if TypeFeasiblySubsumesType 0 g amap m ty CanCoerce objArgTy then
ad
// We get to keep our rights if this is a base call
elif IsBaseCall objArgs then
ad
else
AccessibleFrom(paths, None)
| _ -> ad
if not (IsTypeAndMethInfoAccessible amap m adOriginal ad minfo) then
error (Error (FSComp.SR.tcMethodNotAccessible(minfo.LogicalName),m))
CheckMethInfoAttributes g m tyargsOpt minfo |> CommitOperationResult
let CheckRecdFieldMutation m denv (rfinfo:RecdFieldInfo) =
if not rfinfo.RecdField.IsMutable then error (FieldNotMutable(denv,rfinfo.RecdFieldRef,m))
//-------------------------------------------------------------------------
// Information about object constructors
//-------------------------------------------------------------------------
type SafeInitData =
| SafeInitField of RecdFieldRef * RecdField
| NoSafeInitInfo
type CtorInfo =
{ // Object model constructors have a very specific form to satisfy .NET limitations.
// For "new = \arg. { new C with ... }"
// ctor = 3 indicates about to type check "\arg. (body)",
// ctor = 2 indicates about to type check "body"
// ctor = 1 indicates actually type checking the body expression
// 0 indicates everywhere else, including auxiliary expressions such e1 in "let x = e1 in { new ... }"
// REVIEW: clean up this rather odd approach ...
ctorShapeCounter: int
/// A handle to the ref cell to hold results of 'this' for 'type X() as x = ...' and 'new() as x = ...' constructs
/// in case 'x' is used in the arguments to the 'inherits' call.
safeThisValOpt: Val option
/// A handle to the boolean ref cell to hold success of initialized 'this' for 'type X() as x = ...' constructs
safeInitInfo: SafeInitData
ctorIsImplicit: bool
}
//-------------------------------------------------------------------------
// Type environments.
// - Named items in scope (values)
// - Record of type variables that can't be generalized
// - Our 'location' as a concrete compilation path
// - mutable accumulator for the module type currently being accumulated
//-------------------------------------------------------------------------
[<NoEquality; NoComparison>]
type UngeneralizableItem(computeFreeTyvars : (unit -> FreeTyvars)) =
// Flag is for: have we determined that this item definitely has
// no free type inference variables? This implies that
// (a) it will _never_ have any free type inference variables as further constraints are added to the system.
// (b) its set of FreeTycons will not change as further constraints are added to the system
let mutable willNeverHaveFreeTypars = false
// If WillNeverHaveFreeTypars then we can cache the computation of FreeTycons, since they are invariant.
let mutable cachedFreeLocalTycons = emptyFreeTycons
// If WillNeverHaveFreeTypars then we can cache the computation of FreeTraitSolutions, since they are invariant.
let mutable cachedFreeTraitSolutions = emptyFreeLocals
member item.GetFreeTyvars() =
let fvs = computeFreeTyvars()
if fvs.FreeTypars.IsEmpty then
willNeverHaveFreeTypars <- true
cachedFreeLocalTycons <- fvs.FreeTycons
cachedFreeTraitSolutions <- fvs.FreeTraitSolutions
fvs
member item.WillNeverHaveFreeTypars = willNeverHaveFreeTypars
member item.CachedFreeLocalTycons = cachedFreeLocalTycons
member item.CachedFreeTraitSolutions = cachedFreeTraitSolutions
[<NoEquality; NoComparison>]
type TcEnv =
{ /// Name resolution information
eNameResEnv : NameResolutionEnv
/// The list of items in the environment that may contain free inference
/// variables (which may not be generalized). The relevant types may
/// change as a result of inference equations being asserted, hence may need to
/// be recomputed.
eUngeneralizableItems: UngeneralizableItem list
// Two (!) versions of the current module path
// These are used to:
// - Look up the appropriate point in the corresponding signature
// see if an item is public or not
// - Change fslib canonical module type to allow compiler references to these items
// - Record the cpath for concrete modul_specs, tycon_specs and excon_specs so they can cache their generated IL representation where necessary
// - Record the pubpath of public, concrete {val,tycon,modul,excon}_specs.
// This information is used mainly when building non-local references
// to public items.
//
// Of the two, 'ePath' is the one that's barely used. It's only
// used by UpdateAccModuleOrNamespaceType to modify the CCU while compiling FSharp.Core
ePath: Ident list
eCompPath: CompilationPath
eAccessPath: CompilationPath
/// This field is computed from other fields, but we amortize the cost of computing it.
eAccessRights: AccessorDomain
/// Internals under these should be accessible
eInternalsVisibleCompPaths: CompilationPath list
/// Mutable accumulator for the current module type
eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref
/// Context information for type checker
eContextInfo : ContextInfo
/// Here Some tcref indicates we can access protected members in all super types
eFamilyType: TyconRef option
// Information to enforce special restrictions on valid expressions
// for .NET constructors.
eCtorInfo : CtorInfo option
eCallerMemberName : string option
}
member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv
member tenv.NameEnv = tenv.eNameResEnv
member tenv.AccessRights = tenv.eAccessRights
/// Compute the value of this computed, cached field
let computeAccessRights eAccessPath eInternalsVisibleCompPaths eFamilyType =
AccessibleFrom (eAccessPath :: eInternalsVisibleCompPaths, eFamilyType) // env.eAccessRights
let emptyTcEnv g =
let cpath = compPathInternal // allow internal access initially
{ eNameResEnv = NameResolutionEnv.Empty g
eUngeneralizableItems = []
ePath = []
eCompPath = cpath // dummy
eAccessPath = cpath // dummy
eAccessRights = computeAccessRights cpath [] None // compute this field
eInternalsVisibleCompPaths = []
eContextInfo = ContextInfo.NoContext
eModuleOrNamespaceTypeAccumulator = ref (NewEmptyModuleOrNamespaceType Namespace)
eFamilyType = None
eCtorInfo = None
eCallerMemberName = None }
//-------------------------------------------------------------------------
// Helpers related to determining if we're in a constructor and/or a class
// that may be able to access "protected" members.
//-------------------------------------------------------------------------
let InitialExplicitCtorInfo (safeThisValOpt, safeInitInfo) =
{ ctorShapeCounter = 3
safeThisValOpt = safeThisValOpt
safeInitInfo = safeInitInfo
ctorIsImplicit = false}
let InitialImplicitCtorInfo () =
{ ctorShapeCounter = 0
safeThisValOpt = None
safeInitInfo = NoSafeInitInfo
ctorIsImplicit = true }
let EnterFamilyRegion tcref env =
let eFamilyType = Some tcref
{ env with
eAccessRights = computeAccessRights env.eAccessPath env.eInternalsVisibleCompPaths eFamilyType // update this computed field
eFamilyType = eFamilyType }
let ExitFamilyRegion env =
let eFamilyType = None
match env.eFamilyType with
| None -> env // optimization to avoid reallocation
| _ ->
{ env with
eAccessRights = computeAccessRights env.eAccessPath env.eInternalsVisibleCompPaths eFamilyType // update this computed field
eFamilyType = eFamilyType }
let AreWithinCtorShape env = match env.eCtorInfo with None -> false | Some ctorInfo -> ctorInfo.ctorShapeCounter > 0
let AreWithinImplicitCtor env = match env.eCtorInfo with None -> false | Some ctorInfo -> ctorInfo.ctorIsImplicit
let GetCtorShapeCounter env = match env.eCtorInfo with None -> 0 | Some ctorInfo -> ctorInfo.ctorShapeCounter
let GetRecdInfo env = match env.eCtorInfo with None -> RecdExpr | Some ctorInfo -> if ctorInfo.ctorShapeCounter = 1 then RecdExprIsObjInit else RecdExpr
let AdjustCtorShapeCounter f env = {env with eCtorInfo = Option.map (fun ctorInfo -> { ctorInfo with ctorShapeCounter = f ctorInfo.ctorShapeCounter }) env.eCtorInfo }
let ExitCtorShapeRegion env = AdjustCtorShapeCounter (fun _ -> 0) env
//-------------------------------------------------------------------------
// Add stuff to environments and register things as ungeneralizeable.
//-------------------------------------------------------------------------
let isEmptyFreeTyvars ftyvs =
Zset.isEmpty ftyvs.FreeTypars &&
Zset.isEmpty ftyvs.FreeTycons
let addFreeItemOfTy typ eUngeneralizableItems =
let fvs = freeInType CollectAllNoCaching typ
if isEmptyFreeTyvars fvs then eUngeneralizableItems
else UngeneralizableItem(fun () -> freeInType CollectAllNoCaching typ) :: eUngeneralizableItems
let rec addFreeInModuleTy (mtyp:ModuleOrNamespaceType) acc =
QueueList.foldBack (typeOfVal >> accFreeInType CollectAllNoCaching) mtyp.AllValsAndMembers
(QueueList.foldBack (fun (mspec:ModuleOrNamespace) acc -> addFreeInModuleTy mspec.ModuleOrNamespaceType acc) mtyp.AllEntities acc)
let freeInModuleTy mtyp = addFreeInModuleTy mtyp emptyFreeTyvars
let addFreeItemOfModuleTy mtyp eUngeneralizableItems =
let fvs = freeInModuleTy mtyp
if isEmptyFreeTyvars fvs then eUngeneralizableItems
else UngeneralizableItem(fun () -> freeInModuleTy mtyp) :: eUngeneralizableItems
let AddValMapToNameEnv vs nenv =
NameMap.foldBackRange (fun v nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) vs nenv
let AddValListToNameEnv vs nenv =
List.foldBack (fun v nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) vs nenv
let addInternalsAccessibility env (ccu:CcuThunk) =
let compPath = CompPath (ccu.ILScopeRef,[])
let eInternalsVisibleCompPaths = compPath :: env.eInternalsVisibleCompPaths
{ env with
eAccessRights = computeAccessRights env.eAccessPath eInternalsVisibleCompPaths env.eFamilyType // update this computed field
eInternalsVisibleCompPaths = compPath :: env.eInternalsVisibleCompPaths }
let ModifyNameResEnv f env = { env with eNameResEnv = f env.eNameResEnv }
let AddLocalValPrimitive (v:Val) env =
let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env
{ env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems }
let AddLocalValMap tcSink scopem (vals:Val NameMap) env =
let env =
if vals.IsEmpty then
env
else
let env = ModifyNameResEnv (AddValMapToNameEnv vals) env
{ env with eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems }
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalVals tcSink scopem (vals:Val list) env =
let env =
if isNil vals then
env
else
let env = ModifyNameResEnv (AddValListToNameEnv vals) env
{ env with eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems }
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalVal tcSink scopem v env =
let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env
let env = {env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems }
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalExnDefnAndReport tcSink scopem env (exnc:Tycon) =
let env = ModifyNameResEnv (fun nenv -> AddExceptionDeclsToNameEnv BulkAdd.No nenv (mkLocalEntityRef exnc)) env
(* Also make VisualStudio think there is an identifier in scope at the range of the identifier text of its binding location *)
CallEnvSink tcSink (exnc.Range,env.NameEnv,env.eAccessRights)
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalTyconRefs ownDefinition g amap m tcrefs env =
if isNil tcrefs then env else
env |> ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false nenv tcrefs)
let AddLocalTycons g amap m (tycons: Tycon list) env =
if isNil tycons then env else
env |> AddLocalTyconRefs false g amap m (List.map mkLocalTyconRef tycons)
let AddLocalTyconsAndReport tcSink scopem g amap m tycons env =
let env = AddLocalTycons g amap m tycons env
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
//-------------------------------------------------------------------------
// Open a structure or an IL namespace
//-------------------------------------------------------------------------
let OpenModulesOrNamespaces tcSink g amap scopem root env mvvs =
let env =
if isNil mvvs then env else
ModifyNameResEnv (fun nenv -> AddModulesAndNamespacesContentsToNameEnv g amap env.eAccessRights scopem root nenv mvvs) env
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddRootModuleOrNamespaceRefs g amap m env modrefs =
if isNil modrefs then env else
ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefsToNameEnv g amap m true env.eAccessRights nenv modrefs) env
let AddNonLocalCcu g amap scopem env assemblyName (ccu:CcuThunk, internalsVisibleToAttributes) =
let internalsVisible =
internalsVisibleToAttributes
|> List.exists (fun visibleTo ->
try
System.Reflection.AssemblyName(visibleTo).Name = assemblyName
with e ->
warning(InvalidInternalsVisibleToAssemblyName(visibleTo,ccu.FileName))
false)
let env = if internalsVisible then addInternalsAccessibility env ccu else env
// Compute the top-rooted module or namespace references
let modrefs = ccu.RootModulesAndNamespaces |> List.map (mkNonLocalCcuRootEntityRef ccu)
// Compute the top-rooted type definitions
let tcrefs = ccu.RootTypeAndExceptionDefinitions |> List.map (mkNonLocalCcuRootEntityRef ccu)
let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs
let env =
if isNil tcrefs then env else
ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.Yes false g amap scopem true nenv tcrefs) env
//CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespaceType) =
// Compute the top-rooted module or namespace references
let modrefs = mtyp.ModuleAndNamespaceDefinitions |> List.map mkLocalModRef
// Compute the top-rooted type definitions
let tcrefs = mtyp.TypeAndExceptionDefinitions |> List.map mkLocalTyconRef
let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs
let env =
if isNil tcrefs then env else
ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No false g amap scopem true nenv tcrefs) env
let env = { env with eUngeneralizableItems = addFreeItemOfModuleTy mtyp env.eUngeneralizableItems }
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddModuleAbbreviationAndReport tcSink scopem id modrefs env =
let env =
if isNil modrefs then env else
ModifyNameResEnv (fun nenv -> AddModuleAbbrevToNameEnv id nenv modrefs) env
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
let item = Item.ModuleOrNamespaces modrefs
CallNameResolutionSink tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,env.eAccessRights)
env
let AddLocalSubModule g amap m env (modul:ModuleOrNamespace) =
let env = ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights nenv (mkLocalModRef modul)) env
let env = { env with eUngeneralizableItems = addFreeItemOfModuleTy modul.ModuleOrNamespaceType env.eUngeneralizableItems }
env
let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul:ModuleOrNamespace) =
let env = AddLocalSubModule g amap m env modul
CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let RegisterDeclaredTypars typars env =
if isNil typars then env else
{ env with eUngeneralizableItems = List.foldBack (mkTyparTy >> addFreeItemOfTy) typars env.eUngeneralizableItems }
let AddDeclaredTypars check typars env =
if isNil typars then env else
let env = ModifyNameResEnv (fun nenv -> AddDeclaredTyparsToNameEnv check nenv typars) env
RegisterDeclaredTypars typars env
/// Compilation environment for typechecking a compilation unit. Contains the
/// F# and .NET modules loaded from disk, the search path, a table indicating
/// how to List.map F# modules to assembly names, and some nasty globals
/// related to type inference. These are:
/// - all the type variables generated for this compilation unit
/// - the set of active fixups for "letrec" type inference
[<NoEquality; NoComparison>]
type cenv =
{ g: TcGlobals
/// Push an entry every time a recursive value binding is used,
/// in order to be able to fix up recursive type applications as
/// we infer type parameters
mutable recUses: ValMultiMap<(Expr ref * range * bool)>
/// Checks to run after all inference is complete.
mutable postInferenceChecks: ResizeArray<unit -> unit>
/// Are we in a script? if so relax the reporting of discarded-expression warnings at the top level
isScript: bool
/// Environment needed to convert IL types to F# types in the importer.
amap: Import.ImportMap
/// Used to generate new syntactic argument names in post-parse syntactic processing
synArgNameGenerator: SynArgNameGenerator
tcSink: TcResultsSink
/// Holds a reference to the component being compiled.
/// This field is very rarely used (mainly when fixing up forward references to fslib.
topCcu: CcuThunk
/// Holds the current inference constraints
css: ConstraintSolverState
/// Are we compiling the signature of a module from fslib?
compilingCanonicalFslibModuleType: bool
isSig: bool
haveSig: bool
niceNameGen: NiceNameGenerator
infoReader: InfoReader
nameResolver: NameResolver
conditionalDefines: string list
}
static member Create (g,isScript,niceNameGen,amap,topCcu,isSig,haveSig,conditionalDefines,tcSink, tcVal) =
let infoReader = new InfoReader(g,amap)
let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars m tpsorig
let nameResolver = new NameResolver(g,amap,infoReader,instantiationGenerator)
{ g = g
amap = amap
recUses = ValMultiMap<_>.Empty
postInferenceChecks = ResizeArray()
topCcu = topCcu
isScript = isScript
css = ConstraintSolverState.New(g,amap,infoReader,tcVal)
infoReader = infoReader
tcSink = tcSink
nameResolver = nameResolver
niceNameGen = niceNameGen
synArgNameGenerator = SynArgNameGenerator()
isSig = isSig
haveSig = haveSig
compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFslib
conditionalDefines = conditionalDefines }
let CopyAndFixupTypars m rigid tpsorig =
ConstraintSolver.FreshenAndFixupTypars m rigid [] [] tpsorig
let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy =
ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy)
//-------------------------------------------------------------------------
// Generate references to the module being generated - used for
// public items.
//-------------------------------------------------------------------------
let MakeInitialEnv env =
// Note: here we allocate a new module type accumulator
let mtypeAcc = ref (NewEmptyModuleOrNamespaceType Namespace)
{ env with eModuleOrNamespaceTypeAccumulator = mtypeAcc },mtypeAcc
let MakeInnerEnvWithAcc env nm mtypeAcc modKind =
let path = env.ePath @ [nm]
let cpath = env.eCompPath.NestedCompPath nm.idText modKind
{ env with
ePath = path
eCompPath = cpath
eAccessPath = cpath
eAccessRights = computeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType // update this computed field
eNameResEnv = { env.eNameResEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) }
eModuleOrNamespaceTypeAccumulator = mtypeAcc }
let MakeInnerEnv env nm modKind =
// Note: here we allocate a new module type accumulator
let mtypeAcc = ref (NewEmptyModuleOrNamespaceType modKind)
MakeInnerEnvWithAcc env nm mtypeAcc modKind,mtypeAcc
let MakeInnerEnvForTyconRef _cenv env tcref isExtrinsicExtension =
if isExtrinsicExtension then
// Extension members don't get access to protected stuff
env
else
// Regular members get access to protected stuff
let env = EnterFamilyRegion tcref env
// Note: assumes no nesting
let eAccessPath = env.eCompPath.NestedCompPath tcref.LogicalName ModuleOrType
{ env with
eAccessRights = computeAccessRights eAccessPath env.eInternalsVisibleCompPaths env.eFamilyType // update this computed field
eAccessPath = eAccessPath }
let MakeInnerEnvForMember cenv env (v:Val) =
match v.MemberInfo with
| None -> env
| Some _ -> MakeInnerEnvForTyconRef cenv env v.MemberApparentParent v.IsExtensionMember
let GetCurrAccumulatedModuleOrNamespaceType env = !(env.eModuleOrNamespaceTypeAccumulator)
let SetCurrAccumulatedModuleOrNamespaceType env x = env.eModuleOrNamespaceTypeAccumulator := x
/// Set up the initial environment
let LocateEnv ccu env enclosingNamespacePath =
let cpath = compPathOfCcu ccu
let env =
{env with
ePath = []
eCompPath = cpath
eAccessPath = cpath
// update this computed field
eAccessRights = computeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType }
let env = List.fold (fun env id -> MakeInnerEnv env id Namespace |> fst) env enclosingNamespacePath
env
let BuildRootModuleType enclosingNamespacePath (cpath:CompilationPath) mtyp =
(enclosingNamespacePath,(cpath, (mtyp, None)))
||> List.foldBack (fun id (cpath, (mtyp, mspec)) ->
let a,b = wrapModuleOrNamespaceTypeInNamespace id cpath.ParentCompPath mtyp
cpath.ParentCompPath, (a, match mspec with Some _ -> mspec | None -> Some b))
|> snd
let BuildRootModuleExpr enclosingNamespacePath (cpath:CompilationPath) mexpr =
(enclosingNamespacePath,(cpath, mexpr))
||> List.foldBack (fun id (cpath, mexpr) -> (cpath.ParentCompPath, wrapModuleOrNamespaceExprInNamespace id cpath.ParentCompPath mexpr))
|> snd
let TryStripPrefixPath (g:TcGlobals) (enclosingNamespacePath: Ident list) =
match enclosingNamespacePath with
| p::rest when
g.isInteractive &&
not (isNil rest) &&
p.idText.StartsWith(FsiDynamicModulePrefix,System.StringComparison.Ordinal) &&
p.idText.[FsiDynamicModulePrefix.Length..] |> String.forall System.Char.IsDigit
-> Some(p,rest)
| _ -> None
let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env =
if isNil enclosingNamespacePath then
env
else
// For F# interactive, skip "FSI_0002" prefixes when determining the path to open implicitly
let enclosingNamespacePathToOpen =
match TryStripPrefixPath g enclosingNamespacePath with
| Some(_,rest) -> rest
| None -> enclosingNamespacePath
let ad = env.eAccessRights
match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults amap scopem OpenQualified env.eNameResEnv ad enclosingNamespacePathToOpen with
| Result modrefs -> OpenModulesOrNamespaces tcSink g amap scopem false env (List.map p23 modrefs)
| Exception _ -> env
//-------------------------------------------------------------------------
// Helpers for unification
//-------------------------------------------------------------------------
/// Optimized unification routine that avoids creating new inference
/// variables unnecessarily
let UnifyRefTupleType contextInfo cenv denv m ty ps =
let ptys =
if isRefTupleTy cenv.g ty then
let ptys = destRefTupleTy cenv.g ty
if (List.length ps) = (List.length ptys) then ptys
else NewInferenceTypes ps
else NewInferenceTypes ps
let contextInfo =
match contextInfo with
| ContextInfo.RecordFields -> ContextInfo.TupleInRecordFields
| _ -> contextInfo
AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoRef, ptys))
ptys
/// Optimized unification routine that avoids creating new inference
/// variables unnecessarily
let UnifyStructTupleType contextInfo cenv denv m ty ps =
let ptys =
if isStructTupleTy cenv.g ty then
let ptys = destStructTupleTy cenv.g ty
if (List.length ps) = (List.length ptys) then ptys
else NewInferenceTypes ps
else NewInferenceTypes ps
AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoStruct, ptys))
ptys
/// Optimized unification routine that avoids creating new inference
/// variables unnecessarily
let UnifyFunctionTypeUndoIfFailed cenv denv m ty =
match tryDestFunTy cenv.g ty with
| None ->
let domainTy = NewInferenceType ()
let resultTy = NewInferenceType ()
if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then
Some(domainTy,resultTy)
else
None
| r -> r
/// Optimized unification routine that avoids creating new inference
/// variables unnecessarily
let UnifyFunctionType extraInfo cenv denv mFunExpr ty =
match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr ty with
| Some res -> res
| None ->
match extraInfo with
| Some argm -> error (NotAFunction(denv,ty,mFunExpr,argm))
| None -> error (FunctionExpected(denv,ty,mFunExpr))
let ReportImplicitlyIgnoredBoolExpression denv m ty expr =
let checkExpr m exprOpt =
match exprOpt with
| Expr.App(Expr.Val(vf,_,_),_,_,exprs,_) when vf.LogicalName = opNameEquals ->
match exprs with
| Expr.App(Expr.Val(propRef,_,_),_,_,Expr.Val(vf,_,_) :: _,_) :: _ ->
if propRef.IsPropertyGetterMethod then
let propertyName = propRef.PropertyName
let hasCorrespondingSetter =
match propRef.ActualParent with
| Parent entityRef ->
entityRef.MembersOfFSharpTyconSorted
|> List.exists (fun valRef -> valRef.IsPropertySetterMethod && valRef.PropertyName = propertyName)
| _ -> false
if hasCorrespondingSetter then
UnitTypeExpectedWithPossiblePropertySetter (denv,ty,vf.DisplayName,propertyName,m)
else
UnitTypeExpectedWithEquality (denv,ty,m)
else
UnitTypeExpectedWithEquality (denv,ty,m)
| Expr.Op(TOp.ILCall(_,_,_,_,_,_,_,methodRef,_,_,_),_,Expr.Val(vf,_,_) :: _,_) :: _ when methodRef.Name.StartsWith "get_"->
UnitTypeExpectedWithPossiblePropertySetter (denv,ty,vf.DisplayName,PrettyNaming.ChopPropertyName(methodRef.Name),m)
| Expr.Val(vf,_,_) :: _ ->
UnitTypeExpectedWithPossibleAssignment (denv,ty,vf.IsMutable,vf.DisplayName,m)
| _ -> UnitTypeExpectedWithEquality (denv,ty,m)
| _ -> UnitTypeExpected (denv,ty,m)
match expr with
| Some(Expr.Let(_,Expr.Sequential(_,inner,_,_,_),_,_))
| Some(Expr.Sequential(_,inner,_,_,_)) ->
let rec extractNext expr =
match expr with
| Expr.Sequential(_,inner,_,_,_) -> extractNext inner
| _ -> checkExpr expr.Range expr
extractNext inner
| Some expr -> checkExpr m expr
| _ -> UnitTypeExpected (denv,ty,m)
let UnifyUnitType cenv denv m ty exprOpt =
if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty cenv.g.unit_ty then
true
else
let domainTy = NewInferenceType ()
let resultTy = NewInferenceType ()
if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then
warning (FunctionValueUnexpected(denv,ty,m))
else
if not (typeEquiv cenv.g cenv.g.bool_ty ty) then
warning (UnitTypeExpected (denv,ty,m))
else
warning (ReportImplicitlyIgnoredBoolExpression denv m ty exprOpt)
false
//-------------------------------------------------------------------------
// Attribute target flags
//-------------------------------------------------------------------------
// Logically extends System.AttributeTargets
module AttributeTargets =
let FieldDecl = AttributeTargets.Field ||| AttributeTargets.Property
let FieldDeclRestricted = AttributeTargets.Field
let UnionCaseDecl = AttributeTargets.Method ||| AttributeTargets.Property
let TyconDecl = AttributeTargets.Class ||| AttributeTargets.Interface ||| AttributeTargets.Delegate ||| AttributeTargets.Struct ||| AttributeTargets.Enum
let ExnDecl = AttributeTargets.Class
let ModuleDecl = AttributeTargets.Class
let Top = AttributeTargets.Assembly ||| AttributeTargets.Module ||| AttributeTargets.Method
let SettersOfPropInfos (pinfos:PropInfo list) = pinfos |> List.choose (fun pinfo -> if pinfo.HasSetter then Some(pinfo.SetterMethod,Some pinfo) else None)
let GettersOfPropInfos (pinfos:PropInfo list) = pinfos |> List.choose (fun pinfo -> if pinfo.HasGetter then Some(pinfo.GetterMethod,Some pinfo) else None)
// Specifies if overload resolution needs to notify Language Service of overload resolution result.
// In contrast with similar types in nameres, this type is in terms of infos instead of items.
// Convertors from Items to infos for methods and properties are provided.
[<RequireQualifiedAccess>]
type AfterTcOverloadResolution =
// Notification is not needed
| DoNothing
// Notify the tcSink
| SendToSink of ((MethInfo * PropInfo option) -> unit) * IfOverloadResolutionFails
// Find override among given overrides and notify the tcSink
// The list contains candidate overrides.
| ReplaceWithOverrideAndSendToSink of (MethInfo * PropInfo option) list * ((MethInfo * PropInfo option) -> unit) * IfOverloadResolutionFails
static member ForMethods afterOverloadResolution =
match afterOverloadResolution with
| AfterOverloadResolution.DoNothing ->
AfterTcOverloadResolution.DoNothing
| AfterOverloadResolution.SendToSink(callSink,fallback) ->
AfterTcOverloadResolution.SendToSink ((fun (minfo,_) -> Item.MethodGroup(minfo.LogicalName,[minfo],None) |> callSink), fallback)
| AfterOverloadResolution.ReplaceWithOverrideAndSendToSink (Item.MethodGroup(_,overridenMinfos,_orig), callSink,fallback) ->
AfterTcOverloadResolution.ReplaceWithOverrideAndSendToSink
((overridenMinfos |> List.map (fun minfo -> minfo,None)),(fun (minfo,_) -> Item.MethodGroup(minfo.LogicalName,[minfo],None) |> callSink),fallback)
| _ -> error(InternalError("Name resolution does not match overriden for method groups", range0))
static member ForProperties name gettersOrSetters afterOverloadResolution =
let sendPropertyToSink callSink =
fun (_,pinfoOpt) ->
match pinfoOpt with
| Some pinfo -> Item.Property(name,[pinfo]) |> callSink
| _ -> ()
match afterOverloadResolution with
| AfterOverloadResolution.DoNothing -> AfterTcOverloadResolution.DoNothing
| AfterOverloadResolution.SendToSink(callSink,fallback) -> AfterTcOverloadResolution.SendToSink(sendPropertyToSink callSink,fallback)
| AfterOverloadResolution.ReplaceWithOverrideAndSendToSink (Item.Property(_,pinfos),callSink,fallback) ->
AfterTcOverloadResolution.ReplaceWithOverrideAndSendToSink(gettersOrSetters pinfos, sendPropertyToSink callSink,fallback)
| AfterOverloadResolution.ReplaceWithOverrideAndSendToSink (_,_,_) ->
error(InternalError("Name resolution does not match overriden for properties",range0))
static member ForConstructors afterOverloadResolution =
match afterOverloadResolution with
| AfterOverloadResolution.DoNothing ->
AfterTcOverloadResolution.DoNothing
| AfterOverloadResolution.SendToSink(callSink,fallback) ->
AfterTcOverloadResolution.SendToSink ((fun (minfo,_) -> Item.CtorGroup(minfo.LogicalName,[minfo]) |> callSink), fallback)
| _ -> error(InternalError("Name resolution does not match overriden for constructor groups", range0))
static member ForNewConstructors tcSink (env:TcEnv) mObjTy methodName minfos =
let sendToSink refinedMinfos =
CallNameResolutionSink tcSink (mObjTy,env.NameEnv,Item.CtorGroup(methodName,refinedMinfos),Item.CtorGroup(methodName,minfos),ItemOccurence.Use,env.DisplayEnv,env.eAccessRights)
match minfos with
| [] -> AfterTcOverloadResolution.DoNothing
| [_] ->
sendToSink minfos
AfterTcOverloadResolution.DoNothing
| _ ->
AfterTcOverloadResolution.SendToSink ((fun (minfo,_) -> sendToSink [minfo]), (fun () -> sendToSink minfos) |> IfOverloadResolutionFails)
member this.OnOverloadResolutionFailure() =
match this with
| AfterTcOverloadResolution.DoNothing -> ()
| AfterTcOverloadResolution.SendToSink(_,IfOverloadResolutionFails f) -> f()
| AfterTcOverloadResolution.ReplaceWithOverrideAndSendToSink(_,_,IfOverloadResolutionFails f) -> f()
/// Typecheck rational constant terms in units-of-measure exponents
let rec TcSynRationalConst c =
match c with
| SynRationalConst.Integer i -> intToRational i
| SynRationalConst.Negate c' -> NegRational (TcSynRationalConst c')
| SynRationalConst.Rational(p,q,_) -> DivRational (intToRational p) (intToRational q)
/// Typecheck constant terms in expressions and patterns
let TcConst cenv ty m env c =
let rec tcMeasure ms =
match ms with
| SynMeasure.One -> Measure.One
| SynMeasure.Named(tc,m) ->
let ad = env.eAccessRights
let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Use OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No)
match tcref.TypeOrMeasureKind with
| TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m))
| TyparKind.Measure -> Measure.Con tcref
| SynMeasure.Power(ms, exponent, _) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent)
| SynMeasure.Product(ms1,ms2,_) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2)
| SynMeasure.Divide(ms1, ((SynMeasure.Seq (_::(_::_), _)) as ms2), m) ->
warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(),m))
Measure.Prod(tcMeasure ms1, Measure.Inv (tcMeasure ms2))
| SynMeasure.Divide(ms1,ms2,_) ->
Measure.Prod(tcMeasure ms1, Measure.Inv (tcMeasure ms2))
| SynMeasure.Seq(mss,_) -> ProdMeasures (List.map tcMeasure mss)
| SynMeasure.Anon _ -> error(Error(FSComp.SR.tcUnexpectedMeasureAnon(),m))
| SynMeasure.Var(_,m) -> error(Error(FSComp.SR.tcNonZeroConstantCannotHaveGenericUnit(),m))
let unif ty2 = UnifyTypes cenv env m ty ty2
let unif_measure_arg iszero tcr c =
let measureTy =
match c with
| SynConst.Measure(_, SynMeasure.Anon _) ->
(mkAppTy tcr [TType_measure (Measure.Var (NewAnonTypar (TyparKind.Measure,m,TyparRigidity.Anon,(if iszero then NoStaticReq else HeadTypeStaticReq),TyparDynamicReq.No)))])
| SynConst.Measure(_, ms) -> mkAppTy tcr [TType_measure (tcMeasure ms)]
| _ -> mkAppTy tcr [TType_measure Measure.One]
unif measureTy
match c with
| SynConst.Unit -> unif cenv.g.unit_ty; Const.Unit
| SynConst.Bool i -> unif cenv.g.bool_ty; Const.Bool i
| SynConst.SByte i -> unif cenv.g.sbyte_ty; Const.SByte i
| SynConst.Int16 i -> unif cenv.g.int16_ty; Const.Int16 i
| SynConst.Int32 i -> unif cenv.g.int_ty; Const.Int32 i
| SynConst.Int64 i -> unif cenv.g.int64_ty; Const.Int64 i
| SynConst.IntPtr i -> unif cenv.g.nativeint_ty; Const.IntPtr i
| SynConst.Byte i -> unif cenv.g.byte_ty; Const.Byte i
| SynConst.UInt16 i -> unif cenv.g.uint16_ty; Const.UInt16 i
| SynConst.UInt32 i -> unif cenv.g.uint32_ty; Const.UInt32 i
| SynConst.UInt64 i -> unif cenv.g.uint64_ty; Const.UInt64 i
| SynConst.UIntPtr i -> unif cenv.g.unativeint_ty; Const.UIntPtr i
| SynConst.Measure(SynConst.Single f, _) | SynConst.Single f -> unif_measure_arg (f=0.0f) cenv.g.pfloat32_tcr c; Const.Single f
| SynConst.Measure(SynConst.Double f, _) | SynConst.Double f -> unif_measure_arg (f=0.0) cenv.g.pfloat_tcr c; Const.Double f
| SynConst.Measure(SynConst.Decimal s, _) | SynConst.Decimal s -> unif_measure_arg false cenv.g.pdecimal_tcr c; Const.Decimal s
| SynConst.Measure(SynConst.SByte i, _) | SynConst.SByte i -> unif_measure_arg (i=0y) cenv.g.pint8_tcr c; Const.SByte i
| SynConst.Measure(SynConst.Int16 i, _) | SynConst.Int16 i -> unif_measure_arg (i=0s) cenv.g.pint16_tcr c; Const.Int16 i
| SynConst.Measure(SynConst.Int32 i, _) | SynConst.Int32 i -> unif_measure_arg (i=0) cenv.g.pint_tcr c; Const.Int32 i
| SynConst.Measure(SynConst.Int64 i, _) | SynConst.Int64 i -> unif_measure_arg (i=0L) cenv.g.pint64_tcr c; Const.Int64 i
| SynConst.Char c -> unif cenv.g.char_ty; Const.Char c
| SynConst.String (s,_) -> unif cenv.g.string_ty; Const.String s
| SynConst.UserNum _ -> error(InternalError(FSComp.SR.tcUnexpectedBigRationalConstant(), m))
| SynConst.Measure _ -> error(Error(FSComp.SR.tcInvalidTypeForUnitsOfMeasure(), m))
| SynConst.UInt16s _ -> error(InternalError(FSComp.SR.tcUnexpectedConstUint16Array(),m))
| SynConst.Bytes _ -> error(InternalError(FSComp.SR.tcUnexpectedConstByteArray(),m))
/// Convert an Abstract IL ILFieldInit value read from .NET metadata to a TAST constant
let TcFieldInit (_m:range) lit =
match lit with
| ILFieldInit.String s -> Const.String s
| ILFieldInit.Null -> Const.Zero
| ILFieldInit.Bool b -> Const.Bool b
| ILFieldInit.Char c -> Const.Char (char (int c))
| ILFieldInit.Int8 x -> Const.SByte x
| ILFieldInit.Int16 x -> Const.Int16 x
| ILFieldInit.Int32 x -> Const.Int32 x
| ILFieldInit.Int64 x -> Const.Int64 x
| ILFieldInit.UInt8 x -> Const.Byte x
| ILFieldInit.UInt16 x -> Const.UInt16 x
| ILFieldInit.UInt32 x -> Const.UInt32 x
| ILFieldInit.UInt64 x -> Const.UInt64 x
| ILFieldInit.Single f -> Const.Single f
| ILFieldInit.Double f -> Const.Double f
//-------------------------------------------------------------------------
// Arities. These serve two roles in the system:
// 1. syntactic arities come from the syntactic forms found
// signature files and the syntactic forms of function and member definitions.
// 2. compiled arities representing representation choices w.r.t. internal representations of
// functions and members.
//-------------------------------------------------------------------------
// Adjust the arities that came from the parsing of the toptyp (arities) to be a valSynData.
// This means replacing the "[unitArg]" arising from a "unit -> ty" with a "[]".
let AdjustValSynInfoInSignature g ty (SynValInfo(argsData,retData) as sigMD) =
if argsData.Length = 1 && argsData.Head.Length = 1 && isFunTy g ty && typeEquiv g g.unit_ty (domainOfFunTy g ty) then
SynValInfo(argsData.Head.Tail :: argsData.Tail, retData)
else
sigMD
/// The ValReprInfo for a value, except the number of typars is not yet inferred
type PartialValReprInfo = PartialValReprInfo of ArgReprInfo list list * ArgReprInfo
let TranslateTopArgSynInfo isArg m tcAttributes (SynArgInfo(attrs,isOpt,nm)) =
// Synthesize an artificial "OptionalArgument" attribute for the parameter
let optAttrs =
if isOpt then
[ ( { TypeName=LongIdentWithDots(pathToSynLid m ["Microsoft";"FSharp";"Core";"OptionalArgument"],[])
ArgExpr=mkSynUnit m
Target=None
AppliesToGetterAndSetter=false
Range=m} : SynAttribute) ]
else
[]
if isArg && not (isNil attrs) && Option.isNone nm then
errorR(Error(FSComp.SR.tcParameterRequiresName(),m))
if not isArg && Option.isSome nm then
errorR(Error(FSComp.SR.tcReturnValuesCannotHaveNames(),m))
// Call the attribute checking function
let attribs = tcAttributes (optAttrs@attrs)
({ Attribs = attribs; Name = nm } : ArgReprInfo)
/// Members have an arity inferred from their syntax. This "valSynData" is not quite the same as the arities
/// used in the middle and backends of the compiler ("topValInfo").
/// "0" in a valSynData (see Ast.arity_of_pat) means a "unit" arg in a topValInfo
/// Hence remove all "zeros" from arity and replace them with 1 here.
/// Note we currently use the compiled form for choosing unique names, to distinguish overloads because this must match up
/// between signature and implementation, and the signature just has "unit".
let TranslateTopValSynInfo m tcAttributes (SynValInfo(argsData,retData)) =
PartialValReprInfo (argsData |> List.mapSquared (TranslateTopArgSynInfo true m (tcAttributes AttributeTargets.Parameter)),
retData |> TranslateTopArgSynInfo false m (tcAttributes AttributeTargets.ReturnValue))
let TranslatePartialArity tps (PartialValReprInfo (argsData,retData)) =
ValReprInfo(ValReprInfo.InferTyparInfo tps,argsData,retData)
//-------------------------------------------------------------------------
// Members
//-------------------------------------------------------------------------
let ComputeLogicalName (id:Ident) memberFlags =
match memberFlags.MemberKind with
| MemberKind.ClassConstructor -> ".cctor"
| MemberKind.Constructor -> ".ctor"
| MemberKind.Member ->
match id.idText with
| (".ctor" | ".cctor") as r -> errorR(Error(FSComp.SR.tcInvalidMemberNameCtor(),id.idRange)); r
| r -> r
| MemberKind.PropertyGetSet -> error(InternalError(FSComp.SR.tcMemberKindPropertyGetSetNotExpected(),id.idRange))
| MemberKind.PropertyGet -> "get_" + id.idText
| MemberKind.PropertySet -> "set_" + id.idText
/// ValMemberInfoTransient(memberInfo,logicalName,compiledName)
type ValMemberInfoTransient = ValMemberInfoTransient of ValMemberInfo * string * string
/// Make the unique "name" for a member.
//
// optImplSlotTy = None (for classes) or Some ty (when implementing interface type ty)
let MakeMemberDataAndMangledNameForMemberVal(g,tcref,isExtrinsic,attrs,optImplSlotTys,memberFlags,valSynData,id,isCompGen) =
let logicalName = ComputeLogicalName id memberFlags
let optIntfSlotTys = if optImplSlotTys |> List.forall (isInterfaceTy g) then optImplSlotTys else []
let memberInfo : ValMemberInfo =
{ ApparentParent=tcref
MemberFlags=memberFlags
IsImplemented=false
// NOTE: This value is initially only set for interface implementations and those overrides
// where we manage to pre-infer which abstract is overriden by the method. It is filled in
// properly when we check the allImplemented implementation checks at the end of the inference scope.
ImplementedSlotSigs=optImplSlotTys |> List.map (fun ity -> TSlotSig(logicalName,ity,[],[],[],None)) }
let isInstance = MemberIsCompiledAsInstance g tcref isExtrinsic memberInfo attrs
if (memberFlags.IsDispatchSlot || not (isNil optIntfSlotTys)) then
if not isInstance then
errorR(VirtualAugmentationOnNullValuedType(id.idRange))
elif not memberFlags.IsOverrideOrExplicitImpl && memberFlags.IsInstance then
if not isExtrinsic && not isInstance then
warning(NonVirtualAugmentationOnNullValuedType(id.idRange))
let compiledName =
if isExtrinsic then
let tname = tcref.LogicalName
let text = tname + "." + logicalName
let text = if memberFlags.MemberKind <> MemberKind.Constructor && memberFlags.MemberKind <> MemberKind.ClassConstructor && not memberFlags.IsInstance then text^".Static" else text
let text = if memberFlags.IsOverrideOrExplicitImpl then text^".Override" else text
text
else
List.foldBack (tcrefOfAppTy g >> qualifiedMangledNameOfTyconRef) optIntfSlotTys logicalName
if not isCompGen && IsMangledOpName id.idText && IsInfixOperator id.idText then
let m = id.idRange
let name = DecompileOpName id.idText
// Check symbolic members. Expect valSynData implied arity to be [[2]].
match SynInfo.AritiesOfArgs valSynData with
| [] | [0] -> warning(Error(FSComp.SR.memberOperatorDefinitionWithNoArguments(name),m))
| n :: otherArgs ->
let opTakesThreeArgs = PrettyNaming.IsTernaryOperator name
if n<>2 && not opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonPairArgument(name,n),m))
if n<>3 && opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonTripleArgument(name,n),m))
if not (isNil otherArgs) then warning(Error(FSComp.SR.memberOperatorDefinitionWithCurriedArguments(name),m))
if IsMangledOpName id.idText && isExtrinsic then
warning(Error(FSComp.SR.tcMemberOperatorDefinitionInExtrinsic(),id.idRange))
ValMemberInfoTransient(memberInfo,logicalName,compiledName)
type OverridesOK =
| OverridesOK
| WarnOnOverrides
| ErrorOnOverrides
/// A type to represent information associated with values to indicate what explicit (declared) type parameters
/// are given and what additional type parameters can be inferred, if any.
///
/// The declared type parameters, e.g. let f<'a> (x:'a) = x, plus an indication
/// of whether additional polymorphism may be inferred, e.g. let f<'a,..> (x:'a) y = x
type ExplicitTyparInfo = ExplicitTyparInfo of Tast.Typars * Tast.Typars * bool
let permitInferTypars = ExplicitTyparInfo ([], [], true)
let dontInferTypars = ExplicitTyparInfo ([], [], false)
type ArgAndRetAttribs = ArgAndRetAttribs of Tast.Attribs list list * Tast.Attribs
let noArgOrRetAttribs = ArgAndRetAttribs ([],[])
/// A flag to represent the sort of bindings are we processing.
/// Processing "declaration" and "class" bindings that make up a module (such as "let x = 1 let y = 2")
/// shares the same code paths (e.g. TcLetBinding and TcLetrec) as processing expression bindings (such as "let x = 1 in ...")
/// Member bindings also use this path.
//
/// However there are differences in how different bindings get processed,
/// i.e. module bindings get published to the implicitly accumulated module type, but expression 'let' bindings don't.
type DeclKind =
| ModuleOrMemberBinding
/// Extensions to a type within the same assembly
| IntrinsicExtensionBinding
/// Extensions to a type in a different assembly
| ExtrinsicExtensionBinding
| ClassLetBinding of (* isStatic *) bool
| ObjectExpressionOverrideBinding
| ExpressionBinding
static member IsModuleOrMemberOrExtensionBinding x =
match x with
| ModuleOrMemberBinding -> true
| IntrinsicExtensionBinding -> true
| ExtrinsicExtensionBinding -> true
| ClassLetBinding _ -> false
| ObjectExpressionOverrideBinding -> false
| ExpressionBinding -> false
static member MustHaveArity x = DeclKind.IsModuleOrMemberOrExtensionBinding x
member x.CanBeDllImport =
match x with
| ModuleOrMemberBinding -> true
| IntrinsicExtensionBinding -> true
| ExtrinsicExtensionBinding -> true
| ClassLetBinding _ -> true
| ObjectExpressionOverrideBinding -> false
| ExpressionBinding -> false
static member IsAccessModifierPermitted x = DeclKind.IsModuleOrMemberOrExtensionBinding x
static member ImplicitlyStatic x = DeclKind.IsModuleOrMemberOrExtensionBinding x
static member AllowedAttribTargets memberFlagsOpt x =
match x with
| ModuleOrMemberBinding | ObjectExpressionOverrideBinding ->
match memberFlagsOpt with
| Some flags when flags.MemberKind = MemberKind.Constructor -> AttributeTargets.Constructor
| Some flags when flags.MemberKind = MemberKind.PropertyGetSet -> AttributeTargets.Event ||| AttributeTargets.Property
| Some flags when flags.MemberKind = MemberKind.PropertyGet -> AttributeTargets.Event ||| AttributeTargets.Property
| Some flags when flags.MemberKind = MemberKind.PropertySet -> AttributeTargets.Property
| Some _ -> AttributeTargets.Method
| None -> AttributeTargets.Field ||| AttributeTargets.Method ||| AttributeTargets.Property
| IntrinsicExtensionBinding -> AttributeTargets.Method ||| AttributeTargets.Property
| ExtrinsicExtensionBinding -> AttributeTargets.Method ||| AttributeTargets.Property
| ClassLetBinding _ -> AttributeTargets.Field ||| AttributeTargets.Method
| ExpressionBinding -> enum 0 // indicates attributes not allowed on expression 'let' bindings
// Note: now always true
static member CanGeneralizeConstrainedTypars x =
match x with
| ModuleOrMemberBinding -> true
| IntrinsicExtensionBinding -> true
| ExtrinsicExtensionBinding -> true
| ClassLetBinding _ -> true
| ObjectExpressionOverrideBinding -> true
| ExpressionBinding -> true
static member ConvertToLinearBindings x =
match x with
| ModuleOrMemberBinding -> true
| IntrinsicExtensionBinding -> true
| ExtrinsicExtensionBinding -> true
| ClassLetBinding _ -> true
| ObjectExpressionOverrideBinding -> true
| ExpressionBinding -> false
static member CanOverrideOrImplement x =
match x with
| ModuleOrMemberBinding -> OverridesOK
| IntrinsicExtensionBinding -> WarnOnOverrides
| ExtrinsicExtensionBinding -> ErrorOnOverrides
| ClassLetBinding _ -> ErrorOnOverrides
| ObjectExpressionOverrideBinding -> OverridesOK
| ExpressionBinding -> ErrorOnOverrides
//-------------------------------------------------------------------------
// Data structures that track the gradual accumualtion of information
// about values and members during inference.
//-------------------------------------------------------------------------
/// The results of preliminary pass over patterns to extract variables being declared.
type PrelimValScheme1 =
| PrelimValScheme1 of
Ident *
ExplicitTyparInfo *
TType *
PartialValReprInfo option *
ValMemberInfoTransient option *
bool *
ValInline *
ValBaseOrThisInfo *
ArgAndRetAttribs *
SynAccess option *
bool
member x.Type = let (PrelimValScheme1(_,_,ty,_,_,_,_,_,_,_,_)) = x in ty
member x.Ident = let (PrelimValScheme1(id,_,_,_,_,_,_,_,_,_,_)) = x in id
/// The results of applying let-style generalization after type checking.
type PrelimValScheme2 =
PrelimValScheme2 of
Ident *
TypeScheme *
PartialValReprInfo option *
ValMemberInfoTransient option *
bool *
ValInline *
ValBaseOrThisInfo *
ArgAndRetAttribs *
SynAccess option *
bool *
bool (* hasDeclaredTypars *)
/// The results of applying arity inference to PrelimValScheme2
type ValScheme =
| ValScheme of
Ident *
TypeScheme *
ValReprInfo option *
ValMemberInfoTransient option *
bool * // isMutable
ValInline *
ValBaseOrThisInfo *
SynAccess option *
bool * // compgen *
bool * // isIncrClass
bool * // isTyFunc
bool // hasDeclaredTypars
member x.GeneralizedTypars = let (ValScheme(_,TypeScheme(gtps,_),_,_,_,_,_,_,_,_,_,_)) = x in gtps
member x.TypeScheme = let (ValScheme(_,ts,_,_,_,_,_,_,_,_,_,_)) = x in ts
//-------------------------------------------------------------------------
// Data structures that track the whole process of taking a syntactic binding and
// checking it.
//-------------------------------------------------------------------------
/// Translation of patterns is List.unzip into three phases. The first collects names.
/// The second is run after val_specs have been created for those names and inference
/// has been resolved. The second phase is run by applying a function returned by the
/// first phase. The input to the second phase is a List.map that gives the Val and type scheme
/// for each value bound by the pattern.
type TcPatPhase2Input =
| TcPatPhase2Input of (Val * TypeScheme) NameMap * bool
// Get an input indicating we are no longer on the left-most path through a disjunctive "or" pattern
member x.RightPath = (let (TcPatPhase2Input(a,_)) = x in TcPatPhase2Input(a,false))
/// The first phase of checking and elaborating a binding leaves a whole goop of information.
/// This is a bit of a mess: much of this information is carried on a per-value basis by the
/// "NameMap<PrelimValScheme1>".
type CheckedBindingInfo =
| CheckedBindingInfo of
ValInline *
Tast.Attribs *
XmlDoc *
(TcPatPhase2Input -> PatternMatchCompilation.Pattern) *
ExplicitTyparInfo *
NameMap<PrelimValScheme1> *
Expr *
ArgAndRetAttribs *
TType *
range *
SequencePointInfoForBinding *
bool * // compiler generated?
Const option * // literal value?
bool // fixed?
member x.Expr = let (CheckedBindingInfo(_,_,_,_,_,_,expr,_,_,_,_,_,_,_)) = x in expr
member x.SeqPoint = let (CheckedBindingInfo(_,_,_,_,_,_,_,_,_,_,spBind,_,_,_)) = x in spBind
//-------------------------------------------------------------------------
// Helpers related to type schemes
//-------------------------------------------------------------------------
let GeneralizedTypeForTypeScheme typeScheme =
let (TypeScheme(generalizedTypars,tau)) = typeScheme
tryMkForallTy generalizedTypars tau
let NonGenericTypeScheme ty = TypeScheme([],ty)
//-------------------------------------------------------------------------
// Helpers related to publishing values, types and members into the
// elaborated representation.
//-------------------------------------------------------------------------
let UpdateAccModuleOrNamespaceType cenv env f =
// When compiling FSharp.Core, modify the fslib CCU to ensure forward stable references used by
// the compiler can be resolved ASAP. Not at all pretty but it's hard to
// find good ways to do references from the compiler into a term graph.
if cenv.compilingCanonicalFslibModuleType then
let nleref = mkNonLocalEntityRef cenv.topCcu (arrPathOfLid env.ePath)
let modul = nleref.Deref
modul.entity_modul_contents <- MaybeLazy.Strict (f true modul.ModuleOrNamespaceType)
SetCurrAccumulatedModuleOrNamespaceType env (f false (GetCurrAccumulatedModuleOrNamespaceType env))
let PublishModuleDefn cenv env mspec =
UpdateAccModuleOrNamespaceType cenv env (fun intoFslibCcu mty ->
if intoFslibCcu then mty
else mty.AddEntity mspec)
let item = Item.ModuleOrNamespaces([mkLocalModRef mspec])
CallNameResolutionSink cenv.tcSink (mspec.Range,env.NameEnv,item,item,ItemOccurence.Binding,env.DisplayEnv,env.eAccessRights)
let PublishTypeDefn cenv env tycon =
UpdateAccModuleOrNamespaceType cenv env (fun _ mty ->
mty.AddEntity tycon)
let PublishValueDefnPrim cenv env (vspec:Val) =
UpdateAccModuleOrNamespaceType cenv env (fun _ mty ->
mty.AddVal vspec)
let PublishValueDefn cenv env declKind (vspec:Val) =
if (declKind = ModuleOrMemberBinding) &&
((GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind = Namespace) &&
(Option.isNone vspec.MemberInfo) then
errorR(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),vspec.Range))
if (declKind = ExtrinsicExtensionBinding) &&
((GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind = Namespace) then
errorR(Error(FSComp.SR.tcNamespaceCannotContainExtensionMembers(),vspec.Range))
// Publish the value to the module type being generated.
match declKind with
| ModuleOrMemberBinding
| ExtrinsicExtensionBinding
| IntrinsicExtensionBinding -> PublishValueDefnPrim cenv env vspec
| _ -> ()
match vspec.MemberInfo with
| Some _ when
(not vspec.IsCompilerGenerated &&
// Extrinsic extensions don't get added to the tcaug
not (declKind = ExtrinsicExtensionBinding)) ->
// // Static initializers don't get published to the tcaug
// not (memberInfo.MemberFlags.MemberKind = MemberKind.ClassConstructor)) ->
let tcaug = vspec.MemberApparentParent.TypeContents
let vref = mkLocalValRef vspec
tcaug.tcaug_adhoc <- NameMultiMap.add vspec.LogicalName vref tcaug.tcaug_adhoc
tcaug.tcaug_adhoc_list.Add (ValRefIsExplicitImpl cenv.g vref, vref)
| _ -> ()
let CombineVisibilityAttribs vis1 vis2 m =
match vis1 with
| Some _ ->
if Option.isSome vis2 then
errorR(Error(FSComp.SR.tcMultipleVisibilityAttributes(),m))
vis1
| _ -> vis2
let ComputeAccessAndCompPath env declKindOpt m vis overrideVis actualParent =
let accessPath = env.eAccessPath
let accessModPermitted =
match declKindOpt with
| None -> true
| Some declKind -> DeclKind.IsAccessModifierPermitted declKind
if Option.isSome vis && not accessModPermitted then
errorR(Error(FSComp.SR.tcMultipleVisibilityAttributesWithLet(),m))
let vis =
match overrideVis, vis with
| Some v,_ -> v
| _, None -> taccessPublic (* a module or member binding defaults to "public" *)
| _, Some SynAccess.Public -> taccessPublic
| _, Some SynAccess.Private -> taccessPrivate accessPath
| _, Some SynAccess.Internal -> taccessInternal
let vis =
match actualParent with
| ParentNone -> vis
| Parent tcref -> combineAccess vis tcref.Accessibility
let cpath = if accessModPermitted then Some env.eCompPath else None
vis,cpath
let CheckForAbnormalOperatorNames cenv (idRange:range) opName isMember =
if (idRange.EndColumn - idRange.StartColumn <= 5) &&
not cenv.g.compilingFslib
then
match opName with
| PrettyNaming.Relational ->
if isMember then
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForRelationalOperator(opName, (CompileOpName opName)),idRange))
else
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionRelational(opName),idRange))
| PrettyNaming.Equality ->
if isMember then
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForEquality(opName, (CompileOpName opName)),idRange))
else
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionEquality(opName),idRange))
| PrettyNaming.Control ->
if isMember then
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberName(opName, (CompileOpName opName)),idRange))
else
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinition(opName),idRange))
| PrettyNaming.Indexer ->
if not isMember then
error(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidIndexOperatorDefinition(opName),idRange))
| PrettyNaming.FixedTypes ->
if isMember then
warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes(opName),idRange))
| PrettyNaming.Other -> ()
let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(id,typeScheme,topValData,memberInfoOpt,isMutable,inlineFlag,baseOrThis,vis,compgen,isIncrClass,isTyFunc,hasDeclaredTypars)),attrs,doc,konst,isGeneratedEventVal) =
let ty = GeneralizedTypeForTypeScheme typeScheme
let m = id.idRange
let isTopBinding =
match declKind with
| ModuleOrMemberBinding -> true
| ExtrinsicExtensionBinding -> true
| IntrinsicExtensionBinding -> true
| _ -> false
let isExtrinsic = (declKind = ExtrinsicExtensionBinding)
let actualParent, overrideVis =
// Use the parent of the member if it's available
// If it's an extrinsic extension member or not a member then use the containing module.
match memberInfoOpt with
| Some (ValMemberInfoTransient(memberInfo,_,_)) when not isExtrinsic ->
if memberInfo.ApparentParent.IsModuleOrNamespace then
errorR(InternalError(FSComp.SR.tcExpectModuleOrNamespaceParent(id.idText),m))
// Members of interface implementations have the accessibility of the interface
// they are implementing.
let vis =
if Tastops.MemberIsExplicitImpl cenv.g memberInfo then
let slotSig = List.head memberInfo.ImplementedSlotSigs
match slotSig.ImplementedType with
| TType_app (tyconref,_) -> Some tyconref.Accessibility
| _ -> None
else
None
Parent(memberInfo.ApparentParent), vis
| _ -> altActualParent, None
let vis,_ = ComputeAccessAndCompPath env (Some declKind) id.idRange vis overrideVis actualParent
let inlineFlag =
if HasFSharpAttributeOpt cenv.g cenv.g.attrib_DllImportAttribute attrs then
if inlineFlag = ValInline.PseudoVal || inlineFlag = ValInline.Always then
errorR(Error(FSComp.SR.tcDllImportStubsCannotBeInlined(),m))
ValInline.Never
else
let implflags =
match TryFindFSharpAttribute cenv.g cenv.g.attrib_MethodImplAttribute attrs with
| Some (Attrib(_,_,[ AttribInt32Arg flags ],_,_,_,_)) -> flags
| _ -> 0x0
// MethodImplOptions.NoInlining = 0x8
let NO_INLINING = 0x8
if (implflags &&& NO_INLINING) <> 0x0 then
ValInline.Never
else
inlineFlag
// CompiledName not allowed on virtual/abstract/override members
let compiledNameAttrib = TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs
if Option.isSome compiledNameAttrib then
match memberInfoOpt with
| Some (ValMemberInfoTransient(memberInfo,_,_)) ->
if memberInfo.MemberFlags.IsDispatchSlot || memberInfo.MemberFlags.IsOverrideOrExplicitImpl then
errorR(Error(FSComp.SR.tcCompiledNameAttributeMisused(),m))
| None ->
match altActualParent with
| ParentNone -> errorR(Error(FSComp.SR.tcCompiledNameAttributeMisused(),m))
| _ -> ()
let compiledNameIsOnProp =
match memberInfoOpt with
| Some (ValMemberInfoTransient(memberInfo,_,_)) ->
memberInfo.MemberFlags.MemberKind = MemberKind.PropertyGet ||
memberInfo.MemberFlags.MemberKind = MemberKind.PropertySet ||
memberInfo.MemberFlags.MemberKind = MemberKind.PropertyGetSet
| _ -> false
let compiledName =
match compiledNameAttrib with
// We fix up CompiledName on properties during codegen
| Some _ when not compiledNameIsOnProp -> compiledNameAttrib
| _ ->
match memberInfoOpt with
| Some (ValMemberInfoTransient(_,_,compiledName)) ->
Some compiledName
| None ->
None
let logicalName =
match memberInfoOpt with
| Some (ValMemberInfoTransient(_,logicalName,_)) ->
logicalName
| None ->
id.idText
let memberInfoOpt =
match memberInfoOpt with
| Some (ValMemberInfoTransient(memberInfo,_,_)) ->
Some memberInfo
| None ->
None
let vspec =
NewVal (logicalName,id.idRange,compiledName,ty,
(if ((* (isByrefTy cenv.g ty) || *) isMutable) then Mutable else Immutable),
compgen,topValData,vis,vrec,memberInfoOpt,baseOrThis,attrs,inlineFlag,doc,isTopBinding,isExtrinsic,isIncrClass,isTyFunc,
(hasDeclaredTypars || inSig),isGeneratedEventVal,konst,actualParent)
CheckForAbnormalOperatorNames cenv id.idRange (DecompileOpName vspec.CoreDisplayName) (Option.isSome memberInfoOpt)
PublishValueDefn cenv env declKind vspec
match cenv.tcSink.CurrentSink with
| None -> ()
| Some _ ->
if not vspec.IsCompilerGenerated && not (String.hasPrefix vspec.LogicalName "_") then
let nenv = AddFakeNamedValRefToNameEnv vspec.DisplayName env.NameEnv (mkLocalValRef vspec)
CallEnvSink cenv.tcSink (vspec.Range,nenv,env.eAccessRights)
let item = Item.Value(mkLocalValRef vspec)
CallNameResolutionSink cenv.tcSink (vspec.Range,nenv,item,item,ItemOccurence.Binding,env.DisplayEnv,env.eAccessRights)
vspec
let MakeAndPublishVals cenv env (altActualParent,inSig,declKind,vrec,valSchemes,attrs,doc,konst) =
Map.foldBack
(fun name (valscheme:ValScheme) values ->
Map.add name (MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,valscheme,attrs,doc,konst,false), valscheme.TypeScheme) values)
valSchemes
Map.empty
let MakeAndPublishBaseVal cenv env baseIdOpt ty =
baseIdOpt
|> Option.map (fun (id:Ident) ->
let valscheme = ValScheme(id,NonGenericTypeScheme(ty),None,None,false,ValInline.Never,BaseVal,None,false,false,false,false)
MakeAndPublishVal cenv env (ParentNone,false,ExpressionBinding,ValNotInRecScope,valscheme,[],XmlDoc.Empty,None,false))
let InstanceMembersNeedSafeInitCheck cenv m thisTy =
ExistsInEntireHierarchyOfType
(fun ty -> not (isStructTy cenv.g ty) && (match tryDestAppTy cenv.g ty with Some tcref when tcref.HasSelfReferentialConstructor -> true | _ -> false))
cenv.g
cenv.amap
m
AllowMultiIntfInstantiations.Yes
thisTy
let MakeSafeInitField (g: TcGlobals) env m isStatic =
let id = ident(globalNng.FreshCompilerGeneratedName("init",m),m)
let taccess = TAccess [env.eAccessPath]
NewRecdField isStatic None id g.int_ty true true [] [] XmlDoc.Empty taccess true
// Make the "delayed reference" boolean value recording the safe initialization of a type in a hierarchy where there is a HasSelfReferentialConstructor
let ComputeInstanceSafeInitInfo cenv env m thisTy =
if InstanceMembersNeedSafeInitCheck cenv m thisTy then
let rfield = MakeSafeInitField cenv.g env m false
let tcref = tcrefOfAppTy cenv.g thisTy
SafeInitField (mkRecdFieldRef tcref rfield.Name, rfield)
else
NoSafeInitInfo
// Make the "delayed reference" value where the this pointer will reside after calling the base class constructor
// Make the value for the 'this' pointer for use within a constructor
let MakeAndPublishSafeThisVal cenv env (thisIdOpt: Ident option) thisTy =
match thisIdOpt with
| Some thisId ->
// for structs, thisTy is a byref
if not (isFSharpObjModelTy cenv.g thisTy) then
errorR(Error(FSComp.SR.tcStructsCanOnlyBindThisAtMemberDeclaration(),thisId.idRange))
let valScheme = ValScheme(thisId,NonGenericTypeScheme(mkRefCellTy cenv.g thisTy),None,None,false,ValInline.Never,CtorThisVal,None,false,false,false,false)
Some(MakeAndPublishVal cenv env (ParentNone, false, ExpressionBinding, ValNotInRecScope, valScheme, [], XmlDoc.Empty, None, false))
| None ->
None
//-------------------------------------------------------------------------
// Helpers for type inference for recursive bindings
//-------------------------------------------------------------------------
/// Fixup the type instantiation at recursive references. Used after the bindings have been
/// checked. The fixups are applied by using mutation.
let AdjustAndForgetUsesOfRecValue cenv (vrefTgt: ValRef) (valScheme : ValScheme) =
let (TypeScheme(generalizedTypars,_)) = valScheme.TypeScheme
let fty = GeneralizedTypeForTypeScheme valScheme.TypeScheme
let lvrefTgt = vrefTgt.Deref
if not (isNil generalizedTypars) then
// Find all the uses of this recursive binding and use mutation to adjust the expressions
// at those points in order to record the inferred type parameters.
let recUses = cenv.recUses.Find lvrefTgt
recUses
|> List.iter (fun (fixupPoint,m,isComplete) ->
if not isComplete then
// Keep any values for explicit type arguments
let fixedUpExpr =
let vrefFlags,tyargs0 =
match !fixupPoint with
| Expr.App(Expr.Val (_,vrefFlags,_),_,tyargs0,[],_) -> vrefFlags,tyargs0
| Expr.Val(_,vrefFlags,_) -> vrefFlags,[]
| _ ->
errorR(Error(FSComp.SR.tcUnexpectedExprAtRecInfPoint(),m))
NormalValUse,[]
let ityargs = generalizeTypars (List.drop (List.length tyargs0) generalizedTypars)
primMkApp (Expr.Val (vrefTgt,vrefFlags,m),fty) (tyargs0 @ ityargs) [] m
fixupPoint := fixedUpExpr)
vrefTgt.Deref.SetValRec ValNotInRecScope
cenv.recUses <- cenv.recUses.Remove vrefTgt.Deref
/// Set the properties of recursive values that are only fully known after inference is complete
let AdjustRecType _cenv (vspec:Val) (ValScheme(_,typeScheme,topValData,_,_,_,_,_,_,_,_,_)) =
let fty = GeneralizedTypeForTypeScheme typeScheme
vspec.SetType fty
vspec.SetValReprInfo topValData
vspec.SetValRec (ValInRecScope true)
/// Record the generated value expression as a place where we will have to
/// adjust using AdjustAndForgetUsesOfRecValue at a letrec point. Every use of a value
/// under a letrec gets used at the _same_ type instantiation.
let RecordUseOfRecValue cenv vrec (vrefTgt: ValRef) vexp m =
match vrec with
| ValInRecScope isComplete ->
let fixupPoint = ref vexp
cenv.recUses <- cenv.recUses.Add (vrefTgt.Deref, (fixupPoint,m,isComplete))
Expr.Link (fixupPoint)
| ValNotInRecScope ->
vexp
type RecursiveUseFixupPoints = RecursiveUseFixupPoints of (Expr ref * range) list
/// Get all recursive references, for fixing up delayed recursion using laziness
let GetAllUsesOfRecValue cenv vrefTgt =
RecursiveUseFixupPoints (cenv.recUses.Find vrefTgt |> List.map (fun (fixupPoint,m,_) -> (fixupPoint,m)))
//-------------------------------------------------------------------------
// Helpers for Generalization
//-------------------------------------------------------------------------
let ChooseCanonicalDeclaredTyparsAfterInference g denv declaredTypars m =
declaredTypars |> List.iter (fun tp ->
let ty = mkTyparTy tp
if not (isAnyParTy g ty) then
error(Error(FSComp.SR.tcLessGenericBecauseOfAnnotation(tp.Name,NicePrint.prettyStringOfTy denv ty),tp.Range)))
let declaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference g declaredTypars
if (ListSet.setify typarEq declaredTypars).Length <> declaredTypars.Length then
errorR(Error(FSComp.SR.tcConstrainedTypeVariableCannotBeGeneralized(),m))
declaredTypars
let ChooseCanonicalValSchemeAfterInference g denv valscheme m =
let (ValScheme(id,typeScheme,arityInfo,memberInfoOpt,isMutable,inlineFlag,baseOrThis,vis,compgen,isIncrClass,isTyFunc,hasDeclaredTypars)) = valscheme
let (TypeScheme(generalizedTypars,ty)) = typeScheme
let generalizedTypars = ChooseCanonicalDeclaredTyparsAfterInference g denv generalizedTypars m
let typeScheme = TypeScheme(generalizedTypars,ty)
let valscheme = ValScheme(id,typeScheme,arityInfo,memberInfoOpt,isMutable,inlineFlag,baseOrThis,vis,compgen,isIncrClass,isTyFunc,hasDeclaredTypars)
valscheme
let PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars =
declaredTypars @ (generalizedTypars |> List.filter (fun tp -> not (ListSet.contains typarEq tp declaredTypars)))
let SetTyparRigid _g denv m (tp:Typar) =
match tp.Solution with
| None -> ()
| Some ty ->
if tp.IsCompilerGenerated then
errorR(Error(FSComp.SR.tcGenericParameterHasBeenConstrained(NicePrint.prettyStringOfTy denv ty),m))
else
errorR(Error(FSComp.SR.tcTypeParameterHasBeenConstrained(NicePrint.prettyStringOfTy denv ty),tp.Range))
tp.SetRigidity TyparRigidity.Rigid
let GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTyparsForThisBinding
(PrelimValScheme1(id,iflex,ty,partialValReprInfo,memberInfoOpt,isMutable,inlineFlag,baseOrThis,argAttribs,vis,compgen)) =
let (ExplicitTyparInfo(_rigidCopyOfDeclaredTypars,declaredTypars,_)) = iflex
let m = id.idRange
let allDeclaredTypars = enclosingDeclaredTypars@declaredTypars
let allDeclaredTypars = ChooseCanonicalDeclaredTyparsAfterInference cenv.g denv allDeclaredTypars m
// Trim out anything not in type of the value (as opposed to the type of the r.h.s)
// This is important when a single declaration binds
// multiple generic items, where each item does not use all the polymorphism
// of the r.h.s. , e.g. let x,y = None,[]
let computeRelevantTypars thruFlag =
let ftps = freeInTypeLeftToRight cenv.g thruFlag ty
let generalizedTypars = generalizedTyparsForThisBinding |> List.filter (fun tp -> ListSet.contains typarEq tp ftps)
// Put declared typars first
let generalizedTypars = PlaceTyparsInDeclarationOrder allDeclaredTypars generalizedTypars
generalizedTypars
let generalizedTypars = computeRelevantTypars false
// Check stability of existence and ordering of type parameters under erasure of type abbreviations
let generalizedTyparsLookingThroughTypeAbbreviations = computeRelevantTypars true
if not (generalizedTypars.Length = generalizedTyparsLookingThroughTypeAbbreviations.Length &&
List.forall2 typarEq generalizedTypars generalizedTyparsLookingThroughTypeAbbreviations)
then
warning(Error(FSComp.SR.tcTypeParametersInferredAreNotStable(),m))
let hasDeclaredTypars = not (isNil declaredTypars)
// This is just about the only place we form a TypeScheme
let tyScheme = TypeScheme(generalizedTypars, ty)
PrelimValScheme2(id,tyScheme,partialValReprInfo,memberInfoOpt,isMutable,inlineFlag,baseOrThis,argAttribs,vis,compgen,hasDeclaredTypars)
let GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars types =
NameMap.map (GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars) types
let DontGeneralizeVals types =
let dontGeneralizeVal (PrelimValScheme1(id,_,ty,partialValReprInfoOpt,memberInfoOpt,isMutable,inlineFlag,baseOrThis,argAttribs,vis,compgen)) =
PrelimValScheme2(id, NonGenericTypeScheme(ty), partialValReprInfoOpt,memberInfoOpt,isMutable,inlineFlag,baseOrThis,argAttribs,vis,compgen,false)
NameMap.map dontGeneralizeVal types
let InferGenericArityFromTyScheme (TypeScheme(generalizedTypars,_)) partialValReprInfo =
TranslatePartialArity generalizedTypars partialValReprInfo
let ComputeIsTyFunc(id:Ident,hasDeclaredTypars,arityInfo:ValReprInfo option) =
hasDeclaredTypars &&
(match arityInfo with
| None -> error(Error(FSComp.SR.tcExplicitTypeParameterInvalid(),id.idRange))
| Some info -> info.NumCurriedArgs = 0)
let UseSyntacticArity declKind typeScheme partialValReprInfo =
if DeclKind.MustHaveArity declKind then
Some(InferGenericArityFromTyScheme typeScheme partialValReprInfo)
else
None
/// Combine the results of InferSynValData and InferArityOfExpr.
//
// The F# spec says that we infer arities from declaration forms and types.
//
// For example
// let f (a,b) c = 1 // gets arity [2;1]
// let f (a:int*int) = 1 // gets arity [2], based on type
// let f () = 1 // gets arity [0]
// let f = (fun (x:int) (y:int) -> 1) // gets arity [1;1]
// let f = (fun (x:int*int) y -> 1) // gets arity [2;1]
//
// Some of this arity inference is purely syntax directed and done in InferSynValData in ast.fs
// Some is done by InferArityOfExpr.
//
// However, there are some corner cases in this specification. In particular, consider
// let f () () = 1 // [0;1] or [0;0]? Answer: [0;1]
// let f (a:unit) = 1 // [0] or [1]? Answer: [1]
// let f = (fun () -> 1) // [0] or [1]? Answer: [0]
// let f = (fun (a:unit) -> 1) // [0] or [1]? Answer: [1]
//
// The particular choice of [1] for
// let f (a:unit) = 1
// is intended to give a disambiguating form for members that override methods taking a single argument
// instantiated to type "unit", e.g.
// type Base<'a> =
// abstract M : 'a -> unit
//
// { new Base<int> with
// member x.M(v:int) = () }
//
// { new Base<unit> with
// member x.M(v:unit) = () }
//
let CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme =
let (PrelimValScheme2(_,typeScheme,partialValReprInfoOpt,memberInfoOpt,isMutable,_,_,ArgAndRetAttribs(argAttribs,retAttribs),_,_,_)) = prelimScheme
match partialValReprInfoOpt, DeclKind.MustHaveArity declKind with
| _ ,false -> None
| None ,true -> Some(PartialValReprInfo([],ValReprInfo.unnamedRetVal))
// Don't use any expression information for members, where syntax dictates the arity completely
| _ when memberInfoOpt.IsSome ->
partialValReprInfoOpt
| Some(partialValReprInfoFromSyntax),true ->
let (PartialValReprInfo(curriedArgInfosFromSyntax,retInfoFromSyntax)) = partialValReprInfoFromSyntax
let partialArityInfo =
if isMutable then
PartialValReprInfo ([],retInfoFromSyntax)
else
let (ValReprInfo (_,curriedArgInfosFromExpression,_)) =
InferArityOfExpr g (GeneralizedTypeForTypeScheme typeScheme) argAttribs retAttribs rhsExpr
// Choose between the syntactic arity and the expression-inferred arity
// If the syntax specifies an eliminated unit arg, then use that
let choose ai1 ai2 =
match ai1,ai2 with
| [],_ -> []
// Dont infer eliminated unit args from the expression if they don't occur syntactically.
| ai,[] -> ai
// If we infer a tupled argument from the expression and/or type then use that
| _ when ai1.Length < ai2.Length -> ai2
| _ -> ai1
let rec loop ais1 ais2 =
match ais1,ais2 with
// If the expression infers additional arguments then use those (this shouldn't happen, since the
// arity inference done on the syntactic form should give identical results)
| [],ais | ais,[] -> ais
| (h1::t1),(h2::t2) -> choose h1 h2 :: loop t1 t2
let curriedArgInfos = loop curriedArgInfosFromSyntax curriedArgInfosFromExpression
PartialValReprInfo (curriedArgInfos,retInfoFromSyntax)
Some(partialArityInfo)
let BuildValScheme declKind partialArityInfoOpt prelimScheme =
let (PrelimValScheme2(id,typeScheme,_,memberInfoOpt,isMutable,inlineFlag,baseOrThis,_,vis,compgen,hasDeclaredTypars)) = prelimScheme
let topValInfo =
if DeclKind.MustHaveArity declKind then
Option.map (InferGenericArityFromTyScheme typeScheme) partialArityInfoOpt
else
None
let isTyFunc = ComputeIsTyFunc(id,hasDeclaredTypars,topValInfo)
ValScheme(id,typeScheme,topValInfo,memberInfoOpt,isMutable,inlineFlag,baseOrThis,vis,compgen,false,isTyFunc,hasDeclaredTypars)
let UseCombinedArity g declKind rhsExpr prelimScheme =
let partialArityInfoOpt = CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme
BuildValScheme declKind partialArityInfoOpt prelimScheme
let UseNoArity prelimScheme =
BuildValScheme ExpressionBinding None prelimScheme
let MakeSimpleVals cenv env names =
let tyschemes = DontGeneralizeVals names
let valSchemes = NameMap.map UseNoArity tyschemes
let values = MakeAndPublishVals cenv env (ParentNone,false,ExpressionBinding,ValNotInRecScope,valSchemes,[],XmlDoc.Empty,None)
let vspecMap = NameMap.map fst values
values,vspecMap
let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv =
let values,vspecMap =
if not mergeNamesInOneNameresEnv then MakeSimpleVals cenv env names
else
// reason: now during typecheck we create new name resolution environment for all components of tupled arguments in lambda.
// When trying to find best environment for the given position first we pick the most deeply nested scope that contains given position
// (and that will be lambda body - correct one), then we look for the better subtree on the left hand side
// (and that will be name resolution environment containing second parameter parameter - without the first one).
// fix: I've tried to make fix as local as possible to reduce overall impact on the source code.
// Idea of the fix: replace existing typecheck results sink and capture all reported name resolutions (this will be all parameters in lambda).
// After that - we restore the sink back, generate new name resolution environment that contains all captured names and report generated environment
// to the old sink.
// default behavior - send EnvWithScope notification for every resolved name
// what we do here is override this default behavior and capture only all name resolution notifications
// later we'll process them and create one name resolution env that will contain names from all notifications
let nameResolutions = ResizeArray()
let values,vspecMap =
let sink =
{ new ITypecheckResultsSink with
member this.NotifyEnvWithScope(_, _, _) = () // ignore EnvWithScope reports
member this.NotifyNameResolution(pos, a, b, occurence, denv, nenv, ad, m, replacing) =
if not m.IsSynthetic then
nameResolutions.Add(pos, a, b, occurence, denv, nenv, ad, m, replacing)
member this.NotifyExprHasType(_, _, _, _, _, _) = assert false // no expr typings in MakeSimpleVals
member this.NotifyFormatSpecifierLocation _ = ()
member this.CurrentSource = None }
use _h = WithNewTypecheckResultsSink(sink, cenv.tcSink)
MakeSimpleVals cenv env names
if nameResolutions.Count <> 0 then
let (_, _, _, _, _, _, ad, m1, _replacing) = nameResolutions.[0]
// mergedNameEnv - name resolution env that contains all names
// mergedRange - union of ranges of names
let mergedNameEnv, mergedRange =
((env.NameEnv, m1), nameResolutions) ||> Seq.fold (fun (nenv, merged) (_pos, item, _b, _occurence, _denv, _nenv, _ad, m, _) ->
// MakeAndPublishVal creates only Item.Value
let item = match item with Item.Value(item) -> item | _ -> failwith "impossible"
(AddFakeNamedValRefToNameEnv item.DisplayName nenv item), (unionRanges m merged)
)
// send notification about mergedNameEnv
CallEnvSink cenv.tcSink (mergedRange, mergedNameEnv, ad)
// call CallNameResolutionSink for all captured name resolutions using mergedNameEnv
for (_, item, b, occurence, denv, _nenv, ad, m, _replacing) in nameResolutions do
CallNameResolutionSink cenv.tcSink (m, mergedNameEnv, item, b, occurence, denv, ad)
values,vspecMap
let envinner = AddLocalValMap cenv.tcSink m vspecMap env
envinner,values,vspecMap
//-------------------------------------------------------------------------
// Helpers to freshen existing types and values, i.e. when a reference
// to C<_> occurs then generate C<?ty> for a fresh type inference variable ?ty.
//-------------------------------------------------------------------------
let FreshenTyconRef m rigid (tcref:TyconRef) declaredTyconTypars =
let tpsorig = declaredTyconTypars
let tps = copyTypars tpsorig
if rigid <> TyparRigidity.Rigid then
tps |> List.iter (fun tp -> tp.SetRigidity rigid)
let renaming,tinst = FixupNewTypars m [] [] tpsorig tps
(TType_app(tcref,List.map mkTyparTy tpsorig), tps, renaming, TType_app(tcref,tinst))
let FreshenPossibleForallTy g m rigid ty =
let tpsorig,tau = tryDestForallTy g ty
if isNil tpsorig then
[],[],tau
else
// tps may be have been equated to other tps in equi-recursive type inference and units-of-measure type inference. Normalize them here
let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference g tpsorig
let tps,renaming,tinst = CopyAndFixupTypars m rigid tpsorig
tps,tinst,instType renaming tau
let infoOfTyconRef m (tcref:TyconRef) =
let tps,renaming,tinst = FreshenTypeInst m (tcref.Typars m)
tps,renaming,tinst,TType_app (tcref,tinst)
/// Given a abstract method, which may be a generic method, freshen the type in preparation
/// to apply it as a constraint to the method that implements the abstract slot
let FreshenAbstractSlot g amap m synTyparDecls absMethInfo =
// Work out if an explicit instantiation has been given. If so then the explicit type
// parameters will be made rigid and checked for generalization. If not then auto-generalize
// by making the copy of the type parameters on the virtual being overriden rigid.
let typarsFromAbsSlotAreRigid =
match synTyparDecls with
| SynValTyparDecls(synTypars,infer,_) ->
if infer && not (isNil synTypars) then
errorR(Error(FSComp.SR.tcOverridingMethodRequiresAllOrNoTypeParameters(),m))
isNil synTypars
let (CompiledSig (argtys,retTy,fmtps,_)) = CompiledSigOfMeth g amap m absMethInfo
// If the virual method is a generic method then copy its type parameters
let typarsFromAbsSlot,typarInstFromAbsSlot,_ =
let ttps = absMethInfo.GetFormalTyparsOfDeclaringType m
let ttinst = argsOfAppTy g absMethInfo.EnclosingType
let rigid = if typarsFromAbsSlotAreRigid then TyparRigidity.Rigid else TyparRigidity.Flexible
ConstraintSolver.FreshenAndFixupTypars m rigid ttps ttinst fmtps
// Work out the required type of the member
let argTysFromAbsSlot = argtys |> List.mapSquared (instType typarInstFromAbsSlot)
let retTyFromAbsSlot = retTy |> GetFSharpViewOfReturnType g |> instType typarInstFromAbsSlot
typarsFromAbsSlotAreRigid,typarsFromAbsSlot,argTysFromAbsSlot, retTyFromAbsSlot
//-------------------------------------------------------------------------
// Helpers to typecheck expressions and patterns
//-------------------------------------------------------------------------
let BuildFieldMap cenv env isPartial ty flds m =
let ad = env.eAccessRights
if isNil flds then invalidArg "flds" "BuildFieldMap"
let frefSets =
let allFields = flds |> List.map (fun ((_,ident),_) -> ident)
flds
|> List.map (fun (fld,fldExpr) ->
let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fld allFields
fld,frefSet,fldExpr)
let relevantTypeSets =
frefSets |> List.map (fun (_,frefSet,_) -> frefSet |> List.map (fun (FieldResolution(rfref,_)) -> rfref.TyconRef))
let tcref =
match List.fold (ListSet.intersect (tyconRefEq cenv.g)) (List.head relevantTypeSets) (List.tail relevantTypeSets) with
| [tcref] -> tcref
| tcrefs ->
if isPartial then
warning (Error(FSComp.SR.tcFieldsDoNotDetermineUniqueRecordType(),m))
// try finding a record type with the same number of fields as the ones that are given.
match tcrefs |> List.tryFind (fun tc -> tc.TrueFieldsAsList.Length = flds.Length) with
| Some tcref -> tcref
| _ ->
// OK, there isn't a unique, good type dictated by the intersection for the field refs.
// We're going to get an error of some kind below.
// Just choose one field ref and let the error come later
let (_,frefSet1,_) = List.head frefSets
let (FieldResolution(fref1,_)) = List.head frefSet1
fref1.TyconRef
let fldsmap,rfldsList =
((Map.empty,[]), frefSets) ||> List.fold (fun (fs,rfldsList) (fld,frefs,fldExpr) ->
match frefs |> List.filter (fun (FieldResolution(fref2,_)) -> tyconRefEq cenv.g tcref fref2.TyconRef) with
| [FieldResolution(fref2,showDeprecated)] ->
// Record the precise resolution of the field for intellisense
let item = FreshenRecdFieldRef cenv.nameResolver m fref2
CallNameResolutionSink cenv.tcSink ((snd fld).idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad)
CheckRecdFieldAccessible cenv.amap m env.eAccessRights fref2 |> ignore
CheckFSharpAttributes cenv.g fref2.PropertyAttribs m |> CommitOperationResult
if Map.containsKey fref2.FieldName fs then
errorR (Error(FSComp.SR.tcFieldAppearsTwiceInRecord(fref2.FieldName),m))
if showDeprecated then
warning(Deprecated(FSComp.SR.nrRecordTypeNeedsQualifiedAccess(fref2.FieldName,fref2.Tycon.DisplayName) |> snd,m))
if not (tyconRefEq cenv.g tcref fref2.TyconRef) then
let (_,frefSet1,_) = List.head frefSets
let (FieldResolution(fref1,_)) = List.head frefSet1
errorR (FieldsFromDifferentTypes(env.DisplayEnv,fref1,fref2,m))
fs,rfldsList
else
Map.add fref2.FieldName fldExpr fs,(fref2.FieldName,fldExpr)::rfldsList
| _ -> error(Error(FSComp.SR.tcRecordFieldInconsistentTypes(),m)))
tcref,fldsmap,List.rev rfldsList
let rec ApplyUnionCaseOrExn (makerForUnionCase,makerForExnTag) m cenv env overallTy item =
let ad = env.eAccessRights
match item with
| Item.ExnCase ecref ->
CheckEntityAttributes cenv.g ecref m |> CommitOperationResult
UnifyTypes cenv env m overallTy cenv.g.exn_ty
CheckTyconAccessible cenv.amap m ad ecref |> ignore
let mkf = makerForExnTag ecref
mkf,recdFieldTysOfExnDefRef ecref, [ for f in (recdFieldsOfExnDefRef ecref) -> f.Id ]
| Item.UnionCase(ucinfo,showDeprecated) ->
if showDeprecated then
warning(Deprecated(FSComp.SR.nrUnionTypeNeedsQualifiedAccess(ucinfo.Name,ucinfo.Tycon.DisplayName) |> snd,m))
let ucref = ucinfo.UnionCaseRef
CheckUnionCaseAttributes cenv.g ucref m |> CommitOperationResult
CheckUnionCaseAccessible cenv.amap m ad ucref |> ignore
let gtyp2 = actualResultTyOfUnionCase ucinfo.TypeInst ucref
let inst = mkTyparInst ucref.TyconRef.TyparsNoRange ucinfo.TypeInst
UnifyTypes cenv env m overallTy gtyp2
let mkf = makerForUnionCase(ucref,ucinfo.TypeInst)
mkf,actualTysOfUnionCaseFields inst ucref, [ for f in ucref.AllFieldsAsList -> f.Id ]
| _ -> invalidArg "item" "not a union case or exception reference"
let ApplyUnionCaseOrExnTypes m cenv env overallTy c =
ApplyUnionCaseOrExn ((fun (a,b) mArgs args -> mkUnionCaseExpr(a,b,args,unionRanges m mArgs)),
(fun a mArgs args -> mkExnExpr (a,args,unionRanges m mArgs))) m cenv env overallTy c
let ApplyUnionCaseOrExnTypesForPat m cenv env overallTy c =
ApplyUnionCaseOrExn ((fun (a,b) mArgs args -> TPat_unioncase(a,b,args,unionRanges m mArgs)),
(fun a mArgs args -> TPat_exnconstr(a,args,unionRanges m mArgs))) m cenv env overallTy c
let UnionCaseOrExnCheck (env: TcEnv) nargtys nargs m =
if nargs <> nargtys then error (UnionCaseWrongArguments(env.DisplayEnv,nargtys,nargs,m))
let TcUnionCaseOrExnField cenv (env: TcEnv) ty1 m c n funcs =
let ad = env.eAccessRights
let mkf,argtys, _argNames =
match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false m ad env.eNameResEnv TypeNameResolutionInfo.Default c with
| (Item.UnionCase _ | Item.ExnCase _) as item ->
ApplyUnionCaseOrExn funcs m cenv env ty1 item
| _ -> error(Error(FSComp.SR.tcUnknownUnion(),m))
if n >= List.length argtys then
error (UnionCaseWrongNumberOfArgs(env.DisplayEnv,List.length argtys,n,m))
let ty2 = List.item n argtys
mkf,ty2
//-------------------------------------------------------------------------
// Environment of explicit type parameters, e.g. 'a in "(x : 'a)"
//-------------------------------------------------------------------------
type SyntacticUnscopedTyparEnv = UnscopedTyparEnv of NameMap<Typar>
let emptyUnscopedTyparEnv : SyntacticUnscopedTyparEnv = UnscopedTyparEnv Map.empty
let AddUnscopedTypar n p (UnscopedTyparEnv tab) = UnscopedTyparEnv (Map.add n p tab)
let TryFindUnscopedTypar n (UnscopedTyparEnv tab) = Map.tryFind n tab
let HideUnscopedTypars typars (UnscopedTyparEnv tab) =
UnscopedTyparEnv (List.fold (fun acc (tp:Typar) -> Map.remove tp.Name acc) tab typars)
//-------------------------------------------------------------------------
// Helpers for generalizing type variables
//-------------------------------------------------------------------------
type GeneralizeConstrainedTyparOptions =
| CanGeneralizeConstrainedTypars
| DoNotGeneralizeConstrainedTypars
module GeneralizationHelpers =
let ComputeUngeneralizableTypars env =
// This is just a List.fold. Unfolded here to enable better profiling
let rec loop acc (items: UngeneralizableItem list) =
match items with
| [] -> acc
| item::rest ->
let acc =
if item.WillNeverHaveFreeTypars then
acc
else
let ftps = item.GetFreeTyvars().FreeTypars
if ftps.IsEmpty then
acc
else
// These union operations are a performance sore point
unionFreeTypars ftps acc
loop acc rest
loop emptyFreeTypars env.eUngeneralizableItems
let ComputeUnabstractableTycons env =
let acc_in_free_item acc (item: UngeneralizableItem) =
let ftycs =
if item.WillNeverHaveFreeTypars then item.CachedFreeLocalTycons else
let ftyvs = item.GetFreeTyvars()
ftyvs.FreeTycons
if ftycs.IsEmpty then acc else unionFreeTycons ftycs acc
List.fold acc_in_free_item emptyFreeTycons env.eUngeneralizableItems
let ComputeUnabstractableTraitSolutions env =
let acc_in_free_item acc (item: UngeneralizableItem) =
let ftycs =
if item.WillNeverHaveFreeTypars then item.CachedFreeTraitSolutions else
let ftyvs = item.GetFreeTyvars()
ftyvs.FreeTraitSolutions
if ftycs.IsEmpty then acc else unionFreeLocals ftycs acc
List.fold acc_in_free_item emptyFreeLocals env.eUngeneralizableItems
let rec IsGeneralizableValue g t =
match t with
| Expr.Lambda _ | Expr.TyLambda _ | Expr.Const _ | Expr.Val _ -> true
// Look through coercion nodes corresponding to introduction of subsumption
| Expr.Op(TOp.Coerce,[inputTy;actualTy],[e1],_) when isFunTy g actualTy && isFunTy g inputTy ->
IsGeneralizableValue g e1
| Expr.Op(op,_,args,_) ->
match op with
| TOp.Tuple _ -> true
| TOp.UnionCase uc -> not (isUnionCaseRefAllocObservable uc)
| TOp.Recd(ctorInfo,tcref) ->
match ctorInfo with
| RecdExpr -> not (isRecdOrUnionOrStructTyconRefAllocObservable g tcref)
| RecdExprIsObjInit -> false
| TOp.Array -> isNil args
| TOp.ExnConstr ec -> not (isExnAllocObservable ec)
| TOp.ILAsm([],_) -> true
| _ -> false
&& List.forall (IsGeneralizableValue g) args
| Expr.LetRec(binds,body,_,_) ->
binds |> List.forall (fun b -> IsGeneralizableValue g b.Expr) &&
IsGeneralizableValue g body
| Expr.Let(bind,body,_,_) ->
IsGeneralizableValue g bind.Expr &&
IsGeneralizableValue g body
// Applications of type functions are _not_ normally generalizable unless explicitly marked so
| Expr.App(Expr.Val (vref,_,_),_,_,[],_) when vref.IsTypeFunction ->
HasFSharpAttribute g g.attrib_GeneralizableValueAttribute vref.Attribs
| Expr.App(e1,_,_,[],_) -> IsGeneralizableValue g e1
| Expr.TyChoose(_,b,_) -> IsGeneralizableValue g b
| Expr.Obj (_,ty,_,_,_,_,_) -> isInterfaceTy g ty || isDelegateTy g ty
| Expr.Link eref -> IsGeneralizableValue g !eref
| _ -> false
let CanGeneralizeConstrainedTyparsForDecl declKind =
if DeclKind.CanGeneralizeConstrainedTypars declKind
then CanGeneralizeConstrainedTypars
else DoNotGeneralizeConstrainedTypars
/// Recursively knock out typars we can't generalize.
/// For non-generalized type variables be careful to iteratively knock out
/// both the typars and any typars free in the constraints of the typars
/// into the set that are considered free in the environment.
let rec TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag (generalizedTypars:Typar list) freeInEnv =
// Do not generalize type variables with a static requirement unless function is marked 'inline'
let generalizedTypars,ungeneralizableTypars1 =
if inlineFlag = ValInline.PseudoVal then generalizedTypars,[]
else generalizedTypars |> List.partition (fun tp -> tp.StaticReq = NoStaticReq)
// Do not generalize type variables which would escape their scope
// because they are free in the environment
let generalizedTypars,ungeneralizableTypars2 =
List.partition (fun x -> not (Zset.contains x freeInEnv)) generalizedTypars
// Some situations, e.g. implicit class constructions that represent functions as fields,
// do not allow generalisation over constrained typars. (since they can not be represented as fields)
let generalizedTypars,ungeneralizableTypars3 =
generalizedTypars
|> List.partition (fun tp ->
genConstrainedTyparFlag = CanGeneralizeConstrainedTypars ||
tp.Constraints.IsEmpty)
if isNil ungeneralizableTypars1 && isNil ungeneralizableTypars2 && isNil ungeneralizableTypars3 then
generalizedTypars, freeInEnv
else
let freeInEnv =
unionFreeTypars
(accFreeInTypars CollectAllNoCaching ungeneralizableTypars1
(accFreeInTypars CollectAllNoCaching ungeneralizableTypars2
(accFreeInTypars CollectAllNoCaching ungeneralizableTypars3 emptyFreeTyvars))).FreeTypars
freeInEnv
TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag generalizedTypars freeInEnv
/// Condense type variables in positive position
let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m) =
// The type of the value is ty11 * ... * ty1N -> ... -> tyM1 * ... * tyMM -> retTy
// This is computed REGARDLESS of the arity of the expression.
let curriedArgTys,retTy = stripFunTy cenv.g tauTy
let allUntupledArgTys = curriedArgTys |> List.collect (tryDestRefTupleTy cenv.g)
// Compute the type variables in 'retTy'
let returnTypeFreeTypars = freeInTypeLeftToRight cenv.g false retTy
let allUntupledArgTysWithFreeVars = allUntupledArgTys |> List.map (fun ty -> (ty, freeInTypeLeftToRight cenv.g false ty))
let relevantUniqueSubtypeConstraint (tp:Typar) =
// Find a single subtype constraint
match tp.Constraints |> List.partition (function (TyparConstraint.CoercesTo _) -> true | _ -> false) with
| [TyparConstraint.CoercesTo(cxty,_)], others ->
// Throw away null constraints if they are implied
if others |> List.exists (function (TyparConstraint.SupportsNull(_)) -> not (TypeSatisfiesNullConstraint cenv.g m cxty) | _ -> true)
then None
else Some cxty
| _ -> None
// Condensation typars can't be used in the constraints of any candidate condensation typars. So compute all the
// typars free in the constraints of tyIJ
let lhsConstraintTypars =
allUntupledArgTys |> List.collect (fun ty ->
match tryDestTyparTy cenv.g ty with
| Some tp ->
match relevantUniqueSubtypeConstraint tp with
| Some cxty -> freeInTypeLeftToRight cenv.g false cxty
| None -> []
| None -> [])
let IsCondensationTypar (tp:Typar) =
// A condensation typar may not a user-generated type variable nor has it been unified with any user type variable
(tp.DynamicReq = TyparDynamicReq.No) &&
// A condensation typar must have a single constraint "'a :> A"
(Option.isSome (relevantUniqueSubtypeConstraint tp)) &&
// This is type variable is not used on the r.h.s. of the type
not (ListSet.contains typarEq tp returnTypeFreeTypars) &&
// A condensation typar can't be used in the constraints of any candidate condensation typars
not (ListSet.contains typarEq tp lhsConstraintTypars) &&
// A condensation typar must occur precisely once in tyIJ, and must not occur free in any other tyIJ
(match allUntupledArgTysWithFreeVars |> List.partition (fun (ty,_) -> match tryDestTyparTy cenv.g ty with Some destTypar -> typarEq destTypar tp | _ -> false) with
| [_], rest -> not (rest |> List.exists (fun (_,fvs) -> ListSet.contains typarEq tp fvs))
| _ -> false)
let condensationTypars, generalizedTypars = generalizedTypars |> List.partition IsCondensationTypar
// Condensation solves type variables eagerly and removes them from the generalization set
condensationTypars |> List.iter (fun tp ->
ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp)
generalizedTypars
let CanonicalizePartialInferenceProblem (cenv,denv,m) tps =
// Canonicalize constraints prior to generalization
let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv)
TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps)
(fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m)))
|> RaiseOperationResult
let ComputeAndGeneralizeGenericTypars (cenv,
denv:DisplayEnv,
m,
freeInEnv:FreeTypars,
canInferTypars,
genConstrainedTyparFlag,
inlineFlag,
exprOpt,
allDeclaredTypars: Typars,
maxInferredTypars: Typars,
tauTy,
resultFirst) =
let allDeclaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g allDeclaredTypars
let typarsToAttemptToGeneralize =
if (match exprOpt with None -> true | Some e -> IsGeneralizableValue cenv.g e)
then (ListSet.unionFavourLeft typarEq allDeclaredTypars maxInferredTypars)
else allDeclaredTypars
let generalizedTypars,freeInEnv =
TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag typarsToAttemptToGeneralize freeInEnv
allDeclaredTypars
|> List.iter (fun tp ->
if Zset.memberOf freeInEnv tp then
let ty = mkTyparTy tp
error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty),m)))
let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m)
let generalizedTypars =
if canInferTypars then generalizedTypars
else generalizedTypars |> List.filter (fun tp -> ListSet.contains typarEq tp allDeclaredTypars)
let allConstraints = List.collect (fun (tp:Typar) -> tp.Constraints) generalizedTypars
let generalizedTypars = ConstraintSolver.SimplifyMeasuresInTypeScheme cenv.g resultFirst generalizedTypars tauTy allConstraints
// Generalization turns inference type variables into rigid, quantified type variables,
// (they may be rigid already)
generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m)
// Generalization removes constraints related to generalized type variables
let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv
EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars
generalizedTypars
//-------------------------------------------------------------------------
// Helpers to freshen existing types and values, i.e. when a reference
// to C<_> occurs then generate C<?ty> for a fresh type inference variable ?ty.
//-------------------------------------------------------------------------
let CheckDeclaredTyparsPermitted (memFlagsOpt, declaredTypars, m) =
match memFlagsOpt with
| None -> ()
| Some memberFlags ->
match memberFlags.MemberKind with
// can't infer extra polymorphism for properties
| MemberKind.PropertyGet
| MemberKind.PropertySet ->
if not (isNil declaredTypars) then
errorR(Error(FSComp.SR.tcPropertyRequiresExplicitTypeParameters(),m))
| MemberKind.Constructor ->
if not (isNil declaredTypars) then
errorR(Error(FSComp.SR.tcConstructorCannotHaveTypeParameters(),m))
| _ -> ()
/// Properties and Constructors may only generalize the variables associated with the containing class (retrieved from the 'this' pointer)
/// Also check they don't declare explicit typars.
let ComputeCanInferExtraGeneralizableTypars (parentRef, canInferTypars, memFlagsOpt) =
canInferTypars &&
(match memFlagsOpt with
| None -> true
| Some memberFlags ->
match memberFlags.MemberKind with
// can't infer extra polymorphism for properties
| MemberKind.PropertyGet | MemberKind.PropertySet -> false
// can't infer extra polymorphism for class constructors
| MemberKind.ClassConstructor -> false
// can't infer extra polymorphism for constructors
| MemberKind.Constructor -> false
// feasible to infer extra polymorphism
| _ -> true) &&
(match parentRef with
| Parent tcref -> not tcref.IsFSharpDelegateTycon
| _ -> true) // no generic paramters inferred for 'Invoke' method
//-------------------------------------------------------------------------
// ComputeInlineFlag
//-------------------------------------------------------------------------
let ComputeInlineFlag memFlagsOption isInline isMutable m =
let inlineFlag =
// Mutable values may never be inlined
// Constructors may never be inlined
// Calls to virtual/abstract slots may never be inlined
if isMutable ||
(match memFlagsOption with
| None -> false
| Some x -> (x.MemberKind = MemberKind.Constructor) || x.IsDispatchSlot || x.IsOverrideOrExplicitImpl)
then ValInline.Never
elif isInline then ValInline.PseudoVal
else ValInline.Optional
if isInline && (inlineFlag <> ValInline.PseudoVal) then
errorR(Error(FSComp.SR.tcThisValueMayNotBeInlined(),m))
inlineFlag
//-------------------------------------------------------------------------
// Binding normalization.
//
// Determine what sort of value is being bound (normal value, instance
// member, normal function, static member etc.) and make some
// name-resolution-sensitive adjustments to the syntax tree.
//
// One part of this "normalization" ensures:
// "let SynPat.LongIdent(f) = e" when f not a datatype constructor --> let Pat_var(f) = e"
// "let SynPat.LongIdent(f) pat = e" when f not a datatype constructor --> let Pat_var(f) = \pat. e"
// "let (SynPat.LongIdent(f) : ty) = e" when f not a datatype constructor --> let (Pat_var(f) : ty) = e"
// "let (SynPat.LongIdent(f) : ty) pat = e" when f not a datatype constructor --> let (Pat_var(f) : ty) = \pat. e"
//
// This is because the first lambda in a function definition "let F x = e"
// now looks like a constructor application, i.e. let (F x) = e ...
// also let A.F x = e ...
// also let f x = e ...
//
// The other parts turn property definitions into method definitions.
//-------------------------------------------------------------------------
// NormalizedBindingRhs records the r.h.s. of a binding after some munging just before type checking.
// NOTE: This is a bit of a mess. In the early implementation of F# we decided
// to have the parser convert "let f x = e" into
// "let f = fun x -> e". This is called "pushing" a pattern across to the right hand side. Complex
// patterns (e.g. non-tuple patterns) result in a computation on the right.
// However, this approach really isn't that great - especially since
// the language is now considerably more complex, e.g. we use
// type information from the first (but not the second) form in
// type inference for recursive bindings, and the first form
// may specify .NET attributes for arguments. There are still many
// relics of this approach around, e.g. the expression in BindingRhs
// below is of the second form. However, to extract relevant information
// we keep a record of the pats and optional explicit return type already pushed
// into expression so we can use any user-given type information from these
type NormalizedBindingRhs =
| NormalizedBindingRhs of SynSimplePats list * SynBindingReturnInfo option * SynExpr
let PushOnePatternToRhs (cenv:cenv) isMember p (NormalizedBindingRhs(spatsL,rtyOpt,rhsExpr)) =
let spats,rhsExpr = PushPatternToExpr cenv.synArgNameGenerator isMember p rhsExpr
NormalizedBindingRhs(spats::spatsL, rtyOpt,rhsExpr)
type NormalizedBindingPatternInfo =
NormalizedBindingPat of SynPat * NormalizedBindingRhs * SynValData * SynValTyparDecls
/// Represents a syntactic, unchecked binding after the resolution of the name resolution status of pattern
/// constructors and after "pushing" all complex patterns to the right hand side.
type NormalizedBinding =
| NormalizedBinding of
SynAccess option *
SynBindingKind *
bool * (* pesudo/mustinline value? *)
bool * (* mutable *)
SynAttributes *
XmlDoc *
SynValTyparDecls *
SynValData *
SynPat *
NormalizedBindingRhs *
range *
SequencePointInfoForBinding
type IsObjExprBinding =
| ObjExprBinding
| ValOrMemberBinding
module BindingNormalization =
/// Push a bunch of pats at once. They may contain patterns, e.g. let f (A x) (B y) = ...
/// In this case the sematnics is let f a b = let A x = a in let B y = b
let private PushMultiplePatternsToRhs (cenv:cenv) isMember ps (NormalizedBindingRhs(spatsL,rtyOpt,rhsExpr)) =
let spatsL2,rhsExpr = PushCurriedPatternsToExpr cenv.synArgNameGenerator rhsExpr.Range isMember ps rhsExpr
NormalizedBindingRhs(spatsL2@spatsL, rtyOpt, rhsExpr)
let private MakeNormalizedStaticOrValBinding cenv isObjExprBinding id vis typars args rhsExpr valSynData =
let (SynValData(memberFlagsOpt,_,_)) = valSynData
NormalizedBindingPat(mkSynPatVar vis id, PushMultiplePatternsToRhs cenv ((isObjExprBinding = ObjExprBinding) || Option.isSome memberFlagsOpt) args rhsExpr,valSynData,typars)
let private MakeNormalizedInstanceMemberBinding cenv thisId memberId toolId vis m typars args rhsExpr valSynData =
NormalizedBindingPat(SynPat.InstanceMember(thisId,memberId,toolId,vis,m), PushMultiplePatternsToRhs cenv true args rhsExpr,valSynData,typars)
let private NormalizeStaticMemberBinding cenv memberFlags valSynData id vis typars args m rhsExpr =
let (SynValData(_,valSynInfo,thisIdOpt)) = valSynData
if memberFlags.IsInstance then
// instance method without adhoc "this" argument
error(Error(FSComp.SR.tcInstanceMemberRequiresTarget(),m))
match args, memberFlags.MemberKind with
| _,MemberKind.PropertyGetSet -> error(Error(FSComp.SR.tcUnexpectedPropertyInSyntaxTree(),m))
| [],MemberKind.ClassConstructor -> error(Error(FSComp.SR.tcStaticInitializerRequiresArgument(),m))
| [],MemberKind.Constructor -> error(Error(FSComp.SR.tcObjectConstructorRequiresArgument(),m))
| [_],MemberKind.ClassConstructor
| [_],MemberKind.Constructor -> MakeNormalizedStaticOrValBinding cenv ValOrMemberBinding id vis typars args rhsExpr valSynData
// Static property declared using 'static member P = expr': transformed to a method taking a "unit" argument
// static property: these transformed into methods taking one "unit" argument
| [],MemberKind.Member ->
let memberFlags = {memberFlags with MemberKind = MemberKind.PropertyGet}
let valSynData = SynValData(Some memberFlags,valSynInfo,thisIdOpt)
NormalizedBindingPat(mkSynPatVar vis id,
PushOnePatternToRhs cenv true (SynPat.Const(SynConst.Unit,m)) rhsExpr,
valSynData,
typars)
| _ -> MakeNormalizedStaticOrValBinding cenv ValOrMemberBinding id vis typars args rhsExpr valSynData
let private NormalizeInstanceMemberBinding cenv memberFlags valSynData thisId memberId (toolId:Ident option) vis typars args m rhsExpr =
let (SynValData(_,valSynInfo,thisIdOpt)) = valSynData
if not memberFlags.IsInstance then
// static method with adhoc "this" argument
error(Error(FSComp.SR.tcStaticMemberShouldNotHaveThis(),m))
match args, memberFlags.MemberKind with
| _,MemberKind.ClassConstructor -> error(Error(FSComp.SR.tcExplicitStaticInitializerSyntax(),m))
| _,MemberKind.Constructor -> error(Error(FSComp.SR.tcExplicitObjectConstructorSyntax(),m))
| _,MemberKind.PropertyGetSet -> error(Error(FSComp.SR.tcUnexpectedPropertySpec(),m))
// Instance property declared using 'x.Member': transformed to methods taking a "this" and a "unit" argument
// We push across the 'this' arg in mk_rec_binds
| [],MemberKind.Member ->
let memberFlags = {memberFlags with MemberKind = MemberKind.PropertyGet}
NormalizedBindingPat
(SynPat.InstanceMember(thisId,memberId,toolId,vis,m),
PushOnePatternToRhs cenv true (SynPat.Const(SynConst.Unit,m)) rhsExpr,
// Update the member info to record that this is a MemberKind.PropertyGet
SynValData(Some memberFlags,valSynInfo,thisIdOpt),
typars)
| _ -> MakeNormalizedInstanceMemberBinding cenv thisId memberId toolId vis m typars args rhsExpr valSynData
let private NormalizeBindingPattern cenv nameResolver isObjExprBinding (env: TcEnv) valSynData pat rhsExpr =
let ad = env.eAccessRights
let (SynValData(memberFlagsOpt,_,_)) = valSynData
let rec normPattern pat =
// One major problem with versions of F# prior to 1.9.x was that data constructors easily 'pollute' the namespace
// of available items, to the point that you can't even define a function with the same name as an existing union case.
match pat with
| SynPat.FromParseError(p,_) -> normPattern p
| SynPat.LongIdent (LongIdentWithDots(longId,_), toolId, tyargs, SynConstructorArgs.Pats args, vis, m) ->
let typars = match tyargs with None -> inferredTyparDecls | Some typars -> typars
match memberFlagsOpt with
| None ->
match ResolvePatternLongIdent cenv.tcSink nameResolver AllIdsOK true m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with
| Item.NewDef id ->
if id.idText = opNameCons then
NormalizedBindingPat(pat,rhsExpr,valSynData,typars)
else
if isObjExprBinding = ObjExprBinding then
errorR(Deprecated(FSComp.SR.tcObjectExpressionFormDeprecated(),m))
MakeNormalizedStaticOrValBinding cenv isObjExprBinding id vis typars args rhsExpr valSynData
| _ ->
error(Error(FSComp.SR.tcInvalidDeclaration(),m))
| Some memberFlags ->
match longId with
// x.Member in member binding patterns.
| [thisId;memberId] -> NormalizeInstanceMemberBinding cenv memberFlags valSynData thisId memberId toolId vis typars args m rhsExpr
| [memberId] -> NormalizeStaticMemberBinding cenv memberFlags valSynData memberId vis typars args m rhsExpr
| _ -> NormalizedBindingPat(pat,rhsExpr,valSynData,typars)
// Object constructors are normalized in TcLetrec
// Here we are normalizing member definitions with simple (not long) ids,
// e.g. "static member x = 3" and "member x = 3" (instance with missing "this." comes through here. It is trapped and generates a warning)
| SynPat.Named (SynPat.Wild _, id, false, vis, m)
when
(match memberFlagsOpt with
| None -> false
| Some memberFlags ->
not (memberFlags.MemberKind = MemberKind.Constructor) &&
not (memberFlags.MemberKind = MemberKind.ClassConstructor)) ->
NormalizeStaticMemberBinding cenv (Option.get memberFlagsOpt) valSynData id vis inferredTyparDecls [] m rhsExpr
| SynPat.Typed(pat',x,y) ->
let (NormalizedBindingPat(pat'',e'',valSynData,typars)) = normPattern pat'
NormalizedBindingPat(SynPat.Typed(pat'',x,y), e'',valSynData,typars)
| SynPat.Attrib(_,_,m) ->
error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m))
| _ ->
NormalizedBindingPat(pat,rhsExpr,valSynData,inferredTyparDecls)
normPattern pat
let NormalizeBinding isObjExprBinding cenv (env: TcEnv) b =
match b with
| Binding (vis,bkind,isInline,isMutable,attrs,doc,valSynData,p,retInfo,rhsExpr,mBinding,spBind) ->
let (NormalizedBindingPat(pat,rhsExpr,valSynData,typars)) =
NormalizeBindingPattern cenv cenv.nameResolver isObjExprBinding env valSynData p (NormalizedBindingRhs ([], retInfo, rhsExpr))
NormalizedBinding(vis,bkind,isInline,isMutable,attrs,doc.ToXmlDoc(),typars,valSynData,pat,rhsExpr,mBinding,spBind)
//-------------------------------------------------------------------------
// input is:
// [<CompileAsEvent>]
// member x.P with get = fun () -> e
// -->
// member x.add_P< >(argName) = (e).AddHandler(argName)
// member x.remove_P< >(argName) = (e).RemoveHandler(argName)
module EventDeclarationNormalization =
let ConvertSynInfo m (SynValInfo(argInfos,retInfo)) =
// reconstitute valSynInfo by adding the argument
let argInfos =
match argInfos with
| [[thisArgInfo];[]] -> [[thisArgInfo];SynInfo.unnamedTopArg] // instance property getter
| [[]] -> [SynInfo.unnamedTopArg] // static property getter
| _ -> error(BadEventTransformation(m))
// reconstitute valSynInfo
SynValInfo(argInfos,retInfo)
// THe property x.P becomes methods x.add_P and x.remove_P
let ConvertMemberFlags memberFlags = { memberFlags with MemberKind = MemberKind.Member }
let private ConvertMemberFlagsOpt m memberFlagsOpt =
match memberFlagsOpt with
| Some memberFlags -> Some (ConvertMemberFlags memberFlags)
| _ -> error(BadEventTransformation(m))
let private ConvertSynData m valSynData =
let (SynValData(memberFlagsOpt,valSynInfo,thisIdOpt)) = valSynData
let memberFlagsOpt = ConvertMemberFlagsOpt m memberFlagsOpt
let valSynInfo = ConvertSynInfo m valSynInfo
SynValData(memberFlagsOpt,valSynInfo,thisIdOpt)
let rec private RenameBindingPattern f declPattern =
match declPattern with
| SynPat.FromParseError(p,_) -> RenameBindingPattern f p
| SynPat.Typed(pat',_,_) -> RenameBindingPattern f pat'
| SynPat.Named (SynPat.Wild m1, id,x2,vis2,m) -> SynPat.Named (SynPat.Wild m1, ident(f id.idText,id.idRange) ,x2,vis2,m)
| SynPat.InstanceMember(thisId,id,toolId,vis2,m) -> SynPat.InstanceMember(thisId,ident(f id.idText,id.idRange),toolId,vis2,m)
| _ -> error(Error(FSComp.SR.tcOnlySimplePatternsInLetRec(),declPattern.Range))
/// Some F# bindings syntactically imply additional bindings, notably properties
/// annotated with [<CLIEvent>]
let GenerateExtraBindings cenv (bindingAttribs,binding) =
let (NormalizedBinding(vis1, bindingKind, isInline, isMutable, _, bindingXmlDoc, _synTyparDecls, valSynData, declPattern, bindingRhs, mBinding, spBind)) = binding
if CompileAsEvent cenv.g bindingAttribs then
let MakeOne (prefix,target) =
let declPattern = RenameBindingPattern (fun s -> prefix^s) declPattern
let argName = "handler"
// modify the rhs and argument data
let bindingRhs,valSynData =
let (NormalizedBindingRhs(_,_,rhsExpr)) = bindingRhs
let m = rhsExpr.Range
// reconstitute valSynInfo by adding the argument
let valSynData = ConvertSynData m valSynData
match rhsExpr with
// Detect 'fun () -> e' which results from the compilation of a property getter
| SynExpr.Lambda (_,_,SynSimplePats.SimplePats([],_), trueRhsExpr,m) ->
let rhsExpr = mkSynApp1 (SynExpr.DotGet(SynExpr.Paren(trueRhsExpr,range0,None,m),range0,LongIdentWithDots([ident(target,m)],[]),m)) (SynExpr.Ident(ident(argName,m))) m
// reconstitute rhsExpr
let bindingRhs = NormalizedBindingRhs([],None,rhsExpr)
// add the argument to the expression
let bindingRhs = PushOnePatternToRhs cenv true (mkSynPatVar None (ident (argName,mBinding))) bindingRhs
bindingRhs,valSynData
| _ ->
error(BadEventTransformation(m))
// reconstitute the binding
NormalizedBinding(vis1,bindingKind,isInline,isMutable,[],bindingXmlDoc,noInferredTypars,valSynData,declPattern,bindingRhs,mBinding,spBind)
[ MakeOne ("add_","AddHandler"); MakeOne ("remove_","RemoveHandler") ]
else
[]
/// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable.
/// Also adjust the "this" type to take into account whether the type is a struct.
let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars =
#if EXTENDED_EXTENSION_MEMBERS // indicates if extension members can add additional constraints to type parameters
let tcrefObjTy,enclosingDeclaredTypars,renaming,objTy = FreshenTyconRef m (if isExtrinsic then TyparRigidity.Flexible else rigid) tcref declaredTyconTypars
#else
let tcrefObjTy,enclosingDeclaredTypars,renaming,objTy = FreshenTyconRef m rigid tcref declaredTyconTypars
#endif
// Struct members have a byref 'this' type (unless they are extrinsic extension members)
let thisTy =
if tcref.IsStructOrEnumTycon && not isExtrinsic then
mkByrefTy cenv.g objTy
else
objTy
tcrefObjTy,enclosingDeclaredTypars,renaming,objTy,thisTy
// The early generalization rule of F# 2.0 can be unsound for members in generic types (Bug DevDiv2 10649).
// It gives rise to types like "Forall T. ?X -> ?Y" where ?X and ?Y are later discovered to involve T.
//
// For example:
// type C<'T>() =
// let mutable x = Unchecked.defaultof<_> // unknown inference variable ?X
// static member A() = x
// // At this point A is generalized early to "Forall T. unit -> ?X"
// static member B1() = C<string>.A()
// // At this point during type inference, the return type of C<string>.A() is '?X'
// // After type inference, the return type of C<string>.A() is 'string'
// static member B2() = C<int>.A()
// // At this point during type inference, the return type of C<int>.A() is '?X'
// // After type inference, the return type of C<int>.A() is 'int'
// member this.C() = (x : 'T)
// // At this point during type inference the type of 'x' is inferred to be 'T'
//
// Here "A" is generalized too early.
//
// Ideally we would simply generalize "A" later, when it is known to be
// sound. However, that can lead to other problems (e.g. some programs that typecheck today would no longer
// be accepted). As a result, we deal with this unsoundness by an adhoc post-type-checking
// consistency check for recursive uses of "A" with explicit instantiations within the recursive
// scope of "A".
let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tinst, vty, tau, m) =
match vrec with
| ValInRecScope isComplete when isComplete && not (isNil tinst) ->
//printfn "pushing post-inference check for '%s', vty = '%s'" v.DisplayName (DebugPrint.showType vty)
cenv.postInferenceChecks.Add (fun () ->
//printfn "running post-inference check for '%s'" v.DisplayName
//printfn "tau = '%s'" (DebugPrint.showType tau)
//printfn "vty = '%s'" (DebugPrint.showType vty)
let tpsorig,tau2 = tryDestForallTy cenv.g vty
//printfn "tau2 = '%s'" (DebugPrint.showType tau2)
if not (isNil tpsorig) then
let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g tpsorig
let tau3 = instType (mkTyparInst tpsorig tinst) tau2
//printfn "tau3 = '%s'" (DebugPrint.showType tau3)
if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau tau3) then
let txt = bufs (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv buf v)
error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt),m)))
| _ -> ()
/// TcVal. "Use" a value, normally at a fresh type instance (unless optInst is
/// given). optInst is set when an explicit type instantiation is given, e.g.
/// Seq.empty<string>
/// In this case the vrefFlags inside optInst are just NormalValUse.
///
/// optInst is is also set when building the final call for a reference to an
/// F# object model member, in which case the optInst is the type instantiation
/// inferred by member overload resolution, and vrefFlags indicate if the
/// member is being used in a special way, i.e. may be one of:
/// | CtorValUsedAsSuperInit "inherit Panel()"
/// | CtorValUsedAsSelfInit "new() = new OwnType(3)"
/// | VSlotDirectCall "base.OnClick(eventArgs)"
let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst m =
let v = vref.Deref
let vrec = v.RecursiveValInfo
v.SetHasBeenReferenced()
CheckValAccessible m env.eAccessRights vref
if checkAttributes then
CheckValAttributes cenv.g vref m |> CommitOperationResult
let vty = vref.Type
// byref-typed values get dereferenced
if isByrefTy cenv.g vty then
let isSpecial = true
mkAddrGet m vref, isSpecial, destByrefTy cenv.g vty, [], tpenv
else
match v.LiteralValue with
| Some c ->
// Literal values go to constants
let isSpecial = true
// The value may still be generic, e.g.
// [<Literal>]
// let Null = null
let _,tinst,tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty
Expr.Const(c,m,tau),isSpecial,tau,tinst,tpenv
| None ->
// References to 'this' in classes get dereferenced from their implicit reference cell and poked
if v.BaseOrThisInfo = CtorThisVal && isRefCellTy cenv.g vty then
let exprForVal = exprForValRef m vref
//if AreWithinCtorPreConstruct env then
// warning(SelfRefObjCtor(AreWithinImplicitCtor env, m))
let ty = destRefCellTy cenv.g vty
let isSpecial = true
mkCallCheckThis cenv.g m ty (mkRefCellGet cenv.g m ty exprForVal), isSpecial, ty, [], tpenv
else
// Instantiate the value
let vrefFlags,tinst,tau,tpenv =
// Have we got an explicit instantiation?
match optInst with
// No explicit instantiation (the normal case)
| None ->
if HasFSharpAttribute cenv.g cenv.g.attrib_RequiresExplicitTypeArgumentsAttribute v.Attribs then
errorR(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(v.DisplayName),m))
match vrec with
| ValInRecScope false ->
let tps,tau = vref.TypeScheme
let tinst = tps |> List.map mkTyparTy
NormalValUse,tinst,tau,tpenv
| ValInRecScope true
| ValNotInRecScope ->
let _,tinst,tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty
NormalValUse,tinst,tau,tpenv
// If we have got an explicit instantiation then use that
| Some(vrefFlags,checkTys) ->
let checkInst (tinst:TypeInst) =
if not v.IsMember && not v.PermitsExplicitTypeInstantiation && tinst.Length > 0 && v.Typars.Length > 0 then
warning(Error(FSComp.SR.tcDoesNotAllowExplicitTypeArguments(v.DisplayName),m))
match vrec with
| ValInRecScope false ->
let tpsorig,tau = vref.TypeScheme
let (tinst:TypeInst),tpenv = checkTys tpenv (tpsorig |> List.map (fun tp -> tp.Kind))
checkInst tinst
if tpsorig.Length <> tinst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tpsorig.Length, tinst.Length),m))
let tau2 = instType (mkTyparInst tpsorig tinst) tau
(tpsorig, tinst) ||> List.iter2 (fun tp ty ->
try UnifyTypes cenv env m (mkTyparTy tp) ty
with _ -> error (Recursion(env.DisplayEnv,v.Id,tau2,tau,m)))
vrefFlags,tinst,tau2,tpenv
| ValInRecScope true
| ValNotInRecScope ->
let tps,tptys,tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty
//dprintfn "After Freshen: tau = %s" (Layout.showL (typeL tau))
let (tinst:TypeInst),tpenv = checkTys tpenv (tps |> List.map (fun tp -> tp.Kind))
checkInst tinst
//dprintfn "After Check: tau = %s" (Layout.showL (typeL tau))
if tptys.Length <> tinst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, tinst.Length),m))
List.iter2 (UnifyTypes cenv env m) tptys tinst
TcValEarlyGeneralizationConsistencyCheck cenv env (v, vrec, tinst, vty, tau, m)
//dprintfn "After Unify: tau = %s" (Layout.showL (typeL tau))
vrefFlags,tinst,tau,tpenv
let exprForVal = Expr.Val (vref,vrefFlags,m)
let exprForVal = mkTyAppExpr m (exprForVal,vty) tinst
let isSpecial =
(match vrefFlags with NormalValUse | PossibleConstrainedCall _ -> false | _ -> true) ||
valRefEq cenv.g vref cenv.g.splice_expr_vref ||
valRefEq cenv.g vref cenv.g.splice_raw_expr_vref
let exprForVal = RecordUseOfRecValue cenv vrec vref exprForVal m
exprForVal, isSpecial, tau, tinst, tpenv
/// simplified version of TcVal used in calls to BuildMethodCall (typrelns.fs)
/// this function is used on typechecking step for making calls to provided methods and on optimization step (for the same purpose).
let LightweightTcValForUsingInBuildMethodCall g (vref:ValRef) vrefFlags (vrefTypeInst : TTypes) m =
let v = vref.Deref
let vty = vref.Type
// byref-typed values get dereferenced
if isByrefTy g vty then
mkAddrGet m vref, destByrefTy g vty
else
match v.LiteralValue with
| Some c ->
let _,_,tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty
Expr.Const(c,m,tau),tau
| None ->
// Instantiate the value
let tau =
// If we have got an explicit instantiation then use that
let tps,tptys,tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty
if tptys.Length <> vrefTypeInst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, vrefTypeInst.Length),m));
instType (mkTyparInst tps vrefTypeInst) tau
let exprForVal = Expr.Val (vref,vrefFlags,m)
let exprForVal = mkTyAppExpr m (exprForVal,vty) vrefTypeInst
exprForVal, tau
/// Mark points where we decide whether an expression will support automatic
/// decondensation or not. This is somewhat a relic of a previous implementation of decondensation and could
/// be removed
type ApplicableExpr =
| ApplicableExpr of
// context
cenv *
// the function-valued expression
Expr *
// is this the first in an application series
bool
member x.Range =
match x with
| ApplicableExpr (_,e,_) -> e.Range
member x.Type =
match x with
| ApplicableExpr (cenv,e,_) -> tyOfExpr cenv.g e
member x.SupplyArgument(e2,m) =
let (ApplicableExpr (cenv,fe,first)) = x
let combinedExpr =
match fe with
| Expr.App(e1,e1ty,tyargs1,args1,e1m) when
(not first || isNil args1) &&
(not (isForallTy cenv.g e1ty) || isFunTy cenv.g (applyTys cenv.g e1ty (tyargs1,args1))) ->
Expr.App(e1,e1ty,tyargs1,args1@[e2],unionRanges e1m m)
| _ ->
Expr.App(fe,tyOfExpr cenv.g fe,[],[e2],m)
ApplicableExpr(cenv, combinedExpr,false)
member x.Expr =
match x with
| ApplicableExpr(_,e,_) -> e
let MakeApplicableExprNoFlex cenv expr =
ApplicableExpr (cenv,expr,true)
/// This function reverses the effect of condensation for a named function value (indeed it can
/// work for any expression, though we only invoke it immediately after a call to TcVal).
///
/// De-condensation is determined BEFORE any arguments are checked. Thus
/// let f (x:'a) (y:'a) = ()
///
/// f (new obj()) "string"
///
/// does not type check (the argument instantiates 'a to "obj" but there is no flexibility on the
/// second argument position.
///
/// De-condensation is applied AFTER taking into account an explicit type instantiation. This
/// let f<'a> (x:'a) = ()
///
/// f<obj>("string)"
///
/// will type check but
///
/// Sealed types and 'obj' do not introduce generic flexibility when functions are used as first class
/// values.
///
/// For 'obj' this is because introducing this flexibility would NOT be the reverse of condensation,
/// since we don't condense
/// f : 'a -> unit
/// to
/// f : obj -> unit
///
/// We represent the flexibility in the TAST by leaving a function-to-function coercion node in the tree
/// This "special" node is immediately eliminated by the use of IteratedFlexibleAdjustArityOfLambdaBody as soon as we
/// first transform the tree (currently in optimization)
let MakeApplicableExprWithFlex cenv (env: TcEnv) expr =
let exprTy = tyOfExpr cenv.g expr
let m = expr.Range
let isNonFlexibleType ty = isSealedTy cenv.g ty
let argTys,retTy = stripFunTy cenv.g exprTy
let curriedActualTypes = argTys |> List.map (tryDestRefTupleTy cenv.g)
if (curriedActualTypes.IsEmpty ||
curriedActualTypes |> List.exists (List.exists (isByrefTy cenv.g)) ||
curriedActualTypes |> List.forall (List.forall isNonFlexibleType)) then
ApplicableExpr (cenv,expr,true)
else
let curriedFlexibleTypes =
curriedActualTypes |> List.mapSquared (fun actualType ->
if isNonFlexibleType actualType
then actualType
else
let flexibleType = NewInferenceType ()
AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType;
flexibleType)
// Create a coercion to represent the expansion of the application
let expr = mkCoerceExpr (expr,mkIteratedFunTy (List.map (mkRefTupledTy cenv.g) curriedFlexibleTypes) retTy,m,exprTy)
ApplicableExpr (cenv,expr,true)
/// Checks, warnings and constraint assertions for downcasts
let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy =
if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then
warning(TypeTestUnnecessary(m))
if isTyparTy cenv.g srcTy then
error(IndeterminateRuntimeCoercion(denv,srcTy,tgty,m))
if isSealedTy cenv.g srcTy then
error(RuntimeCoercionSourceSealed(denv,srcTy,m))
if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then
if isCast then
AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgty
else
AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgty
if isErasedType cenv.g tgty then
if isCast then
warning(Error(FSComp.SR.tcTypeCastErased(NicePrint.minimalStringOfType denv tgty, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g tgty)), m))
else
error(Error(FSComp.SR.tcTypeTestErased(NicePrint.minimalStringOfType denv tgty, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g tgty)), m))
else
getErasedTypes cenv.g tgty |>
List.iter (fun ety -> if isMeasureTy cenv.g ety
then warning(Error(FSComp.SR.tcTypeTestLosesMeasures(NicePrint.minimalStringOfType denv ety), m))
else warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g ety)),m)))
/// Checks, warnings and constraint assertions for upcasts
let TcStaticUpcast cenv denv m tgty srcTy =
if isTyparTy cenv.g tgty then
error(IndeterminateStaticCoercion(denv,srcTy,tgty,m))
if isSealedTy cenv.g tgty then
warning(CoercionTargetSealed(denv,tgty,m))
if typeEquiv cenv.g srcTy tgty then
warning(UpcastUnnecessary(m))
AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgty srcTy
let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseFlags minst objArgs args =
let conditionalCallDefineOpt = TryFindMethInfoStringAttribute cenv.g m cenv.g.attrib_ConditionalAttribute minfo
match conditionalCallDefineOpt with
| Some d when not (List.contains d cenv.conditionalDefines) ->
// Methods marked with 'Conditional' must return 'unit'
UnifyTypes cenv env m cenv.g.unit_ty (minfo.GetFSharpReturnTy(cenv.amap, m, minst))
mkUnit cenv.g m, cenv.g.unit_ty
| _ ->
#if EXTENSIONTYPING
match minfo with
| ProvidedMeth(_, mi, _,_) ->
// BuildInvokerExpressionForProvidedMethodCall converts references to F# intrinsics back to values
// and uses TcVal to do this. However we don't want to check attributes again for provided references to values,
// so we pass 'false' for 'checkAttributes'.
let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g
let _, retExpt, retTy = ProvidedMethodCalls.BuildInvokerExpressionForProvidedMethodCall tcVal (cenv.g, cenv.amap, mi, objArgs, isMutable, isProp, valUseFlags, args, m)
retExpt, retTy
| _ ->
#endif
let tcVal valref valUse ttypes m =
let a,_, b, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) m
a, b
BuildMethodCall tcVal cenv.g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args
let TryFindIntrinsicOrExtensionMethInfo (cenv:cenv) (env: TcEnv) m ad nm ty =
AllMethInfosOfTypeInScope cenv.infoReader env.NameEnv (Some(nm),ad) IgnoreOverrides m ty
/// Build the 'test and dispose' part of a 'use' statement
let BuildDisposableCleanup cenv env m (v:Val) =
v.SetHasBeenReferenced()
let ad = env.eAccessRights
let disposeMethod =
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad "Dispose" cenv.g.system_IDisposable_typ with
| [x] -> x
| _ -> error(InternalError(FSComp.SR.tcCouldNotFindIDisposable(),m))
// For struct types the test is simpler: we can determine if IDisposable is supported, and even when it is, we can avoid doing the type test
// Note this affects the elaborated form seen by quotations etc.
if isStructTy cenv.g v.Type then
if TypeFeasiblySubsumesType 0 cenv.g cenv.amap m cenv.g.system_IDisposable_typ CanCoerce v.Type then
// We can use NeverMutates here because the variable is going out of scope, there is no need to take a defensive
// copy of it.
let disposeExpr,_ = BuildPossiblyConditionalMethodCall cenv env NeverMutates m false disposeMethod NormalValUse [] [exprForVal v.Range v] []
disposeExpr
else
mkUnit cenv.g m
else
let disposeObjVar,disposeObjExpr = Tastops.mkCompGenLocal m "objectToDispose" cenv.g.system_IDisposable_typ
let disposeExpr,_ = BuildPossiblyConditionalMethodCall cenv env PossiblyMutates m false disposeMethod NormalValUse [] [disposeObjExpr] []
let inpe = mkCoerceExpr(exprForVal v.Range v,cenv.g.obj_ty,m,v.Type)
mkIsInstConditional cenv.g m cenv.g.system_IDisposable_typ inpe disposeObjVar disposeExpr (mkUnit cenv.g m)
/// Build call to get_OffsetToStringData as part of 'fixed'
let BuildOffsetToStringData cenv env m =
let ad = env.eAccessRights
let offsetToStringDataMethod =
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad "get_OffsetToStringData" cenv.g.system_RuntimeHelpers_typ with
| [x] -> x
| _ -> error(Error(FSComp.SR.tcCouldNotFindOffsetToStringData(),m))
let offsetExpr,_ = BuildPossiblyConditionalMethodCall cenv env NeverMutates m false offsetToStringDataMethod NormalValUse [] [] []
offsetExpr
let BuildILFieldGet g amap m objExpr (finfo:ILFieldInfo) =
let fref = finfo.ILFieldRef
let isValueType = finfo.IsValueType
let valu = if isValueType then AsValue else AsObject
let tinst = finfo.TypeInst
let fieldType = finfo.FieldType (amap,m)
#if EXTENSIONTYPING
let ty = tyOfExpr g objExpr
match finfo with
| ProvidedField _ when (isErasedType g ty) ->
// we know it's accessible, and there are no attributes to check for now...
match finfo.LiteralValue with
| None ->
error (Error(FSComp.SR.tcTPFieldMustBeLiteral(), m))
| Some lit ->
Expr.Const(TcFieldInit m lit,m,fieldType)
| _ ->
#endif
let wrap,objExpr = mkExprAddrOfExpr g isValueType false NeverMutates objExpr None m
// The empty instantiation on the AbstractIL 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.EnclosingTypeRef [])
// Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr.
wrap (mkAsmExpr (([ mkNormalLdfld fspec ] @ (if finfo.IsInitOnly then [ AI_nop ] else [])), tinst,[objExpr],[fieldType],m))
let BuildILFieldSet g m objExpr (finfo:ILFieldInfo) argExpr =
let fref = finfo.ILFieldRef
let isValueType = finfo.IsValueType
let valu = if isValueType then AsValue else AsObject
let tinst = finfo.TypeInst
// The empty instantiation on the AbstractIL 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.EnclosingTypeRef [])
if finfo.IsInitOnly then error (Error (FSComp.SR.tcFieldIsReadonly(),m))
let wrap,objExpr = mkExprAddrOfExpr g isValueType false DefinitelyMutates objExpr None m
wrap (mkAsmExpr ([ mkNormalStfld fspec ], tinst,[objExpr; argExpr],[],m))
let BuildILStaticFieldSet m (finfo:ILFieldInfo) argExpr =
let fref = finfo.ILFieldRef
let isValueType = finfo.IsValueType
let valu = if isValueType then AsValue else AsObject
let tinst = finfo.TypeInst
// The empty instantiation on the AbstractIL 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.EnclosingTypeRef [])
if finfo.IsInitOnly then error (Error (FSComp.SR.tcFieldIsReadonly(),m))
mkAsmExpr ([ mkNormalStsfld fspec ], tinst,[argExpr],[],m)
let BuildRecdFieldSet g m objExpr (rfinfo:RecdFieldInfo) argExpr =
let tgty = rfinfo.EnclosingType
let valu = isStructTy g tgty
let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,m,tyOfExpr g objExpr)
let wrap,objExpr = mkExprAddrOfExpr g valu false DefinitelyMutates objExpr None m
wrap (mkRecdFieldSetViaExprAddr (objExpr,rfinfo.RecdFieldRef,rfinfo.TypeInst,argExpr,m) )
//-------------------------------------------------------------------------
// Helpers dealing with named and optional args at callsites
//-------------------------------------------------------------------------
let (|BinOpExpr|_|) e =
match e with
| SynExpr.App (_, _, SynExpr.App(_, _, SingleIdent opId, a, _), b, _) -> Some (opId,a,b)
| _ -> None
let (|SimpleEqualsExpr|_|) e =
match e with
| BinOpExpr(opId,a,b) when opId.idText = opNameEquals -> Some (a,b)
| _ -> None
// For join clauses that join on nullable, we syntactically insert the creation of nullable values on the appropriate side of the condition,
// then pull the syntax apart again
let (|JoinRelation|_|) cenv env (e:SynExpr) =
let m = e.Range
let ad = env.eAccessRights
let isOpName opName vref s =
(s = opName) &&
match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default [ident(opName,m)] with
| Item.Value vref2, [] -> valRefEq cenv.g vref vref2
| _ -> false
match e with
| BinOpExpr(opId,a,b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> Some (a,b)
| BinOpExpr(opId,a,b) when isOpName opNameEqualsNullable cenv.g.equals_nullable_operator_vref opId.idText ->
let a = SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [MangledGlobalName;"System"] "Nullable",a,a.Range)
Some (a,b)
| BinOpExpr(opId,a,b) when isOpName opNameNullableEquals cenv.g.nullable_equals_operator_vref opId.idText ->
let b = SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet b.Range [MangledGlobalName;"System"] "Nullable",b,b.Range)
Some (a,b)
| BinOpExpr(opId,a,b) when isOpName opNameNullableEqualsNullable cenv.g.nullable_equals_nullable_operator_vref opId.idText ->
Some (a,b)
| _ -> None
/// Detect a named argument at a callsite
let TryGetNamedArg e =
match e with
| SimpleEqualsExpr(LongOrSingleIdent(isOpt,LongIdentWithDots([a],_),None,_),b) -> Some(isOpt,a,b)
| _ -> None
let inline IsNamedArg e =
match e with
| SimpleEqualsExpr(LongOrSingleIdent(_,LongIdentWithDots([_],_),None,_),_) -> true
| _ -> false
/// Get the method arguments at a callsite, taking into account named and optional arguments
let GetMethodArgs arg =
let args =
match arg with
| SynExpr.Const (SynConst.Unit,_) -> []
| SynExprParen(SynExpr.Tuple (args,_,_),_,_,_) | SynExpr.Tuple (args,_,_) -> args
| SynExprParen(arg,_,_,_) | arg -> [arg]
let unnamedCallerArgs,namedCallerArgs =
args |> List.takeUntil IsNamedArg
let namedCallerArgs =
namedCallerArgs
|> List.choose (fun e ->
match TryGetNamedArg e with
| None ->
// ignore errors to avoid confusing error messages in cases like foo(a = 1,)
// do not abort overload resolution in case if named arguments are mixed with errors
match e with
| SynExpr.ArbitraryAfterError _ -> None
| _ -> error(Error(FSComp.SR.tcNameArgumentsMustAppearLast(), e.Range))
| namedArg -> namedArg)
unnamedCallerArgs, namedCallerArgs
//-------------------------------------------------------------------------
// Helpers dealing with pattern match compilation
//-------------------------------------------------------------------------
let CompilePatternForMatch cenv (env: TcEnv) mExpr matchm warnOnUnused actionOnFailure (v,generalizedTypars) clauses inputTy resultTy =
let dtree,targets = CompilePattern cenv.g env.DisplayEnv cenv.amap mExpr matchm warnOnUnused actionOnFailure (v,generalizedTypars) clauses inputTy resultTy
mkAndSimplifyMatch NoSequencePointAtInvisibleBinding mExpr matchm resultTy dtree targets
/// Compile a pattern
let CompilePatternForMatchClauses cenv env mExpr matchm warnOnUnused actionOnFailure inputTy resultTy tclauses =
// Avoid creating a dummy in the common cases where we are about to bind a name for the expression
// CLEANUP: avoid code duplication with code further below, i.e.all callers should call CompilePatternForMatch
match tclauses with
| [TClause(TPat_as (pat1,PBind (v,TypeScheme(generalizedTypars,_)),_),None,TTarget(vs,e,spTarget),m2)] ->
let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (v,generalizedTypars) [TClause(pat1,None,TTarget(ListSet.remove valEq v vs,e,spTarget),m2)] inputTy resultTy
v,expr
| _ ->
let idv,_ = Tastops.mkCompGenLocal mExpr "matchValue" inputTy
let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (idv,[]) tclauses inputTy resultTy
idv,expr
//-------------------------------------------------------------------------
// Helpers dealing with sequence expressions
//-------------------------------------------------------------------------
/// Get the fragmentary expressions resulting from turning
/// an expression into an enumerable value, e.g. at 'for' loops
// localAlloc is relevant if the enumerator is a mutable struct and indicates
// if the enumerator can be allocated as a mutable local variable
let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr =
let ad = env.eAccessRights
let err k ty =
let txt = NicePrint.minimalStringOfType env.DisplayEnv ty
let msg = if k then FSComp.SR.tcTypeCannotBeEnumerated(txt) else FSComp.SR.tcEnumTypeCannotBeEnumerated(txt)
Exception(Error(msg,m))
let findMethInfo k m nm ty =
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad nm ty with
| [] -> err k ty
| res :: _ -> Result res
// Ensure there are no curried arguments, and indeed no arguments at all
let hasArgs (minfo:MethInfo) minst =
match minfo.GetParamTypes(cenv.amap, m, minst) with
| [[]] -> false
| _ -> true
let tryType (exprToSearchForGetEnumeratorAndItem,tyToSearchForGetEnumeratorAndItem) =
match findMethInfo true m "GetEnumerator" tyToSearchForGetEnumeratorAndItem with
| Exception e -> Exception e
| Result getEnumerator_minfo ->
let getEnumerator_minst = FreshenMethInfo m getEnumerator_minfo
let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnTy(cenv.amap, m, getEnumerator_minst)
if hasArgs getEnumerator_minfo getEnumerator_minst then err true tyToSearchForGetEnumeratorAndItem else
match findMethInfo false m "MoveNext" retTypeOfGetEnumerator with
| Exception e -> Exception e
| Result moveNext_minfo ->
let moveNext_minst = FreshenMethInfo m moveNext_minfo
let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnTy(cenv.amap, m, moveNext_minst)
if not (typeEquiv cenv.g cenv.g.bool_ty retTypeOfMoveNext) then err false retTypeOfGetEnumerator else
if hasArgs moveNext_minfo moveNext_minst then err false retTypeOfGetEnumerator else
match findMethInfo false m "get_Current" retTypeOfGetEnumerator with
| Exception e -> Exception e
| Result get_Current_minfo ->
let get_Current_minst = FreshenMethInfo m get_Current_minfo
if hasArgs get_Current_minfo get_Current_minst then err false retTypeOfGetEnumerator else
let enumElemTy = get_Current_minfo.GetFSharpReturnTy(cenv.amap, m, get_Current_minst)
// Compute the element type of the strongly typed enumerator
//
// Like C#, we detect the 'GetEnumerator' pattern for .NET version 1.x abstractions that don't
// support the correct generic interface. However unlike C# we also go looking for a 'get_Item' or 'Item' method
// with a single integer indexer argument to try to get a strong type for the enumeration should the Enumerator
// not provide anything useful. To enable interop with some legacy COM APIs,
// the single integer indexer argument is allowed to have type 'object'.
let enumElemTy =
if isObjTy cenv.g enumElemTy then
// Look for an 'Item' property, or a set of these with consistent return types
let allEquivReturnTypes (minfo:MethInfo) (others:MethInfo list) =
let returnTy = minfo.GetFSharpReturnTy(cenv.amap, m, [])
others |> List.forall (fun other -> typeEquiv cenv.g (other.GetFSharpReturnTy(cenv.amap, m, [])) returnTy)
let isInt32OrObjectIndexer (minfo:MethInfo) =
match minfo.GetParamTypes(cenv.amap, m, []) with
| [[ty]] ->
// e.g. MatchCollection
typeEquiv cenv.g cenv.g.int32_ty ty ||
// e.g. EnvDTE.Documents.Item
typeEquiv cenv.g cenv.g.obj_ty ty
| _ -> false
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad "get_Item" tyToSearchForGetEnumeratorAndItem with
| (minfo :: others) when (allEquivReturnTypes minfo others &&
List.exists isInt32OrObjectIndexer (minfo :: others)) ->
minfo.GetFSharpReturnTy(cenv.amap, m, [])
| _ ->
// Some types such as XmlNodeList have only an Item method
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad "Item" tyToSearchForGetEnumeratorAndItem with
| (minfo :: others) when (allEquivReturnTypes minfo others &&
List.exists isInt32OrObjectIndexer (minfo :: others)) ->
minfo.GetFSharpReturnTy(cenv.amap, m, [])
| _ -> enumElemTy
else
enumElemTy
let isEnumeratorTypeStruct = isStructTy cenv.g retTypeOfGetEnumerator
let originalRetTypeOfGetEnumerator = retTypeOfGetEnumerator
let (enumeratorVar,enumeratorExpr), retTypeOfGetEnumerator =
if isEnumeratorTypeStruct then
if localAlloc then
Tastops.mkMutableCompGenLocal m "enumerator" retTypeOfGetEnumerator, retTypeOfGetEnumerator
else
let refCellTyForRetTypeOfGetEnumerator = mkRefCellTy cenv.g retTypeOfGetEnumerator
let v,e = Tastops.mkMutableCompGenLocal m "enumerator" refCellTyForRetTypeOfGetEnumerator
(v, mkRefCellGet cenv.g m retTypeOfGetEnumerator e), refCellTyForRetTypeOfGetEnumerator
else
Tastops.mkCompGenLocal m "enumerator" retTypeOfGetEnumerator, retTypeOfGetEnumerator
let getEnumExpr, getEnumTy =
let (getEnumExpr, getEnumTy) as res = BuildPossiblyConditionalMethodCall cenv env PossiblyMutates m false getEnumerator_minfo NormalValUse getEnumerator_minst [exprToSearchForGetEnumeratorAndItem] []
if not isEnumeratorTypeStruct || localAlloc then res
else
// wrap enumerators that are represented as mutable structs into ref cells
let getEnumExpr = mkRefCell cenv.g m originalRetTypeOfGetEnumerator getEnumExpr
let getEnumTy = mkRefCellTy cenv.g getEnumTy
getEnumExpr, getEnumTy
let guardExpr ,guardTy = BuildPossiblyConditionalMethodCall cenv env DefinitelyMutates m false moveNext_minfo NormalValUse moveNext_minst [enumeratorExpr] []
let currentExpr,currentTy = BuildPossiblyConditionalMethodCall cenv env DefinitelyMutates m true get_Current_minfo NormalValUse get_Current_minst [enumeratorExpr] []
let betterCurrentExpr = mkCoerceExpr(currentExpr,enumElemTy,currentExpr.Range,currentTy)
Result(enumeratorVar, enumeratorExpr,retTypeOfGetEnumerator,enumElemTy,getEnumExpr,getEnumTy, guardExpr,guardTy, betterCurrentExpr)
// First try the original known static type
match (if isArray1DTy cenv.g exprty then Exception (Failure "") else tryType (expr,exprty)) with
| Result res -> res
| Exception e ->
let probe ty =
if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ty exprty) then
match tryType (mkCoerceExpr(expr,ty,expr.Range,exprty),ty) with
| Result res -> Some res
| Exception e ->