[Pkg-cli-apps-commits] [fsharp] 08/71: Clean commit of Microsoft code drop for F# Compiler 3.1 from http://fsharppowerpack.codeplex.com/SourceControl/list/changesets change 72229
Christopher Halse Rogers
raof-guest at moszumanska.debian.org
Fri Jan 17 05:18:07 UTC 2014
This is an automated email from the git hooks/post-receive script.
raof-guest pushed a commit to tag 3.1.0
in repository fsharp.
commit d4e8b9b09a839b082ee8175d3670018054fe98c0
Author: Don Syme <donsyme at fastmail.fm>
Date: Thu Oct 3 10:58:26 2013 +0100
Clean commit of Microsoft code drop for F# Compiler 3.1 from http://fsharppowerpack.codeplex.com/SourceControl/list/changesets change 72229
---
src/absil/il.fs | 736 +++---
src/absil/il.fsi | 103 +-
src/absil/ilascii.fs | 3 +-
src/absil/illib.fs | 506 +---
src/absil/ilpars.fsy | 9 +-
src/absil/ilprint.fs | 39 +-
src/absil/ilread.fs | 12 +-
src/absil/ilread.fsi | 2 +-
src/absil/ilreflect.fs | 43 +-
src/absil/ilsupp.fs | 32 +-
src/absil/ilsupp.fsi | 1 +
src/absil/ilwrite.fs | 76 +-
src/absil/ilwrite.fsi | 2 +-
src/absil/zmap.fs | 13 +-
src/absil/zmap.fsi | 13 +-
src/absil/zset.fs | 11 +-
src/absil/zset.fsi | 11 +-
src/fsharp/ErrorLogger.fs | 5 +
src/fsharp/FSComp.txt | 31 +-
.../FSharp.Build-proto/FSharp.Build-proto.fsproj | 14 +-
src/fsharp/FSharp.Build/FSharp.Build.fsproj | 22 +-
src/fsharp/FSharp.Build/Fsc.fs | 21 +-
src/fsharp/FSharp.Build/Fsc.fsi | 3 +
.../FSharp.Compiler.Interactive.Settings.fsproj | 10 -
.../FSharp.Compiler.Server.Shared.fsproj | 10 -
.../FSharp.Compiler.Silverlight.fsproj | 2 +
src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj | 26 +-
.../FSharp.Core.Unittests.fsproj | 24 +-
.../FSharp.Core.Unittests/SurfaceArea.2.0.fs | 5 +-
.../FSharp.Core.Unittests/SurfaceArea.4.0.fs | 27 +
.../FSharp.Core.Unittests/SurfaceArea.Portable.fs | 27 +
src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs | 19 +-
src/fsharp/FSharp.Core/Linq.fs | 50 +-
src/fsharp/FSharp.Core/Query.fs | 137 +-
src/fsharp/FSharp.Core/QueryExtensions.fs | 8 +
src/fsharp/FSharp.Core/SR.fs | 6 +
src/fsharp/FSharp.Core/control.fs | 153 +-
src/fsharp/FSharp.Core/control.fsi | 1 -
src/fsharp/FSharp.Core/event.fs | 7 +-
src/fsharp/FSharp.Core/prim-types.fs | 216 +-
src/fsharp/FSharp.Core/prim-types.fsi | 56 +-
src/fsharp/FSharp.Core/printf.fs | 1791 +++++++++-----
src/fsharp/FSharp.Core/quotations.fs | 423 +++-
src/fsharp/FSharp.Core/reflect.fs | 366 ++-
src/fsharp/FSharp.Core/reflect.fsi | 376 ++-
src/fsharp/FSharp.Core/seq.fs | 2 +-
src/fsharp/FSharp.Data.TypeProviders/Util.fsi | 3 -
src/fsharp/Fsc-proto/Fsc-proto.fsproj | 14 +-
src/fsharp/Fsc/Fsc.fsproj | 12 +-
src/fsharp/InternalFileSystemUtils.fs | 5 +
src/fsharp/InternalFileSystemUtils.fsi | 4 +
src/fsharp/NicePrint.fs | 91 +-
src/fsharp/ReferenceResolution.fs | 107 +-
src/fsharp/ReferenceResolution.fsi | 3 +
src/fsharp/Salsa/VsMocks.fs | 41 +-
src/fsharp/ast.fs | 80 +-
src/fsharp/build.fs | 559 +++--
src/fsharp/build.fsi | 61 +-
src/fsharp/check.fs | 37 +-
src/fsharp/creflect.fs | 201 +-
src/fsharp/csolve.fs | 287 +--
src/fsharp/csolve.fsi | 5 +-
src/fsharp/detuple.fs | 2 +-
src/fsharp/env.fs | 141 +-
src/fsharp/est.fs | 7 +-
src/fsharp/est.fsi | 3 +-
src/fsharp/fsc.fs | 419 +++-
src/fsharp/fsc.fsi | 28 +-
src/fsharp/fscmain.fs | 43 +-
src/fsharp/fscopts.fs | 20 +-
src/fsharp/fsi/FSIstrings.txt | 2 +
src/fsharp/fsi/Fsi.fsproj | 12 +-
src/fsharp/fsi/fsi.exe.config | 18 +-
src/fsharp/fsi/fsi.fs | 130 +-
src/fsharp/fsi/fsiAnyCPU.exe.config | 18 +-
src/fsharp/fsi/fsimain.fs | 29 +-
src/fsharp/ilxgen.fs | 179 +-
src/fsharp/import.fs | 31 +-
src/fsharp/import.fsi | 2 +-
src/fsharp/infos.fs | 1901 +++++++-------
src/fsharp/lexhelp.fs | 4 +-
src/fsharp/lexhelp.fsi | 2 -
src/fsharp/lowertop.fs | 4 +-
src/fsharp/nameres.fs | 1016 ++++----
src/fsharp/nameres.fsi | 48 +-
src/fsharp/opt.fs | 12 +-
src/fsharp/pars.fsy | 102 +-
src/fsharp/patcompile.fs | 15 +-
src/fsharp/range.fs | 2 +-
src/fsharp/range.fsi | 2 +-
src/fsharp/sreflect.fs | 1 +
src/fsharp/sreflect.fsi | 2 +-
src/fsharp/tast.fs | 8 +-
src/fsharp/tastops.fs | 290 ++-
src/fsharp/tastops.fsi | 32 +-
src/fsharp/tc.fs | 2600 +++++++++++---------
src/fsharp/tc.fsi | 2 +-
src/fsharp/tlr.fs | 32 +-
src/fsharp/typrelns.fs | 631 +++--
src/fsharp/unilex.fs | 2 +-
src/fsharp/unilex.fsi | 2 +-
src/fsharp/unittests/TestLib.ProjectSystem.fs | 20 +-
.../unittests/Tests.LanguageService.Completion.fs | 172 +-
.../unittests/Tests.LanguageService.General.fs | 2 +-
.../Tests.LanguageService.GotoDefinition.fs | 38 +-
.../Tests.LanguageService.ParameterInfo.fs | 71 +-
.../unittests/Tests.LanguageService.QuickInfo.fs | 108 +-
.../unittests/Tests.LanguageService.Script.fs | 40 +-
.../unittests/Tests.ProjectSystem.Miscellaneous.fs | 6 +-
.../unittests/Tests.ProjectSystem.References.fs | 111 +-
src/fsharp/unittests/Tests.TypeProvidersImpl.fs | 2 +-
src/fsharp/vs/IncrementalBuild.fs | 10 +-
src/fsharp/vs/IncrementalBuild.fsi | 10 +-
src/fsharp/vs/ServiceDeclarations.fs | 100 +-
src/fsharp/vs/ServiceDeclarations.fsi | 11 +-
src/fsharp/vs/ServiceLexing.fs | 11 +-
src/fsharp/vs/ServiceLexing.fsi | 18 +-
src/fsharp/vs/ServiceParseTreeWalk.fs | 8 +-
src/fsharp/vs/ServiceUntypedParse.fs | 65 +-
src/fsharp/vs/ServiceUntypedParse.fsi | 4 +-
src/fsharp/vs/SimpleServices.fs | 17 +-
src/fsharp/vs/service.fs | 97 +-
src/fsharp/vs/service.fsi | 31 +-
src/ilx/cu_erase.fs | 4 +-
src/utils/CompilerLocationUtils.fs | 17 +-
src/utils/TaggedCollections.fs | 26 +-
src/utils/prim-lexing.fs | 4 +-
src/utils/prim-lexing.fsi | 4 +-
src/utils/sformat.fs | 101 +-
src/utils/sformat.fsi | 9 +
130 files changed, 9811 insertions(+), 6060 deletions(-)
diff --git a/src/absil/il.fs b/src/absil/il.fs
index 699bee0..ae0a031 100755
--- a/src/absil/il.fs
+++ b/src/absil/il.fs
@@ -467,18 +467,29 @@ type ILAssemblyRef(data) =
assemRefLocale=locale; }
static member FromAssemblyName (aname:System.Reflection.AssemblyName) =
- let culture = None
- let locale = None
+ let locale = None
+ //match aname.CultureInfo with
+ // | null -> None
+ // | x -> Some x.Name
+ let publicKey =
+ match aname.GetPublicKey() with
+ | null | [| |] ->
+ match aname.GetPublicKeyToken() with
+ | null | [| |] -> None
+ | bytes -> Some (PublicKeyToken bytes)
+ | bytes ->
+ Some (PublicKey bytes)
+
let version =
- let v = aname.Version
- Some(uint16 v.Major,uint16 v.Minor,uint16 v.Build,uint16 v.Revision)
- let key =
- match aname.GetPublicKeyToken() with
- | null | [| |] -> None
- | bytes -> Some (PublicKeyToken bytes)
- let retargetable = (aname.Flags = System.Reflection.AssemblyNameFlags.Retargetable)
- ILAssemblyRef.Create(aname.Name,culture,key,retargetable,version,locale)
-
+ match aname.Version with
+ | null -> None
+ | v -> Some (uint16 v.Major,uint16 v.Minor,uint16 v.Build,uint16 v.Revision)
+
+ let retargetable = aname.Flags = System.Reflection.AssemblyNameFlags.Retargetable
+
+ ILAssemblyRef.Create(aname.Name,None,publicKey,retargetable,version,locale)
+
+
member aref.QualifiedName =
let b = new System.Text.StringBuilder(100)
@@ -554,7 +565,7 @@ type ILScopeRef =
| ILScopeRef.Assembly aref when aref.Name = "mscorlib" -> ""
| ILScopeRef.Assembly aref -> aref.QualifiedName
- member scoref.QualifiedNameWithNoShortMscorlib =
+ member scoref.QualifiedNameWithNoShortPrimaryAssembly =
match scoref with
| ILScopeRef.Local -> ""
| ILScopeRef.Module mref -> "module "+mref.Name
@@ -672,12 +683,12 @@ type ILTypeRef =
member tref.BasicQualifiedName =
String.concat "+" (tref.Enclosing @ [ tref.Name ])
- member tref.AddQualifiedNameExtensionWithNoShortMscorlib(basic) =
- let sco = tref.Scope.QualifiedNameWithNoShortMscorlib
+ member tref.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic) =
+ let sco = tref.Scope.QualifiedNameWithNoShortPrimaryAssembly
if sco = "" then basic else String.concat ", " [basic;sco]
- member tref.QualifiedNameWithNoShortMscorlib =
- tref.AddQualifiedNameExtensionWithNoShortMscorlib(tref.BasicQualifiedName)
+ member tref.QualifiedNameWithNoShortPrimaryAssembly =
+ tref.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(tref.BasicQualifiedName)
member tref.QualifiedName =
let basic = tref.BasicQualifiedName
@@ -706,10 +717,10 @@ and
if ILList.isEmpty x.GenericArgs then
tc
else
- tc + "[" + String.concat "," (x.GenericArgs |> ILList.map (fun arg -> "[" + arg.QualifiedNameWithNoShortMscorlib + "]")) + "]"
+ tc + "[" + String.concat "," (x.GenericArgs |> ILList.map (fun arg -> "[" + arg.QualifiedNameWithNoShortPrimaryAssembly + "]")) + "]"
- member x.AddQualifiedNameExtensionWithNoShortMscorlib(basic) =
- x.TypeRef.AddQualifiedNameExtensionWithNoShortMscorlib(basic)
+ member x.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic) =
+ x.TypeRef.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic)
member x.FullName=x.TypeRef.FullName
@@ -736,19 +747,19 @@ and [<RequireQualifiedAccess; StructuralEquality; StructuralComparison>]
| ILType.Byref _ty -> failwith "unexpected byref type"
| ILType.FunctionPointer _mref -> failwith "unexpected function pointer type"
- member x.AddQualifiedNameExtensionWithNoShortMscorlib(basic) =
+ member x.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic) =
match x with
| ILType.TypeVar _n -> basic
- | ILType.Modified(_,_ty1,ty2) -> ty2.AddQualifiedNameExtensionWithNoShortMscorlib(basic)
- | ILType.Array (ILArrayShape(_s),ty) -> ty.AddQualifiedNameExtensionWithNoShortMscorlib(basic)
- | ILType.Value tr | ILType.Boxed tr -> tr.AddQualifiedNameExtensionWithNoShortMscorlib(basic)
+ | ILType.Modified(_,_ty1,ty2) -> ty2.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic)
+ | ILType.Array (ILArrayShape(_s),ty) -> ty.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic)
+ | ILType.Value tr | ILType.Boxed tr -> tr.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(basic)
| ILType.Void -> failwith "void"
| ILType.Ptr _ty -> failwith "unexpected pointer type"
| ILType.Byref _ty -> failwith "unexpected byref type"
| ILType.FunctionPointer _mref -> failwith "unexpected function pointer type"
- member x.QualifiedNameWithNoShortMscorlib =
- x.AddQualifiedNameExtensionWithNoShortMscorlib(x.BasicQualifiedName)
+ member x.QualifiedNameWithNoShortPrimaryAssembly =
+ x.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(x.BasicQualifiedName)
and
[<CustomEquality; CustomComparison>]
@@ -2384,122 +2395,182 @@ let destILArrTy ty = match ty with ILType.Array(shape,ty) -> (shape,ty) | _ -> f
// Sigs of special types built-in
// --------------------------------------------------------------------
+[<Literal>]
let tname_Object = "System.Object"
+[<Literal>]
let tname_String = "System.String"
+[<Literal>]
let tname_StringBuilder = "System.Text.StringBuilder"
+[<Literal>]
let tname_AsyncCallback = "System.AsyncCallback"
+[<Literal>]
let tname_IAsyncResult = "System.IAsyncResult"
+[<Literal>]
let tname_IComparable = "System.IComparable"
+[<Literal>]
let tname_Exception = "System.Exception"
+[<Literal>]
let tname_Type = "System.Type"
+[<Literal>]
let tname_Missing = "System.Reflection.Missing"
+[<Literal>]
let tname_Activator = "System.Activator"
+[<Literal>]
let tname_SerializationInfo = "System.Runtime.Serialization.SerializationInfo"
+[<Literal>]
let tname_StreamingContext = "System.Runtime.Serialization.StreamingContext"
+[<Literal>]
let tname_SecurityPermissionAttribute = "System.Security.Permissions.SecurityPermissionAttribute"
+[<Literal>]
let tname_Delegate = "System.Delegate"
+[<Literal>]
let tname_ValueType = "System.ValueType"
+[<Literal>]
let tname_TypedReference = "System.TypedReference"
+[<Literal>]
let tname_Enum = "System.Enum"
+[<Literal>]
let tname_MulticastDelegate = "System.MulticastDelegate"
+[<Literal>]
let tname_Array = "System.Array"
-
+[<Literal>]
let tname_Int64 = "System.Int64"
+[<Literal>]
let tname_UInt64 = "System.UInt64"
+[<Literal>]
let tname_Int32 = "System.Int32"
+[<Literal>]
let tname_UInt32 = "System.UInt32"
+[<Literal>]
let tname_Int16 = "System.Int16"
+[<Literal>]
let tname_UInt16 = "System.UInt16"
+[<Literal>]
let tname_SByte = "System.SByte"
+[<Literal>]
let tname_Byte = "System.Byte"
+[<Literal>]
let tname_Single = "System.Single"
+[<Literal>]
let tname_Double = "System.Double"
+[<Literal>]
let tname_Bool = "System.Boolean"
+[<Literal>]
let tname_Char = "System.Char"
+[<Literal>]
let tname_IntPtr = "System.IntPtr"
+[<Literal>]
let tname_UIntPtr = "System.UIntPtr"
+[<Literal>]
let tname_RuntimeArgumentHandle = "System.RuntimeArgumentHandle"
+[<Literal>]
let tname_RuntimeTypeHandle = "System.RuntimeTypeHandle"
+[<Literal>]
let tname_RuntimeMethodHandle = "System.RuntimeMethodHandle"
+[<Literal>]
let tname_RuntimeFieldHandle = "System.RuntimeFieldHandle"
+/// Represents the capabilities of target framework profile.
+/// Different profiles may omit some types or contain them in different assemblies
+type IPrimaryAssemblyTraits =
+
+ abstract TypedReferenceTypeScopeRef : ILScopeRef option
+ abstract RuntimeArgumentHandleTypeScopeRef : ILScopeRef option
+ abstract SerializationInfoTypeScopeRef : ILScopeRef option
+ abstract SecurityPermissionAttributeTypeScopeRef : ILScopeRef option
+ abstract IDispatchConstantAttributeScopeRef : ILScopeRef option
+ abstract IUnknownConstantAttributeScopeRef : ILScopeRef option
+ abstract ArgIteratorTypeScopeRef : ILScopeRef option
+ abstract MarshalByRefObjectScopeRef : ILScopeRef option
+ abstract ThreadStaticAttributeScopeRef : ILScopeRef option
+ abstract SpecialNameAttributeScopeRef : ILScopeRef option
+ abstract ContextStaticAttributeScopeRef : ILScopeRef option
+ abstract NonSerializedAttributeScopeRef : ILScopeRef option
+
+ abstract SystemRuntimeInteropServicesScopeRef : Lazy<ILScopeRef>
+ abstract SystemLinqExpressionsScopeRef : Lazy<ILScopeRef>
+ abstract SystemCollectionsScopeRef : Lazy<ILScopeRef>
+ abstract SystemReflectionScopeRef : Lazy<ILScopeRef>
+ abstract SystemDiagnosticsDebugScopeRef : Lazy<ILScopeRef>
+ abstract ScopeRef : ILScopeRef
+
[<NoEquality; NoComparison>]
type ILGlobals =
- { mscorlibScopeRef: ILScopeRef;
- mscorlibAssemblyName: string;
+ { traits : IPrimaryAssemblyTraits
+ primaryAssemblyName : string
noDebugData: bool;
tref_Object: ILTypeRef
- ; tspec_Object: ILTypeSpec
- ; typ_Object: ILType
- ; tref_String: ILTypeRef
- ; typ_String: ILType
- ; typ_StringBuilder: ILType
- ; typ_AsyncCallback: ILType
- ; typ_IAsyncResult: ILType
- ; typ_IComparable: ILType
- ; tref_Type: ILTypeRef
- ; typ_Type: ILType
- ; typ_Missing: ILType
- ; typ_Activator: ILType
- ; typ_Delegate: ILType
- ; typ_ValueType: ILType
- ; typ_Enum: ILType
- ; tspec_TypedReference: ILTypeSpec
- ; typ_TypedReference: ILType
- ; typ_MulticastDelegate: ILType
- ; typ_Array: ILType
- ; tspec_Int64: ILTypeSpec
- ; tspec_UInt64: ILTypeSpec
- ; tspec_Int32: ILTypeSpec
- ; tspec_UInt32: ILTypeSpec
- ; tspec_Int16: ILTypeSpec
- ; tspec_UInt16: ILTypeSpec
- ; tspec_SByte: ILTypeSpec
- ; tspec_Byte: ILTypeSpec
- ; tspec_Single: ILTypeSpec
- ; tspec_Double: ILTypeSpec
- ; tspec_IntPtr: ILTypeSpec
- ; tspec_UIntPtr: ILTypeSpec
- ; tspec_Char: ILTypeSpec
- ; tspec_Bool: ILTypeSpec
- ; typ_int8: ILType
- ; typ_int16: ILType
- ; typ_int32: ILType
- ; typ_int64: ILType
- ; typ_uint8: ILType
- ; typ_uint16: ILType
- ; typ_uint32: ILType
- ; typ_uint64: ILType
- ; typ_float32: ILType
- ; typ_float64: ILType
- ; typ_bool: ILType
- ; typ_char: ILType
- ; typ_IntPtr: ILType
- ; typ_UIntPtr: ILType
- ; typ_RuntimeArgumentHandle: ILType
- ; typ_RuntimeTypeHandle: ILType
- ; typ_RuntimeMethodHandle: ILType
- ; typ_RuntimeFieldHandle: ILType
- ; typ_Byte: ILType
- ; typ_Int16: ILType
- ; typ_Int32: ILType
- ; typ_Int64: ILType
- ; typ_SByte: ILType
- ; typ_UInt16: ILType
- ; typ_UInt32: ILType
- ; typ_UInt64: ILType
- ; typ_Single: ILType
- ; typ_Double: ILType
- ; typ_Bool: ILType
- ; typ_Char: ILType
- ; typ_SerializationInfo: ILType
- ; typ_StreamingContext: ILType
- ; tref_SecurityPermissionAttribute: ILTypeRef
- ; tspec_Exception: ILTypeSpec
- ; typ_Exception: ILType
- ; mutable generatedAttribsCache: ILAttribute list
- ; mutable debuggerBrowsableNeverAttributeCache : ILAttribute option
- ; mutable debuggerTypeProxyAttributeCache : ILAttribute option }
+ tspec_Object: ILTypeSpec
+ typ_Object: ILType
+ tref_String: ILTypeRef
+ typ_String: ILType
+ typ_StringBuilder: ILType
+ typ_AsyncCallback: ILType
+ typ_IAsyncResult: ILType
+ typ_IComparable: ILType
+ tref_Type: ILTypeRef
+ typ_Type: ILType
+ typ_Missing: Lazy<ILType>
+ typ_Activator: ILType
+ typ_Delegate: ILType
+ typ_ValueType: ILType
+ typ_Enum: ILType
+ tspec_TypedReference: ILTypeSpec option
+ typ_TypedReference: ILType option
+ typ_MulticastDelegate: ILType
+ typ_Array: ILType
+ tspec_Int64: ILTypeSpec
+ tspec_UInt64: ILTypeSpec
+ tspec_Int32: ILTypeSpec
+ tspec_UInt32: ILTypeSpec
+ tspec_Int16: ILTypeSpec
+ tspec_UInt16: ILTypeSpec
+ tspec_SByte: ILTypeSpec
+ tspec_Byte: ILTypeSpec
+ tspec_Single: ILTypeSpec
+ tspec_Double: ILTypeSpec
+ tspec_IntPtr: ILTypeSpec
+ tspec_UIntPtr: ILTypeSpec
+ tspec_Char: ILTypeSpec
+ tspec_Bool: ILTypeSpec
+ typ_int8: ILType
+ typ_int16: ILType
+ typ_int32: ILType
+ typ_int64: ILType
+ typ_uint8: ILType
+ typ_uint16: ILType
+ typ_uint32: ILType
+ typ_uint64: ILType
+ typ_float32: ILType
+ typ_float64: ILType
+ typ_bool: ILType
+ typ_char: ILType
+ typ_IntPtr: ILType
+ typ_UIntPtr: ILType
+ typ_RuntimeArgumentHandle: ILType option
+ typ_RuntimeTypeHandle: ILType
+ typ_RuntimeMethodHandle: ILType
+ typ_RuntimeFieldHandle: ILType
+ typ_Byte: ILType
+ typ_Int16: ILType
+ typ_Int32: ILType
+ typ_Int64: ILType
+ typ_SByte: ILType
+ typ_UInt16: ILType
+ typ_UInt32: ILType
+ typ_UInt64: ILType
+ typ_Single: ILType
+ typ_Double: ILType
+ typ_Bool: ILType
+ typ_Char: ILType
+ typ_SerializationInfo: ILType option
+ typ_StreamingContext: ILType
+ tref_SecurityPermissionAttribute: ILTypeRef option
+ tspec_Exception: ILTypeSpec
+ typ_Exception: ILType
+ mutable generatedAttribsCache: ILAttribute list
+ mutable debuggerBrowsableNeverAttributeCache : ILAttribute option
+ mutable debuggerTypeProxyAttributeCache : ILAttribute option }
override x.ToString() = "<ILGlobals>"
let mkNormalCall mspec = I_call (Normalcall, mspec, None)
@@ -2530,100 +2601,115 @@ let tname_CompilerGeneratedAttribute = "System.Runtime.CompilerServices.Compiler
let tname_DebuggableAttribute = "System.Diagnostics.DebuggableAttribute"
-let mkILGlobals mscorlibScopeRef mscorlibAssemblyNameOpt noDebugData =
- let mscorlibAssemblyName =
- match mscorlibAssemblyNameOpt with
- | Some name -> name
- | None -> (match mscorlibScopeRef with
- | ILScopeRef.Assembly assref -> assref.Name
- | _ -> failwith "mkILGlobals: mscorlib ILScopeRef is not an assembly ref")
- let tref_Object = mkILTyRef (mscorlibScopeRef,tname_Object)
+let mkILGlobals (traits : IPrimaryAssemblyTraits) primaryAssemblyNameOpt noDebugData =
+ let primaryAssemblyName =
+ match primaryAssemblyNameOpt with
+ | Some name -> name
+ | None ->
+ match traits.ScopeRef with
+ | ILScopeRef.Assembly assembly -> assembly.Name
+ | _ -> failwith "mkILGlobals: system runtime ILScopeRef is not an assembly ref"
+ let systemRuntimeScopeRef = traits.ScopeRef
+ let tref_Object = mkILTyRef (systemRuntimeScopeRef, tname_Object)
let tspec_Object = mkILNonGenericTySpec tref_Object
let typ_Object = mkILBoxedType tspec_Object
- let tref_String = mkILTyRef (mscorlibScopeRef,tname_String)
+ let tref_String = mkILTyRef (systemRuntimeScopeRef, tname_String)
let tspec_String = mkILNonGenericTySpec tref_String
let typ_String = mkILBoxedType tspec_String
- let tref_StringBuilder = mkILTyRef (mscorlibScopeRef,tname_StringBuilder)
+ let tref_StringBuilder = mkILTyRef (systemRuntimeScopeRef, tname_StringBuilder)
let tspec_StringBuilder = mkILNonGenericTySpec tref_StringBuilder
let typ_StringBuilder = mkILBoxedType tspec_StringBuilder
- let tref_AsyncCallback = mkILTyRef (mscorlibScopeRef,tname_AsyncCallback)
+ let tref_AsyncCallback = mkILTyRef (systemRuntimeScopeRef, tname_AsyncCallback)
let tspec_AsyncCallback = mkILNonGenericTySpec tref_AsyncCallback
let typ_AsyncCallback = mkILBoxedType tspec_AsyncCallback
- let tref_IAsyncResult = mkILTyRef (mscorlibScopeRef,tname_IAsyncResult)
+ let tref_IAsyncResult = mkILTyRef (systemRuntimeScopeRef,tname_IAsyncResult)
let tspec_IAsyncResult = mkILNonGenericTySpec tref_IAsyncResult
let typ_IAsyncResult = mkILBoxedType tspec_IAsyncResult
- let tref_IComparable = mkILTyRef (mscorlibScopeRef,tname_IComparable)
+ let tref_IComparable = mkILTyRef (systemRuntimeScopeRef,tname_IComparable)
let tspec_IComparable = mkILNonGenericTySpec tref_IComparable
let typ_IComparable = mkILBoxedType tspec_IComparable
- let tref_Exception = mkILTyRef (mscorlibScopeRef,tname_Exception)
+ let tref_Exception = mkILTyRef (systemRuntimeScopeRef,tname_Exception)
let tspec_Exception = mkILNonGenericTySpec tref_Exception
let typ_Exception = mkILBoxedType tspec_Exception
- let tref_Type = mkILTyRef(mscorlibScopeRef,tname_Type)
+ let tref_Type = mkILTyRef(systemRuntimeScopeRef,tname_Type)
let tspec_Type = mkILNonGenericTySpec tref_Type
let typ_Type = mkILBoxedType tspec_Type
- let tref_Missing = mkILTyRef(mscorlibScopeRef,tname_Missing)
- let tspec_Missing = mkILNonGenericTySpec tref_Missing
- let typ_Missing = mkILBoxedType tspec_Missing
-
+ let typ_Missing =
+ lazy(
+ let tref_Missing = mkILTyRef(traits.SystemReflectionScopeRef.Value ,tname_Missing)
+ let tspec_Missing = mkILNonGenericTySpec tref_Missing
+ mkILBoxedType tspec_Missing
+ )
- let tref_Activator = mkILTyRef(mscorlibScopeRef,tname_Activator)
+ let tref_Activator = mkILTyRef(systemRuntimeScopeRef,tname_Activator)
let tspec_Activator = mkILNonGenericTySpec tref_Activator
let typ_Activator = mkILBoxedType tspec_Activator
- let tref_SerializationInfo = mkILTyRef(mscorlibScopeRef,tname_SerializationInfo)
- let tspec_SerializationInfo = mkILNonGenericTySpec tref_SerializationInfo
- let typ_SerializationInfo = mkILBoxedType tspec_SerializationInfo
+ let typ_SerializationInfo =
+ match traits.SerializationInfoTypeScopeRef with
+ | Some scopeRef ->
+ let tref_SerializationInfo = mkILTyRef(scopeRef,tname_SerializationInfo)
+ let tspec_SerializationInfo = mkILNonGenericTySpec tref_SerializationInfo
+ Some (mkILBoxedType tspec_SerializationInfo)
+ | None -> None
- let tref_StreamingContext = mkILTyRef(mscorlibScopeRef,tname_StreamingContext)
+ let tref_StreamingContext = mkILTyRef(systemRuntimeScopeRef,tname_StreamingContext)
let tspec_StreamingContext = mkILNonGenericTySpec tref_StreamingContext
let typ_StreamingContext = ILType.Value tspec_StreamingContext
- let tref_SecurityPermissionAttribute = mkILTyRef(mscorlibScopeRef,tname_SecurityPermissionAttribute)
+ let tref_SecurityPermissionAttribute =
+ match traits.SecurityPermissionAttributeTypeScopeRef with
+ | Some scopeRef -> Some (mkILTyRef(scopeRef,tname_SecurityPermissionAttribute))
+ | None -> None
- let tref_Delegate = mkILTyRef(mscorlibScopeRef,tname_Delegate)
+ let tref_Delegate = mkILTyRef(systemRuntimeScopeRef,tname_Delegate)
let tspec_Delegate = mkILNonGenericTySpec tref_Delegate
let typ_Delegate = mkILBoxedType tspec_Delegate
- let tref_ValueType = mkILTyRef (mscorlibScopeRef,tname_ValueType)
+ let tref_ValueType = mkILTyRef (systemRuntimeScopeRef,tname_ValueType)
let tspec_ValueType = mkILNonGenericTySpec tref_ValueType
let typ_ValueType = mkILBoxedType tspec_ValueType
-
- let tref_TypedReference = mkILTyRef (mscorlibScopeRef,tname_TypedReference)
- let tspec_TypedReference = mkILNonGenericTySpec tref_TypedReference
- let typ_TypedReference = ILType.Value tspec_TypedReference
-
- let tref_Enum = mkILTyRef (mscorlibScopeRef,tname_Enum)
+
+ let tspec_TypedReference, typ_TypedReference =
+ match traits.TypedReferenceTypeScopeRef with
+ | Some scopeRef ->
+ let tref_TypedReference = mkILTyRef (scopeRef,tname_TypedReference)
+ let tspec_TypedReference = mkILNonGenericTySpec tref_TypedReference
+ Some tspec_TypedReference, Some(ILType.Value tspec_TypedReference)
+ | None -> None, None
+
+ let tref_Enum = mkILTyRef (systemRuntimeScopeRef,tname_Enum)
let tspec_Enum = mkILNonGenericTySpec tref_Enum
let typ_Enum = mkILBoxedType tspec_Enum
- let tref_MulticastDelegate = mkILTyRef (mscorlibScopeRef,tname_MulticastDelegate)
+ let tref_MulticastDelegate = mkILTyRef (systemRuntimeScopeRef,tname_MulticastDelegate)
let tspec_MulticastDelegate = mkILNonGenericTySpec tref_MulticastDelegate
let typ_MulticastDelegate = mkILBoxedType tspec_MulticastDelegate
- let typ_Array = mkILBoxedType (mkILNonGenericTySpec (mkILTyRef (mscorlibScopeRef,tname_Array)))
-
- let tref_Int64 = mkILTyRef (mscorlibScopeRef,tname_Int64)
- let tref_UInt64 = mkILTyRef (mscorlibScopeRef,tname_UInt64)
- let tref_Int32 = mkILTyRef (mscorlibScopeRef,tname_Int32)
- let tref_UInt32 = mkILTyRef (mscorlibScopeRef,tname_UInt32)
- let tref_Int16 = mkILTyRef (mscorlibScopeRef,tname_Int16)
- let tref_UInt16 = mkILTyRef (mscorlibScopeRef,tname_UInt16)
- let tref_SByte = mkILTyRef (mscorlibScopeRef,tname_SByte)
- let tref_Byte = mkILTyRef (mscorlibScopeRef,tname_Byte)
- let tref_Single = mkILTyRef (mscorlibScopeRef,tname_Single)
- let tref_Double = mkILTyRef (mscorlibScopeRef,tname_Double)
- let tref_Bool = mkILTyRef (mscorlibScopeRef,tname_Bool)
- let tref_Char = mkILTyRef (mscorlibScopeRef,tname_Char)
- let tref_IntPtr = mkILTyRef (mscorlibScopeRef,tname_IntPtr)
- let tref_UIntPtr = mkILTyRef (mscorlibScopeRef,tname_UIntPtr)
+ let typ_Array = mkILBoxedType (mkILNonGenericTySpec (mkILTyRef (systemRuntimeScopeRef,tname_Array)))
+
+ let tref_Int64 = mkILTyRef (systemRuntimeScopeRef,tname_Int64)
+ let tref_UInt64 = mkILTyRef (systemRuntimeScopeRef,tname_UInt64)
+ let tref_Int32 = mkILTyRef (systemRuntimeScopeRef,tname_Int32)
+ let tref_UInt32 = mkILTyRef (systemRuntimeScopeRef,tname_UInt32)
+ let tref_Int16 = mkILTyRef (systemRuntimeScopeRef,tname_Int16)
+ let tref_UInt16 = mkILTyRef (systemRuntimeScopeRef,tname_UInt16)
+ let tref_SByte = mkILTyRef (systemRuntimeScopeRef,tname_SByte)
+ let tref_Byte = mkILTyRef (systemRuntimeScopeRef,tname_Byte)
+ let tref_Single = mkILTyRef (systemRuntimeScopeRef,tname_Single)
+ let tref_Double = mkILTyRef (systemRuntimeScopeRef,tname_Double)
+ let tref_Bool = mkILTyRef (systemRuntimeScopeRef,tname_Bool)
+ let tref_Char = mkILTyRef (systemRuntimeScopeRef,tname_Char)
+ let tref_IntPtr = mkILTyRef (systemRuntimeScopeRef,tname_IntPtr)
+ let tref_UIntPtr = mkILTyRef (systemRuntimeScopeRef,tname_UIntPtr)
let tspec_Int64 = mkILNonGenericTySpec tref_Int64
let tspec_UInt64 = mkILNonGenericTySpec tref_UInt64
@@ -2668,127 +2754,126 @@ let mkILGlobals mscorlibScopeRef mscorlibAssemblyNameOpt noDebugData =
let typ_Bool = ILType.Value tspec_Bool
let typ_Char = ILType.Value tspec_Char
- let tref_RuntimeArgumentHandle = mkILTyRef (mscorlibScopeRef,tname_RuntimeArgumentHandle)
- let tspec_RuntimeArgumentHandle = mkILNonGenericTySpec tref_RuntimeArgumentHandle
- let typ_RuntimeArgumentHandle = ILType.Value tspec_RuntimeArgumentHandle
- let tref_RuntimeTypeHandle = mkILTyRef (mscorlibScopeRef,tname_RuntimeTypeHandle)
+ let tref_RuntimeArgumentHandle =
+ match traits.RuntimeArgumentHandleTypeScopeRef with
+ | Some scopeRef -> Some(mkILTyRef (scopeRef,tname_RuntimeArgumentHandle))
+ | None -> None
+ let tspec_RuntimeArgumentHandle = Option.map mkILNonGenericTySpec tref_RuntimeArgumentHandle
+ let typ_RuntimeArgumentHandle = Option.map ILType.Value tspec_RuntimeArgumentHandle
+ let tref_RuntimeTypeHandle = mkILTyRef (systemRuntimeScopeRef,tname_RuntimeTypeHandle)
let tspec_RuntimeTypeHandle = mkILNonGenericTySpec tref_RuntimeTypeHandle
let typ_RuntimeTypeHandle = ILType.Value tspec_RuntimeTypeHandle
- let tref_RuntimeMethodHandle = mkILTyRef (mscorlibScopeRef,tname_RuntimeMethodHandle)
+ let tref_RuntimeMethodHandle = mkILTyRef (systemRuntimeScopeRef,tname_RuntimeMethodHandle)
let tspec_RuntimeMethodHandle = mkILNonGenericTySpec tref_RuntimeMethodHandle
let typ_RuntimeMethodHandle = ILType.Value tspec_RuntimeMethodHandle
- let tref_RuntimeFieldHandle = mkILTyRef (mscorlibScopeRef,tname_RuntimeFieldHandle)
+ let tref_RuntimeFieldHandle = mkILTyRef (systemRuntimeScopeRef,tname_RuntimeFieldHandle)
let tspec_RuntimeFieldHandle = mkILNonGenericTySpec tref_RuntimeFieldHandle
let typ_RuntimeFieldHandle = ILType.Value tspec_RuntimeFieldHandle
- { mscorlibScopeRef =mscorlibScopeRef
- ; mscorlibAssemblyName =mscorlibAssemblyName
- ; noDebugData =noDebugData
- ; tref_Object =tref_Object
- ; tspec_Object =tspec_Object
- ; typ_Object =typ_Object
- ; tref_String =tref_String
- ; typ_String =typ_String
- ; typ_StringBuilder =typ_StringBuilder
- ; typ_AsyncCallback =typ_AsyncCallback
- ; typ_IAsyncResult =typ_IAsyncResult
- ; typ_IComparable =typ_IComparable
- ; typ_Activator =typ_Activator
- ; tref_Type =tref_Type
- ; typ_Type =typ_Type
- ; typ_Missing =typ_Missing
- ; typ_Delegate =typ_Delegate
- ; typ_ValueType =typ_ValueType
- ; typ_Enum =typ_Enum
- ; tspec_TypedReference =tspec_TypedReference
- ; typ_TypedReference =typ_TypedReference
- ; typ_MulticastDelegate =typ_MulticastDelegate
- ; typ_Array =typ_Array
- ; tspec_Int64 =tspec_Int64
- ; tspec_UInt64 =tspec_UInt64
- ; tspec_Int32 =tspec_Int32
- ; tspec_UInt32 =tspec_UInt32
- ; tspec_Int16 =tspec_Int16
- ; tspec_UInt16 =tspec_UInt16
- ; tspec_SByte =tspec_SByte
- ; tspec_Byte =tspec_Byte
- ; tspec_Single =tspec_Single
- ; tspec_Double =tspec_Double
- ; tspec_IntPtr =tspec_IntPtr
- ; tspec_UIntPtr =tspec_UIntPtr
- ; tspec_Char =tspec_Char
- ; tspec_Bool =tspec_Bool
- ; typ_int8 =typ_int8
- ; typ_int16 =typ_int16
- ; typ_int32 =typ_int32
- ; typ_int64 =typ_int64
- ; typ_uint8 =typ_uint8
- ; typ_uint16 =typ_uint16
- ; typ_uint32 =typ_uint32
- ; typ_uint64 =typ_uint64
- ; typ_float32 =typ_float32
- ; typ_float64 =typ_float64
- ; typ_bool =typ_bool
- ; typ_char =typ_char
- ; typ_IntPtr =typ_IntPtr
- ; typ_UIntPtr =typ_UIntPtr
- ; typ_RuntimeArgumentHandle =typ_RuntimeArgumentHandle
- ; typ_RuntimeTypeHandle =typ_RuntimeTypeHandle
- ; typ_RuntimeMethodHandle =typ_RuntimeMethodHandle
- ; typ_RuntimeFieldHandle =typ_RuntimeFieldHandle
+ { traits = traits
+ primaryAssemblyName = primaryAssemblyName
+ noDebugData = noDebugData
+ tref_Object = tref_Object
+ tspec_Object = tspec_Object
+ typ_Object = typ_Object
+ tref_String = tref_String
+ typ_String = typ_String
+ typ_StringBuilder = typ_StringBuilder
+ typ_AsyncCallback = typ_AsyncCallback
+ typ_IAsyncResult = typ_IAsyncResult
+ typ_IComparable = typ_IComparable
+ typ_Activator = typ_Activator
+ tref_Type = tref_Type
+ typ_Type = typ_Type
+ typ_Missing = typ_Missing
+ typ_Delegate = typ_Delegate
+ typ_ValueType = typ_ValueType
+ typ_Enum = typ_Enum
+ tspec_TypedReference = tspec_TypedReference
+ typ_TypedReference = typ_TypedReference
+ typ_MulticastDelegate = typ_MulticastDelegate
+ typ_Array = typ_Array
+ tspec_Int64 = tspec_Int64
+ tspec_UInt64 = tspec_UInt64
+ tspec_Int32 = tspec_Int32
+ tspec_UInt32 = tspec_UInt32
+ tspec_Int16 = tspec_Int16
+ tspec_UInt16 = tspec_UInt16
+ tspec_SByte = tspec_SByte
+ tspec_Byte = tspec_Byte
+ tspec_Single = tspec_Single
+ tspec_Double = tspec_Double
+ tspec_IntPtr = tspec_IntPtr
+ tspec_UIntPtr = tspec_UIntPtr
+ tspec_Char = tspec_Char
+ tspec_Bool = tspec_Bool
+ typ_int8 = typ_int8
+ typ_int16 = typ_int16
+ typ_int32 = typ_int32
+ typ_int64 = typ_int64
+ typ_uint8 = typ_uint8
+ typ_uint16 = typ_uint16
+ typ_uint32 = typ_uint32
+ typ_uint64 = typ_uint64
+ typ_float32 = typ_float32
+ typ_float64 = typ_float64
+ typ_bool = typ_bool
+ typ_char = typ_char
+ typ_IntPtr = typ_IntPtr
+ typ_UIntPtr =typ_UIntPtr
+ typ_RuntimeArgumentHandle = typ_RuntimeArgumentHandle
+ typ_RuntimeTypeHandle = typ_RuntimeTypeHandle
+ typ_RuntimeMethodHandle = typ_RuntimeMethodHandle
+ typ_RuntimeFieldHandle = typ_RuntimeFieldHandle
- ; typ_Byte =typ_Byte
- ; typ_Int16 =typ_Int16
- ; typ_Int32 =typ_Int32
- ; typ_Int64 =typ_Int64
- ; typ_SByte =typ_SByte
- ; typ_UInt16 =typ_UInt16
- ; typ_UInt32 =typ_UInt32
- ; typ_UInt64 =typ_UInt64
- ; typ_Single =typ_Single
- ; typ_Double =typ_Double
- ; typ_Bool =typ_Bool
- ; typ_Char =typ_Char
- ; typ_SerializationInfo=typ_SerializationInfo
- ; typ_StreamingContext=typ_StreamingContext
- ; tref_SecurityPermissionAttribute=tref_SecurityPermissionAttribute
- ; tspec_Exception =tspec_Exception
- ; typ_Exception =typ_Exception
- ; generatedAttribsCache = []
- ; debuggerBrowsableNeverAttributeCache = None
- ; debuggerTypeProxyAttributeCache = None }
+ typ_Byte = typ_Byte
+ typ_Int16 = typ_Int16
+ typ_Int32 = typ_Int32
+ typ_Int64 = typ_Int64
+ typ_SByte = typ_SByte
+ typ_UInt16 = typ_UInt16
+ typ_UInt32 = typ_UInt32
+ typ_UInt64 = typ_UInt64
+ typ_Single = typ_Single
+ typ_Double = typ_Double
+ typ_Bool = typ_Bool
+ typ_Char = typ_Char
+ typ_SerializationInfo = typ_SerializationInfo
+ typ_StreamingContext = typ_StreamingContext
+ tref_SecurityPermissionAttribute = tref_SecurityPermissionAttribute
+ tspec_Exception = tspec_Exception
+ typ_Exception = typ_Exception
+ generatedAttribsCache = []
+ debuggerBrowsableNeverAttributeCache = None
+ debuggerTypeProxyAttributeCache = None }
(* NOTE: ecma_ prefix refers to the standard "mscorlib" *)
let ecmaPublicKey = PublicKeyToken (Bytes.ofInt32Array [|0xde; 0xad; 0xbe; 0xef; 0xca; 0xfe; 0xfa; 0xce |])
-
-let ecmaMscorlibScopeRef = ILScopeRef.Assembly (ILAssemblyRef.Create("mscorlib", None, Some ecmaPublicKey, true, None, None))
-
-let ecmaILGlobals = mkILGlobals ecmaMscorlibScopeRef None false
let mkInitializeArrayMethSpec ilg =
- mkILNonGenericStaticMethSpecInTy(mkILNonGenericBoxedTy(mkILTyRef(ilg.mscorlibScopeRef,"System.Runtime.CompilerServices.RuntimeHelpers")),"InitializeArray", [ilg.typ_Array;ilg.typ_RuntimeFieldHandle], ILType.Void)
-(* e.ilg. [mkMscorlibExnNewobj "System.InvalidCastException"] *)
-let mkMscorlibExnNewobj ilg eclass =
- mkNormalNewobj (mkILNonGenericCtorMethSpec (mkILTyRef(ilg.mscorlibScopeRef,eclass),[]))
+ mkILNonGenericStaticMethSpecInTy(mkILNonGenericBoxedTy(mkILTyRef(ilg.traits.ScopeRef,"System.Runtime.CompilerServices.RuntimeHelpers")),"InitializeArray", [ilg.typ_Array;ilg.typ_RuntimeFieldHandle], ILType.Void)
+(* e.ilg. [mkPrimaryAssemblyExnNewobj "System.InvalidCastException"] *)
+let mkPrimaryAssemblyExnNewobj ilg eclass =
+ mkNormalNewobj (mkILNonGenericCtorMethSpec (mkILTyRef(ilg.traits.ScopeRef,eclass),[]))
let typ_is_boxed = function ILType.Boxed _ -> true | _ -> false
let typ_is_value = function ILType.Value _ -> true | _ -> false
-let tspec_is_mscorlib ilg (tspec:ILTypeSpec) n =
+let tspec_is_primaryAssembly ilg (tspec:ILTypeSpec) n =
let tref = tspec.TypeRef
let scoref = tref.Scope
(tref.Name = n) &&
match scoref with
- | ILScopeRef.Assembly n -> n.Name = ilg.mscorlibAssemblyName
+ | ILScopeRef.Assembly n -> n.Name = ilg.primaryAssemblyName
| ILScopeRef.Module _ -> false
| ILScopeRef.Local -> true
let typ_is_boxed_mscorlib_typ ilg (ty:ILType) n =
- typ_is_boxed ty && tspec_is_mscorlib ilg ty.TypeSpec n
+ typ_is_boxed ty && tspec_is_primaryAssembly ilg ty.TypeSpec n
let typ_is_value_mscorlib_typ ilg (ty:ILType) n =
- typ_is_value ty && tspec_is_mscorlib ilg ty.TypeSpec n
+ typ_is_value ty && tspec_is_primaryAssembly ilg ty.TypeSpec n
let isILObjectTy ilg ty = typ_is_boxed_mscorlib_typ ilg ty tname_Object
let isILStringTy ilg ty = typ_is_boxed_mscorlib_typ ilg ty tname_String
@@ -4209,22 +4294,22 @@ let encodeCustomAttrString s =
let rec encodeCustomAttrElemType x =
match x with
- | ILType.Value tspec when tspec.Name = "System.SByte" -> [| et_I1 |]
- | ILType.Value tspec when tspec.Name = "System.Byte" -> [| et_U1 |]
- | ILType.Value tspec when tspec.Name = "System.Int16" -> [| et_I2 |]
- | ILType.Value tspec when tspec.Name = "System.UInt16" -> [| et_U2 |]
- | ILType.Value tspec when tspec.Name = "System.Int32" -> [| et_I4 |]
- | ILType.Value tspec when tspec.Name = "System.UInt32" -> [| et_U4 |]
- | ILType.Value tspec when tspec.Name = "System.Int64" -> [| et_I8 |]
- | ILType.Value tspec when tspec.Name = "System.UInt64" -> [| et_U8 |]
- | ILType.Value tspec when tspec.Name = "System.Double" -> [| et_R8 |]
- | ILType.Value tspec when tspec.Name = "System.Single" -> [| et_R4 |]
- | ILType.Value tspec when tspec.Name = "System.Char" -> [| et_CHAR |]
- | ILType.Value tspec when tspec.Name = "System.Boolean" -> [| et_BOOLEAN |]
- | ILType.Boxed tspec when tspec.Name = "System.String" -> [| et_STRING |]
- | ILType.Boxed tspec when tspec.Name = "System.Object" -> [| 0x51uy |]
- | ILType.Boxed tspec when tspec.Name = "System.Type" -> [| 0x50uy |]
- | ILType.Value tspec -> Array.append [| 0x55uy |] (encodeCustomAttrString tspec.TypeRef.QualifiedNameWithNoShortMscorlib)
+ | ILType.Value tspec when tspec.Name = tname_SByte -> [| et_I1 |]
+ | ILType.Value tspec when tspec.Name = tname_Byte -> [| et_U1 |]
+ | ILType.Value tspec when tspec.Name = tname_Int16 -> [| et_I2 |]
+ | ILType.Value tspec when tspec.Name = tname_UInt16 -> [| et_U2 |]
+ | ILType.Value tspec when tspec.Name = tname_Int32 -> [| et_I4 |]
+ | ILType.Value tspec when tspec.Name = tname_UInt32 -> [| et_U4 |]
+ | ILType.Value tspec when tspec.Name = tname_Int64 -> [| et_I8 |]
+ | ILType.Value tspec when tspec.Name = tname_UInt64 -> [| et_U8 |]
+ | ILType.Value tspec when tspec.Name = tname_Double -> [| et_R8 |]
+ | ILType.Value tspec when tspec.Name = tname_Single -> [| et_R4 |]
+ | ILType.Value tspec when tspec.Name = tname_Char -> [| et_CHAR |]
+ | ILType.Value tspec when tspec.Name = tname_Bool -> [| et_BOOLEAN |]
+ | ILType.Boxed tspec when tspec.Name = tname_String -> [| et_STRING |]
+ | ILType.Boxed tspec when tspec.Name = tname_Object -> [| 0x51uy |]
+ | ILType.Boxed tspec when tspec.Name = tname_Type -> [| 0x50uy |]
+ | ILType.Value tspec -> Array.append [| 0x55uy |] (encodeCustomAttrString tspec.TypeRef.QualifiedNameWithNoShortPrimaryAssembly)
| ILType.Array (shape, elemType) when shape = ILArrayShape.SingleDimensional ->
Array.append [| et_SZARRAY |] (encodeCustomAttrElemType elemType)
| _ -> failwith "encodeCustomAttrElemType: unrecognized custom element type"
@@ -4295,14 +4380,14 @@ let rec encodeCustomAttrPrimValue ilg c =
| ILAttribElem.UInt64 x -> u64AsBytes x
| ILAttribElem.Single x -> ieee32AsBytes x
| ILAttribElem.Double x -> ieee64AsBytes x
- | ILAttribElem.Type (Some ty) -> encodeCustomAttrString ty.QualifiedNameWithNoShortMscorlib
- | ILAttribElem.TypeRef (Some tref) -> encodeCustomAttrString tref.QualifiedNameWithNoShortMscorlib
+ | ILAttribElem.Type (Some ty) -> encodeCustomAttrString ty.QualifiedNameWithNoShortPrimaryAssembly
+ | ILAttribElem.TypeRef (Some tref) -> encodeCustomAttrString tref.QualifiedNameWithNoShortPrimaryAssembly
| ILAttribElem.Array (_,elems) ->
[| yield! i32AsBytes elems.Length; for elem in elems do yield! encodeCustomAttrPrimValue ilg elem |]
and encodeCustomAttrValue ilg ty c =
match ty, c with
- | ILType.Boxed tspec, _ when tspec.Name = "System.Object" ->
+ | ILType.Boxed tspec, _ when tspec.Name = tname_Object ->
[| yield! encodeCustomAttrElemTypeForObject c; yield! encodeCustomAttrPrimValue ilg c |]
| ILType.Array (shape, elemType), ILAttribElem.Array (_,elems) when shape = ILArrayShape.SingleDimensional ->
[| yield! i32AsBytes elems.Length; for elem in elems do yield! encodeCustomAttrValue ilg elemType elem |]
@@ -4334,49 +4419,94 @@ let mkILCustomAttribMethRef (ilg: ILGlobals) (mspec:ILMethodSpec, fixedArgs: lis
let mkILCustomAttribute ilg (tref,argtys,argvs,propvs) =
mkILCustomAttribMethRef ilg (mkILNonGenericCtorMethSpec (tref,argtys),argvs,propvs)
+let MscorlibScopeRef = ILScopeRef.Assembly (ILAssemblyRef.Create("mscorlib", None, Some ecmaPublicKey, true, None, None))
+let mkMscorlibBasedTraits mscorlibRef =
+ let ecmaMscorlibScopeRef = Some mscorlibRef
+ let lazyRef = lazy mscorlibRef
+ {
+ new IPrimaryAssemblyTraits with
+ member this.ScopeRef = mscorlibRef
+ member this.SystemReflectionScopeRef = lazyRef
+ member this.TypedReferenceTypeScopeRef = ecmaMscorlibScopeRef
+ member this.RuntimeArgumentHandleTypeScopeRef = ecmaMscorlibScopeRef
+ member this.SerializationInfoTypeScopeRef = ecmaMscorlibScopeRef
+ member this.SecurityPermissionAttributeTypeScopeRef = ecmaMscorlibScopeRef
+ member this.SystemDiagnosticsDebugScopeRef = lazyRef
+ member this.SystemRuntimeInteropServicesScopeRef = lazyRef
+ member this.IDispatchConstantAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.IUnknownConstantAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.ContextStaticAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.ThreadStaticAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.SystemLinqExpressionsScopeRef = lazyRef
+ member this.SystemCollectionsScopeRef = lazyRef
+ member this.SpecialNameAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.NonSerializedAttributeScopeRef = ecmaMscorlibScopeRef
+ member this.MarshalByRefObjectScopeRef = ecmaMscorlibScopeRef
+ member this.ArgIteratorTypeScopeRef = ecmaMscorlibScopeRef
+ }
+let EcmaILGlobals = mkILGlobals (mkMscorlibBasedTraits MscorlibScopeRef) None false
+
(* Q: CompilerGeneratedAttribute is new in 2.0. Unconditional generation of this attribute prevents running on 1.1 Framework. (discovered running on early mono version). *)
-let tref_CompilerGeneratedAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_CompilerGeneratedAttribute)
+let tref_CompilerGeneratedAttribute ilg = mkILTyRef (ilg.traits.ScopeRef, tname_CompilerGeneratedAttribute)
+[<Literal>]
let tname_DebuggerNonUserCodeAttribute = "System.Diagnostics.DebuggerNonUserCodeAttribute"
+[<Literal>]
let tname_DebuggableAttribute_DebuggingModes = "DebuggingModes"
+[<Literal>]
let tname_DebuggerHiddenAttribute = "System.Diagnostics.DebuggerHiddenAttribute"
+[<Literal>]
let tname_DebuggerDisplayAttribute = "System.Diagnostics.DebuggerDisplayAttribute"
+[<Literal>]
let tname_DebuggerTypeProxyAttribute = "System.Diagnostics.DebuggerTypeProxyAttribute"
+[<Literal>]
let tname_DebuggerStepThroughAttribute = "System.Diagnostics.DebuggerStepThroughAttribute"
+[<Literal>]
let tname_DebuggerBrowsableAttribute = "System.Diagnostics.DebuggerBrowsableAttribute"
+[<Literal>]
let tname_DebuggerBrowsableState = "System.Diagnostics.DebuggerBrowsableState"
-let tref_DebuggerNonUserCodeAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerNonUserCodeAttribute)
-let tref_DebuggerStepThroughAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerStepThroughAttribute)
-let tref_DebuggerHiddenAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerHiddenAttribute)
-let tref_DebuggerDisplayAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerDisplayAttribute)
-let tref_DebuggerTypeProxyAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerTypeProxyAttribute)
-let tref_DebuggerBrowsableAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggerBrowsableAttribute)
-let tref_DebuggableAttribute ilg = mkILTyRef (ilg.mscorlibScopeRef,tname_DebuggableAttribute)
-let tref_DebuggableAttribute_DebuggingModes ilg = mkILNestedTyRef (ilg.mscorlibScopeRef,[tname_DebuggableAttribute],tname_DebuggableAttribute_DebuggingModes)
-
-let typ_DebuggerBrowsableState ilg =
- let tref_DebuggerBrowsableState = mkILTyRef(ilg.mscorlibScopeRef,tname_DebuggerBrowsableState)
- ILType.Value (mkILNonGenericTySpec tref_DebuggerBrowsableState)
-
-let mkCompilerGeneratedAttribute ilg = mkILCustomAttribute ilg (tref_CompilerGeneratedAttribute ilg,[],[],[])
-let mkDebuggerNonUserCodeAttribute ilg = mkILCustomAttribute ilg (tref_DebuggerNonUserCodeAttribute ilg,[],[],[])
-let mkDebuggerHiddenAttribute ilg = mkILCustomAttribute ilg (tref_DebuggerHiddenAttribute ilg,[],[],[])
-let mkDebuggerDisplayAttribute ilg s = mkILCustomAttribute ilg (tref_DebuggerDisplayAttribute ilg,[ilg.typ_String],[ILAttribElem.String (Some s)],[])
-let mkDebuggerTypeProxyAttribute ilg (ty:ILType) =
- mkILCustomAttribute ilg (tref_DebuggerTypeProxyAttribute ilg,[ilg.typ_Type],[ILAttribElem.TypeRef (Some ty.TypeRef)],[])
-let mkDebuggerBrowsableAttribute ilg n = mkILCustomAttribute ilg (tref_DebuggerBrowsableAttribute ilg,[typ_DebuggerBrowsableState ilg],[ILAttribElem.Int32 n],[])
-let mkDebuggerBrowsableNeverAttribute ilg =
- match ilg.debuggerBrowsableNeverAttributeCache with
- | None ->
- let res = mkDebuggerBrowsableAttribute ilg 0
- ilg.debuggerBrowsableNeverAttributeCache <- Some res
- res
- | Some res -> res
-let mkDebuggerStepThroughAttribute ilg = mkILCustomAttribute ilg (tref_DebuggerStepThroughAttribute ilg,[],[],[])
-let mkDebuggableAttribute ilg (jitTracking, jitOptimizerDisabled) =
- mkILCustomAttribute ilg (tref_DebuggableAttribute ilg,[ilg.typ_Bool;ilg.typ_Bool], [ILAttribElem.Bool jitTracking; ILAttribElem.Bool jitOptimizerDisabled],[])
-
+let mkSystemDiagnosticsDebugTypeRef (ilg : ILGlobals) typeName = mkILTyRef (ilg.traits.SystemDiagnosticsDebugScopeRef.Value, typeName)
+let mkSystemDiagnosticsDebuggableTypeRef (ilg : ILGlobals) = mkILTyRef (ilg.traits.ScopeRef, tname_DebuggableAttribute)
+let tref_DebuggableAttribute_DebuggingModes ilg = mkILNestedTyRef (ilg.traits.ScopeRef, [tname_DebuggableAttribute],tname_DebuggableAttribute_DebuggingModes)
+
+
+type ILGlobals with
+ member this.mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerNonUserCodeAttribute, [], [], [])
+ member this.mkDebuggerHiddenAttribute() = mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerHiddenAttribute, [], [], [])
+ member this.mkDebuggerDisplayAttribute s = mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerDisplayAttribute, [this.typ_String],[ILAttribElem.String (Some s)],[])
+ member this.mkDebuggerTypeProxyAttribute (ty : ILType) = mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerTypeProxyAttribute, [this.typ_Type],[ILAttribElem.TypeRef (Some ty.TypeRef)],[])
+ member this.tref_DebuggerBrowsableAttribute n =
+ let typ_DebuggerBrowsableState =
+ let tref = mkSystemDiagnosticsDebugTypeRef this tname_DebuggerBrowsableState
+ ILType.Value (mkILNonGenericTySpec tref)
+ mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerBrowsableAttribute, [typ_DebuggerBrowsableState],[ILAttribElem.Int32 n],[])
+
+ member this.mkDebuggerBrowsableNeverAttribute() =
+ match this.debuggerBrowsableNeverAttributeCache with
+ | None ->
+ let res = this.tref_DebuggerBrowsableAttribute 0
+ this.debuggerBrowsableNeverAttributeCache <- Some res
+ res
+ | Some res -> res
+
+ member this.mkDebuggerStepThroughAttribute() = mkILCustomAttribute this (mkSystemDiagnosticsDebugTypeRef this tname_DebuggerStepThroughAttribute, [], [], [])
+ member this.mkDebuggableAttribute (jitTracking, jitOptimizerDisabled) =
+ mkILCustomAttribute this (mkSystemDiagnosticsDebuggableTypeRef this, [this.typ_Bool; this.typ_Bool], [ILAttribElem.Bool jitTracking; ILAttribElem.Bool jitOptimizerDisabled], [])
+
+
+ member this.mkDebuggableAttributeV2(jitTracking, ignoreSymbolStoreSequencePoints, jitOptimizerDisabled,enableEnC) =
+ let tref = mkSystemDiagnosticsDebuggableTypeRef this
+ mkILCustomAttribute this
+ (tref,[mkILNonGenericValueTy (tref_DebuggableAttribute_DebuggingModes this)],
+ [ILAttribElem.Int32(
+ (* See System.Diagnostics.DebuggableAttribute.DebuggingModes *)
+ (if jitTracking then 1 else 0) |||
+ (if jitOptimizerDisabled then 256 else 0) |||
+ (if ignoreSymbolStoreSequencePoints then 2 else 0) |||
+ (if enableEnC then 4 else 0))],[])
+
+ member this.mkCompilerGeneratedAttribute () = mkILCustomAttribute this (tref_CompilerGeneratedAttribute this, [], [], [])
// Bug 2129. Requests attributes to be added to compiler generated methods
let addGeneratedAttrs ilg (attrs: ILAttributes) =
@@ -4384,8 +4514,8 @@ let addGeneratedAttrs ilg (attrs: ILAttributes) =
match ilg.generatedAttribsCache with
| [] ->
let res = [ if not ilg.noDebugData then
- yield mkCompilerGeneratedAttribute ilg
- yield mkDebuggerNonUserCodeAttribute ilg]
+ yield ilg.mkCompilerGeneratedAttribute()
+ yield ilg.mkDebuggerNonUserCodeAttribute()]
ilg.generatedAttribsCache <- res
res
| res -> res
@@ -4395,7 +4525,7 @@ let addMethodGeneratedAttrs ilg (mdef:ILMethodDef) = {mdef with CustomAttrs
let addPropertyGeneratedAttrs ilg (pdef:ILPropertyDef) = {pdef with CustomAttrs = addGeneratedAttrs ilg pdef.CustomAttrs}
let addFieldGeneratedAttrs ilg (fdef:ILFieldDef) = {fdef with CustomAttrs = addGeneratedAttrs ilg fdef.CustomAttrs}
-let add_never_attrs ilg (attrs: ILAttributes) = mkILCustomAttrs (attrs.AsList @ [mkDebuggerBrowsableNeverAttribute ilg])
+let add_never_attrs (ilg : ILGlobals) (attrs: ILAttributes) = mkILCustomAttrs (attrs.AsList @ [ilg.mkDebuggerBrowsableNeverAttribute()])
let addPropertyNeverAttrs ilg (pdef:ILPropertyDef) = {pdef with CustomAttrs = add_never_attrs ilg pdef.CustomAttrs}
let addFieldNeverAttrs ilg (fdef:ILFieldDef) = {fdef with CustomAttrs = add_never_attrs ilg fdef.CustomAttrs}
@@ -4413,7 +4543,7 @@ let mkPermissionSet (ilg: ILGlobals) (action,attributes: list<(ILTypeRef * (stri
[| yield (byte '.');
yield! z_unsigned_int attributes.Length;
for (tref:ILTypeRef,props) in attributes do
- yield! encodeCustomAttrString tref.QualifiedNameWithNoShortMscorlib
+ yield! encodeCustomAttrString tref.QualifiedNameWithNoShortPrimaryAssembly
let bytes =
[| yield! z_unsigned_int props.Length;
for (nm,typ,value) in props do
@@ -4673,18 +4803,8 @@ let decodeILAttribData ilg (ca: ILAttribute) scope =
let v,sigptr = parseVal ty sigptr
parseNamed ((nm,ty,isProp,v) :: acc) (n-1) sigptr
let named = parseNamed [] (int nnamed) sigptr
- fixedArgs,named
-
+ fixedArgs,named
-let mkDebuggableAttributeV2 ilg (jitTracking, ignoreSymbolStoreSequencePoints, jitOptimizerDisabled,enableEnC) =
- mkILCustomAttribute ilg
- (tref_DebuggableAttribute ilg,[mkILNonGenericValueTy (tref_DebuggableAttribute_DebuggingModes ilg)],
- [ILAttribElem.Int32(
- (* See System.Diagnostics.DebuggableAttribute.DebuggingModes *)
- (if jitTracking then 1 else 0) |||
- (if jitOptimizerDisabled then 256 else 0) |||
- (if ignoreSymbolStoreSequencePoints then 2 else 0) |||
- (if enableEnC then 4 else 0))],[])
// --------------------------------------------------------------------
// Functions to collect up all the references in a full module or
diff --git a/src/absil/il.fsi b/src/absil/il.fsi
index 5b5090f..1459512 100755
--- a/src/absil/il.fsi
+++ b/src/absil/il.fsi
@@ -8,7 +8,6 @@
//
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-
/// The "unlinked" view of .NET metadata and code. Central to
/// to Abstract IL library
module internal Microsoft.FSharp.Compiler.AbstractIL.IL
@@ -52,7 +51,7 @@ type ILList<'T> = 'T list
// format used for code.
//
// 2. The "typ_XYZ", "tspec_XYZ" and "mspec_XYZ" values which
-// can be used to reference types in the "mscorlib" assembly.
+// can be used to reference types in the "primary assembly (either System.Runtime or mscorlib)" assembly.
//
// 3. The "rescopeXYZ" functions which can be used to lift a piece of
// metadata from one assembly and transform it to a piece of metadata
@@ -135,7 +134,7 @@ type ILAssemblyRef =
member Hash: byte[] option;
member PublicKey: PublicKey option;
/// CLI says this indicates if the assembly can be retargeted (at runtime) to be from a different publisher.
- member Retargetable: bool;
+ member Retargetable: bool;
member Version: ILVersionInfo option;
member Locale: string option
interface System.IComparable
@@ -270,7 +269,7 @@ type ILArrayBounds = ILArrayBound * ILArrayBound
[<StructuralEquality; StructuralComparison>]
type ILArrayShape =
- | ILArrayShape of ILArrayBounds list (* lobound/size pairs *)
+ | ILArrayShape of ILArrayBounds list // lobound/size pairs
member Rank : int
/// Bounds for a single dimensional, zero based array
static member SingleDimensional: ILArrayShape
@@ -304,7 +303,7 @@ type ILTypeRef =
member BasicQualifiedName : string
member QualifiedName: string
#if EXTENSIONTYPING
- member QualifiedNameWithNoShortMscorlib: string
+ member QualifiedNameWithNoShortPrimaryAssembly: string
#endif
interface System.IComparable
@@ -365,7 +364,7 @@ and
member GenericArgs : ILGenericArgs
member IsTyvar : bool
member BasicQualifiedName : string
- member QualifiedNameWithNoShortMscorlib : string
+ member QualifiedNameWithNoShortPrimaryAssembly : string
and [<StructuralEquality; StructuralComparison>]
ILCallingSignature =
@@ -592,8 +591,8 @@ type ILInstr =
// Control transfer
| I_br of ILCodeLabel
| I_jmp of ILMethodSpec
- | I_brcmp of ILComparisonInstr * ILCodeLabel * ILCodeLabel (* second label is fall-through *)
- | I_switch of (ILCodeLabel list * ILCodeLabel) (* last label is fallthrough *)
+ | I_brcmp of ILComparisonInstr * ILCodeLabel * ILCodeLabel // second label is fall-through
+ | I_switch of (ILCodeLabel list * ILCodeLabel) // last label is fallthrough
| I_ret
// Method call
@@ -1396,7 +1395,7 @@ type ILTypeDefAccess =
// really, absolutely a value type until you bind the
// super class and test it for type equality against System.ValueType.
// However, this is unbearably annoying, as it means you
-// have to load "mscorlib" and perform bind operations
+// have to load "primary runtime assembly (System.Runtime or mscorlib)" and perform bind operations
// in order to be able to determine some quite simple
// things. So we approximate by simply looking at the name
// of the superclass when loading.
@@ -1662,6 +1661,30 @@ val isTypeNameForGlobalFunctions: string -> bool
val ungenericizeTypeName: string -> string (* e.g. List`1 --> List *)
+/// Represents the capabilities of target framework profile.
+/// Different profiles may omit some types or contain them in different assemblies
+type IPrimaryAssemblyTraits =
+
+ abstract TypedReferenceTypeScopeRef : ILScopeRef option
+ abstract RuntimeArgumentHandleTypeScopeRef : ILScopeRef option
+ abstract SerializationInfoTypeScopeRef : ILScopeRef option
+ abstract SecurityPermissionAttributeTypeScopeRef : ILScopeRef option
+ abstract IDispatchConstantAttributeScopeRef : ILScopeRef option
+ abstract IUnknownConstantAttributeScopeRef : ILScopeRef option
+ abstract ArgIteratorTypeScopeRef : ILScopeRef option
+ abstract MarshalByRefObjectScopeRef : ILScopeRef option
+ abstract ThreadStaticAttributeScopeRef : ILScopeRef option
+ abstract SpecialNameAttributeScopeRef : ILScopeRef option
+ abstract ContextStaticAttributeScopeRef : ILScopeRef option
+ abstract NonSerializedAttributeScopeRef : ILScopeRef option
+
+ abstract SystemRuntimeInteropServicesScopeRef : Lazy<ILScopeRef>
+ abstract SystemLinqExpressionsScopeRef : Lazy<ILScopeRef>
+ abstract SystemCollectionsScopeRef : Lazy<ILScopeRef>
+ abstract SystemReflectionScopeRef : Lazy<ILScopeRef>
+ abstract SystemDiagnosticsDebugScopeRef : Lazy<ILScopeRef>
+ abstract ScopeRef : ILScopeRef
+
// ====================================================================
// PART 2
//
@@ -1670,14 +1693,14 @@ val ungenericizeTypeName: string -> string (* e.g. List`1 --> List *)
// e.g. by filling in all appropriate record fields.
// ==================================================================== *)
-/// A table of common references to items in mscorlib. Version-neutral references
-/// can be generated using ecmaILGlobals. If you have already loaded a particular
-/// version of mscorlib you should reference items via an ILGlobals for that particular
-/// version of mscorlib built using mkILGlobals.
+/// A table of common references to items in primary assebly (System.Runtime or mscorlib).
+/// If you have already loaded a particular version of system runtime assembly you should reference items via an ILGlobals for that particular
+/// version of system runtime assembly built using mkILGlobals.
[<NoEquality; NoComparison>]
type ILGlobals =
- { mscorlibScopeRef: ILScopeRef
- mscorlibAssemblyName: string
+ {
+ traits : IPrimaryAssemblyTraits
+ primaryAssemblyName: string
noDebugData: bool
tref_Object: ILTypeRef
tspec_Object: ILTypeSpec
@@ -1690,13 +1713,13 @@ type ILGlobals =
typ_IComparable: ILType
tref_Type: ILTypeRef
typ_Type: ILType
- typ_Missing: ILType
+ typ_Missing: Lazy<ILType>
typ_Activator: ILType
typ_Delegate: ILType
typ_ValueType: ILType
typ_Enum: ILType
- tspec_TypedReference: ILTypeSpec
- typ_TypedReference: ILType
+ tspec_TypedReference: ILTypeSpec option
+ typ_TypedReference: ILType option
typ_MulticastDelegate: ILType
typ_Array: ILType
tspec_Int64: ILTypeSpec
@@ -1727,7 +1750,7 @@ type ILGlobals =
typ_char: ILType
typ_IntPtr: ILType
typ_UIntPtr: ILType
- typ_RuntimeArgumentHandle: ILType
+ typ_RuntimeArgumentHandle: ILType option
typ_RuntimeTypeHandle: ILType
typ_RuntimeMethodHandle: ILType
typ_RuntimeFieldHandle: ILType
@@ -1743,18 +1766,33 @@ type ILGlobals =
typ_Double: ILType
typ_Bool: ILType
typ_Char: ILType
- typ_SerializationInfo: ILType
+ typ_SerializationInfo: ILType option
typ_StreamingContext: ILType
- tref_SecurityPermissionAttribute : ILTypeRef
+ tref_SecurityPermissionAttribute : ILTypeRef option
tspec_Exception: ILTypeSpec
typ_Exception: ILType
mutable generatedAttribsCache: ILAttribute list
mutable debuggerBrowsableNeverAttributeCache : ILAttribute option
mutable debuggerTypeProxyAttributeCache : ILAttribute option }
-/// Build the table of commonly used references given a ILScopeRef for mscorlib.
-val mkILGlobals : ILScopeRef -> string option -> bool -> ILGlobals
+ with
+ member mkDebuggableAttribute: bool (* debug tracking *) * bool (* disable JIT optimizations *) -> ILAttribute
+ /// Some commonly used custom attibutes
+ member mkDebuggableAttributeV2 : bool (* jitTracking *) * bool (* ignoreSymbolStoreSequencePoints *) * bool (* disable JIT optimizations *) * bool (* enable EnC *) -> ILAttribute
+ member mkCompilerGeneratedAttribute : unit -> ILAttribute
+ member mkDebuggerNonUserCodeAttribute : unit -> ILAttribute
+ member mkDebuggerStepThroughAttribute : unit -> ILAttribute
+ member mkDebuggerHiddenAttribute : unit -> ILAttribute
+ member mkDebuggerDisplayAttribute : string -> ILAttribute
+ member mkDebuggerTypeProxyAttribute : ILType -> ILAttribute
+ member mkDebuggerBrowsableNeverAttribute : unit -> ILAttribute
+
+/// Build the table of commonly used references given a ILScopeRef for system runtime assembly.
+val mkILGlobals : IPrimaryAssemblyTraits -> string option -> bool -> ILGlobals
+
+val mkMscorlibBasedTraits : ILScopeRef -> IPrimaryAssemblyTraits
+val EcmaILGlobals : ILGlobals
/// When writing a binary the fake "toplevel" type definition (called <Module>)
/// must come first. This function puts it first, and creates it in the returned list as an empty typedef if it
@@ -2171,28 +2209,11 @@ val instILType: ILGenericArgs -> ILType -> ILType
/// This is a 'vendor neutral' way of referencing mscorlib.
val ecmaPublicKey: PublicKey
-/// This is a 'vendor neutral' way of referencing mscorlib.
-val ecmaMscorlibScopeRef: ILScopeRef
-/// This is a 'vendor neutral' collection of references to items in mscorlib.
-val ecmaILGlobals: ILGlobals
-
/// Some commonly used methods
val mkInitializeArrayMethSpec: ILGlobals -> ILMethodSpec
-val mkMscorlibExnNewobj: ILGlobals -> string -> ILInstr
-
-/// Some commonly used custom attibutes
-val mkDebuggableAttribute: ILGlobals -> bool (* debug tracking *) * bool (* disable JIT optimizations *) -> ILAttribute
-val mkDebuggableAttributeV2: ILGlobals -> bool (* jitTracking *) * bool (* ignoreSymbolStoreSequencePoints *) * bool (* disable JIT optimizations *) * bool (* enable EnC *) -> ILAttribute
-
-val mkCompilerGeneratedAttribute : ILGlobals -> ILAttribute
-val mkDebuggerNonUserCodeAttribute : ILGlobals -> ILAttribute
-val mkDebuggerStepThroughAttribute : ILGlobals -> ILAttribute
-val mkDebuggerHiddenAttribute : ILGlobals -> ILAttribute
-val mkDebuggerDisplayAttribute : ILGlobals -> string -> ILAttribute
-val mkDebuggerTypeProxyAttribute : ILGlobals -> ILType -> ILAttribute
-val mkDebuggerBrowsableNeverAttribute : ILGlobals -> ILAttribute
+val mkPrimaryAssemblyExnNewobj: ILGlobals -> string -> ILInstr
val addMethodGeneratedAttrs : ILGlobals -> ILMethodDef -> ILMethodDef
val addPropertyGeneratedAttrs : ILGlobals -> ILPropertyDef -> ILPropertyDef
diff --git a/src/absil/ilascii.fs b/src/absil/ilascii.fs
index 709cc83..ceca10c 100755
--- a/src/absil/ilascii.fs
+++ b/src/absil/ilascii.fs
@@ -21,7 +21,8 @@ open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types
open Microsoft.FSharp.Compiler.AbstractIL.IL
-let parseILGlobals = ref ecmaILGlobals
+// set to the proper value at build.fs (BuildFrameworkTcImports)
+let parseILGlobals = ref EcmaILGlobals
// --------------------------------------------------------------------
// Table of parsing and pretty printing data for instructions.
diff --git a/src/absil/illib.fs b/src/absil/illib.fs
index 3b7bfb5..6df5dca 100755
--- a/src/absil/illib.fs
+++ b/src/absil/illib.fs
@@ -11,7 +11,9 @@
//----------------------------------------------------------------------------
-module (* internal *) Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
+
+
+module internal Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
#nowarn "1178" // The struct, record or union type 'internal_instr_extension' is not structurally comparable because the type
@@ -59,6 +61,8 @@ module Order =
module Array =
+ let take n xs = xs |> Seq.take n |> Array.ofSeq
+
let mapq f inp =
match inp with
| [| |] -> inp
@@ -94,9 +98,9 @@ module Array =
res, acc
- // REVIEW: systematically eliminate fmap/mapFold duplication.
+ // REVIEW: systematically eliminate foldMap/mapFold duplication.
// They only differ by the tuple returned by the function.
- let fmap f s l =
+ let foldMap f s l =
let mutable acc = s
let n = Array.length l
let mutable res = Array.zeroCreate n
@@ -160,8 +164,8 @@ module Option =
| None -> dflt
| Some x -> x
- // REVIEW: systematically eliminate fmap/mapFold duplication
- let fmap f z l =
+ // REVIEW: systematically eliminate foldMap/mapFold duplication
+ let foldMap f z l =
match l with
| None -> z,None
| Some x -> let z,x = f z x
@@ -350,11 +354,11 @@ module List =
List.rev r, s
// note: not tail recursive
- let rec mapfoldBack f l s =
+ let rec mapFoldBack f l s =
match l with
| [] -> ([],s)
| h::t ->
- let t',s = mapfoldBack f t s
+ let t',s = mapFoldBack f t s
let h',s = f h s
(h'::t', s)
@@ -369,10 +373,10 @@ module List =
let count pred xs = List.fold (fun n x -> if pred x then n+1 else n) 0 xs
- let rec private repeatA n x acc = if n <= 0 then acc else repeatA (n-1) x (x::acc)
- let repeat n x = repeatA n x []
+ let rec private repeatAux n x acc = if n <= 0 then acc else repeatAux (n-1) x (x::acc)
+ let repeat n x = repeatAux n x []
- (* WARNING: not tail-recursive *)
+ // WARNING: not tail-recursive
let mapHeadTail fhead ftail = function
| [] -> []
| [x] -> [fhead x]
@@ -385,25 +389,27 @@ module List =
let singleton x = [x]
// note: must be tail-recursive
- let rec private fmapA f z l acc =
+ let rec private foldMapAux f z l acc =
match l with
| [] -> z,List.rev acc
| x::xs -> let z,x = f z x
- fmapA f z xs (x::acc)
+ foldMapAux f z xs (x::acc)
// note: must be tail-recursive
- // REVIEW: systematically eliminate fmap/mapFold duplication
- let fmap f z l = fmapA f z l []
+ // REVIEW: systematically eliminate foldMap/mapFold duplication
+ let foldMap f z l = foldMapAux f z l []
let collect2 f xs ys = List.concat (List.map2 f xs ys)
+ let toArraySquared xss = xss |> List.map List.toArray |> List.toArray
let iterSquared f xss = xss |> List.iter (List.iter f)
let collectSquared f xss = xss |> List.collect (List.collect f)
let mapSquared f xss = xss |> List.map (List.map f)
- let mapfoldSquared f xss = xss |> mapFold (mapFold f)
+ let mapFoldSquared f z xss = mapFold (mapFold f) z xss
let forallSquared f xss = xss |> List.forall (List.forall f)
let mapiSquared f xss = xss |> List.mapi (fun i xs -> xs |> List.mapi (fun j x -> f i j x))
let existsSquared f xss = xss |> List.exists (fun xs -> xs |> List.exists (fun x -> f x))
+ let mapiFoldSquared f z xss = mapFoldSquared f z (xss |> mapiSquared (fun i j x -> (i,j,x)))
module String =
let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index for the character was not found in the string"))
@@ -539,13 +545,13 @@ module FlatList =
let arr,acc = Array.mapFold f acc x.array
FlatList(arr),acc
- // REVIEW: systematically eliminate fmap/mapFold duplication
- let fmap f acc (x:FlatList<_>) =
+ // REVIEW: systematically eliminate foldMap/mapFold duplication
+ let foldMap f acc (x:FlatList<_>) =
match x.array with
| null ->
acc,FlatList.Empty
| arr ->
- let acc,arr = Array.fmap f acc x.array
+ let acc,arr = Array.foldMap f acc x.array
acc,FlatList(arr)
#endif
#if FLAT_LIST_AS_LIST
@@ -558,7 +564,7 @@ module FlatList =
let order eltOrder = List.order eltOrder
let mapq f (x:FlatList<_>) = List.mapq f x
let mapFold f acc (x:FlatList<_>) = List.mapFold f acc x
- let fmap f acc (x:FlatList<_>) = List.fmap f acc x
+ let foldMap f acc (x:FlatList<_>) = List.foldMap f acc x
#endif
@@ -568,7 +574,7 @@ module FlatList =
let order eltOrder = Array.order eltOrder
let mapq f x = Array.mapq f x
let mapFold f acc x = Array.mapFold f acc x
- let fmap f acc x = Array.fmap f acc x
+ let foldMap f acc x = Array.foldMap f acc x
#endif
@@ -674,7 +680,7 @@ module Eventually =
| Exception e -> raise e)
let tryWith e handler =
- catch e
+ catch e
|> bind (function Result v -> Done v | Exception e -> handler e)
type EventuallyBuilder() =
@@ -837,18 +843,18 @@ module NameMap =
let toList (l: NameMap<'T>) = Map.toList l
let layer (m1 : NameMap<'T>) m2 = Map.foldBack Map.add m1 m2
- (* not a very useful function - only called in one place - should be changed *)
+ /// Not a very useful function - only called in one place - should be changed
let layerAdditive addf m1 m2 =
Map.foldBack (fun x y sofar -> Map.add x (addf (Map.tryFindMulti x sofar) y) sofar) m1 m2
- // Union entries by identical key, using the provided function to union sets of values
+ /// Union entries by identical key, using the provided function to union sets of values
let union unionf (ms: NameMap<_> seq) =
seq { for m in ms do yield! m }
|> Seq.groupBy (fun (KeyValue(k,_v)) -> k)
|> Seq.map (fun (k,es) -> (k,unionf (Seq.map (fun (KeyValue(_k,v)) -> v) es)))
|> Map.ofSeq
- (* For every entry in m2 find an entry in m1 and fold *)
+ /// For every entry in m2 find an entry in m1 and fold
let subfold2 errf f m1 m2 acc =
Map.foldBack (fun n x2 acc -> try f n (Map.find n m1) x2 acc with :? KeyNotFoundException -> errf n x2) m2 acc
@@ -915,435 +921,6 @@ module MultiMap =
let empty : MultiMap<_,_> = Map.empty
let initBy f xs : MultiMap<_,_> = xs |> Seq.groupBy f |> Seq.map (fun (k,v) -> (k,List.ofSeq v)) |> Map.ofSeq
-#if LAYERED_MAPS
-/// State of immutable map collection, converted to a dictionary on first lookup.
-[<RequireQualifiedAccess>]
-type LayeredMapState<'Key,'Value when 'Key : equality and 'Key : comparison> =
- /// Collapsible(entries, size)
- | Collapsible of list<seq<KeyValuePair<'Key,'Value>>> * int
- /// Collapsed(frontMap, backingDict)
- | Collapsed of (Map<'Key,'Value> * Dictionary<'Key,'Value>)
-
-/// Immutable map collection, with explicit flattening to a backing dictionary
-///
-/// A layered map is still an immutable map containing a "front"
-/// F# Map, but the layered map collapses its entries to a "backing"
-/// dictionary at specific "add-and-collapse" points.
-///
-/// For maps built from multiple "add-and-collapse" operations,
-/// the process of building the collapsed maps is coalesced.
-[<Sealed>]
-type LayeredMap<'Key,'Value when 'Key : equality and 'Key : comparison>(state:LayeredMapState<'Key,'Value>) =
- let mutable state = state
- static let empty = LayeredMap<'Key,'Value>(LayeredMapState.Collapsible ([],0))
-
- let entries() =
- match state with
- | LayeredMapState.Collapsible (el,n) -> (el,n)
- | LayeredMapState.Collapsed (m,d) -> [(m :> seq<_>); (d :> seq<_>)], m.Count + d.Count
-
- let markAsCollapsible() =
- match state with
- | LayeredMapState.Collapsible _ -> ()
- | LayeredMapState.Collapsed _ -> state <- LayeredMapState.Collapsible (entries())
-
- let collapse() =
- match state with
- | LayeredMapState.Collapsible (el, n) ->
- let d = Dictionary<_,_>(n)
- for e in List.rev el do
- for (KeyValue(k,v)) in e do
- d.[k] <- v
- let p = (Map.empty, d)
- state <- LayeredMapState.Collapsed p
- p
- | LayeredMapState.Collapsed p -> p
-
- let dict() =
- markAsCollapsible()
- let (_,dict) = collapse()
- dict
-
- static member Empty : LayeredMap<'Key,'Value> = empty
-
- member x.TryGetValue (key,res:byref<'Value>) =
- let (m,d) = collapse()
- match m.TryFind key with
- | None -> d.TryGetValue (key,&res)
- | Some r -> res <- r; true
-
- member x.ContainsKey k =
- let (map,dict) = collapse()
- map.ContainsKey k || dict.ContainsKey k
-
- member x.Item
- with get key =
- // collapse on first lookup
- let (map,dict) = collapse()
- match map.TryFind key with
- | None ->
- let mutable res = Unchecked.defaultof<_>
- if dict.TryGetValue (key, &res) then res
- else raise <| KeyNotFoundException("the key was not found in the LayerdNameMap")
- | Some v -> v
-
- member x.TryFind key =
- let (map,dict) = collapse()
- match map.TryFind key with
- | None ->
- let mutable res = Unchecked.defaultof<_>
- if dict.TryGetValue (key, &res) then Some res else None
- | res -> res
-
- member x.Values = dict().Values
-
- member x.Elements = dict() |> Seq.readonly
-
- member x.Add (key, value) =
- match state with
- | LayeredMapState.Collapsible (el,n) -> LayeredMap<_,_>(LayeredMapState.Collapsible ((([| KeyValuePair(key,value) |] :> seq<_>) :: el), n + 1))
- | LayeredMapState.Collapsed (map,dict) -> LayeredMap (LayeredMapState.Collapsed (map.Add (key,value), dict))
-
- member x.AddAndMarkAsCollapsible (kvs: _[]) =
- let el,n = entries()
- LayeredMap<_,_>(LayeredMapState.Collapsible (((kvs :> seq<_>) :: el), n + kvs.Length))
-
- member x.MarkAsCollapsible () =
- markAsCollapsible()
- x
-#endif
-
-#if LAYERED_MULTI_MAP
-/// State of immutable map collection, converted to a dictionary on first lookup.
-[<RequireQualifiedAccess>]
-type LayeredMultiMapState<'Key,'Value when 'Key : equality and 'Key : comparison> =
- /// Collapsible(entries, size)
- | Collapsible of list<seq<KeyValuePair<'Key,'Value list>>> * int
- /// Collapsed(frontMap, backingDict)
- | Collapsed of (MultiMap<'Key,'Value> * Dictionary<'Key,'Value list>)
-
-/// Immutable map collection, with explicit flattening to a backing dictionary
-[<Sealed>]
-type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(state:LayeredMultiMapState<'Key,'Value>) =
-
- let mutable state = state
- static let empty = LayeredMultiMap<'Key,'Value>(LayeredMultiMapState.Collapsible ([],0))
-
- let entries() =
- match state with
- | LayeredMultiMapState.Collapsible (el,n) -> (el,n)
- | LayeredMultiMapState.Collapsed (m,d) -> [(m :> seq<_>); (d :> seq<_>)], m.Count + d.Count
-
- let markAsCollapsible() =
- match state with
- | LayeredMultiMapState.Collapsible _ -> ()
- | LayeredMultiMapState.Collapsed _ -> state <- LayeredMultiMapState.Collapsible (entries())
-
- let collapse() =
- match state with
- | LayeredMultiMapState.Collapsible (el, n) ->
- let d = Dictionary<_,_>(n)
- for e in List.rev el do
- for (KeyValue(k,vs)) in e do
- for v in List.rev vs do
- let prev =
- let mutable res = Unchecked.defaultof<'Value list>
- let ok = d.TryGetValue(k,&res)
- if ok then res else []
- d.[k] <- v::prev
- let p = (MultiMap.empty, d)
- state <- LayeredMultiMapState.Collapsed p
- p
- | LayeredMultiMapState.Collapsed p -> p
-
- let dict() =
- markAsCollapsible()
- let (_,dict) = collapse()
- dict
-
- static member Empty : LayeredMultiMap<'Key,'Value> = empty
-
- member x.TryGetValue (key,res:byref<'Value list>) =
- let (m,d) = collapse()
- match m.TryFind key with
- | None -> d.TryGetValue (key,&res)
- | Some res1 ->
- let mutable res2 = Unchecked.defaultof<'Value list>
- let ok = d.TryGetValue (key,&res2)
- if ok then res <- (res1 at res2); true
- else res <- res1; true
-
- member x.ContainsKey k =
- let (map,dict) = collapse()
- map.ContainsKey k || dict.ContainsKey k
-
- member x.Item
- with get key =
- let mutable res = Unchecked.defaultof<_>
- if x.TryGetValue (key, &res) then res
- else []
-
- member x.TryFind key =
- let mutable res = Unchecked.defaultof<_>
- if x.TryGetValue (key, &res) then Some res
- else None
-
- member x.Values = dict().Values |> Seq.concat
-
- member x.Add (key, value) =
- match state with
- | LayeredMultiMapState.Collapsible (el,n) -> LayeredMultiMap<_,_>(LayeredMultiMapState.Collapsible ((([| KeyValuePair(key,[value]) |] :> seq<_>) :: el), n + 1))
- | LayeredMultiMapState.Collapsed (map,dict) -> LayeredMultiMap (LayeredMultiMapState.Collapsed (MultiMap.add key value map, dict))
-
- member x.AddAndMarkAsCollapsible (kvs: _[]) =
- let el,n = entries()
- LayeredMultiMap<_,_>(LayeredMultiMapState.Collapsible ((([| for KeyValue(k,v) in kvs -> KeyValuePair(k,[v]) |] :> seq<_>) :: el), n + kvs.Length))
-
- member x.MarkAsCollapsible () =
- markAsCollapsible()
- x
-
-#endif
-//#if NEW_LAYERED_MAP
-
-/// Immutable map collection, with explicit flattening to a backing dictionary
-///
-/// A layered map is still an immutable map containing a "front"
-/// F# Map, but the layered map collapses its treeMap to a "backing"
-/// dictionary at specific "add-and-tryCollapseToDictAndNothingElse" points.
-///
-/// For maps built from multiple "add-and-tryCollapseToDictAndNothingElse" operations,
-/// the process of building the collapsed maps is coalesced.
-type LayeredMap<'Key,'Value when 'Key : equality and 'Key : comparison>
- (// The queue of operations to build the full map, empty except during bulk-add operations
- xqueue: list<Choice<KeyValuePair<'Key,'Value>[],
- ('Key * ('Value option -> 'Value))>>,
- // The existing backing tree map (which is looked up in preference to the dictionary)
- xentries: Map<'Key,'Value>,
- // The existing backing dictionary (which may be null)
- xdict: Dictionary<'Key,'Value>) =
- static let empty = LayeredMap<'Key,'Value>([], Map.empty, null)
- let mutable state = (xqueue,xentries,xdict)
-
- let tryCollapseToDictAndNothingElse force =
- let (bulkQueue,treeMap,fastDict) = state
- if not bulkQueue.IsEmpty || force then
- // bulkQueue.Length +
- let d = Dictionary<_,_>(treeMap.Count + (match fastDict with null -> 0 | _ -> fastDict.Count))
- begin
- match fastDict with
- | null -> ()
- | _ ->
- for (KeyValue(k,v)) in fastDict do
- d.[k] <- v
- end
- treeMap |> Map.iter (fun k v -> d.[k] <- v)
- for kvsOrModify in List.rev bulkQueue do
- match kvsOrModify with
- | Choice1Of2 kvs ->
- for (KeyValue(k,v)) in kvs do
- d.[k] <- v
- | Choice2Of2 (k,updatef) ->
- let mutable prev = Unchecked.defaultof<_>
- let n = updatef (if d.TryGetValue(k,&prev) then Some prev else None)
- d.[k] <- n
-
- state <- ([], Map.empty, d)
- d
- elif treeMap.IsEmpty then fastDict
- else null
-
- static member Empty : LayeredMap<'Key,'Value> = empty
-
- member x.TryGetValue (key,res:byref<'Value>) =
- match tryCollapseToDictAndNothingElse false with
- | null ->
- let (_,treeMap,fastDict) = state
- match treeMap.TryFind key with
- | None ->
- match fastDict with
- | null -> false
- | _ -> fastDict.TryGetValue (key,&res)
- | Some r -> res <- r; true
- | fastDict ->
- //printfn "collapsed"
- match fastDict with
- | null -> false
- | _ -> fastDict.TryGetValue (key, &res)
-
- member x.ContainsKey key =
- let mutable res = Unchecked.defaultof<_>
- x.TryGetValue(key, &res)
-
- member x.Item
- with get key =
- let mutable res = Unchecked.defaultof<_>
- let ok = x.TryGetValue(key, &res)
- if ok then res
- else raise <| KeyNotFoundException("the key was not found in the LayerdNameMap")
-
- member x.TryFind key =
- let mutable res = Unchecked.defaultof<_>
- let ok = x.TryGetValue(key, &res)
- if ok then Some res else None
-
- member x.Values = (tryCollapseToDictAndNothingElse true).Values
-
- member x.Elements = (tryCollapseToDictAndNothingElse true) |> Seq.readonly
-
-
- member x.Add (key, value) =
- let (bulkQueue,treeMap,fastDict) = state
- if bulkQueue.IsEmpty then
- let treeMap = treeMap.Add (key, value)
- LayeredMap(bulkQueue, treeMap, fastDict)
- else
- // There are elements in the bulk queue, squash them down (mutating map "x"),
- // then use a one-element treemap
- let newFastDict = tryCollapseToDictAndNothingElse false
- match newFastDict with
- | null -> failwith "unreachable, bulkQueue was non empty, newFastDict should not be null"
- | _ -> LayeredMap([], Map.empty.Add(key,value), newFastDict)
-
- member x.AddAndMarkAsCollapsible (kvs: _[]) =
- if kvs.Length = 0 then x else
- let (bulkQueue,treeMap,fastDict) = state
- let state = (Choice1Of2 kvs::bulkQueue,treeMap,fastDict)
- LayeredMap state
-
- /// Push an item that transforms a possible existing entry. This is used for the bulk updates
- /// in nameres.fs, where, for each type we push during an "open", we must combine the
- /// type with any existing entries for types in the eUnqualifiedItems table.
- member x.LinearTryModifyThenLaterFlatten (key, f: 'Value option -> 'Value) =
- let (bulkQueue,treeMap,fastDict) = state
- let state = (Choice2Of2 (key,f)::bulkQueue,treeMap,fastDict)
- LayeredMap state
-
-
- member x.MarkAsCollapsible () = //x.AddAndMarkAsCollapsible [| |]
- let (bulkQueue,treeMap,fastDict) = state
- let state = (Choice1Of2 [| |]::bulkQueue,treeMap,fastDict)
- LayeredMap state
-
-
-//#endif
-
-//#if NEW_LAYERED_MULTI_MAP
-type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>
- (xqueue: list<KeyValuePair<'Key,'Value>[]>,
- xentries: Map<'Key,'Value list>,
- xdict: Dictionary<'Key,'Value list>) =
- static let empty = LayeredMultiMap<'Key,'Value>([], Map.empty, null)
- let mutable state = (xqueue,xentries,xdict)
-
- let tryCollapseToDictAndNothingElse force =
- let (bulkQueue,treeMap,fastDict) = state
- if not bulkQueue.IsEmpty || force then
- // bulkQueue.Length +
- let d = Dictionary<_,_>(treeMap.Count + (match fastDict with null -> 0 | _ -> fastDict.Count))
- begin
- match fastDict with
- | null -> ()
- | _ ->
- for (KeyValue(k,vs)) in fastDict do
- d.[k] <- vs
- end
- treeMap |> Map.iter (fun k vs ->
- let mutable prev = Unchecked.defaultof<_>
- if d.TryGetValue(k,&prev) then
- d.[k] <- vs at prev
- else
- d.[k] <- vs)
- //printfn "collapsing, bulkQueue = %A" bulkQueue
- for kvs in List.rev bulkQueue do
- //printfn "collapsing, bulkQueue.i] = %A" bulkQueue.[i]
- for (KeyValue(k,v)) in kvs do
- let mutable prev = Unchecked.defaultof<_>
- if d.TryGetValue(k,&prev) then
- d.[k] <- (v::prev)
- else
- d.[k] <- [v]
- state <- ([], Map.empty, d)
- d
- elif treeMap.IsEmpty then fastDict
- else null
-
- static member Empty : LayeredMultiMap<'Key,'Value> = empty
-
- member x.TryGetValue (key,res:byref<'Value list>) =
- match tryCollapseToDictAndNothingElse false with
- | null ->
- let (_,treeMap,fastDict) = state
- match treeMap.TryFind key with
- | None ->
- match fastDict with
- | null -> false
- | _ -> fastDict.TryGetValue (key,&res)
- | Some r ->
- match fastDict with
- | null ->
- res <- r
- true
- | _ ->
- let mutable res2 = Unchecked.defaultof<_>
- if fastDict.TryGetValue (key,&res2) then
- res <- r at res2
- else
- res <- r
- true
- | fastDict ->
- //printfn "collapsed"
- match fastDict with
- | null -> false
- | _ -> fastDict.TryGetValue (key, &res)
-
- member x.ContainsKey key =
- let mutable res = Unchecked.defaultof<_>
- x.TryGetValue(key, &res)
-
- member x.Item
- with get key =
- let mutable res = Unchecked.defaultof<_>
- let ok = x.TryGetValue(key, &res)
- if ok then res else []
-
- member x.TryFind key =
- let mutable res = Unchecked.defaultof<_>
- let ok = x.TryGetValue(key, &res)
- if ok then Some res else None
-
- member x.Values = (tryCollapseToDictAndNothingElse true).Values |> Seq.concat
-
- member x.Elements = (tryCollapseToDictAndNothingElse true) |> Seq.readonly
-
- member x.Add (key, value) =
- let (bulkQueue,treeMap,fastDict) = state
- if bulkQueue.IsEmpty then
- let prev = match treeMap.TryFind key with None -> [] | Some vs -> vs
- let treeMap = treeMap.Add (key, value::prev)
- LayeredMultiMap(bulkQueue, treeMap, fastDict)
- else
- // There are elements in the bulk queue, squash them down (mutating map "x"),
- // then use a one-element treemap
- let newFastDict = tryCollapseToDictAndNothingElse false
- match newFastDict with
- | null -> failwith "unreachable, bulkQueue was non empty, newFastDict should not be null"
- | _ -> LayeredMultiMap([], Map.empty.Add(key,[value]), newFastDict)
-
- member x.AddAndMarkAsCollapsible (kvs: _[]) =
- if kvs.Length = 0 then x else
- let (bulkQueue,treeMap,fastDict) = state
- let state = (kvs::bulkQueue,treeMap,fastDict)
- LayeredMultiMap state
-
- member x.MarkAsCollapsible () = //x.AddAndMarkAsCollapsible [| |]
- let (bulkQueue,treeMap,fastDict) = state
- let state = ([| |]::bulkQueue,treeMap,fastDict)
- LayeredMultiMap state
-
-//#endif
-
-#if NO_LAYERED_MAP
type LayeredMap<'Key,'Value when 'Key : comparison> = Map<'Key,'Value>
type Map<'Key,'Value when 'Key : comparison> with
@@ -1358,28 +935,20 @@ type Map<'Key,'Value when 'Key : comparison> with
member x.Elements = [ for kvp in x -> kvp ]
member x.AddAndMarkAsCollapsible (kvs: _[]) = (x,kvs) ||> Array.fold (fun x (KeyValue(k,v)) -> x.Add(k,v))
member x.LinearTryModifyThenLaterFlatten (key, f: 'Value option -> 'Value) = x.Add (key, f (x.TryFind key))
-
member x.MarkAsCollapsible () = x
-//#endif
-
-
-//#if NO_LAYERED_MULTI_MAP
/// Immutable map collection, with explicit flattening to a backing dictionary
[<Sealed>]
-type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(contents : Map<'Key,'Value list>) =
- static let empty : LayeredMultiMap<'Key,'Value> = LayeredMultiMap Map.empty
+type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(contents : LayeredMap<'Key,'Value list>) =
member x.Add (k,v) = LayeredMultiMap(contents.Add(k,v :: x.[k]))
member x.Item with get k = match contents.TryFind k with None -> [] | Some l -> l
member x.AddAndMarkAsCollapsible (kvs: _[]) =
let x = (x,kvs) ||> Array.fold (fun x (KeyValue(k,v)) -> x.Add(k,v))
x.MarkAsCollapsible()
- member x.MarkAsCollapsible() = x //LayeredMultiMap(contents)
+ member x.MarkAsCollapsible() = LayeredMultiMap(contents.MarkAsCollapsible())
member x.TryFind k = contents.TryFind k
- member x.Values = [ for (KeyValue(_,v)) in contents -> v ] |> Seq.concat
- static member Empty : LayeredMultiMap<'Key,'Value> = empty
-
-#endif
+ member x.Values = contents.Values |> Seq.concat
+ static member Empty : LayeredMultiMap<'Key,'Value> = LayeredMultiMap LayeredMap.Empty
[<AutoOpen>]
module Shim =
@@ -1431,7 +1000,12 @@ module Shim =
with e ->
this.AssemblyLoadFrom(assemblyName.Name + ".dll")
#else
- default this.AssemblyLoadFrom(fileName:string) = System.Reflection.Assembly.LoadFrom fileName
+ default this.AssemblyLoadFrom(fileName:string) =
+#if FX_ATLEAST_40_COMPILER_LOCATION
+ System.Reflection.Assembly.UnsafeLoadFrom fileName
+#else
+ System.Reflection.Assembly.LoadFrom fileName
+#endif
default this.AssemblyLoad(assemblyName:System.Reflection.AssemblyName) = System.Reflection.Assembly.Load assemblyName
#endif
diff --git a/src/absil/ilpars.fsy b/src/absil/ilpars.fsy
index 71545cc..934a686 100755
--- a/src/absil/ilpars.fsy
+++ b/src/absil/ilpars.fsy
@@ -61,13 +61,14 @@ let resolveCurrentMethodSpecScope obj =
resolveMethodSpecScope obj mkILEmptyGenericParams
-let findMscorlibAssemblyRef() =
- match (!parseILGlobals).mscorlibScopeRef with
+let findSystemRuntimeAssemblyRef() =
+ match (!parseILGlobals).traits.ScopeRef with
| ILScopeRef.Assembly aref -> aref
- | _ -> pfailwith "mscorlibScopeRef not set to valid assembly reference in parseILGlobals"
+ | _ -> pfailwith "systemRuntimeScopeRef not set to valid assembly reference in parseILGlobals"
let findAssemblyRef nm =
- if nm = "mscorlib" then findMscorlibAssemblyRef() else
+ if nm = "mscorlib" then findSystemRuntimeAssemblyRef()
+ else
pfailwith ("Undefined assembly ref '" + nm + "'")
%}
diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs
index 0f00958..fdc64db 100755
--- a/src/absil/ilprint.fs
+++ b/src/absil/ilprint.fs
@@ -177,21 +177,21 @@ and goutput_typ env os ty =
| ILType.Byref typ -> goutput_typ env os typ; output_string os "&"
| ILType.Ptr typ -> goutput_typ env os typ; output_string os "*"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_SByte.Name -> output_string os "int8"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Int16.Name -> output_string os "int16"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Int32.Name -> output_string os "int32"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Int64.Name -> output_string os "int64"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_IntPtr.Name -> output_string os "native int"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Byte.Name -> output_string os "unsigned int8"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_UInt16.Name -> output_string os "unsigned int16"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_UInt32.Name -> output_string os "unsigned int32"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_UInt64.Name -> output_string os "unsigned int64"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_UIntPtr.Name -> output_string os "native unsigned int"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Double.Name -> output_string os "float64"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Single.Name -> output_string os "float32"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Bool.Name -> output_string os "bool"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_Char.Name -> output_string os "char"
- | ILType.Value tspec when tspec.Name = ecmaILGlobals.tspec_TypedReference.Name -> output_string os "refany"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_SByte.Name -> output_string os "int8"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Int16.Name -> output_string os "int16"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Int32.Name -> output_string os "int32"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Int64.Name -> output_string os "int64"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_IntPtr.Name -> output_string os "native int"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Byte.Name -> output_string os "unsigned int8"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_UInt16.Name -> output_string os "unsigned int16"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_UInt32.Name -> output_string os "unsigned int32"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_UInt64.Name -> output_string os "unsigned int64"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_UIntPtr.Name -> output_string os "native unsigned int"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Double.Name -> output_string os "float64"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Single.Name -> output_string os "float32"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Bool.Name -> output_string os "bool"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_Char.Name -> output_string os "char"
+ | ILType.Value tspec when tspec.Name = EcmaILGlobals.tspec_TypedReference.Value.Name -> output_string os "refany"
| ILType.Value tspec ->
output_string os "value class ";
goutput_tref env os tspec.TypeRef;
@@ -715,7 +715,7 @@ let rec goutput_instr env os inst =
goutput_dlocref env os (mkILArrTy(typ,shape));
output_string os ".ctor";
let rank = shape.Rank
- output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) ecmaILGlobals.typ_int32))
+ output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) EcmaILGlobals.typ_int32))
| I_stelem_any (shape,dt) ->
if shape = ILArrayShape.SingleDimensional then
output_string os "stelem.any "; goutput_typ env os dt
@@ -724,7 +724,7 @@ let rec goutput_instr env os inst =
goutput_dlocref env os (mkILArrTy(dt,shape));
output_string os "Set";
let rank = shape.Rank
- output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) ecmaILGlobals.typ_int32) @ [dt])
+ output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) EcmaILGlobals.typ_int32) @ [dt])
| I_ldelem_any (shape,tok) ->
if shape = ILArrayShape.SingleDimensional then
output_string os "ldelem.any "; goutput_typ env os tok
@@ -735,7 +735,7 @@ let rec goutput_instr env os inst =
goutput_dlocref env os (mkILArrTy(tok,shape));
output_string os "Get";
let rank = shape.Rank
- output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) ecmaILGlobals.typ_int32))
+ output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) EcmaILGlobals.typ_int32))
| I_ldelema (ro,_,shape,tok) ->
if ro = ReadonlyAddress then output_string os "readonly. ";
if shape = ILArrayShape.SingleDimensional then
@@ -747,7 +747,7 @@ let rec goutput_instr env os inst =
goutput_dlocref env os (mkILArrTy(tok,shape));
output_string os "Address";
let rank = shape.Rank
- output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) ecmaILGlobals.typ_int32))
+ output_parens (output_seq "," (goutput_typ env)) os (Array.toList (Array.create ( rank) EcmaILGlobals.typ_int32))
| I_box tok -> output_string os "box "; goutput_typ env os tok
| I_unbox tok -> output_string os "unbox "; goutput_typ env os tok
@@ -1216,7 +1216,6 @@ let output_module_fragment_aux _refs os modul =
with e ->
output_string os "*** Error during printing : "; output_string os (e.ToString()); os.Flush();
reraise()
- raise e
let output_module_fragment os modul =
let refs = computeILRefs modul
diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs
index 01ca3b5..bd4035f 100755
--- a/src/absil/ilread.fs
+++ b/src/absil/ilread.fs
@@ -26,7 +26,10 @@ open System.Collections.Generic
open Internal.Utilities
open Microsoft.FSharp.Compiler.AbstractIL
open Microsoft.FSharp.Compiler.AbstractIL.Internal
+#if NO_PDB_READER
+#else
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Support
+#endif
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
open Microsoft.FSharp.Compiler.AbstractIL.Internal.BinaryConstants
open Microsoft.FSharp.Compiler.AbstractIL.IL
@@ -2175,7 +2178,10 @@ and sigptrGetTy ctxt numtypars bytes sigptr =
mkILArrTy (typ, shape), sigptr
elif b0 = et_VOID then ILType.Void, sigptr
- elif b0 = et_TYPEDBYREF then ctxt.ilg.typ_TypedReference, sigptr
+ elif b0 = et_TYPEDBYREF then
+ match ctxt.ilg.typ_TypedReference with
+ | Some t -> t, sigptr
+ | _ -> failwith "system runtime doesn't contain System.TypedReference"
elif b0 = et_CMOD_REQD || b0 = et_CMOD_OPT then
let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr
let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
@@ -4076,10 +4082,10 @@ let rec genOpenBinaryReader infile is opts =
let CloseILModuleReader x = x.dispose()
-let defaults =
+let mkDefault ilg =
{ optimizeForMemory=false;
pdbPath= None;
- ilGlobals=ecmaILGlobals }
+ ilGlobals = ilg }
#if NO_PDB_READER
let ClosePdbReader _x = ()
diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi
index 55969db..c459e18 100755
--- a/src/absil/ilread.fsi
+++ b/src/absil/ilread.fsi
@@ -48,7 +48,7 @@ type ILReaderOptions =
ilGlobals: ILGlobals;
optimizeForMemory: bool (* normally off, i.e. optimize for startup-path speed *) }
-val defaults : ILReaderOptions
+val mkDefault : ILGlobals -> ILReaderOptions
// The non-memory resources (i.e. the file handle) associated with
// the read can be recovered by calling CloseILModuleReader. Any reamining
diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs
index f40fd0f..6fbfbbe 100755
--- a/src/absil/ilreflect.fs
+++ b/src/absil/ilreflect.fs
@@ -414,7 +414,8 @@ type emEnv =
emLocals : LocalBuilder[];
emLabels : Zmap<IL.ILCodeLabel,Label>;
emTyvars : Type[] list; // stack
- emEntryPts : (TypeBuilder * string) list }
+ emEntryPts : (TypeBuilder * string) list
+ delayedFieldInits : (unit -> unit) list}
let orderILTypeRef = ComparisonIdentity.Structural<ILTypeRef>
let orderILMethodRef = ComparisonIdentity.Structural<ILMethodRef>
@@ -430,7 +431,8 @@ let emEnv0 =
emLocals = [| |];
emLabels = Zmap.empty codeLabelOrder;
emTyvars = [];
- emEntryPts = []; }
+ emEntryPts = []
+ delayedFieldInits = [] }
let envBindTypeRef emEnv (tref:ILTypeRef) (typT,typB,typeDef)=
match typT with
@@ -581,8 +583,10 @@ and convTypeAux cenv emEnv preferCreated typ =
baseT.MakeByRefType() |> nonNull "convType: byref"
| ILType.TypeVar tv -> envGetTyvar emEnv tv |> nonNull "convType: tyvar"
// XXX: REVIEW: complete the following cases.
+ | ILType.Modified (false, _, modifiedTy) -> convTypeAux cenv emEnv preferCreated modifiedTy
+ | ILType.Modified (true, _, _) -> failwith "convType: modreq"
| ILType.FunctionPointer _callsig -> failwith "convType: fptr"
- | ILType.Modified _ -> failwith "convType: modified"
+
// [Bug 4063].
// The convType functions convert AbsIL types into concrete Type values.
@@ -919,6 +923,8 @@ let emitInstrCall cenv emEnv (ilG:ILGenerator) opCall tail (mspec:ILMethodSpec)
else
let minfo = convMethodSpec cenv emEnv mspec
#if SILVERLIGHT
+ // When generating code for silverlight, we intercept direct
+ // calls to System.Console.WriteLine.
let fullName = minfo.DeclaringType.FullName + "." + minfo.Name
let minfo =
if fullName = "System.Console.WriteLine" || fullName = "System.Console.Write" then
@@ -1653,7 +1659,23 @@ let buildFieldPass2 cenv tref (typB:TypeBuilder) emEnv (fdef : ILFieldDef) =
typB.DefineFieldAndLog(fdef.Name,fieldT,attrs)
// set default value
- fdef.LiteralValue |> Option.iter (fun initial -> fieldB.SetConstant(convFieldInit initial));
+ let emEnv =
+ match fdef.LiteralValue with
+ | None -> emEnv
+ | Some initial ->
+ if not fieldT.IsEnum
+#if FX_ATLEAST_45
+ || not fieldT.Assembly.IsDynamic // it is ok to init fields with type = enum that are defined in other assemblies
+#endif
+ then
+ fieldB.SetConstant(convFieldInit initial)
+ emEnv
+ else
+ // if field type (enum) is defined in FSI dynamic assembly it is created as nested type
+ // => its underlying type cannot be explicitly specified and will be inferred at the very moment of first field definition
+ // => here we cannot detect if underlying type is already set so as a conservative solution we delay initialization of fields
+ // to the end of pass2 (types and members are already created but method bodies are yet not emitted)
+ { emEnv with delayedFieldInits = (fun() -> fieldB.SetConstant(convFieldInit initial))::emEnv.delayedFieldInits }
#if FX_ATLEAST_SILVERLIGHT_50
#else
fdef.Offset |> Option.iter (fun offset -> fieldB.SetOffset(offset));
@@ -1761,8 +1783,8 @@ let typeAttributesOfTypeLayout cenv emEnv x =
else
Some(convCustomAttr cenv emEnv
(IL.mkILCustomAttribute cenv.ilg
- (mkILTyRef (cenv.ilg.mscorlibScopeRef,"System.Runtime.InteropServices.StructLayoutAttribute"),
- [mkILNonGenericValueTy (mkILTyRef (cenv.ilg.mscorlibScopeRef,"System.Runtime.InteropServices.LayoutKind")) ],
+ (mkILTyRef (cenv.ilg.traits.ScopeRef,"System.Runtime.InteropServices.StructLayoutAttribute"),
+ [mkILNonGenericValueTy (mkILTyRef (cenv.ilg.traits.ScopeRef,"System.Runtime.InteropServices.LayoutKind")) ],
[ ILAttribElem.Int32 0x02 ],
(p.Pack |> Option.toList |> List.map (fun x -> ("Pack", cenv.ilg.typ_int32, false, ILAttribElem.Int32 (int32 x)))) @
(p.Size |> Option.toList |> List.map (fun x -> ("Size", cenv.ilg.typ_int32, false, ILAttribElem.Int32 x)))))) in
@@ -2024,6 +2046,12 @@ let buildModuleFragment cenv emEnv (asmB : AssemblyBuilder) (modB : ModuleBuilde
let emEnv = List.fold (buildModuleTypePass1 cenv modB) emEnv tdefs
tdefs |> List.iter (buildModuleTypePass1b cenv emEnv)
let emEnv = List.fold (buildModuleTypePass2 cenv) emEnv tdefs
+
+ for delayedFieldInit in emEnv.delayedFieldInits do
+ delayedFieldInit()
+
+ let emEnv = { emEnv with delayedFieldInits = [] }
+
let emEnv = List.fold (buildModuleTypePass3 cenv modB) emEnv tdefs
let visited = new Dictionary<_,_>(10)
let created = new Dictionary<_,_>(10)
@@ -2053,7 +2081,7 @@ let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo) =
let filename = assemblyName ^ ".dll"
let currentDom = System.AppDomain.CurrentDomain
#if SILVERLIGHT
- let _asmDir = if optimize then "." else "." // TODO: factor out optimize
+ ignore optimize
let asmName = new AssemblyName()
asmName.Name <- assemblyName;
let asmB = currentDom.DefineDynamicAssembly(asmName,AssemblyBuilderAccess.Run)
@@ -2129,4 +2157,3 @@ let LookupType cenv emEnv typ = convCreatedType cenv emEnv typ
let LookupFieldRef emEnv fref = Zmap.tryFind fref emEnv.emFieldMap |> Option.map (fun fieldBuilder -> fieldBuilder :> FieldInfo)
let LookupMethodRef emEnv mref = Zmap.tryFind mref emEnv.emMethMap |> Option.map (fun methodBuilder -> methodBuilder :> MethodInfo)
-
diff --git a/src/absil/ilsupp.fs b/src/absil/ilsupp.fs
index 9dbceeb..ebc9672 100755
--- a/src/absil/ilsupp.fs
+++ b/src/absil/ilsupp.fs
@@ -53,9 +53,9 @@ let check _action (hresult) =
// of the debug symbols file. This function takes output file name and returns debug file name.
let getDebugFileName outfile =
if IL.runningOnMono then
- outfile^".mdb"
+ outfile+".mdb"
else
- (Filename.chopExtension outfile)^".pdb"
+ (Filename.chopExtension outfile)+".pdb"
type PEFileType = X86 | X64
@@ -897,8 +897,8 @@ type IMetadataEmit =
[< Guid("B01FAFEB-C450-3A4D-BEEC-B4CEEC01E006") ; InterfaceType(ComInterfaceType.InterfaceIsIUnknown) >]
[< ComVisible(false) >]
type ISymUnmanagedDocumentWriter =
- abstract SetSource : sourceSize : int * source : byte[] -> unit
- abstract SetCheckSum : algorithmId : System.Guid * checkSumSize : int * checkSum : byte [] -> unit
+ abstract SetSource : sourceSize : int * [<MarshalAs(UnmanagedType.LPArray)>] source : byte[] -> unit
+ abstract SetCheckSum : algorithmId : System.Guid * checkSumSize : int * [<MarshalAs(UnmanagedType.LPArray)>] checkSum : byte [] -> unit
// Struct used to retrieve info on the debug output
[<Struct; StructLayout(LayoutKind.Sequential)>]
@@ -1023,7 +1023,6 @@ type ISymUnmanagedWriter2 =
isect : int *
offset : int -> unit
-
type PdbWriter = { symWriter : ISymUnmanagedWriter2 }
type PdbDocumentWriter = { symDocWriter : ISymUnmanagedDocumentWriter } (* pointer to pDocumentWriter COM object *)
@@ -1060,6 +1059,10 @@ let pdbInitialize (binaryName:string) (pdbName:string) =
[<assembly:System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Reliability", "CA2001:AvoidCallingProblematicMethods", Scope="member", Target="Microsoft.FSharp.Compiler.AbstractIL.Internal.Support.#pdbClose(Microsoft.FSharp.Compiler.AbstractIL.Internal.Support+PdbWriter)", MessageId="System.GC.Collect")>]
do()
+let pdbCloseDocument(documentWriter : PdbDocumentWriter) =
+ Marshal.ReleaseComObject (documentWriter.symDocWriter)
+ |> ignore
+
[<System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Reliability", "CA2001:AvoidCallingProblematicMethods", MessageId="System.GC.Collect")>]
let pdbClose (writer:PdbWriter) =
writer.symWriter.Close()
@@ -1071,7 +1074,6 @@ let pdbClose (writer:PdbWriter) =
// The SymReader class gets around this problem by implementing the ISymUnmanagedDispose
// interface, which the SymWriter class, unfortunately, does not.
// Right now, take the same approach as mdbg, and manually forcing a collection.
-
let rc = Marshal.ReleaseComObject(writer.symWriter)
for i = 0 to (rc - 1) do
Marshal.ReleaseComObject(writer.symWriter) |> ignore
@@ -1091,6 +1093,23 @@ let pdbClose (writer:PdbWriter) =
let pdbSetUserEntryPoint (writer:PdbWriter) (entryMethodToken:int32) =
writer.symWriter.SetUserEntryPoint((uint32)entryMethodToken)
+// Document checksum algorithms
+
+let guidSourceHashMD5 = System.Guid(0x406ea660u, 0x64cfus, 0x4c82us, 0xb6uy, 0xf0uy, 0x42uy, 0xd4uy, 0x81uy, 0x72uy, 0xa7uy, 0x99uy) //406ea660-64cf-4c82-b6f0-42d48172a799
+let hashSizeOfMD5 = 16
+
+// If the FIPS algorithm policy is enabled on the computer (e.g., for US government employees and contractors)
+// then obtaining the MD5 implementation in BCL will throw.
+// In this case, catch the failure, and not set a checksum.
+let internal setCheckSum (url:string, writer:ISymUnmanagedDocumentWriter) =
+ try
+ use file = new FileStream(url, FileMode.Open, FileAccess.Read, FileShare.Read)
+ use md5 = System.Security.Cryptography.MD5.Create()
+ let checkSum = md5.ComputeHash(file)
+ if (checkSum.Length = hashSizeOfMD5) then
+ writer.SetCheckSum (guidSourceHashMD5, hashSizeOfMD5, checkSum)
+ with _ -> ()
+
let pdbDefineDocument (writer:PdbWriter) (url:string) =
//3F5162F8-07C6-11D3-9053-00C04FA302A1
//let mutable corSymLanguageTypeCSharp = System.Guid(0x3F5162F8u, 0x07C6us, 0x11D3us, 0x90uy, 0x53uy, 0x00uy, 0xC0uy, 0x4Fuy, 0xA3uy, 0x02uy, 0xA1uy)
@@ -1099,6 +1118,7 @@ let pdbDefineDocument (writer:PdbWriter) (url:string) =
let mutable corSymDocumentTypeText = System.Guid(0x5a869d0bu, 0x6611us, 0x11d3us, 0xbduy, 0x2auy, 0x0uy, 0x0uy, 0xf8uy, 0x8uy, 0x49uy, 0xbduy)
let mutable docWriter = Unchecked.defaultof<ISymUnmanagedDocumentWriter>
writer.symWriter.DefineDocument(url, &corSymLanguageTypeFSharp, &corSymLanguageVendorMicrosoft, &corSymDocumentTypeText, &docWriter)
+ setCheckSum (url, docWriter)
{ symDocWriter = docWriter }
let pdbOpenMethod (writer:PdbWriter) (methodToken:int32) =
diff --git a/src/absil/ilsupp.fsi b/src/absil/ilsupp.fsi
index d6e4f0e..44cd9a5 100755
--- a/src/absil/ilsupp.fsi
+++ b/src/absil/ilsupp.fsi
@@ -108,6 +108,7 @@ val pdbInitialize:
string (* .pdb to write *) ->
PdbWriter
val pdbClose: PdbWriter -> unit
+val pdbCloseDocument : PdbDocumentWriter -> unit
val pdbSetUserEntryPoint: PdbWriter -> int32 -> unit
val pdbDefineDocument: PdbWriter -> string -> PdbDocumentWriter
val pdbOpenMethod: PdbWriter -> int32 -> unit
diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs
index d49b53f..67174d8 100755
--- a/src/absil/ilwrite.fs
+++ b/src/absil/ilwrite.fs
@@ -346,6 +346,10 @@ let WritePdbInfo fixupOverlappingSequencePoints showTimes f fpdb info =
end);
reportTime showTimes "PDB: Wrote methods";
let res = pdbGetDebugInfo !pdbw
+
+ for pdbDoc in docs do
+ pdbCloseDocument pdbDoc
+
pdbClose !pdbw;
reportTime showTimes "PDB: Closed";
res
@@ -910,7 +914,7 @@ type TypeDefTableKey = TdKey of string list (* enclosing *) * string (* type nam
[<NoEquality; NoComparison>]
type cenv =
- { mscorlib: ILScopeRef;
+ { primaryAssembly: ILScopeRef;
ilg: ILGlobals;
emitTailcalls: bool;
showTimes: bool;
@@ -1583,8 +1587,6 @@ and GenTypeDefPass2 pidx enc cenv (td:ILTypeDef) =
td.NestedTypes.AsList |> GenTypeDefsPass2 tidx (enc@[td.Name]) cenv
with e ->
failwith ("Error in pass2 for type "+td.Name+", error: "+e.Message);
- reraise()
- raise e
and GenTypeDefsPass2 pidx enc cenv tds =
List.iter (GenTypeDefPass2 pidx enc cenv) tds
@@ -1642,17 +1644,15 @@ and GetFieldDefAsFieldDefIdx cenv tidx fd =
// --------------------------------------------------------------------
let GetMethodRefAsMethodDefIdx cenv (mref:ILMethodRef) =
+ let tref = mref.EnclosingTypeRef
try
- let tref = mref.EnclosingTypeRef
if not (isTypeRefLocal tref) then
failwithf "method referred to by method impl, event or property is not in a type defined in this module, method ref is %A" mref;
let tidx = GetIdxForTypeDef cenv (TdKey(tref.Enclosing,tref.Name))
let mdkey = MethodDefKey (tidx,mref.GenericArity, mref.Name, mref.ReturnType, mref.ArgTypes, mref.CallingConv.IsStatic)
FindMethodDefIdx cenv mdkey
with e ->
- failwithf "Error in GetMethodRefAsMethodDefIdx for mref = %A, error: %s" mref.Name e.Message;
- reraise()
- raise e
+ failwithf "Error in GetMethodRefAsMethodDefIdx for mref = %A, error: %s" (mref.Name, tref.Name) e.Message;
let rec MethodRefInfoAsMemberRefRow cenv env fenv (nm,typ,callconv,args,ret,varargs,genarity) =
MemberRefRow(GetTypeAsMemberRefParent cenv env typ,
@@ -1794,11 +1794,11 @@ and GetCustomAttrRow cenv hca attr =
CustomAttributeType (fst cat, snd cat);
Blob (GetCustomAttrDataAsBlobIdx cenv attr.Data); |]
-and GenCustomAttrPass3 cenv hca attr =
+and GenCustomAttrPass3Or4 cenv hca attr =
AddUnsharedRow cenv TableNames.CustomAttribute (GetCustomAttrRow cenv hca attr) |> ignore
-and GenCustomAttrsPass3 cenv hca (attrs: ILAttributes) =
- attrs.AsList |> List.iter (GenCustomAttrPass3 cenv hca)
+and GenCustomAttrsPass3Or4 cenv hca (attrs: ILAttributes) =
+ attrs.AsList |> List.iter (GenCustomAttrPass3Or4 cenv hca)
// --------------------------------------------------------------------
// ILPermissionSet --> DeclSecurity rows
@@ -2763,7 +2763,7 @@ and GetFieldDefSigAsBlobIdx cenv env fd = GetFieldDefTypeAsBlobIdx cenv env fd.T
and GenFieldDefPass3 cenv env fd =
let fidx = AddUnsharedRow cenv TableNames.Field (GetFieldDefAsFieldDefRow cenv env fd)
- GenCustomAttrsPass3 cenv (hca_FieldDef,fidx) fd.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_FieldDef,fidx) fd.CustomAttrs;
// Write FieldRVA table - fixups into data section done later
match fd.Data with
| None -> ()
@@ -2836,12 +2836,15 @@ and GenGenericParamConstraintPass4 cenv env gpidx ty =
AddUnsharedRow cenv TableNames.GenericParamConstraint (GenTypeAsGenericParamConstraintRow cenv env gpidx ty) |> ignore
and GenGenericParamPass3 cenv env idx owner gp =
+ // here we just collect generic params, its constraints\custom attributes will be processed on pass4
// shared since we look it up again below in GenGenericParamPass4
- let gpidx = AddSharedRow cenv TableNames.GenericParam (GetGenericParamAsGenericParamRow cenv env idx owner gp)
- GenCustomAttrsPass3 cenv (hca_GenericParam,gpidx) gp.CustomAttrs;
+ AddSharedRow cenv TableNames.GenericParam (GetGenericParamAsGenericParamRow cenv env idx owner gp)
+ |> ignore
+
and GenGenericParamPass4 cenv env idx owner gp =
let gpidx = FindOrAddRow cenv TableNames.GenericParam (GetGenericParamAsGenericParamRow cenv env idx owner gp)
+ GenCustomAttrsPass3Or4 cenv (hca_GenericParam, gpidx) gp.CustomAttrs
gp.Constraints |> ILList.iter (GenGenericParamConstraintPass4 cenv env gpidx)
// --------------------------------------------------------------------
@@ -2866,7 +2869,7 @@ and GenParamPass3 cenv env seq param =
then ()
else
let pidx = AddUnsharedRow cenv TableNames.Param (GetParamAsParamRow cenv env seq param)
- GenCustomAttrsPass3 cenv (hca_ParamDef,pidx) param.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_ParamDef,pidx) param.CustomAttrs;
// Write FieldRVA table - fixups into data section done later
match param.Marshal with
| None -> ()
@@ -2885,7 +2888,7 @@ let GenReturnAsParamRow (returnv : ILReturn) =
let GenReturnPass3 cenv (returnv: ILReturn) =
if isSome returnv.Marshal || nonNil returnv.CustomAttrs.AsList then
let pidx = AddUnsharedRow cenv TableNames.Param (GenReturnAsParamRow returnv)
- GenCustomAttrsPass3 cenv (hca_ParamDef,pidx) returnv.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_ParamDef,pidx) returnv.CustomAttrs;
match returnv.Marshal with
| None -> ()
| Some ntyp ->
@@ -3003,7 +3006,7 @@ let GenMethodDefPass3 cenv env (md:ILMethodDef) =
if midx <> idx2 then failwith "index of method def on pass 3 does not match index on pass 2";
GenReturnPass3 cenv md.Return;
md.Parameters |> ILList.iteri (fun n param -> GenParamPass3 cenv env (n+1) param) ;
- md.CustomAttrs |> GenCustomAttrsPass3 cenv (hca_MethodDef,midx) ;
+ md.CustomAttrs |> GenCustomAttrsPass3Or4 cenv (hca_MethodDef,midx) ;
md.SecurityDecls.AsList |> GenSecurityDeclsPass3 cenv (hds_MethodDef,midx);
md.GenericParams |> List.iteri (fun n gp -> GenGenericParamPass3 cenv env n (tomd_MethodDef, midx) gp) ;
match md.mdBody.Contents with
@@ -3091,7 +3094,7 @@ and GenPropertyPass3 cenv env prop =
[| GetFieldInitFlags i;
HasConstant (hc_Property, pidx);
Blob (GetFieldInitAsBlobIdx cenv i) |]) |> ignore
- GenCustomAttrsPass3 cenv (hca_Property,pidx) prop.CustomAttrs
+ GenCustomAttrsPass3Or4 cenv (hca_Property,pidx) prop.CustomAttrs
let rec GenEventMethodSemanticsPass3 cenv eidx kind mref =
let addIdx = try GetMethodRefAsMethodDefIdx cenv mref with MethodDefNotFound -> 1
@@ -3118,7 +3121,7 @@ and GenEventPass3 cenv env (md: ILEventDef) =
md.RemoveMethod |> GenEventMethodSemanticsPass3 cenv eidx 0x0010
Option.iter (GenEventMethodSemanticsPass3 cenv eidx 0x0020) md.FireMethod
List.iter (GenEventMethodSemanticsPass3 cenv eidx 0x0004) md.OtherMethods;
- GenCustomAttrsPass3 cenv (hca_Event,eidx) md.CustomAttrs
+ GenCustomAttrsPass3Or4 cenv (hca_Event,eidx) md.CustomAttrs
// --------------------------------------------------------------------
@@ -3150,7 +3153,7 @@ let rec GetResourceAsManifestResourceRow cenv r =
and GenResourcePass3 cenv r =
let idx = AddUnsharedRow cenv TableNames.ManifestResource (GetResourceAsManifestResourceRow cenv r)
- GenCustomAttrsPass3 cenv (hca_ManifestResource,idx) r.CustomAttrs
+ GenCustomAttrsPass3Or4 cenv (hca_ManifestResource,idx) r.CustomAttrs
// --------------------------------------------------------------------
// ILTypeDef --> generate ILFieldDef, ILMethodDef, ILPropertyDef etc. rows
@@ -3177,7 +3180,7 @@ let rec GenTypeDefPass3 enc cenv (td:ILTypeDef) =
SimpleIndex (TableNames.TypeDef, tidx) |]) |> ignore
td.SecurityDecls.AsList |> GenSecurityDeclsPass3 cenv (hds_TypeDef,tidx);
- td.CustomAttrs |> GenCustomAttrsPass3 cenv (hca_TypeDef,tidx);
+ td.CustomAttrs |> GenCustomAttrsPass3Or4 cenv (hca_TypeDef,tidx);
td.GenericParams |> List.iteri (fun n gp -> GenGenericParamPass3 cenv env n (tomd_TypeDef,tidx) gp) ;
td.NestedTypes.AsList |> GenTypeDefsPass3 (enc@[td.Name]) cenv;
with e ->
@@ -3220,7 +3223,7 @@ let rec GenNestedExportedTypePass3 cenv cidx (ce: ILNestedExportedType) =
StringE (GetStringHeapIdx cenv ce.Name);
StringE 0;
Implementation (i_ExportedType, cidx) |])
- GenCustomAttrsPass3 cenv (hca_ExportedType,nidx) ce.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_ExportedType,nidx) ce.CustomAttrs;
GenNestedExportedTypesPass3 cenv nidx ce.Nested
and GenNestedExportedTypesPass3 cenv nidx (nce: ILNestedExportedTypes) =
@@ -3239,7 +3242,7 @@ and GenExportedTypePass3 cenv (ce: ILExportedTypeOrForwarder) =
nelem;
nselem;
Implementation (fst impl, snd impl); |])
- GenCustomAttrsPass3 cenv (hca_ExportedType,cidx) ce.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_ExportedType,cidx) ce.CustomAttrs;
GenNestedExportedTypesPass3 cenv cidx ce.Nested
and GenExportedTypesPass3 cenv (ce: ILExportedTypesAndForwarders) =
@@ -3278,7 +3281,7 @@ and GetManifsetAsAssemblyRow cenv m =
and GenManifestPass3 cenv m =
let aidx = AddUnsharedRow cenv TableNames.Assembly (GetManifsetAsAssemblyRow cenv m)
GenSecurityDeclsPass3 cenv (hds_Assembly,aidx) m.SecurityDecls.AsList;
- GenCustomAttrsPass3 cenv (hca_Assembly,aidx) m.CustomAttrs;
+ GenCustomAttrsPass3Or4 cenv (hca_Assembly,aidx) m.CustomAttrs;
GenExportedTypesPass3 cenv m.ExportedTypes;
// Record the entrypoint decl if needed.
match m.EntrypointElsewhere with
@@ -3335,23 +3338,23 @@ let GenModule (cenv : cenv) (modul: ILModuleDef) =
(match modul.Manifest with None -> () | Some m -> GenManifestPass3 cenv m);
GenTypeDefsPass3 [] cenv tds;
reportTime cenv.showTimes "Module Generation Pass 3";
- GenCustomAttrsPass3 cenv (hca_Module,midx) modul.CustomAttrs;
- // GenericParam is the only sorted table indexed by Columns in other tables (GenericParamConstraint).
- // Hence we need to sort it before we emit any entries in GenericParamConstraint.
+ GenCustomAttrsPass3Or4 cenv (hca_Module,midx) modul.CustomAttrs;
+ // GenericParam is the only sorted table indexed by Columns in other tables (GenericParamConstraint\CustomAttributes).
+ // Hence we need to sort it before we emit any entries in GenericParamConstraint\CustomAttributes that are attached to generic params.
// Note this mutates the rows in a table. 'SetRowsOfTable' clears
// the key --> index map since it is no longer valid
cenv.GetTable(TableNames.GenericParam).SetRowsOfTable (SortTableRows TableNames.GenericParam (cenv.GetTable(TableNames.GenericParam).EntriesAsArray));
GenTypeDefsPass4 [] cenv tds;
reportTime cenv.showTimes "Module Generation Pass 4"
-let generateIL requiredDataFixups (desiredMetadataVersion,generatePdb,mscorlib,emitTailcalls,showTimes) (m : ILModuleDef) noDebugData cilStartAddress =
+let generateIL requiredDataFixups (desiredMetadataVersion,generatePdb, ilg : ILGlobals, emitTailcalls,showTimes) (m : ILModuleDef) noDebugData cilStartAddress =
let isDll = m.IsDLL
let cenv =
- { mscorlib=mscorlib;
+ { primaryAssembly=ilg.traits.ScopeRef;
emitTailcalls=emitTailcalls;
showTimes=showTimes;
- ilg = mkILGlobals mscorlib None noDebugData; // assumes mscorlib is Scope_assembly _ ILScopeRef
+ ilg = mkILGlobals ilg.traits None noDebugData; // assumes mscorlib is Scope_assembly _ ILScopeRef
desiredMetadataVersion=desiredMetadataVersion;
requiredDataFixups= requiredDataFixups;
requiredStringFixups = [];
@@ -3468,7 +3471,7 @@ module FileSystemUtilites =
// Fail silently
#endif
-let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,mscorlib,emitTailcalls,showTimes) modul noDebugData cilStartAddress =
+let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,ilg,emitTailcalls,showTimes) modul noDebugData cilStartAddress =
// When we know the real RVAs of the data section we fixup the references for the FieldRVA table.
// These references are stored as offsets into the metadata we return from this function
@@ -3477,7 +3480,7 @@ let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,mscorlib,emitTail
let next = cilStartAddress
let strings,userStrings,blobs,guids,tables,entryPointToken,code,requiredStringFixups,data,resources,pdbData,mappings =
- generateIL requiredDataFixups (desiredMetadataVersion,generatePdb,mscorlib,emitTailcalls,showTimes) modul noDebugData cilStartAddress
+ generateIL requiredDataFixups (desiredMetadataVersion,generatePdb,ilg,emitTailcalls,showTimes) modul noDebugData cilStartAddress
reportTime showTimes "Generated Tables and Code";
let tableSize (tab: TableName) = tables.[tab.Index].Length
@@ -3917,7 +3920,7 @@ let writeDirectory os dict =
let writeBytes (os: BinaryWriter) (chunk:byte[]) = os.Write(chunk,0,chunk.Length)
-let writeBinaryAndReportMappings (outfile, mscorlib, pdbfile: string option, signer: ILStrongNameSigner option, fixupOverlappingSequencePoints, emitTailcalls, showTimes, dumpDebugInfo) modul noDebugData =
+let writeBinaryAndReportMappings (outfile, ilg, pdbfile: string option, signer: ILStrongNameSigner option, fixupOverlappingSequencePoints, emitTailcalls, showTimes, dumpDebugInfo) modul noDebugData =
// Store the public key from the signer into the manifest. This means it will be written
// to the binary and also acts as an indicator to leave space for delay sign
@@ -4024,7 +4027,7 @@ let writeBinaryAndReportMappings (outfile, mscorlib, pdbfile: string option, sig
if modul.MetadataVersion <> "" then
parseILVersion modul.MetadataVersion
else
- match mscorlib with
+ match ilg.traits.ScopeRef with
| ILScopeRef.Local -> failwith "Expected mscorlib to be ILScopeRef.Assembly was ILScopeRef.Local"
| ILScopeRef.Module(_) -> failwith "Expected mscorlib to be ILScopeRef.Assembly was ILScopeRef.Module"
| ILScopeRef.Assembly(aref) ->
@@ -4034,7 +4037,7 @@ let writeBinaryAndReportMappings (outfile, mscorlib, pdbfile: string option, sig
| None -> failwith "Expected msorlib to have a version number"
let entryPointToken,code,codePadding,metadata,data,resources,requiredDataFixups,pdbData,mappings =
- writeILMetadataAndCode ((pdbfile <> None), desiredMetadataVersion,mscorlib,emitTailcalls,showTimes) modul noDebugData next
+ writeILMetadataAndCode ((pdbfile <> None), desiredMetadataVersion, ilg,emitTailcalls,showTimes) modul noDebugData next
reportTime showTimes "Generated IL and metadata";
let _codeChunk,next = chunk code.Length next
@@ -4523,7 +4526,6 @@ let writeBinaryAndReportMappings (outfile, mscorlib, pdbfile: string option, sig
FileSystem.FileDelete outfile
with _ -> ());
reraise()
- raise e // is this really needed?
reportTime showTimes "Writing Image";
@@ -4602,7 +4604,7 @@ let writeBinaryAndReportMappings (outfile, mscorlib, pdbfile: string option, sig
type options =
- { mscorlib: ILScopeRef;
+ { ilg: ILGlobals;
pdbfile: string option;
signer: ILStrongNameSigner option;
fixupOverlappingSequencePoints: bool;
@@ -4612,7 +4614,7 @@ type options =
let WriteILBinary outfile (args: options) modul noDebugData =
- ignore (writeBinaryAndReportMappings (outfile, args.mscorlib, args.pdbfile, args.signer, args.fixupOverlappingSequencePoints, args.emitTailcalls, args.showTimes, args.dumpDebugInfo) modul noDebugData)
+ ignore (writeBinaryAndReportMappings (outfile, args.ilg, args.pdbfile, args.signer, args.fixupOverlappingSequencePoints, args.emitTailcalls, args.showTimes, args.dumpDebugInfo) modul noDebugData)
diff --git a/src/absil/ilwrite.fsi b/src/absil/ilwrite.fsi
index bc17084..62a2003 100755
--- a/src/absil/ilwrite.fsi
+++ b/src/absil/ilwrite.fsi
@@ -26,7 +26,7 @@ type ILStrongNameSigner =
static member OpenKeyContainer: string -> ILStrongNameSigner
type options =
- { mscorlib: ILScopeRef;
+ { ilg: ILGlobals
pdbfile: string option;
signer : ILStrongNameSigner option;
fixupOverlappingSequencePoints : bool;
diff --git a/src/absil/zmap.fs b/src/absil/zmap.fs
index 5248c17..03d7337 100755
--- a/src/absil/zmap.fs
+++ b/src/absil/zmap.fs
@@ -1,4 +1,13 @@
-(* (c) Microsoft Corporation. Apache 2.0 License *)
+//----------------------------------------------------------------------------
+// Copyright (c) 2002-2012 Microsoft Corporation.
+//
+// This source code is subject to terms and conditions of the Apache License, Version 2.0. A
+// copy of the license can be found in the License.html file at the root of this distribution.
+// By using this source code in any fashion, you are agreeing to be bound
+// by the terms of the Apache License, Version 2.0.
+//
+// You must not remove this notice, or any other, from this software.
+//----------------------------------------------------------------------------
namespace Microsoft.FSharp.Compiler.AbstractIL.Internal
@@ -33,7 +42,7 @@ module internal Zmap =
let isEmpty (m:Zmap<_,_>) = m.IsEmpty
- let fmap f z (m:Zmap<_,_>) =
+ let foldMap f z (m:Zmap<_,_>) =
let m,z = m.FoldAndMap (fun k v z -> let z,v' = f z k v in v',z) z in
z,m
diff --git a/src/absil/zmap.fsi b/src/absil/zmap.fsi
index 0aa0fbd..ea8f4c5 100755
--- a/src/absil/zmap.fsi
+++ b/src/absil/zmap.fsi
@@ -1,4 +1,13 @@
-(* (c) Microsoft Corporation. Apache 2.0 License *)
+//----------------------------------------------------------------------------
+// Copyright (c) 2002-2012 Microsoft Corporation.
+//
+// This source code is subject to terms and conditions of the Apache License, Version 2.0. A
+// copy of the license can be found in the License.html file at the root of this distribution.
+// By using this source code in any fashion, you are agreeing to be bound
+// by the terms of the Apache License, Version 2.0.
+//
+// You must not remove this notice, or any other, from this software.
+//----------------------------------------------------------------------------
namespace Microsoft.FSharp.Compiler.AbstractIL.Internal
@@ -26,7 +35,7 @@ module internal Zmap =
val map : mapping:('T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U>
val mapi : ('Key -> 'T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U>
val fold : ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U
- val fmap : ('State -> 'Key -> 'T -> 'State * 'U) -> 'State -> Zmap<'Key,'T> -> 'State * Zmap<'Key,'U>
+ val foldMap : ('State -> 'Key -> 'T -> 'State * 'U) -> 'State -> Zmap<'Key,'T> -> 'State * Zmap<'Key,'U>
val iter : action:('T -> 'U -> unit) -> Zmap<'T, 'U> -> unit
val foldSection: 'Key -> 'Key -> ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U
diff --git a/src/absil/zset.fs b/src/absil/zset.fs
index ec92ae0..b7fdccf 100755
--- a/src/absil/zset.fs
+++ b/src/absil/zset.fs
@@ -1,4 +1,13 @@
-(* (c) Microsoft Corporation. Apache 2.0 License *)
+//----------------------------------------------------------------------------
+// Copyright (c) 2002-2012 Microsoft Corporation.
+//
+// This source code is subject to terms and conditions of the Apache License, Version 2.0. A
+// copy of the license can be found in the License.html file at the root of this distribution.
+// By using this source code in any fashion, you are agreeing to be bound
+// by the terms of the Apache License, Version 2.0.
+//
+// You must not remove this notice, or any other, from this software.
+//----------------------------------------------------------------------------
namespace Microsoft.FSharp.Compiler.AbstractIL.Internal
diff --git a/src/absil/zset.fsi b/src/absil/zset.fsi
index 7084bc4..4713d22 100755
--- a/src/absil/zset.fsi
+++ b/src/absil/zset.fsi
@@ -1,4 +1,13 @@
-(* (c) Microsoft Corporation. Apache 2.0 License *)
+//----------------------------------------------------------------------------
+// Copyright (c) 2002-2012 Microsoft Corporation.
+//
+// This source code is subject to terms and conditions of the Apache License, Version 2.0. A
+// copy of the license can be found in the License.html file at the root of this distribution.
+// By using this source code in any fashion, you are agreeing to be bound
+// by the terms of the Apache License, Version 2.0.
+//
+// You must not remove this notice, or any other, from this software.
+//----------------------------------------------------------------------------
namespace Microsoft.FSharp.Compiler.AbstractIL.Internal
diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs
index baedfcb..7bf7fb1 100755
--- a/src/fsharp/ErrorLogger.fs
+++ b/src/fsharp/ErrorLogger.fs
@@ -239,6 +239,11 @@ type ErrorLogger(nameForDebugging:string) =
member this.ErrorSink err =
this.ErrorSinkImpl err
member this.DebugDisplay() = sprintf "ErrorLogger(%s)" nameForDebugging
+ // record the reported error/warning numbers for SQM purpose
+ abstract ErrorNumbers : int list
+ abstract WarningNumbers : int list
+ default this.ErrorNumbers = []
+ default this.WarningNumbers = []
let DiscardErrorsLogger =
{ new ErrorLogger("DiscardErrorsLogger") with
diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt
index f5d6cdf..54adc40 100755
--- a/src/fsharp/FSComp.txt
+++ b/src/fsharp/FSComp.txt
@@ -36,7 +36,7 @@ buildCouldNotReadVersionInfoFromMscorlib,"Could not read version from mscorlib.d
219,buildMscorLibAndFSharpCoreMismatch,"The referenced or default base CLI library 'mscorlib' is binary-incompatible with the referenced F# core library '%s'. Consider recompiling the library or making an explicit reference to a version of this library that matches the CLI version you are using."
220,buildAssemblyResolutionFailed,"Assembly resolution failure at or near this location"
221,buildImplicitModuleIsNotLegalIdentifier,"The declarations in this file will be placed in an implicit module '%s' based on the file name '%s'. However this is not a valid F# identifier, so the contents will not be accessible from other files. Consider renaming the file or adding a 'module' or 'namespace' declaration at the top of the file."
-222,buildMultiFileRequiresNamespaceOrModule,"Files in libraries or multiple-file applications must begin with a namespace or module declaration, e.g. 'namespace SomeNamespace.SubNamespace' or 'module SomeNamespace.SomeModule'"
+222,buildMultiFileRequiresNamespaceOrModule,"Files in libraries or multiple-file applications must begin with a namespace or module declaration, e.g. 'namespace SomeNamespace.SubNamespace' or 'module SomeNamespace.SomeModule'. Only the last source file of an application may omit such a declaration."
223,buildMultipleToplevelModules,"This file contains multiple declarations of the form 'module SomeNamespace.SomeModule'. Only one declaration of this form is permitted in a file. Change your file to use an initial namespace declaration and/or use 'module ModuleName = ...' to define your modules."
buildUnknownFileSuffix,"ParseInput: unknown file suffix for '%s'"
224,buildOptionRequiresParameter,"Option requires parameter: %s"
@@ -90,8 +90,7 @@ tastUnexpectedDecodeOfAutoOpenAttribute,"Unexpected decode of AutoOpenAttribute"
tastUnexpectedDecodeOfInternalsVisibleToAttribute,"Unexpected decode of InternalsVisibleToAttribute"
tastUnexpectedDecodeOfInterfaceDataVersionAttribute,"Unexpected decode of InterfaceDataVersionAttribute"
265,tastActivePatternsLimitedToSeven,"Active patterns cannot return more than 7 possibilities"
-266,tastConstantCannotBeCustomAttribute,"This constant cannot be used as a custom attribute value"
-267,tastNotAConstantExpression,"This is not a constant expression or valid custom attribute value"
+267,tastNotAConstantExpression,"This is not a valid constant expression or custom attribute value"
# -----------------------------------------------------------------------------
# typrelns.fs
# -----------------------------------------------------------------------------
@@ -500,7 +499,6 @@ tcMemberKindPropertyGetSetNotExpected,"MemberKind.PropertyGetSet only expected i
644,tcNamespaceCannotContainExtensionMembers,"Namespaces cannot contain extension members except in the same file and namespace where the type is defined. Consider using a module to hold declarations of extension members."
645,tcMultipleVisibilityAttributes,"Multiple visibility attributes have been specified for this identifier"
646,tcMultipleVisibilityAttributesWithLet,"Multiple visibility attributes have been specified for this identifier. 'let' bindings in classes are always private, as are any 'let' bindings inside expressions."
-tcUnrecognizedAccessibilitySpec,"Unrecognized accessibility specification"
tcInvalidMethodNameForRelationalOperator,"The name '(%s)' should not be used as a member name. To define comparison semantics for a type, implement the 'System.IComparable' interface. If defining a static member for use from other CLI languages then use the name '%s' instead."
tcInvalidMethodNameForEquality,"The name '(%s)' should not be used as a member name. To define equality semantics for a type, override the 'Object.Equals' member. If defining a static member for use from other CLI languages then use the name '%s' instead."
tcInvalidMemberName,"The name '(%s)' should not be used as a member name. If defining a static member for use from other CLI languages then use the name '%s' instead."
@@ -551,7 +549,6 @@ tcCouldNotFindIDisposable,"Couldn't find Dispose on IDisposable, or it was overl
691,tcNameArgumentsMustAppearLast,"Named arguments must appear after all other arguments"
692,tcFunctionRequiresExplicitLambda,"This function value is being used to construct a delegate type whose signature includes a byref argument. You must use an explicit lambda expression taking %d arguments."
693,tcTypeCannotBeEnumerated,"The type '%s' is not a type whose values can be enumerated with this syntax, i.e. is not compatible with either seq<_>, IEnumerable<_> or IEnumerable and does not have a GetEnumerator method"
-694,tcBadReturnTypeForGetEnumerator,"This expression has a method called GetEnumerator, but its return type is a value type. Methods returning struct enumerators cannot be used in this expression form."
695,tcInvalidMixtureOfRecursiveForms,"This recursive binding uses an invalid mixture of recursive forms"
696,tcInvalidObjectConstructionExpression,"This is not a valid object construction expression. Explicit object constructors must either call an alternate constructor or initialize all fields of the object and specify a call to a super class constructor."
697,tcInvalidConstraint,"Invalid constraint"
@@ -718,8 +715,6 @@ tcUnnamedArgumentsDoNotFormPrefix,"The unnamed arguments do not form a prefix of
859,tcNoPropertyFoundForOverride,"No abstract property was found that corresponds to this override"
860,tcAbstractPropertyMissingGetOrSet,"This property overrides or implements an abstract property but the abstract property doesn't have a corresponding %s"
861,tcInvalidSignatureForSet,"Invalid signature for set member"
-862,tcPropertyAlreadyHasDefaultImplementation,"This property already has a default implementation"
-863,tcPropertyImplementedIsAmbiguous,"The property implemented by this default is ambiguous"
864,tcNewMemberHidesAbstractMember,"This new member hides the abstract member '%s'. Rename the member or use 'override' instead."
864,tcNewMemberHidesAbstractMemberWithSuffix,"This new member hides the abstract member '%s' once tuples, functions, units of measure and/or provided types are erased. Rename the member or use 'override' instead."
865,tcStaticInitializersIllegalInInterface,"Interfaces cannot contain definitions of static initializers"
@@ -837,8 +832,6 @@ tcReservedSyntaxForAugmentation,"The syntax 'type X with ...' is reserved for au
ilDynamicInvocationNotSupported,"Dynamic invocation of %s is not supported"
975,ilAddressOfLiteralFieldIsInvalid,"Taking the address of a literal field is invalid"
976,ilAddressOfValueHereIsInvalid,"This operation involves taking the address of a value '%s' represented using a local variable or other special representation. This is invalid."
-978,ilValuesWithLiteralAttributeCannotBeMutable,"Values marked with 'LiteralAttribute' cannot be mutable"
-979,ilValuesWithLiteralAttributeMustBeSimple,"Values marked with 'LiteralAttribute' must currently be simple integer, character, Boolean, string or floating point constants"
980,ilCustomMarshallersCannotBeUsedInFSharp,"Custom marshallers cannot be specified in F# code. Consider using a C# helper function."
981,ilMarshalAsAttributeCannotBeDecoded,"The MarshalAs attribute could not be decoded"
982,ilSignatureForExternalFunctionContainsTypeParameters,"The signature for this external function contains type parameters. Constrain the argument and return types to indicate the types of the corresponding C function."
@@ -927,7 +920,10 @@ optsDCLOHtmlDoc,"The command-line option '%s' has been deprecated. HTML document
optsConsoleColors,"Output warning and error messages in color"
optsUseHighEntropyVA,"Enable high-entropy ASLR"
optsSubSystemVersion,"Specify subsystem version of this assembly"
+optsTargetProfile,"Specify target framework profile of this assembly. Valid values are mscorlib or netcore. Default - mscorlib"
+optsEmitDebugInfoInQuotations,"Emit debug information in quotations"
1051,optsInvalidSubSystemVersion,"Invalid version '%s' for '--subsystemversion'. The version must be 4.00 or greater."
+1052,optsInvalidTargetProfile,"Invalid value '%s' for '--targetprofile', valid values are 'mscorlib' or 'netcore'."
# -----------------------------------------------------------------------------
# service.fs strings
# -----------------------------------------------------------------------------
@@ -942,6 +938,7 @@ typeInfoActiveRecognizer,"active recognizer"
typeInfoField,"field"
typeInfoEvent,"event"
typeInfoProperty,"property"
+typeInfoExtension,"extension"
typeInfoCustomOperation,"custom operation"
typeInfoArgument,"argument"
typeInfoPatternVariable,"patvar"
@@ -1097,7 +1094,6 @@ parsNonAtomicType,"The use of the type syntax 'int C' and 'C <int>' is not perm
1196,tcInvalidUseNullAsTrueValue,"The 'UseNullAsTrueValue' attribute flag may only be used with union types that have one nullary case and at least one non-nullary case"
1197,tcParameterInferredByref,"The parameter '%s' was inferred to have byref type. Parameters of byref type must be given an explicit type annotation, e.g. 'x1: byref<int>'. When used, a byref parameter is implicitly dereferenced."
1198,tcNonUniformMemberUse,"The generic member '%s' has been used at a non-uniform instantiation prior to this program point. Consider reordering the members so this member occurs first. Alternatively, specify the full type of the member explicitly, including argument types, return type and any additional generic parameters and constraints."
-1199,tcNamedArgumentsCannotBeUsedInUnionCaseConstructions,"The use of named arguments in union case expressions is reserved for future use. Arguments of the form 'a=b' should be parenthesized."
1200,tcAttribArgsDiffer,"The attribute '%s' appears in both the implementation and the signature, but the attribute arguments differ. Only the attribute from the signature will be included in the compiled code."
1201,tcCannotCallAbstractBaseMember,"Cannot call an abstract base member: '%s'"
1202,typrelCannotResolveAmbiguityInUnmanaged,"Could not resolve the ambiguity in the use of a generic construct with an 'unmanaged' constraint at or near this position"
@@ -1164,6 +1160,7 @@ fscTooManyErrors,"Exiting - too many errors"
2021,fscRemotingError,"The resident compilation service was not used because a problem occured in communicating with the server."
2022,pathIsInvalid,"Problem with filename '%s': Illegal characters in path."
2023,fscResxSourceFileDeprecated,"Passing a .resx file (%s) as a source file to the compiler is deprecated. Use resgen.exe to transform the .resx file into a .resources file to pass as a --resource option. If you are using MSBuild, this can be done via an <EmbeddedResource> item in the .fsproj project file."
+2024,fscStaticLinkingNoProfileMismatches,"Static linking may not use assembly that targets different profile."
# -----------------------------------------------------------------------------
# Extension typing errors
# -----------------------------------------------------------------------------
@@ -1234,9 +1231,7 @@ invalidFullNameForProvidedType,"invalid full name for provided type"
3085,tcCustomOperationMayNotBeUsedInConjunctionWithNonSimpleLetBindings,"A custom operation may not be used in conjunction with a non-value or recursive 'let' binding in another part of this computation expression"
3086,tcCustomOperationMayNotBeUsedHere,"A custom operation may not be used in conjunction with 'use', 'try/with', 'try/finally', 'if/then/else' or 'match' operators within this computation expression"
3087,tcCustomOperationMayNotBeOverloaded,"The custom operation '%s' refers to a method which is overloaded. The implementations of custom operations may not be overloaded."
-3088,tcTryFinallyMayNotBeUsedWithCustomOperators,"A try/finally expression may not be used within a computation expression with uses of custom operators. Consider using a sequence expression instead."
-3089,tcTryWithMayNotBeUsedWithCustomOperators,"A try/with expression may not be used within a within a computation expression with uses of custom operators. Consider using a sequence expression instead."
-3090,tcIfThenElseMayNotBeUsedWithCustomOperators,"An if/then/else expression may not be used within a computation expression with uses of custom operators. Consider using either an if/then expression, or use a sequence expression instead."
+3090,tcIfThenElseMayNotBeUsedWithinQueries,"An if/then/else expression may not be used within queries. Consider using either an if/then expression, or use a sequence expression instead."
3091,ilxgenUnexpectedArgumentToMethodHandleOfDuringCodegen,"Invalid argument to 'methodhandleof' during codegen"
3092,etProvidedTypeReferenceMissingArgument,"A reference to a provided type was missing a value for the static parameter '%s'. You may need to recompile one or more referenced assemblies."
3093,etProvidedTypeReferenceInvalidText,"A reference to a provided type had an invalid value '%s' for a static parameter. You may need to recompile one or more referenced assemblies."
@@ -1244,7 +1239,7 @@ invalidFullNameForProvidedType,"invalid full name for provided type"
3095,tcCustomOperationNotUsedCorrectly2,"'%s' is not used correctly. Usage: %s. This is a custom operation in this query or computation expression."
customOperationTextLikeJoin,"%s var in collection %s (outerKey = innerKey). Note that parentheses are required after '%s'"
customOperationTextLikeGroupJoin,"%s var in collection %s (outerKey = innerKey) into group. Note that parentheses are required after '%s'"
-customOperationTextLikeZip,"%s collection into var"
+customOperationTextLikeZip,"%s var in collection"
3096,tcBinaryOperatorRequiresVariable,"'%s' must be followed by a variable name. Usage: %s."
3097,tcOperatorIncorrectSyntax,"Incorrect syntax for '%s'. Usage: %s."
3098,tcBinaryOperatorRequiresBody,"'%s' must come after a 'for' selection clause and be followed by the rest of the query. Syntax: ... %s ..."
@@ -1327,4 +1322,10 @@ descriptionUnavailable,"(description unavailable...)"
3170,parsUnderscoreInvalidFieldName,"'_' cannot be used as field name"
3171,tcGeneratedTypesShouldBeInternalOrPrivate,"The provided types generated by this use of a type provider may not be used from other F# assemblies and should be marked internal or private. Consider using 'type internal TypeName = ...' or 'type private TypeName = ...'."
3172,chkGetterAndSetterHaveSamePropertyType,"A property's getter and setter must have the same type. Property '%s' has getter of type '%s' but setter of type '%s'."
-3173,tcRuntimeSuppliedMethodCannotBeUsedInUserCode,"Array method '%s' is supplied by the runtime and cannot be directly used in code. For operations with array elements consider using family of GetArray/SetArray functions from LanguagePrimitives.IntrinsicFunctions module."
\ No newline at end of file
+3173,tcRuntimeSuppliedMethodCannotBeUsedInUserCode,"Array method '%s' is supplied by the runtime and cannot be directly used in code. For operations with array elements consider using family of GetArray/SetArray functions from LanguagePrimitives.IntrinsicFunctions module."
+3174,tcUnionCaseConstructorDoesNotHaveFieldWithGivenName,"Union case/exception '%s' does not have field named '%s'."
+3175,tcUnionCaseFieldCannotBeUsedMoreThanOnce,"Union case/exception field '%s' cannot be used more than once."
+3176,tcFieldNameIsUsedModeThanOnce,"Named field '%s' is used more than once."
+3176,tcFieldNameConflictsWithGeneratedNameForAnonymousField,"Named field '%s' conflicts with autogenerated name for anonymous field."
+3177,tastConstantExpressionOverflow,"This literal expression or attribute argument results in an arithmetic overflow."
+3178,tcIllegalStructTypeForConstantExpression,"This is not valid literal expression. The [<Literal>] attribute will be ignored."
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj b/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj
index 4b285e5..0db59ec 100755
--- a/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj
+++ b/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -23,7 +13,7 @@
<DefineConstants>BUILDING_WITH_LKG;$(DefineConstants)</DefineConstants>
<BuildWith>LKG</BuildWith>
<ProjectGuid>{D8BC791F-C1A9-49DC-9432-0F3090537555}</ProjectGuid>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v3.5</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v3.5</TargetFrameworkVersion>
</PropertyGroup>
<ItemGroup>
<FsSrGen Include="..\FSharp.Build\FSBuild.txt">
@@ -53,7 +43,7 @@
<Reference Include="mscorlib" />
<Reference Include="FSharp.Core" />
<Reference Include="System" />
- <Reference Include="System.Numerics" Condition="'$(TargetFramework)' == 'net40' OR '$(TargetFramework)' == 'mono40'" />
+ <Reference Include="System.Numerics" Condition="'$(TargetFramework)'=='net40'" />
<Reference Include="Microsoft.Build.Engine" />
<Reference Include="Microsoft.Build.Utilities.v3.5" Condition="'$(TargetFramework)' == 'net20'" />
<Reference Include="Microsoft.Build.Tasks.v3.5" Condition="'$(TargetFramework)' == 'net20'" />
diff --git a/src/fsharp/FSharp.Build/FSharp.Build.fsproj b/src/fsharp/FSharp.Build/FSharp.Build.fsproj
index 0be23c7..cfb7c97 100755
--- a/src/fsharp/FSharp.Build/FSharp.Build.fsproj
+++ b/src/fsharp/FSharp.Build/FSharp.Build.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -20,7 +10,7 @@
<OutputType>Library</OutputType>
<AssemblyName>FSharp.Build</AssemblyName>
<AllowCrossTargeting>true</AllowCrossTargeting>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v3.5</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v3.5</TargetFrameworkVersion>
<ProjectGuid>{702A7979-BCF9-4C41-853E-3ADFC9897890}</ProjectGuid>
</PropertyGroup>
<ItemGroup>
@@ -50,12 +40,12 @@
<Reference Include="Microsoft.Build.Engine" />
<Reference Include="Microsoft.Build.Framework" />
- <Reference Include="Microsoft.Build.Utilities.v3.5" Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'" />
- <Reference Include="Microsoft.Build.Tasks.v3.5" Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'" />
+ <Reference Include="Microsoft.Build.Utilities.v3.5" Condition="'$(TargetFramework)'=='net20'" />
+ <Reference Include="Microsoft.Build.Tasks.v3.5" Condition="'$(TargetFramework)'=='net20'" />
- <Reference Include="Microsoft.Build" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
- <Reference Include="Microsoft.Build.Utilities.v4.0" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
- <Reference Include="Microsoft.Build.Tasks.v4.0" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
+ <Reference Include="Microsoft.Build" Condition="'$(TargetFramework)'=='net40'" />
+ <Reference Include="Microsoft.Build.Utilities.v4.0" Condition="'$(TargetFramework)'=='net40'" />
+ <Reference Include="Microsoft.Build.Tasks.v4.0" Condition="'$(TargetFramework)'=='net40'" />
<ProjectReference Include="$(FSharpSourcesRoot)\fsharp\FSharp.Core\FSharp.Core.fsproj">
<Project>{DED3BBD7-53F4-428A-8C9F-27968E768605}</Project>
<Name>FSharp.Core</Name>
diff --git a/src/fsharp/FSharp.Build/Fsc.fs b/src/fsharp/FSharp.Build/Fsc.fs
index 7618ad7..e17ef86 100755
--- a/src/fsharp/FSharp.Build/Fsc.fs
+++ b/src/fsharp/FSharp.Build/Fsc.fs
@@ -149,6 +149,8 @@ type [<Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1704:Iden
let mutable utf8output : bool = false
let mutable subsystemVersion : string = null
let mutable highEntropyVA : bool = false
+ let mutable targetProfile : string = null
+ let mutable sqmSessionGuid : string = null
let mutable capturedArguments : string list = [] // list of individual args, to pass to HostObject Compile()
let mutable capturedFilenames : string list = [] // list of individual source filenames, to pass to HostObject Compile()
@@ -329,6 +331,14 @@ type [<Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1704:Iden
member fsc.HighEntropyVA
with get() = highEntropyVA
and set(p) = highEntropyVA <- p
+
+ member fsc.TargetProfile
+ with get() = targetProfile
+ and set(p) = targetProfile <- p
+
+ member fsc.SqmSessionGuid
+ with get() = sqmSessionGuid
+ and set(p) = sqmSessionGuid <- p
// ToolTask methods
override fsc.ToolName = "fsc.exe"
@@ -502,7 +512,11 @@ type [<Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1704:Iden
builder.AppendSwitch("--highentropyva+")
else
builder.AppendSwitch("--highentropyva-")
-
+
+ builder.AppendSwitchIfNotNull("--sqmsessionguid:", sqmSessionGuid)
+
+ builder.AppendSwitchIfNotNull("--targetprofile:", targetProfile)
+
// OtherFlags - must be second-to-last
builder.AppendSwitchUnquotedIfNotNull("", otherFlags)
capturedArguments <- builder.CapturedArguments()
@@ -517,6 +531,11 @@ type [<Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1704:Iden
fsc.GenerateCommandLineCommands()
member internal fsc.InternalExecuteTool(pathToTool, responseFileCommands, commandLineCommands) =
fsc.ExecuteTool(pathToTool, responseFileCommands, commandLineCommands)
+ member internal fsc.GetCapturedArguments() =
+ [|
+ yield! capturedArguments
+ yield! capturedFilenames
+ |]
module Attributes =
//[<assembly: System.Security.SecurityTransparent>]
diff --git a/src/fsharp/FSharp.Build/Fsc.fsi b/src/fsharp/FSharp.Build/Fsc.fsi
index 3794515..8633f70 100755
--- a/src/fsharp/FSharp.Build/Fsc.fsi
+++ b/src/fsharp/FSharp.Build/Fsc.fsi
@@ -13,6 +13,7 @@ type Fsc = class
member internal InternalGenerateFullPathToTool : unit -> System.String
member internal InternalGenerateCommandLineCommands : unit -> System.String
member internal InternalExecuteTool : string * string * string -> int
+ member internal GetCapturedArguments : unit -> string[]
member BaseAddress : string with get,set
member CodePage : string with get,set
member DebugSymbols : bool with get,set
@@ -52,4 +53,6 @@ type Fsc = class
member Win32ManifestFile : string with get,set
member SubsystemVersion : string with get,set
member HighEntropyVA : bool with get,set
+ member TargetProfile : string with get,set
+ member SqmSessionGuid : string with get,set
end
diff --git a/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj b/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj
index 37d5edd..79fa853 100755
--- a/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj
+++ b/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
diff --git a/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj b/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj
index 143fe0a..71637af 100755
--- a/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj
+++ b/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
diff --git a/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj b/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj
index 95bf9aa..9e080e3 100755
--- a/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj
+++ b/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj
@@ -472,9 +472,11 @@
<Compile Include="..\fsi\fsi.fs">
<Link>fsi.fs</Link>
</Compile>
+<!--
<Compile Include="..\vs\SimpleServices.fs">
<Link>SimpleServices.fs</Link>
</Compile>
+-->
</ItemGroup>
<ItemGroup>
<ProjectReference Include="$(FSharpSourcesRoot)\fsharp\FSharp.Core\FSharp.Core.fsproj">
diff --git a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj
index 3ca5f1d..34d4f5b 100755
--- a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj
+++ b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -23,7 +13,7 @@
<NoWarn>$(NoWarn);44;62;9</NoWarn>
<ProjectGuid>{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}</ProjectGuid>
<AllowCrossTargeting>true</AllowCrossTargeting>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v2.0</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v2.0</TargetFrameworkVersion>
<BaseAddress>0x06800000</BaseAddress>
<OtherFlags>$(OtherFlags) /warnon:1182</OtherFlags>
</PropertyGroup>
@@ -487,9 +477,11 @@
<Compile Include="..\vs\service.fs">
<Link>service.fs</Link>
</Compile>
+<!--
<Compile Include="..\vs\SimpleServices.fs">
<Link>SimpleServices.fs</Link>
</Compile>
+-->
</ItemGroup>
<ItemGroup>
<Reference Include="mscorlib" />
@@ -500,13 +492,13 @@
<Reference Include="System.Runtime.Remoting" />
<Reference Include="Microsoft.Build.Framework" />
<Reference Include="Microsoft.Build.Engine" />
- <Reference Include="Microsoft.Build.Utilities" Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'" />
- <Reference Include="Microsoft.Build.Tasks" Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'" />
+ <Reference Include="Microsoft.Build.Utilities" Condition="'$(TargetFramework)'=='net20'" />
+ <Reference Include="Microsoft.Build.Tasks" Condition="'$(TargetFramework)'=='net20'" />
- <Reference Include="ISymWrapper, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
- <Reference Include="Microsoft.Build" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
- <Reference Include="Microsoft.Build.Utilities.v4.0" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
- <Reference Include="Microsoft.Build.Tasks.v4.0" Condition="'$(TargetFramework)'=='net40' or '$(TargetFramework)'=='mono40'" />
+ <Reference Include="ISymWrapper, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" Condition="'$(TargetFramework)'=='net40'" />
+ <Reference Include="Microsoft.Build" Condition="'$(TargetFramework)'=='net40'" />
+ <Reference Include="Microsoft.Build.Utilities.v4.0" Condition="'$(TargetFramework)'=='net40'" />
+ <Reference Include="Microsoft.Build.Tasks.v4.0" Condition="'$(TargetFramework)'=='net40'" />
<ProjectReference Include="$(FSharpSourcesRoot)\fsharp\FSharp.Core\FSharp.Core.fsproj" >
diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj
index e3dba76..fab4b65 100755
--- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj
+++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj
@@ -2,15 +2,15 @@
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
+ <ProjectGuid>{88e2d422-6852-46e3-a740-83e391dc7973}</ProjectGuid>
</PropertyGroup>
- <Import Project="$(FSharpSourcesRoot)\FSharpSource.Settings.targets" />
+ <Import Project="$(FSharpSourcesRoot)\FSharpSource.Settings.targets" />
<PropertyGroup>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<SchemaVersion>2.0</SchemaVersion>
<AllowCrossTargeting>true</AllowCrossTargeting>
<ReferenceVsAssemblies>true</ReferenceVsAssemblies>
- <ProjectGuid>{88E2D422-6852-46E3-A740-83E391DC7973}</ProjectGuid>
<OutputType>Library</OutputType>
<AssemblyName>FSharp.Core.Unittests</AssemblyName>
<TargetFrameworkVersion Condition=" '$(TargetFramework)' == 'net20' ">v3.5</TargetFrameworkVersion>
@@ -22,7 +22,6 @@
<PropertyGroup>
<DefineConstants Condition=" '$(TargetFramework)' == 'sl5' OR '$(TargetFramework)' == 'sl5-compiler' ">$(DefineConstants);SILVERLIGHT</DefineConstants>
</PropertyGroup>
-
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
<DebugSymbols>true</DebugSymbols>
<DebugType>full</DebugType>
@@ -43,7 +42,7 @@
<ItemGroup>
<Reference Include="nunit.framework" Condition="'$(TargetFramework)' != 'sl5' AND '$(TargetFramework)' != 'sl5-compiler' AND '$(TargetFramework)' != 'sl3-wp'" />
<Reference Include="NUnitFramework" Condition="'$(TargetFramework)' == 'sl5' OR '$(TargetFramework)' == 'sl3-wp' OR '$(TargetFramework)' == 'sl5-compiler'" />
- <ProjectReference Include="$(FSharpSourcesRoot)\fsharp\FSharp.Core\FSharp.Core.fsproj" >
+ <ProjectReference Include="$(FSharpSourcesRoot)\fsharp\FSharp.Core\FSharp.Core.fsproj">
<Project>{DED3BBD7-53F4-428A-8C9F-27968E768605}</Project>
<Name>FSharp.Core</Name>
</ProjectReference>
@@ -51,14 +50,12 @@
<Reference Include="System" />
<Reference Include="System.Numerics" Condition="'$(TargetFramework)' == 'net40'" />
<Reference Include="System.Core" />
- <Reference Include="System.Net" Condition="'$(TargetFramework)' == 'sl5' OR '$(TargetFramework)' == 'sl5-compiler' "/>
- <Reference Include="System.Observable" Condition="'$(TargetFramework)' == 'sl3-wp' "/>
+ <Reference Include="System.Net" Condition="'$(TargetFramework)' == 'sl5' OR '$(TargetFramework)' == 'sl5-compiler' " />
+ <Reference Include="System.Observable" Condition="'$(TargetFramework)' == 'sl3-wp' " />
</ItemGroup>
<ItemGroup>
-
- <Compile Include="NUnitFrameworkShims.fs" Condition="'$(TargetFramework)' == 'sl3-wp'"/>
+ <Compile Include="NUnitFrameworkShims.fs" Condition="'$(TargetFramework)' == 'sl3-wp'" />
<Compile Include="LibraryTestFx.fs" />
-
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\ArrayModule.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\ArrayModule2.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\Array2Module.fs" />
@@ -76,23 +73,18 @@
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\SeqModule.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\SeqModule2.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Collections\StringModule.fs" />
-
<Compile Include="FSharp.Core\Microsoft.FSharp.Core\BigIntType.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Core\IntConversions.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Core\IntConversionsGenerated.fs" />
- <None Include="FSharp.Core\Microsoft.FSharp.Core\IntConversionsTestGenerator.fsx" />
+ <None Include="FSharp.Core\Microsoft.FSharp.Core\IntConversionsTestGenerator.fsx" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Core\PrintfTests.fs" />
-
<Compile Include="FSharp.Core\Microsoft.FSharp.Control\Cancellation.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Control\AsyncType.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Control\LazyType.fs" />
<Compile Include="FSharp.Core\Microsoft.FSharp.Control\ObservableModule.fs" />
-
<Compile Include="FSharp.Core\Microsoft.FSharp.Quotations\FSharpQuotations.fs" />
-
<Compile Include="FSharp.Core\Microsoft.FSharp.Reflection\FSharpReflection.fs" />
<Compile Include="FSharp.Core\PrimTypes.fs" />
-
</ItemGroup>
<Import Project="$(FSharpSourcesRoot)\FSharpSource.targets" />
-</Project>
+</Project>
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs
index 3451ce3..b2d4547 100755
--- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs
+++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs
@@ -8,7 +8,10 @@ type SurfaceAreaTest() =
member this.VerifyArea() =
let file = typeof<int list>.Assembly.Location
let asm = System.Reflection.Assembly.ReflectionOnlyLoadFrom(file)
- if asm.ImageRuntimeVersion.[1] = '2' then // v2.0.50727 - we only want this test to run as 2.0 (nu20), not FSharp.Core 2.0 on CLR 4.0 (nu20on40)
+ let frameworkAsm = typeof<System.String>.Assembly
+ printfn "FSharp.Core image runtime version: %s" asm.ImageRuntimeVersion
+ printfn "Framework image runtime version: %s" frameworkAsm.ImageRuntimeVersion
+ if (frameworkAsm.ImageRuntimeVersion.[1] = '2') then // v2.0.50727 - we only want this test to run as 2.0 (nu20), not FSharp.Core 2.0 on CLR 4.0 (nu20on40)
let referenced = asm.GetReferencedAssemblies()
for ref in referenced do
diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.4.0.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.4.0.fs
index c820170..c1d1d6d 100755
--- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.4.0.fs
+++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.4.0.fs
@@ -2391,11 +2391,15 @@ Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T2 SqrtDynamic[T1,T2](T1)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,,,] GetArraySlice4D[T](T[,,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[Syste [...]
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,,] GetArraySlice3D[T](T[,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,] GetArraySlice2D[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice2DFixed1[T](T[,], Int32, Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice2DFixed2[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice[T](T[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt16 PowUInt16(UInt16, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt32 PowUInt32(UInt32, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt64 PowUInt64(UInt64, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UIntPtr PowUIntPtr(UIntPtr, Int32)
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2DFixed1[T](T[,], Int32, Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2DFixed2[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Int32, T[])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2D[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[,])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice3D[T](T[,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[,,])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice4D[T](T[,,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System. [...]
@@ -3228,6 +3232,29 @@ Microsoft.FSharp.Quotations.PatternsModule: Microsoft.FSharp.Core.FSharpOption`1
Microsoft.FSharp.Quotations.PatternsModule: Microsoft.FSharp.Core.FSharpOption`1[System.Type] DefaultValuePattern(Microsoft.FSharp.Quotations.FSharpExpr)
Microsoft.FSharp.Quotations.PatternsModule: System.String ToString()
Microsoft.FSharp.Quotations.PatternsModule: System.Type GetType()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean Equals(System.Object)
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsExceptionRepresentation.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsRecord.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsUnion.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Int32 GetHashCode()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Int32] FSharpValue.PreComputeUnionTagReader.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Object[]] FSharpValue.PreComputeRecordReader.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Object[]] FSharpValue.PreComputeUnionReader.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object[],System.Object] FSharpValue.PreComputeRecordConstructor.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object[],System.Object] FSharpValue.PreComputeUnionConstructor.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Reflection.UnionCaseInfo[] FSharpType.GetUnionCases.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object FSharpValue.MakeRecord.Static(System.Type, System.Object[], Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object FSharpValue.MakeUnion.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, System.Object[], Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object[] FSharpValue.GetExceptionFields.Static(System.Object, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object[] FSharpValue.GetRecordFields.Static(System.Object, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.ConstructorInfo FSharpValue.PreComputeRecordConstructorInfo.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.MemberInfo FSharpValue.PreComputeUnionTagMemberInfo.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.MethodInfo FSharpValue.PreComputeUnionConstructorInfo.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.PropertyInfo[] FSharpType.GetExceptionFields.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.PropertyInfo[] FSharpType.GetRecordFields.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.String ToString()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Tuple`2[Microsoft.FSharp.Reflection.UnionCaseInfo,System.Object[]] FSharpValue.GetUnionFields.Static(System.Object, System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Type GetType()
Microsoft.FSharp.Reflection.FSharpType: Boolean Equals(System.Object)
Microsoft.FSharp.Reflection.FSharpType: Boolean IsExceptionRepresentation(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Reflection.BindingFlags])
Microsoft.FSharp.Reflection.FSharpType: Boolean IsFunction(System.Type)
diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.Portable.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.Portable.fs
index a318a8d..b5902bf 100755
--- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.Portable.fs
+++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.Portable.fs
@@ -2378,11 +2378,15 @@ Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T2 SqrtDynamic[T1,T2](T1)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,,,] GetArraySlice4D[T](T[,,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[Syste [...]
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,,] GetArraySlice3D[T](T[,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[,] GetArraySlice2D[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice2DFixed1[T](T[,], Int32, Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice2DFixed2[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: T[] GetArraySlice[T](T[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt16 PowUInt16(UInt16, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt32 PowUInt32(UInt32, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UInt64 PowUInt64(UInt64, Int32)
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: UIntPtr PowUIntPtr(UIntPtr, Int32)
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2DFixed1[T](T[,], Int32, Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[])
+Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2DFixed2[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Int32, T[])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice2D[T](T[,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[,])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice3D[T](T[,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], T[,,])
Microsoft.FSharp.Core.Operators+OperatorIntrinsics: Void SetArraySlice4D[T](T[,,,], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System. [...]
@@ -3206,6 +3210,29 @@ Microsoft.FSharp.Quotations.PatternsModule: Microsoft.FSharp.Core.FSharpOption`1
Microsoft.FSharp.Quotations.PatternsModule: Microsoft.FSharp.Core.FSharpOption`1[System.Type] DefaultValuePattern(Microsoft.FSharp.Quotations.FSharpExpr)
Microsoft.FSharp.Quotations.PatternsModule: System.String ToString()
Microsoft.FSharp.Quotations.PatternsModule: System.Type GetType()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean Equals(System.Object)
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsExceptionRepresentation.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsRecord.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Boolean FSharpType.IsUnion.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Int32 GetHashCode()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Int32] FSharpValue.PreComputeUnionTagReader.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Object[]] FSharpValue.PreComputeRecordReader.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object,System.Object[]] FSharpValue.PreComputeUnionReader.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object[],System.Object] FSharpValue.PreComputeRecordConstructor.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Core.FSharpFunc`2[System.Object[],System.Object] FSharpValue.PreComputeUnionConstructor.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: Microsoft.FSharp.Reflection.UnionCaseInfo[] FSharpType.GetUnionCases.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object FSharpValue.MakeRecord.Static(System.Type, System.Object[], Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object FSharpValue.MakeUnion.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, System.Object[], Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object[] FSharpValue.GetExceptionFields.Static(System.Object, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Object[] FSharpValue.GetRecordFields.Static(System.Object, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.ConstructorInfo FSharpValue.PreComputeRecordConstructorInfo.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.MemberInfo FSharpValue.PreComputeUnionTagMemberInfo.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.MethodInfo FSharpValue.PreComputeUnionConstructorInfo.Static(Microsoft.FSharp.Reflection.UnionCaseInfo, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.PropertyInfo[] FSharpType.GetExceptionFields.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Reflection.PropertyInfo[] FSharpType.GetRecordFields.Static(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.String ToString()
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Tuple`2[Microsoft.FSharp.Reflection.UnionCaseInfo,System.Object[]] FSharpValue.GetUnionFields.Static(System.Object, System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Boolean])
+Microsoft.FSharp.Reflection.FSharpReflectionExtensions: System.Type GetType()
Microsoft.FSharp.Reflection.FSharpType: Boolean Equals(System.Object)
Microsoft.FSharp.Reflection.FSharpType: Boolean IsExceptionRepresentation(System.Type, Microsoft.FSharp.Core.FSharpOption`1[System.Reflection.BindingFlags])
Microsoft.FSharp.Reflection.FSharpType: Boolean IsFunction(System.Type)
diff --git a/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs b/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs
index d3ec679..a9bbb7c 100755
--- a/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs
+++ b/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs
@@ -16,15 +16,20 @@ type TypeForwardingModule() =
[<Test>]
member this.TypeForwarding() =
let currentRuntimeVersion = System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion()
+ let currentFSharpCoreTargetRuntime = typeof<int list>.Assembly.ImageRuntimeVersion
let tupleAssemblyName = typeof<System.Tuple<int,int>>.Assembly.FullName
- let mscorlibAssemblyName = "mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089"
- let fsharpCoreAssemblyName = "FSharp.Core, Version=2.3.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"
- // 2.0 runtime
- if currentRuntimeVersion = "v2.0.50727" then
- Assert.AreEqual(tupleAssemblyName, fsharpCoreAssemblyName)
- else
- Assert.AreEqual(tupleAssemblyName, mscorlibAssemblyName)
+ let mscorlib4AssemblyName = "mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089"
+ let fsharpCore2AssemblyName = "FSharp.Core, Version=2.3.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"
+
+ printfn "currentRuntimeVersion = %s; currentFSharpCoreTargetRuntime=%s tupleAssemblyName=%s" currentRuntimeVersion currentFSharpCoreTargetRuntime tupleAssemblyName
+ match (currentRuntimeVersion, currentFSharpCoreTargetRuntime) with
+ | ("v2.0.50727", _)
+ | ("v4.0.30319", "v2.0.50727") ->
+ Assert.AreEqual(tupleAssemblyName, fsharpCore2AssemblyName)
+ | ("v4.0.30319", "v4.0.30319") ->
+ Assert.AreEqual(tupleAssemblyName, mscorlib4AssemblyName)
+ | _ -> failwith "Unknown scenario."
()
#endif
#endif
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Core/Linq.fs b/src/fsharp/FSharp.Core/Linq.fs
index ebc84fc..3103f35 100755
--- a/src/fsharp/FSharp.Core/Linq.fs
+++ b/src/fsharp/FSharp.Core/Linq.fs
@@ -151,6 +151,11 @@ open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns
open Microsoft.FSharp.Quotations.DerivedPatterns
+#if FX_RESHAPED_REFLECTION
+open PrimReflectionAdapters
+open ReflectionAdapters
+#endif
+
module LeafExpressionConverter =
// The following is recognized as a LINQ 'member intialization pattern' in a quotation.
@@ -197,7 +202,12 @@ module LeafExpressionConverter =
let d = Map.ofArray (Array.zip x y)
q.Substitute(fun v -> v |> d.TryFind |> Option.map (fun x -> Expr.Value(x, v.Type))) |> Expr.Cast
- let showAll = BindingFlags.Public ||| BindingFlags.NonPublic
+ let showAll =
+#if FX_RESHAPED_REFLECTION
+ true
+#else
+ BindingFlags.Public ||| BindingFlags.NonPublic
+#endif
let NullableConstructor = typedefof<Nullable<int>>.GetConstructors().[0]
@@ -212,7 +222,7 @@ module LeafExpressionConverter =
#if FX_NO_REFLECTION_METADATA_TOKENS
#else
minfo.MetadataToken = minfo2.MetadataToken &&
-#endif
+#endif
if isg1 then minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition()
else minfo = minfo2
) ->
@@ -403,20 +413,10 @@ module LeafExpressionConverter =
| Patterns.Coerce(x, toTy) ->
let converted = ConvExprToLinqInContext env x
- // Linq to Entities doesn't like 'TypeAs' expressions (coercion from
- // IQueryable<T> to IEnumerable<T>) that are generated e.g. in:
- //
- // seq { for p in dx.Products do
- // for c in dx.Categories do yield p }
- //
- // However, the expression tree has 'C# semantics' so we don't need
- // explicit TypeAs if the coercion is statically type-safe. The rules are subtle,
- // so we don't generate TypeAs (at least) in a simple case when both are
- // reference types and the assignment is statically safe.
- // (see also ``Join using nested 'for' with 'String.Concat' call`` test in v40 build)
-
- if not toTy.IsValueType && not x.Type.IsValueType && toTy.IsAssignableFrom(x.Type) then converted
- else Expression.TypeAs(ConvExprToLinqInContext env x, toTy) |> asExpr
+ // Most of conversion scenarios in C# are covered by Expression.Convert
+ if x.Type.Equals toTy then converted // source and target types match - do nothing
+ elif not (x.Type.IsValueType || toTy.IsValueType) && toTy.IsAssignableFrom x.Type then converted // converting reference type to supertype - do nothing
+ else Expression.Convert(converted, toTy) |> asExpr // emit Expression.Convert
| Patterns.TypeTest(x, toTy) ->
Expression.TypeIs(ConvExprToLinqInContext env x, toTy) |> asExpr
@@ -733,15 +733,19 @@ module LeafExpressionConverter =
| Patterns.Lambda(v, body) ->
let vP = ConvVarToLinq v
let env = { env with varEnv = Map.add v (vP |> asExpr) env.varEnv }
+ let bodyP = ConvExprToLinqInContext env body
+ let lambdaTy, tyargs =
+ if bodyP.Type = typeof<System.Void> then
+ let tyargs = [| vP.Type |]
+ typedefof<Action<_>>, tyargs
+ else
+ let tyargs = [| vP.Type; bodyP.Type |]
#if FX_NO_CONVERTER
- let tyargs = [| v.Type; body.Type |]
- let bodyP = ConvExprToLinqInContext env body
- let convType = typedefof<Func<_, _>>.MakeGenericType tyargs
+ typedefof<Func<_, _>>, tyargs
#else
- let tyargs = [| v.Type; body.Type |]
- let bodyP = ConvExprToLinqInContext env body
- let convType = typedefof<System.Converter<obj, obj>>.MakeGenericType tyargs
+ typedefof<System.Converter<_, _>>, tyargs
#endif
+ let convType = lambdaTy.MakeGenericType tyargs
let convDelegate = Expression.Lambda(convType, bodyP, [| vP |]) |> asExpr
Expression.Call(typeof<FuncConvert>,"ToFSharpFunc", tyargs,[| convDelegate |]) |> asExpr
@@ -797,4 +801,4 @@ module LeafExpressionConverter =
#endif
-
+
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Core/Query.fs b/src/fsharp/FSharp.Core/Query.fs
index 69752f5..b1b8f5b 100755
--- a/src/fsharp/FSharp.Core/Query.fs
+++ b/src/fsharp/FSharp.Core/Query.fs
@@ -12,25 +12,13 @@ open System
open System.Linq
open System.Collections
open System.Collections.Generic
-open System.Linq.Expressions
-open System.Reflection
-#if FX_NO_REFLECTION_EMIT
-#else
-open System.Reflection.Emit
-#endif
+
open Microsoft.FSharp
open Microsoft.FSharp.Core
open Microsoft.FSharp.Core.Operators
-open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
open Microsoft.FSharp.Collections
-open Microsoft.FSharp.Reflection
-open Microsoft.FSharp.Linq
-open Microsoft.FSharp.Linq.RuntimeHelpers.Adapters
-open Microsoft.FSharp.Linq.RuntimeHelpers
-open Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter
open Microsoft.FSharp.Quotations
-open Microsoft.FSharp.Quotations.Patterns
-open Microsoft.FSharp.Quotations.DerivedPatterns
+open Microsoft.FSharp.Linq.RuntimeHelpers
#nowarn "64"
@@ -40,7 +28,6 @@ type QuerySource<'T, 'Q> (source: seq<'T>) =
[<AutoOpen>]
module Helpers =
-
// This helps the somewhat complicated type inference for AverageByNullable and SumByNullable, by making both type in a '+' the same
let inline plus (x:'T) (y:'T) = Checked.(+) x y
@@ -54,9 +41,21 @@ module Helpers =
match source with
| :? System.Linq.IOrderedEnumerable<'T> as source -> source
| _ -> invalidArg "source" (SR.GetString(SR.thenByError))
+
+
+// used so we can define the implementation of QueryBuilder before the Query module (so in Query we can safely use methodhandleof)
+module ForwardDeclarations =
+ type IQueryMethods =
+ abstract Execute : Expr<'T> -> 'U
+ abstract EliminateNestedQueries : Expr -> Expr
+ let mutable Query =
+ {
+ new IQueryMethods with
+ member this.Execute(_) = failwith "IQueryMethods.Execute should never be called"
+ member this.EliminateNestedQueries(_) = failwith "IQueryMethods.EliminateNestedQueries should never be called"
+ }
type QueryBuilder() =
-
member __.For (source:QuerySource<'T,'Q>, body: 'T -> QuerySource<'Result,'Q2>) : QuerySource<'Result,'Q> = QuerySource (Seq.collect (fun x -> (body x).Source) source.Source)
member __.Zero () = QuerySource Seq.empty
member __.Yield x = QuerySource (Seq.singleton x)
@@ -207,6 +206,64 @@ type QueryBuilder() =
member __.LeftOuterJoin (outerSource:QuerySource<_,'Q>, innerSource: QuerySource<_,'Q>, outerKeySelector, innerKeySelector, elementSelector: _ -> seq<_> -> _) : QuerySource<_,'Q> =
QuerySource (System.Linq.Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_,_>(outerKeySelector), Func<_,_>(innerKeySelector), Func<_,_,_>(fun x g -> elementSelector x (g.DefaultIfEmpty()))))
+ member __.RunQueryAsValue (q:Quotations.Expr<'T>) : 'T = ForwardDeclarations.Query.Execute q
+
+ member __.RunQueryAsEnumerable (q:Quotations.Expr<QuerySource<'T,IEnumerable>>) : IEnumerable<'T> =
+ let queryAfterEliminatingNestedQueries = ForwardDeclarations.Query.EliminateNestedQueries q
+ let queryAfterCleanup = Microsoft.FSharp.Linq.RuntimeHelpers.Adapters.CleanupLeaf queryAfterEliminatingNestedQueries
+ (LeafExpressionConverter.EvaluateQuotation queryAfterCleanup :?> QuerySource<'T,IEnumerable>).Source
+
+ member __.RunQueryAsQueryable (q:Quotations.Expr<QuerySource<'T,IQueryable>>) : IQueryable<'T> = ForwardDeclarations.Query.Execute q
+ member this.Run q = this.RunQueryAsQueryable q
+
+namespace Microsoft.FSharp.Linq.QueryRunExtensions
+
+ open Microsoft.FSharp.Core
+
+ [<AutoOpen>]
+ module LowPriority =
+ type Microsoft.FSharp.Linq.QueryBuilder with
+ [<CompiledName("RunQueryAsValue")>]
+ member this.Run (q: Microsoft.FSharp.Quotations.Expr<'T>) = this.RunQueryAsValue q
+
+ [<AutoOpen>]
+ module HighPriority =
+ type Microsoft.FSharp.Linq.QueryBuilder with
+ [<CompiledName("RunQueryAsEnumerable")>]
+ member this.Run (q: Microsoft.FSharp.Quotations.Expr<Microsoft.FSharp.Linq.QuerySource<'T,System.Collections.IEnumerable>>) = this.RunQueryAsEnumerable q
+
+namespace Microsoft.FSharp.Linq
+
+open System
+open System.Linq
+open System.Collections
+open System.Collections.Generic
+open System.Linq.Expressions
+open System.Reflection
+#if FX_NO_REFLECTION_EMIT
+#else
+open System.Reflection.Emit
+#endif
+open Microsoft.FSharp
+open Microsoft.FSharp.Core
+open Microsoft.FSharp.Core.Operators
+open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
+open Microsoft.FSharp.Collections
+open Microsoft.FSharp.Reflection
+open Microsoft.FSharp.Linq
+open Microsoft.FSharp.Linq.RuntimeHelpers.Adapters
+open Microsoft.FSharp.Linq.RuntimeHelpers
+open Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter
+open Microsoft.FSharp.Quotations
+open Microsoft.FSharp.Quotations.Patterns
+open Microsoft.FSharp.Quotations.DerivedPatterns
+
+open Microsoft.FSharp.Linq.QueryRunExtensions
+
+#if FX_RESHAPED_REFLECTION
+open PrimReflectionAdapters
+open ReflectionAdapters
+#endif
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Query =
@@ -940,10 +997,11 @@ module Query =
| MacroReduction reduced -> Some (walk reduced)
| _ -> None)
-
- let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof<QueryBuilder>.GetMethod("Run").MethodHandle)
- let (|CallQueryBuilderRunValue|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof<QueryBuilder>.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.LowPriority").GetMethod("RunQueryAsValue").MethodHandle)
- let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof<QueryBuilder>.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.HighPriority").GetMethod("RunQueryAsEnumerable").MethodHandle)
+ let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b :QueryBuilder, v) -> b.Run(v)))
+ // (typeof<QueryBuilder>.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.LowPriority").GetMethod("RunQueryAsValue").MethodHandle)
+ let (|CallQueryBuilderRunValue|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr<'a>) -> b.Run(v)) : 'a) // type annotations here help overload resolution
+ // (typeof<QueryBuilder>.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.HighPriority").GetMethod("RunQueryAsEnumerable").MethodHandle)
+ let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr<QuerySource<_, IEnumerable>> ) -> b.Run(v))) // type annotations here help overload resolution
let (|CallQueryBuilderFor|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder,source:QuerySource<int,_>,body) -> b.For(source,body)))
let (|CallQueryBuilderYield|_|) : Quotations.Expr -> _ = (|SpecificCall1|_|) (methodhandleof (fun (b:QueryBuilder,value) -> b.Yield value))
let (|CallQueryBuilderYieldFrom|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder,values) -> b.YieldFrom values))
@@ -1493,7 +1551,7 @@ module Query =
let mutVar, mutToImmutSelector = ConvertImmutableConsumerToMutableConsumer sourceConv (immutVar, Expr.Var immutVar)
let immutExprEnumerable = MakeSelect(CanEliminate.Yes, false, mutSource, mutVar, mutToImmutSelector)
let mustReturnIQueryable =
- IsQuerySourceTy immutSourceTy && qTyIsIQueryable (immutSourceTy.GetGenericArguments().[0]) ||
+ IsQuerySourceTy immutSourceTy && qTyIsIQueryable (immutSourceTy.GetGenericArguments().[1]) ||
IsIQueryableTy immutSourceTy
let immutExprFinal =
if mustReturnIQueryable then MakeAsQueryable(immutSourceElemTy,immutExprEnumerable)
@@ -1679,37 +1737,12 @@ module Query =
// We use Unchecked.unbox to allow headOrDefault, lastOrDefault and exactlyOneOrDefault to return Uncehcked.defaultof<_> values for F# types
Unchecked.unbox (EvalNonNestedOuter CanEliminate.No p)
-
-type QueryBuilder with
- member __.RunQueryAsValue (q:Quotations.Expr<'T>) : 'T = Query.QueryExecute q
-
- member __.RunQueryAsEnumerable (q:Quotations.Expr<QuerySource<'T,IEnumerable>>) : IEnumerable<'T> =
- let queryAfterEliminatingNestedQueries = Query.EliminateNestedQueries q
- let queryAfterCleanup = Microsoft.FSharp.Linq.RuntimeHelpers.Adapters.CleanupLeaf queryAfterEliminatingNestedQueries
- (LeafExpressionConverter.EvaluateQuotation queryAfterCleanup :?> QuerySource<'T,IEnumerable>).Source
-
- member __.RunQueryAsQueryable (q:Quotations.Expr<QuerySource<'T,IQueryable>>) : IQueryable<'T> = Query.QueryExecute q
- member this.Run q = this.RunQueryAsQueryable q
-
-
-
-namespace Microsoft.FSharp.Linq.QueryRunExtensions
-
- open Microsoft.FSharp.Core
-
- [<AutoOpen>]
- module LowPriority =
- type Microsoft.FSharp.Linq.QueryBuilder with
- [<CompiledName("RunQueryAsValue")>]
- member this.Run (q: Microsoft.FSharp.Quotations.Expr<'T>) = this.RunQueryAsValue q
-
- [<AutoOpen>]
- module HighPriority =
- type Microsoft.FSharp.Linq.QueryBuilder with
- [<CompiledName("RunQueryAsEnumerable")>]
- member this.Run (q: Microsoft.FSharp.Quotations.Expr<Microsoft.FSharp.Linq.QuerySource<'T,System.Collections.IEnumerable>>) = this.RunQueryAsEnumerable q
-
-
+ do ForwardDeclarations.Query <-
+ {
+ new ForwardDeclarations.IQueryMethods with
+ member this.Execute(q) = QueryExecute q
+ member this.EliminateNestedQueries(e) = EliminateNestedQueries e
+ }
#endif
diff --git a/src/fsharp/FSharp.Core/QueryExtensions.fs b/src/fsharp/FSharp.Core/QueryExtensions.fs
index 6ebbbff..1038f40 100755
--- a/src/fsharp/FSharp.Core/QueryExtensions.fs
+++ b/src/fsharp/FSharp.Core/QueryExtensions.fs
@@ -22,6 +22,10 @@ open System.Collections.Generic
open System.Linq
open System.Linq.Expressions
+#if FX_RESHAPED_REFLECTION
+open PrimReflectionAdapters
+open ReflectionAdapters
+#endif
// ----------------------------------------------------------------------------
@@ -194,7 +198,11 @@ module internal Adapters =
let (|RecordFieldGetSimplification|_|) (expr:Expr) =
match expr with
| Patterns.PropertyGet(Some (Patterns.NewRecord(typ,els)),propInfo,[]) ->
+#if FX_RESHAPED_REFLECTION
+ let fields = Microsoft.FSharp.Reflection.FSharpType.GetRecordFields(typ, true)
+#else
let fields = Microsoft.FSharp.Reflection.FSharpType.GetRecordFields(typ,System.Reflection.BindingFlags.Public|||System.Reflection.BindingFlags.NonPublic)
+#endif
match fields |> Array.tryFindIndex (fun p -> p = propInfo) with
| None -> None
| Some i -> if i < els.Length then Some els.[i] else None
diff --git a/src/fsharp/FSharp.Core/SR.fs b/src/fsharp/FSharp.Core/SR.fs
index a90ecb4..e09caba 100755
--- a/src/fsharp/FSharp.Core/SR.fs
+++ b/src/fsharp/FSharp.Core/SR.fs
@@ -1,7 +1,13 @@
namespace Microsoft.FSharp.Core
module internal SR =
+#if FX_RESHAPED_REFLECTION
+ open System.Reflection
+ type TypeInThisAssembly(_dummy : obj) = class end
+ let private resources = new System.Resources.ResourceManager("FSCore", TypeInThisAssembly(null).GetType().GetTypeInfo().Assembly)
+#else
let private resources = new System.Resources.ResourceManager("FSCore", System.Reflection.Assembly.GetExecutingAssembly())
+#endif
let matchCasesIncomplete = "matchCasesIncomplete"
let resetNotSupported = "resetNotSupported"
diff --git a/src/fsharp/FSharp.Core/control.fs b/src/fsharp/FSharp.Core/control.fs
index 4a02557..e8991d3 100755
--- a/src/fsharp/FSharp.Core/control.fs
+++ b/src/fsharp/FSharp.Core/control.fs
@@ -307,6 +307,13 @@ namespace Microsoft.FSharp.Control
open Microsoft.FSharp.Control
open Microsoft.FSharp.Collections
+#if FX_RESHAPED_REFLECTION
+ open ReflectionAdapters
+ type BindingFlags = ReflectionAdapters.BindingFlags
+#else
+ type BindingFlags = System.Reflection.BindingFlags
+#endif
+
#if FX_NO_TASK
#else
open System.Threading
@@ -464,6 +471,34 @@ namespace Microsoft.FSharp.Control
cont <- Some action
| _ -> failwith "Internal error: attempting to install continuation twice"
+
+#if FSHARP_CORE_NETCORE_PORTABLE
+ // Imitation of desktop functionality for .NETCore
+ // 1. QueueUserWorkItem reimplemented as Task.Run
+ // 2. Thread.CurrentThread type in the code is typically used to check if continuation is called on the same thread that initiated the async computation
+ // if this condition holds we may decide to invoke continuation directly rather than queueing it.
+ // Thread type here is barely a wrapper over CurrentManagedThreadId value - it should be enough to uniquely identify the actual thread
+
+ [<NoComparison; NoEquality>]
+ type internal WaitCallback = WaitCallback of (obj -> unit)
+
+ type ThreadPool =
+ static member QueueUserWorkItem(WaitCallback(cb), state : obj) =
+ System.Threading.Tasks.Task.Run (fun () -> cb(state)) |> ignore
+ true
+
+ [<AllowNullLiteral>]
+ type Thread(threadId : int) =
+ static member CurrentThread = Thread(Environment.CurrentManagedThreadId)
+ member this.ThreadId = threadId
+ override this.GetHashCode() = threadId
+ override this.Equals(other : obj) =
+ match other with
+ | :? Thread as other -> threadId = other.ThreadId
+ | _ -> false
+
+#endif
+
type TrampolineHolder() as this =
let mutable trampoline = null
@@ -864,8 +899,6 @@ namespace Microsoft.FSharp.Control
bindA p1 (fun () -> p2)
-
-
open AsyncBuilderImpl
[<Sealed>]
@@ -1294,9 +1327,11 @@ namespace Microsoft.FSharp.Control
static member CancelDefaultToken() =
let cts = !defaultCancellationTokenSource
- cts.Cancel()
+ // set new CancellationTokenSource before calling Cancel - otherwise if Cancel throws token will stay unchanged
defaultCancellationTokenSource := new CancellationTokenSource()
// we do not dispose the old default CTS - let GC collect it
+ cts.Cancel()
+ // we do not dispose the old default CTS - let GC collect it
static member Catch (p: Async<'T>) =
unprotectedPrimitive (fun ({ aux = aux } as args) ->
@@ -1337,8 +1372,6 @@ namespace Microsoft.FSharp.Control
if tasks.Length = 0 then args.cont [| |] else // must not be in a 'protect' if we call cont explicitly; if cont throws, it should unwind the stack, preserving Dev10 behavior
protectedPrimitiveCore args (fun args ->
let ({ aux = aux } as args) = delimitSyncContext args // manually resync
- let tasks = Seq.toArray l
- if tasks.Length = 0 then args.cont [| |] else
let count = ref tasks.Length
let firstExn = ref None
let results = Array.zeroCreate tasks.Length
@@ -1348,7 +1381,8 @@ namespace Microsoft.FSharp.Control
let trampolineHolder = aux.trampolineHolder
let finishTask(remaining) =
- if (remaining=0) then
+ if (remaining = 0) then
+ innerCTS.Dispose()
match (!firstExn) with
| None -> trampolineHolder.Protect(fun () -> args.cont results)
| Some (Choice1Of2 exn) -> trampolineHolder.Protect(fun () -> aux.econt exn)
@@ -1361,27 +1395,21 @@ namespace Microsoft.FSharp.Control
let recordSuccess i res =
results.[i] <- res;
- let remaining =
- lock count (fun () ->
- decr count;
- if !count = 0 then
- innerCTS.Dispose()
- !count)
- finishTask(remaining)
+ finishTask(Interlocked.Decrement count)
let recordFailure exn =
- let remaining =
- lock count (fun () ->
- decr count;
- match !firstExn with
- | None -> firstExn := Some exn // save the cancellation as the first exception
- | _ -> ()
- if !count = 0 then
- innerCTS.Dispose()
- else
- innerCTS.Cancel()
- !count)
- finishTask(remaining)
+ // capture first exception and then decrement the counter to avoid race when
+ // - thread 1 decremented counter and preempted by the scheduler
+ // - thread 2 decremented counter and called finishTask
+ // since exception is not yet captured - finishtask will fall into success branch
+ match Interlocked.CompareExchange(firstExn, Some exn, None) with
+ | None ->
+ // signal cancellation before decrementing the counter - this guarantees that no other thread can sneak to finishTask and dispose innerCTS
+ // NOTE: Cancel may introduce reentrancy - i.e. when handler registered for the cancellation token invokes cancel continuation that will call 'recordFailure'
+ // to correctly handle this we need to return decremented value, not the current value of 'count' otherwise we may invoke finishTask with value '0' several times
+ innerCTS.Cancel()
+ | _ -> ()
+ finishTask(Interlocked.Decrement count)
tasks |> Array.iteri (fun i p ->
queueAsync
@@ -1396,6 +1424,34 @@ namespace Microsoft.FSharp.Control
|> unfake);
FakeUnit))
+#if FX_NO_TASK
+#else
+ // Contains helpers that will attach continuation to the given task.
+ // Should be invoked as a part of protectedPrimitive(withResync) call
+ module TaskHelpers =
+ let continueWith (task : Task<'T>, ({ aux = aux } as args)) =
+ let continuation (completedTask : Task<_>) : unit =
+ aux.trampolineHolder.Protect((fun () ->
+ if completedTask.IsCanceled then
+ aux.ccont (new OperationCanceledException())
+ elif completedTask.IsFaulted then
+ aux.econt (upcast completedTask.Exception)
+ else
+ args.cont completedTask.Result)) |> unfake
+ task.ContinueWith(Action<Task<'T>>(continuation), TaskContinuationOptions.None) |> ignore |> fake
+
+ let continueWithUnit (task : Task, ({ aux = aux } as args)) =
+ let continuation (completedTask : Task) : unit =
+ aux.trampolineHolder.Protect((fun () ->
+ if completedTask.IsCanceled then
+ aux.ccont (new OperationCanceledException())
+ elif completedTask.IsFaulted then
+ aux.econt (upcast completedTask.Exception)
+ else
+ args.cont ())) |> unfake
+ task.ContinueWith(Action<Task>(continuation), TaskContinuationOptions.None) |> ignore |> fake
+#endif
+
#if FX_NO_REGISTERED_WAIT_HANDLES
[<Sealed>]
[<AutoSerializable(false)>]
@@ -1407,8 +1463,12 @@ namespace Microsoft.FSharp.Control
#if FX_NO_WAITONE_MILLISECONDS
wh.WaitOne(TimeSpan(0L))
#else
+#if FX_NO_EXIT_CONTEXT_FLAGS
+ wh.WaitOne(0)
+#else
wh.WaitOne(0,exitContext=false)
#endif
+#endif
member this.CompletedSynchronously = false // always reschedule
#endif
@@ -1421,6 +1481,13 @@ namespace Microsoft.FSharp.Control
static member StartImmediate(a:Async<unit>,?cancellationToken) : unit =
Async.StartWithContinuations(a,id,raise,ignore,?cancellationToken=cancellationToken)
+#if FSHARP_CORE_NETCORE_PORTABLE
+ static member Sleep(dueTime : int) : Async<unit> =
+ // use combo protectedPrimitiveWithResync + continueWith instead of AwaitTask so we can pass cancellation token to the Delay task
+ unprotectedPrimitiveWithResync ( fun ({ aux = aux} as args) ->
+ TaskHelpers.continueWithUnit(Task.Delay(dueTime, aux.token), args)
+ )
+#else
static member Sleep(dueTime) : Async<unit> =
unprotectedPrimitiveWithResync (fun ({ aux = aux } as args) ->
let timer = ref (None : Timer option)
@@ -1464,6 +1531,7 @@ namespace Microsoft.FSharp.Control
| exn ->
aux.econt exn
)
+#endif
static member AwaitWaitHandle(waitHandle:WaitHandle,?millisecondsTimeout:int) =
let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite
@@ -1513,7 +1581,6 @@ namespace Microsoft.FSharp.Control
|> ignore
// if user has specified timeout different from Timeout.Infinite
// then start another async to track timeout expiration
- // StartWithContinuations already installs trampoline so we can invoke continuation directly
if millisecondsTimeout <> Timeout.Infinite then
Async.StartWithContinuations
(
@@ -1521,7 +1588,7 @@ namespace Microsoft.FSharp.Control
cont = (fun () ->
if latch.Enter() then
registration.Dispose()
- scont false
+ aux.trampolineHolder.Protect(fun () -> scont false)
|> unfake),
econt = ignore, // we do not expect exceptions here
ccont = cancel,
@@ -1817,7 +1884,7 @@ namespace Microsoft.FSharp.Control
resultCell.RegisterResult(res,reuseThread=true) |> unfake)
and del =
#if FX_ATLEAST_PORTABLE
- let invokeMeth = (typeof<Closure<'T>>).GetMethod("Invoke", System.Reflection.BindingFlags.NonPublic ||| System.Reflection.BindingFlags.Public ||| System.Reflection.BindingFlags.Instance)
+ let invokeMeth = (typeof<Closure<'T>>).GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance)
System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeMeth) :?> 'Delegate
#else
System.Delegate.CreateDelegate(typeof<'Delegate>, obj, "Invoke") :?> 'Delegate
@@ -1896,18 +1963,10 @@ namespace Microsoft.FSharp.Control
#if FX_NO_TASK
#else
- static member AwaitTask (task:Task<'T>) : Async<'T> =
- protectedPrimitiveWithResync(fun ({aux = aux} as args) ->
- let continuation (completedTask : Task<_>) : unit =
- aux.trampolineHolder.Protect((fun () ->
- if completedTask.IsCanceled then
- aux.ccont (new OperationCanceledException())
- elif completedTask.IsFaulted then
- aux.econt (upcast completedTask.Exception)
- else
- args.cont completedTask.Result)) |> unfake
- task.ContinueWith(Action<Task<'T>>(continuation), TaskContinuationOptions.None) |> ignore |> fake
- )
+ static member AwaitTask (task:Task<'T>) : Async<'T> =
+ protectedPrimitiveWithResync (fun args ->
+ TaskHelpers.continueWith(task, args)
+ )
#endif
module CommonExtensions =
@@ -1920,7 +1979,14 @@ namespace Microsoft.FSharp.Control
member stream.AsyncRead(buffer: byte[],?offset,?count) =
let offset = defaultArg offset 0
let count = defaultArg count buffer.Length
+#if FSHARP_CORE_NETCORE_PORTABLE
+ // use combo protectedPrimitiveWithResync + continueWith instead of AwaitTask so we can pass cancellation token to the ReadAsync task
+ protectedPrimitiveWithResync (fun ({ aux = aux } as args) ->
+ TaskHelpers.continueWith(stream.ReadAsync(buffer, offset, count, aux.token), args)
+ )
+#else
Async.FromBeginEnd (buffer,offset,count,stream.BeginRead,stream.EndRead)
+#endif
[<CompiledName("AsyncReadBytes")>] // give the extension member a 'nice', unmangled compiled name, unique within this module
member stream.AsyncRead(count) =
@@ -1937,7 +2003,14 @@ namespace Microsoft.FSharp.Control
member stream.AsyncWrite(buffer:byte[], ?offset:int, ?count:int) =
let offset = defaultArg offset 0
let count = defaultArg count buffer.Length
+#if FSHARP_CORE_NETCORE_PORTABLE
+ // use combo protectedPrimitiveWithResync + continueWith instead of AwaitTask so we can pass cancellation token to the WriteAsync task
+ protectedPrimitiveWithResync ( fun ({ aux = aux} as args) ->
+ TaskHelpers.continueWithUnit(stream.WriteAsync(buffer, offset, count, aux.token), args)
+ )
+#else
Async.FromBeginEnd (buffer,offset,count,stream.BeginWrite,stream.EndWrite)
+#endif
type System.Threading.WaitHandle with
member waitHandle.AsyncWaitOne(?millisecondsTimeout:int) = // only used internally, not a public API
diff --git a/src/fsharp/FSharp.Core/control.fsi b/src/fsharp/FSharp.Core/control.fsi
index 585aa97..16e827e 100755
--- a/src/fsharp/FSharp.Core/control.fsi
+++ b/src/fsharp/FSharp.Core/control.fsi
@@ -1,4 +1,3 @@
-
//----------------------------------------------------------------------------
// Copyright (c) 2002-2012 Microsoft Corporation.
//
diff --git a/src/fsharp/FSharp.Core/event.fs b/src/fsharp/FSharp.Core/event.fs
index 02bddcb..1ae53eb 100755
--- a/src/fsharp/FSharp.Core/event.fs
+++ b/src/fsharp/FSharp.Core/event.fs
@@ -20,6 +20,11 @@ namespace Microsoft.FSharp.Control
open System.Reflection
open System.Diagnostics
+#if FX_RESHAPED_REFLECTION
+ open ReflectionAdapters
+ type BindingFlags = ReflectionAdapters.BindingFlags
+#endif
+
#if FX_NO_DELEGATE_DYNAMIC_METHOD
#else
@@ -145,7 +150,7 @@ namespace Microsoft.FSharp.Control
multicast <- System.Delegate.Remove(multicast, d) :?> 'Delegate
interface System.IObservable<'Args> with
member e.Subscribe(observer) =
- let obj = new EventDelegee<'Args>(observer)
+ let obj = new EventDelegee<'Args>(observer)
let h = System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeInfo) :?> 'Delegate
(e :?> IDelegateEvent<'Delegate>).AddHandler(h)
{ new System.IDisposable with
diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs
index 5b31256..7d22ef1 100755
--- a/src/fsharp/FSharp.Core/prim-types.fs
+++ b/src/fsharp/FSharp.Core/prim-types.fs
@@ -75,7 +75,6 @@ namespace Microsoft.FSharp.Core
open System.Globalization
open System.Text
-
//-------------------------------------------------------------------------
// enumerations
@@ -112,8 +111,7 @@ namespace Microsoft.FSharp.Core
clone
open ICloneableExtensions
-#else
-#endif
+#endif
[<AttributeUsage(AttributeTargets.Class,AllowMultiple=false)>]
type SealedAttribute(value:bool) =
@@ -392,6 +390,27 @@ namespace Microsoft.FSharp.Core
[<MeasureAnnotatedAbbreviation>] type int16<[<Measure>] 'Measure> = int16
[<MeasureAnnotatedAbbreviation>] type int64<[<Measure>] 'Measure> = int64
+#if FX_RESHAPED_REFLECTION
+ module PrimReflectionAdapters =
+
+ open System.Reflection
+ open System.Linq
+ // copied from BasicInlinedOperations
+ let inline box (x:'T) = (# "box !0" type ('T) x : obj #)
+ let inline unboxPrim<'T>(x:obj) = (# "unbox.any !0" type ('T) x : 'T #)
+ type System.Type with
+ member inline this.IsGenericType = this.GetTypeInfo().IsGenericType
+ member inline this.IsValueType = this.GetTypeInfo().IsValueType
+ member inline this.IsAssignableFrom(otherTy : Type) = this.GetTypeInfo().IsAssignableFrom(otherTy.GetTypeInfo())
+ member inline this.GetProperty(name) = this.GetRuntimeProperty(name)
+ member inline this.GetMethod(name, parameterTypes) = this.GetRuntimeMethod(name, parameterTypes)
+ member inline this.GetCustomAttributes(attrTy : Type, inherits : bool) : obj[] =
+ unboxPrim<_> (box (CustomAttributeExtensions.GetCustomAttributes(this.GetTypeInfo(), attrTy, false).ToArray()))
+
+ open PrimReflectionAdapters
+
+#endif
+
module BasicInlinedOperations =
let inline unboxPrim<'T>(x:obj) = (# "unbox.any !0" type ('T) x : 'T #)
@@ -443,10 +462,10 @@ namespace Microsoft.FSharp.Core
let inline typeof<'T> =
let tok = (# "ldtoken !0" type('T) : System.RuntimeTypeHandle #)
- System.Type.GetTypeFromHandle(tok)
+ System.Type.GetTypeFromHandle(tok)
let inline typedefof<'T> =
- let ty = typeof<'T>
+ let ty = typeof<'T>
if ty.IsGenericType then ty.GetGenericTypeDefinition() else ty
let inline sizeof<'T> =
@@ -678,10 +697,12 @@ namespace Microsoft.FSharp.Core
open IntrinsicOperators
+#if FX_RESHAPED_REFLECTION
+ open PrimReflectionAdapters
+#endif
[<CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1034:NestedTypesShouldNotBeVisible")>] // nested module OK
module IntrinsicFunctions =
- //-------------------------------------------------------------------------
// Unboxing, type casts, type tests
type TypeNullnessSemantics = int
@@ -704,17 +725,17 @@ namespace Microsoft.FSharp.Core
let ty = typeof<'T>
if ty.IsValueType
then TypeNullnessSemantics_NullNever else
- let mappingAttrs = ty.GetCustomAttributes(typeof<CompilationMappingAttribute>,false)
+ let mappingAttrs = ty.GetCustomAttributes(typeof<CompilationMappingAttribute>, false)
if mappingAttrs.Length = 0
then TypeNullnessSemantics_NullIsExtraValue
elif ty.Equals(typeof<unit>) then
TypeNullnessSemantics_NullTrueValue
- elif typeof<System.Delegate>.IsAssignableFrom(ty) then
+ elif typeof<Delegate>.IsAssignableFrom(ty) then
TypeNullnessSemantics_NullIsExtraValue
- elif ty.GetCustomAttributes(typeof<AllowNullLiteralAttribute>,false).Length > 0 then
+ elif ty.GetCustomAttributes(typeof<AllowNullLiteralAttribute>, false).Length > 0 then
TypeNullnessSemantics_NullIsExtraValue
else
- let reprAttrs = ty.GetCustomAttributes(typeof<CompilationRepresentationAttribute>,false)
+ let reprAttrs = ty.GetCustomAttributes(typeof<CompilationRepresentationAttribute>, false)
if reprAttrs.Length = 0 then
TypeNullnessSemantics_NullNotLiked
else
@@ -2288,7 +2309,11 @@ namespace Microsoft.FSharp.Core
let sign = getSign32 s &p l
let specifier = get0OXB s &p l
if p >= l then formatError() else
- match Char.ToLower(specifier,CultureInfo.InvariantCulture(*FxCop:1304*)) with
+#if FX_NO_TO_LOWER_INVARIANT
+ match Char.ToLower(specifier, CultureInfo.InvariantCulture(*FxCop:1304*)) with
+#else
+ match Char.ToLowerInvariant(specifier) with
+#endif
| 'x' -> sign * (int32OfUInt32 (Convert.ToUInt32(UInt64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture))))
| 'b' -> sign * (int32OfUInt32 (Convert.ToUInt32(parseBinaryUInt64 s p l)))
| 'o' -> sign * (int32OfUInt32 (Convert.ToUInt32(parseOctalUInt64 s p l)))
@@ -2303,7 +2328,11 @@ namespace Microsoft.FSharp.Core
let sign = getSign64 s &p l
let specifier = get0OXB s &p l
if p >= l then formatError() else
- match Char.ToLower(specifier,CultureInfo.InvariantCulture(*FxCop:1304*)) with
+#if FX_NO_TO_LOWER_INVARIANT
+ match Char.ToLower(specifier, CultureInfo.InvariantCulture(*FxCop:1304*)) with
+#else
+ match Char.ToLowerInvariant(specifier) with
+#endif
| 'x' -> sign *. Int64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture)
| 'b' -> sign *. (int64OfUInt64 (parseBinaryUInt64 s p l))
| 'o' -> sign *. (int64OfUInt64 (parseOctalUInt64 s p l))
@@ -3135,6 +3164,7 @@ namespace Microsoft.FSharp.Core
type FuncConvert =
static member ToFSharpFunc( f : Action<_>) = (fun t -> f.Invoke(t))
#if FX_NO_CONVERTER
+ static member ToFSharpFunc( f : System.Func<_, _>) = (fun t -> f.Invoke(t))
#else
static member ToFSharpFunc( f : Converter<_,_>) = (fun t -> f.Invoke(t))
#endif
@@ -4628,6 +4658,9 @@ namespace Microsoft.FSharp.Core
open System.Collections
+#if FX_RESHAPED_REFLECTION
+ open PrimReflectionAdapters
+#endif
let notStarted() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationNotStarted)))
let alreadyFinished() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished)))
@@ -4908,82 +4941,114 @@ namespace Microsoft.FSharp.Core
let inline GetArraySlice (arr: _[]) start finish =
- let start = (match start with None -> 0 | Some n -> n)
- let finish = (match finish with None -> arr.Length - 1 | Some n -> n)
- GetArraySub arr start (finish - start + 1)
+ let start = (match start with None -> 0 | Some n -> n)
+ let finish = (match finish with None -> arr.Length - 1 | Some n -> n)
+ GetArraySub arr start (finish - start + 1)
let inline SetArraySlice (dst: _[]) start finish (src:_[]) =
- let start = (match start with None -> 0 | Some n -> n)
- let finish = (match finish with None -> dst.Length - 1 | Some n -> n)
- SetArraySub dst start (finish - start + 1) src
+ let start = (match start with None -> 0 | Some n -> n)
+ let finish = (match finish with None -> dst.Length - 1 | Some n -> n)
+ SetArraySub dst start (finish - start + 1) src
let GetArraySlice2D (arr: _[,]) start1 finish1 start2 finish2 =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> GetArray2DLength1 arr - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> GetArray2DLength2 arr - 1 | Some n -> n)
- let len1 = (finish1 - start1 + 1)
- let len2 = (finish2 - start2 + 1)
- GetArray2DSub arr start1 start2 len1 len2
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray2DLength1 arr - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray2DLength2 arr - 1 | Some n -> n)
+ let len1 = (finish1 - start1 + 1)
+ let len2 = (finish2 - start2 + 1)
+ GetArray2DSub arr start1 start2 len1 len2
+
+ let inline GetArraySlice2DFixed1 (arr: _[,]) fixed1 start2 finish2 =
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray2DLength2 arr - 1 | Some n -> n)
+ let len2 = (finish2 - start2 + 1)
+ let dst = zeroCreate len2
+ for j = 0 to len2 - 1 do
+ SetArray dst j (GetArray2D arr fixed1 (start2+j))
+ dst
+
+ let inline GetArraySlice2DFixed2 (arr: _[,]) start1 finish1 fixed2 =
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray2DLength1 arr - 1 | Some n -> n)
+ let len1 = (finish1 - start1 + 1)
+ let dst = zeroCreate len1
+ for i = 0 to len1 - 1 do
+ SetArray dst i (GetArray2D arr (start1+i) fixed2)
+ dst
+
+ let inline SetArraySlice2DFixed1 (dst: _[,]) fixed1 start2 finish2 (src:_[]) =
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray2DLength2 dst - 1 | Some n -> n)
+ let len2 = (finish2 - start2 + 1)
+ for j = 0 to len2 - 1 do
+ SetArray2D dst fixed1 (start2+j) (GetArray src j)
+
+ let inline SetArraySlice2DFixed2 (dst: _[,]) start1 finish1 fixed2 (src:_[]) =
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray2DLength1 dst - 1 | Some n -> n)
+ let len1 = (finish1 - start1 + 1)
+ for i = 0 to len1 - 1 do
+ SetArray2D dst (start1+i) fixed2 (GetArray src i)
let SetArraySlice2D (dst: _[,]) start1 finish1 start2 finish2 (src:_[,]) =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> GetArray2DLength1 dst - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> GetArray2DLength2 dst - 1 | Some n -> n)
- SetArray2DSub dst start1 start2 (finish1 - start1 + 1) (finish2 - start2 + 1) src
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray2DLength1 dst - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray2DLength2 dst - 1 | Some n -> n)
+ SetArray2DSub dst start1 start2 (finish1 - start1 + 1) (finish2 - start2 + 1) src
let GetArraySlice3D (arr: _[,,]) start1 finish1 start2 finish2 start3 finish3 =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let start3 = (match start3 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> GetArray3DLength1 arr - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> GetArray3DLength2 arr - 1 | Some n -> n)
- let finish3 = (match finish3 with None -> GetArray3DLength3 arr - 1 | Some n -> n)
- let len1 = (finish1 - start1 + 1)
- let len2 = (finish2 - start2 + 1)
- let len3 = (finish3 - start3 + 1)
- GetArray3DSub arr start1 start2 start3 len1 len2 len3
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let start3 = (match start3 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray3DLength1 arr - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray3DLength2 arr - 1 | Some n -> n)
+ let finish3 = (match finish3 with None -> GetArray3DLength3 arr - 1 | Some n -> n)
+ let len1 = (finish1 - start1 + 1)
+ let len2 = (finish2 - start2 + 1)
+ let len3 = (finish3 - start3 + 1)
+ GetArray3DSub arr start1 start2 start3 len1 len2 len3
let SetArraySlice3D (dst: _[,,]) start1 finish1 start2 finish2 start3 finish3 (src:_[,,]) =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let start3 = (match start3 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> GetArray3DLength1 dst - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> GetArray3DLength2 dst - 1 | Some n -> n)
- let finish3 = (match finish3 with None -> GetArray3DLength3 dst - 1 | Some n -> n)
- SetArray3DSub dst start1 start2 start3 (finish1 - start1 + 1) (finish2 - start2 + 1) (finish3 - start3 + 1) src
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let start3 = (match start3 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> GetArray3DLength1 dst - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> GetArray3DLength2 dst - 1 | Some n -> n)
+ let finish3 = (match finish3 with None -> GetArray3DLength3 dst - 1 | Some n -> n)
+ SetArray3DSub dst start1 start2 start3 (finish1 - start1 + 1) (finish2 - start2 + 1) (finish3 - start3 + 1) src
let GetArraySlice4D (arr: _[,,,]) start1 finish1 start2 finish2 start3 finish3 start4 finish4 =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let start3 = (match start3 with None -> 0 | Some n -> n)
- let start4 = (match start4 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> Array4DLength1 arr - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> Array4DLength2 arr - 1 | Some n -> n)
- let finish3 = (match finish3 with None -> Array4DLength3 arr - 1 | Some n -> n)
- let finish4 = (match finish4 with None -> Array4DLength4 arr - 1 | Some n -> n)
- let len1 = (finish1 - start1 + 1)
- let len2 = (finish2 - start2 + 1)
- let len3 = (finish3 - start3 + 1)
- let len4 = (finish4 - start4 + 1)
- GetArray4DSub arr start1 start2 start3 start4 len1 len2 len3 len4
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let start3 = (match start3 with None -> 0 | Some n -> n)
+ let start4 = (match start4 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> Array4DLength1 arr - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> Array4DLength2 arr - 1 | Some n -> n)
+ let finish3 = (match finish3 with None -> Array4DLength3 arr - 1 | Some n -> n)
+ let finish4 = (match finish4 with None -> Array4DLength4 arr - 1 | Some n -> n)
+ let len1 = (finish1 - start1 + 1)
+ let len2 = (finish2 - start2 + 1)
+ let len3 = (finish3 - start3 + 1)
+ let len4 = (finish4 - start4 + 1)
+ GetArray4DSub arr start1 start2 start3 start4 len1 len2 len3 len4
let SetArraySlice4D (dst: _[,,,]) start1 finish1 start2 finish2 start3 finish3 start4 finish4 (src:_[,,,]) =
- let start1 = (match start1 with None -> 0 | Some n -> n)
- let start2 = (match start2 with None -> 0 | Some n -> n)
- let start3 = (match start3 with None -> 0 | Some n -> n)
- let start4 = (match start4 with None -> 0 | Some n -> n)
- let finish1 = (match finish1 with None -> Array4DLength1 dst - 1 | Some n -> n)
- let finish2 = (match finish2 with None -> Array4DLength2 dst - 1 | Some n -> n)
- let finish3 = (match finish3 with None -> Array4DLength3 dst - 1 | Some n -> n)
- let finish4 = (match finish4 with None -> Array4DLength4 dst - 1 | Some n -> n)
- SetArray4DSub dst start1 start2 start3 start4 (finish1 - start1 + 1) (finish2 - start2 + 1) (finish3 - start3 + 1) (finish4 - start4 + 1) src
+ let start1 = (match start1 with None -> 0 | Some n -> n)
+ let start2 = (match start2 with None -> 0 | Some n -> n)
+ let start3 = (match start3 with None -> 0 | Some n -> n)
+ let start4 = (match start4 with None -> 0 | Some n -> n)
+ let finish1 = (match finish1 with None -> Array4DLength1 dst - 1 | Some n -> n)
+ let finish2 = (match finish2 with None -> Array4DLength2 dst - 1 | Some n -> n)
+ let finish3 = (match finish3 with None -> Array4DLength3 dst - 1 | Some n -> n)
+ let finish4 = (match finish4 with None -> Array4DLength4 dst - 1 | Some n -> n)
+ SetArray4DSub dst start1 start2 start3 start4 (finish1 - start1 + 1) (finish2 - start2 + 1) (finish3 - start3 + 1) (finish4 - start4 + 1) src
let inline GetStringSlice (str:string) start finish =
- let start = (match start with None -> 0 | Some n -> n)
- let finish = (match finish with None -> str.Length - 1 | Some n -> n)
- str.Substring(start, finish-start+1)
+ let start = (match start with None -> 0 | Some n -> n)
+ let finish = (match finish with None -> str.Length - 1 | Some n -> n)
+ str.Substring(start, finish-start+1)
[<NoDynamicInvocation>]
@@ -5406,6 +5471,13 @@ namespace Microsoft.FSharp.Core
when ^T : byte = RangeByte (retype n) (retype step) (retype m)
+ type ``[,]``<'T> with
+ member arr.GetSlice(x : int, y1 : int option, y2 : int option) = GetArraySlice2DFixed1 arr x y1 y2
+ member arr.GetSlice(x1 : int option, x2 : int option, y : int) = GetArraySlice2DFixed2 arr x1 x2 y
+
+ member arr.SetSlice(x : int, y1 : int option, y2 : int option, source:'T[]) = SetArraySlice2DFixed1 arr x y1 y2 source
+ member arr.SetSlice(x1 : int option, x2 : int option, y : int, source:'T[]) = SetArraySlice2DFixed2 arr x1 x2 y source
+
[<CompiledName("Abs")>]
let inline abs (x: ^T) : ^T =
AbsDynamic x
diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi
index acfe621..9387675 100755
--- a/src/fsharp/FSharp.Core/prim-types.fsi
+++ b/src/fsharp/FSharp.Core/prim-types.fsi
@@ -676,7 +676,7 @@ namespace Microsoft.FSharp.Core
/// <summary>This attribute is used for two purposes. When applied to an assembly, it must be given a string
/// argument, and this argument must indicate a valid module or namespace in that assembly. Source
/// code files compiled with a reference to this assembly are processed in an environment
- /// where the given path is automatically oepned.</summary>
+ /// where the given path is automatically opened.</summary>
///
/// <remarks>When applied to a module within an assembly, then the attribute must not be given any arguments.
/// When the enclosing namespace is opened in user source code, the module is also implicitly opened.</remarks>
@@ -1346,6 +1346,20 @@ namespace Microsoft.FSharp.Core
open System
open Microsoft.FSharp.Core
+#if FX_RESHAPED_REFLECTION
+ module internal PrimReflectionAdapters =
+
+ open System.Reflection
+
+ type System.Type with
+ member inline IsGenericType : bool
+ member inline IsValueType : bool
+ member inline GetMethod : string * parameterTypes : Type[] -> MethodInfo
+ member inline GetProperty : string -> PropertyInfo
+ member inline IsAssignableFrom : otherType : Type -> bool
+ member inline GetCustomAttributes : attributeType : Type * inherits: bool -> obj[]
+#endif
+
//-------------------------------------------------------------------------
// F# Choice Types
@@ -1903,12 +1917,12 @@ namespace Microsoft.FSharp.Core
/// <returns>The result of the operation.</returns>
val inline (>>>) : value:^T -> shift:int32 -> ^T when ^T : (static member (>>>) : ^T * int32 -> ^T) and default ^T : int
- /// <summary>Overloaded logical-NOT operator</summary>
+ /// <summary>Overloaded bitwise-NOT operator</summary>
/// <param name="value">The input value.</param>
/// <returns>The result of the operation.</returns>
val inline (~~~) : value:^T -> ^T when ^T : (static member (~~~) : ^T -> ^T) and default ^T : int
- /// <summary>Overloaded prefix=plus operator</summary>
+ /// <summary>Overloaded prefix-plus operator</summary>
/// <param name="value">The input value.</param>
/// <returns>The result of the operation.</returns>
val inline (~+) : value:^T -> ^T when ^T : (static member (~+) : ^T -> ^T) and default ^T : int
@@ -2671,7 +2685,7 @@ namespace Microsoft.FSharp.Core
/// <param name="source">The source array.</param>
val inline SetArraySlice : target:'T[] -> start:int option -> finish:int option -> source:'T[] -> unit
- /// <summary>Gets a slice of an array</summary>
+ /// <summary>Gets a region slice of an array</summary>
/// <param name="source">The source array.</param>
/// <param name="start1">The start index of the first dimension.</param>
/// <param name="finish1">The end index of the first dimension.</param>
@@ -2680,7 +2694,23 @@ namespace Microsoft.FSharp.Core
/// <returns>The two dimensional sub array from the input indices.</returns>
val GetArraySlice2D : source:'T[,] -> start1:int option -> finish1:int option -> start2:int option -> finish2:int option -> 'T[,]
- /// <summary>Sets a slice of an array</summary>
+ /// <summary>Gets a vector slice of a 2D array. The index of the first dimension is fixed.</summary>
+ /// <param name="source">The source array.</param>
+ /// <param name="index1">The index of the first dimension.</param>
+ /// <param name="start2">The start index of the second dimension.</param>
+ /// <param name="finish2">The end index of the second dimension.</param>
+ /// <returns>The sub array from the input indices.</returns>
+ val inline GetArraySlice2DFixed1 : source:'T[,] -> index1:int -> start2:int option -> finish2:int option -> 'T[]
+
+ /// <summary>Gets a vector slice of a 2D array. The index of the second dimension is fixed.</summary>
+ /// <param name="source">The source array.</param>
+ /// <param name="start1">The start index of the first dimension.</param>
+ /// <param name="finish1">The end index of the first dimension.</param>
+ /// <param name="index2">The fixed index of the second dimension.</param>
+ /// <returns>The sub array from the input indices.</returns>
+ val inline GetArraySlice2DFixed2 : source:'T[,] -> start1:int option -> finish1:int option -> index2: int -> 'T[]
+
+ /// <summary>Sets a region slice of an array</summary>
/// <param name="target">The target array.</param>
/// <param name="start1">The start index of the first dimension.</param>
/// <param name="finish1">The end index of the first dimension.</param>
@@ -2689,6 +2719,22 @@ namespace Microsoft.FSharp.Core
/// <param name="source">The source array.</param>
val SetArraySlice2D : target:'T[,] -> start1:int option -> finish1:int option -> start2:int option -> finish2:int option -> source:'T[,] -> unit
+ /// <summary>Sets a vector slice of a 2D array. The index of the first dimension is fixed.</summary>
+ /// <param name="target">The target array.</param>
+ /// <param name="index1">The index of the first dimension.</param>
+ /// <param name="start2">The start index of the second dimension.</param>
+ /// <param name="finish2">The end index of the second dimension.</param>
+ /// <param name="source">The source array.</param>
+ val inline SetArraySlice2DFixed1 : target:'T[,] -> index1:int -> start2:int option -> finish2:int option -> source:'T[] -> unit
+
+ /// <summary>Sets a vector slice of a 2D array. The index of the second dimension is fixed.</summary>
+ /// <param name="target">The target array.</param>
+ /// <param name="start1">The start index of the first dimension.</param>
+ /// <param name="finish1">The end index of the first dimension.</param>
+ /// <param name="index2">The index of the second dimension.</param>
+ /// <param name="source">The source array.</param>
+ val inline SetArraySlice2DFixed2 : target:'T[,] -> start1:int option -> finish1:int option -> index2:int -> source:'T[] -> unit
+
/// <summary>Gets a slice of an array</summary>
/// <param name="source">The source array.</param>
/// <param name="start1">The start index of the first dimension.</param>
diff --git a/src/fsharp/FSharp.Core/printf.fs b/src/fsharp/FSharp.Core/printf.fs
index ad06604..4b11324 100755
--- a/src/fsharp/FSharp.Core/printf.fs
+++ b/src/fsharp/FSharp.Core/printf.fs
@@ -11,619 +11,1278 @@
namespace Microsoft.FSharp.Core
-open Microsoft.FSharp.Core
-open Microsoft.FSharp.Core.Operators
-open Microsoft.FSharp.Collections
-open Microsoft.FSharp.Reflection
-open Microsoft.FSharp.Text.StructuredPrintfImpl
-open System.Globalization
-open System.IO
-open System.Text
-
-type PrintfFormat<'printer,'state,'residue,'result>(value:string) =
+type PrintfFormat<'Printer,'State,'Residue,'Result>(value:string) =
member x.Value = value
-type PrintfFormat<'printer,'state,'residue,'result,'tuple>(value:string) =
- inherit PrintfFormat<'printer,'state,'residue,'result>(value)
+type PrintfFormat<'Printer,'State,'Residue,'Result,'Tuple>(value:string) =
+ inherit PrintfFormat<'Printer,'State,'Residue,'Result>(value)
-type Format<'printer,'state,'residue,'result> = PrintfFormat<'printer,'state,'residue,'result>
-type Format<'printer,'state,'residue,'result,'tuple> = PrintfFormat<'printer,'state,'residue,'result,'tuple>
+type Format<'Printer,'State,'Residue,'Result> = PrintfFormat<'Printer,'State,'Residue,'Result>
+type Format<'Printer,'State,'Residue,'Result,'Tuple> = PrintfFormat<'Printer,'State,'Residue,'Result,'Tuple>
-module PrintfImpl =
+#if FX_RESHAPED_REFLECTION
- open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
- open Microsoft.FSharp.Reflection
+open Microsoft.FSharp.Core.PrimReflectionAdapters
+open Microsoft.FSharp.Core.ReflectionAdapters
+
+#endif
+
+module internal PrintfImpl =
+
+ /// Basic idea of implementation:
+ /// Every Printf.* family should returns curried function that collects arguments and then somehow prints them.
+ /// Idea - instead of building functions on fly argument by argument we instead introduce some predefined parts and then construct functions from these parts
+ /// Parts include:
+ /// Plain ones:
+ /// 1. Final pieces (1..5) - set of functions with arguments number 1..5.
+ /// Primary characteristic - these functions produce final result of the *printf* operation
+ /// 2. Chained pieces (1..5) - set of functions with arguments number 1..5.
+ /// Primary characteristic - these functions doesn not produce final result by itself, instead they tailed with some another piece (chained or final).
+ /// Plain parts correspond to simple format specifiers (that are projected to just one parameter of the function, say %d or %s). However we also have
+ /// format specifiers that can be projected to more than one argument (i.e %a, %t or any simple format specified with * width or precision).
+ /// For them we add special cases (both chained and final to denote that they can either return value themselves or continue with some other piece)
+ /// These primitives allow us to construct curried functions with arbitrary signatures.
+ /// For example:
+ /// - function that corresponds to %s%s%s%s%s (string -> string -> string -> string -> string -> T) will be represented by one piece final 5.
+ /// - function that has more that 5 arguments will include chained parts: %s%s%s%s%s%d%s => chained2 -> final 5
+ /// Primary benefits:
+ /// 1. creating specialized version of any part requires only one reflection call. This means that we can handle up to 5 simple format specifiers
+ /// with just one reflection call
+ /// 2. we can make combinable parts independent from particular printf implementation. Thus final result can be cached and shared.
+ /// i.e when first calll to printf "%s %s" will trigger creation of the specialization. Subsequent calls will pick existing specialization
+ open System
+ open System.IO
+ open System.Collections.Generic
open System.Reflection
+ open Microsoft.FSharp.Core
+ open Microsoft.FSharp.Core.Operators
+ open Microsoft.FSharp.Collections
+ open LanguagePrimitives.IntrinsicOperators
+
+ [<Flags>]
+ type FormatFlags =
+ | None = 0
+ | LeftJustify = 1
+ | PadWithZeros = 2
+ | PlusForPositives = 4
+ | SpaceForPositives = 8
+
+ let inline hasFlag flags (expected : FormatFlags) = (flags &&& expected) = expected
+ let inline isLeftJustify flags = hasFlag flags FormatFlags.LeftJustify
+ let inline isPadWithZeros flags = hasFlag flags FormatFlags.PadWithZeros
+ let inline isPlusForPositives flags = hasFlag flags FormatFlags.PlusForPositives
+ let inline isSpaceForPositives flags = hasFlag flags FormatFlags.SpaceForPositives
+
+ /// Used for width and precision to denote that user has specified '*' flag
+ [<Literal>]
+ let StarValue = -1
+ /// Used for width and precision to denote that corresponding value was omitted in format string
+ [<Literal>]
+ let NotSpecifiedValue = -2
+
+ [<System.Diagnostics.DebuggerDisplayAttribute("{ToString()}")>]
+ [<NoComparison; NoEquality>]
+ type FormatSpecifier =
+ {
+ TypeChar : char
+ Precision : int
+ Width : int
+ Flags : FormatFlags
+ }
+ member this.IsStarPrecision = this.Precision = StarValue
+ member this.IsPrecisionSpecified = this.Precision <> NotSpecifiedValue
+ member this.IsStarWidth = this.Width = StarValue
+ member this.IsWidthSpecified = this.Width <> NotSpecifiedValue
+
+ override this.ToString() =
+ let valueOf n = match n with StarValue -> "*" | NotSpecifiedValue -> "-" | n -> n.ToString()
+ System.String.Format
+ (
+ "'{0}', Precision={1}, Width={2}, Flags={3}",
+ this.TypeChar,
+ (valueOf this.Precision),
+ (valueOf this.Width),
+ this.Flags
+ )
+
+ /// Set of helpers to parse format string
+ module private FormatString =
+ let inline isDigit c = c >= '0' && c <= '9'
+ let intFromString (s : string) pos =
+ let rec go acc i =
+ if isDigit s.[i] then
+ let n = int s.[i] - int '0'
+ go (acc * 10 + n) (i + 1)
+ else acc, i
+ go 0 pos
+
+ let rec findNextFormatSpecifier (s : string) i =
+ if i >= s.Length then
+ s.Length
+ else
+ let c = s.[i]
+ if c = '%' then
+ if i + 1 < s.Length then
+ if s.[i + 1] = '%' then findNextFormatSpecifier s (i + 2)
+ else i
+ else
+ raise (ArgumentException("Missing format specifier"))
+ else findNextFormatSpecifier s (i + 1)
+
+ let parseFlags (s : string) i : FormatFlags * int =
+ let rec go flags i =
+ match s.[i] with
+ | '0' -> go (flags ||| FormatFlags.PadWithZeros) (i + 1)
+ | '+' -> go (flags ||| FormatFlags.PlusForPositives) (i + 1)
+ | ' ' -> go (flags ||| FormatFlags.SpaceForPositives) (i + 1)
+ | '-' -> go (flags ||| FormatFlags.LeftJustify) (i + 1)
+ | _ -> flags, i
+ go FormatFlags.None i
+
+ let parseWidth (s : string) i : int * int =
+ if s.[i] = '*' then StarValue, (i + 1)
+ elif isDigit (s.[i]) then intFromString s i
+ else NotSpecifiedValue, i
+
+ let parsePrecision (s : string) i : int * int =
+ if s.[i] = '.' then
+ if s.[i + 1] = '*' then StarValue, i + 2
+ elif isDigit (s.[i + 1]) then intFromString s (i + 1)
+ else raise (ArgumentException("invalid precision value"))
+ else NotSpecifiedValue, i
+
+ let parseTypeChar (s : string) i : char * int =
+ s.[i], (i + 1)
+
+ /// Abstracts generated printer from the details of particular environment: how to write text, how to produce results etc...
+ [<AbstractClass>]
+ type PrintfEnv<'State, 'Residue, 'Result> =
+ val State : 'State
+ new(s : 'State) = { State = s }
+ abstract Finalize : unit -> 'Result
+ abstract Write : string -> unit
+ abstract WriteT : 'Residue -> unit
+
+ type Utils =
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b) =
+ env.Write a
+ env.Write b
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c) =
+ Utils.Write(env, a, b)
+ env.Write c
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d) =
+ Utils.Write(env, a, b)
+ Utils.Write(env, c, d)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e) =
+ Utils.Write(env, a, b, c)
+ Utils.Write(env, d, e)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f) =
+ Utils.Write(env, a, b, c, d)
+ Utils.Write(env, e, f)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g) =
+ Utils.Write(env, a, b, c, d, e)
+ Utils.Write(env, f, g)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h) =
+ Utils.Write(env, a, b, c, d, e, f)
+ Utils.Write(env, g, h)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i) =
+ Utils.Write(env, a, b, c, d, e, f, g)
+ Utils.Write(env, h ,i)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j) =
+ Utils.Write(env, a, b, c, d, e, f, g, h)
+ Utils.Write(env, i, j)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k) =
+ Utils.Write(env, a, b, c, d, e, f, g, h, i)
+ Utils.Write(env, j, k)
+ static member inline Write (env : PrintfEnv<_, _, _>, a, b, c, d, e, f, g, h, i, j, k, l, m) =
+ Utils.Write(env, a, b, c, d, e, f, g, h, i, j, k)
+ Utils.Write(env, l, m)
+
+ /// Type of results produced by specialization
+ /// This is function that accepts thunk to create PrintfEnv on demand and returns concrete instance of Printer (curried function)
+ /// After all arguments is collected, specialization obtains concrete PrintfEnv from the thunk and use it to output collected data.
+ type PrintfFactory<'State, 'Residue, 'Result, 'Printer> = (unit -> PrintfEnv<'State, 'Residue, 'Result>) -> 'Printer
+
+ [<Literal>]
+ let MaxArgumentsInSpecialization = 5
+
+ /// Specializations are created via factory methods. These methods accepts 2 kinds of arguments
+ /// - parts of format string that corresponds to raw text
+ /// - functions that can transform collected values to strings
+ /// basic shape of the signature of specialization
+ /// <prefix-string> + <converter for arg1> + <suffix that comes after arg1> + ... <converter for arg-N> + <suffix that comes after arg-N>
+ type Specializations<'State, 'Residue, 'Result> private ()=
+
+ static member Final1<'A>
+ (
+ s0, conv1, s1
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) ->
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1)
+ env.Finalize()
+ )
+ )
+ static member Final2<'A, 'B>
+ (
+ s0, conv1, s1, conv2, s2
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) ->
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2)
+ env.Finalize()
+ )
+ )
+
+ static member Final3<'A, 'B, 'C>
+ (
+ s0, conv1, s1, conv2, s2, conv3, s3
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) ->
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3)
+ env.Finalize()
+ )
+ )
+
+ static member Final4<'A, 'B, 'C, 'D>
+ (
+ s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)->
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4)
+ env.Finalize()
+ )
+ )
+ static member Final5<'A, 'B, 'C, 'D, 'E>
+ (
+ s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5, s5
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)->
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e), s5)
+ env.Finalize()
+ )
+ )
+ static member Chained1<'A, 'Tail>
+ (
+ s0, conv1,
+ next
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) ->
+ let env() =
+ let env = env()
+ Utils.Write(env, s0, (conv1 a))
+ env
+ next env : 'Tail
+ )
+ )
+ static member Chained2<'A, 'B, 'Tail>
+ (
+ s0, conv1, s1, conv2,
+ next
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) ->
+ let env() =
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b))
+ env
+ next env : 'Tail
+ )
+ )
+
+ static member Chained3<'A, 'B, 'C, 'Tail>
+ (
+ s0, conv1, s1, conv2, s2, conv3,
+ next
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) ->
+ let env() =
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c))
+ env
+ next env : 'Tail
+ )
+ )
+
+ static member Chained4<'A, 'B, 'C, 'D, 'Tail>
+ (
+ s0, conv1, s1, conv2, s2, conv3, s3, conv4,
+ next
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D)->
+ let env() =
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d))
+ env
+ next env : 'Tail
+ )
+ )
+ static member Chained5<'A, 'B, 'C, 'D, 'E, 'Tail>
+ (
+ s0, conv1, s1, conv2, s2, conv3, s3, conv4, s4, conv5,
+ next
+ ) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (a : 'A) (b : 'B) (c : 'C) (d : 'D) (e : 'E)->
+ let env() =
+ let env = env()
+ Utils.Write(env, s0, (conv1 a), s1, (conv2 b), s2, (conv3 c), s3, (conv4 d), s4, (conv5 e))
+ env
+ next env : 'Tail
+ )
+ )
+
+ static member TFinal(s1 : string, s2 : string) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (f : 'State -> 'Residue) ->
+ let env = env()
+ env.Write(s1)
+ env.WriteT(f env.State)
+ env.Write s2
+ env.Finalize()
+ )
+ )
+ static member TChained<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (f : 'State -> 'Residue) ->
+ let env() =
+ let env = env()
+ env.Write(s1)
+ env.WriteT(f env.State)
+ env
+ next(env) : 'Tail
+ )
+ )
+
+ static member LittleAFinal<'A>(s1 : string, s2 : string) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (f : 'State -> 'A ->'Residue) (a : 'A) ->
+ let env = env()
+ env.Write s1
+ env.WriteT(f env.State a)
+ env.Write s2
+ env.Finalize()
+ )
+ )
+ static member LittleAChained<'A, 'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (f : 'State -> 'A ->'Residue) (a : 'A) ->
+ let env() =
+ let env = env()
+ env.Write s1
+ env.WriteT(f env.State a)
+ env
+ next env : 'Tail
+ )
+ )
+ static member StarFinal1<'A>(s1 : string, conv, s2 : string) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (star1 : int) (a : 'A) ->
+ let env = env()
+ env.Write s1
+ env.Write (conv a star1 : string)
+ env.Write s2
+ env.Finalize()
+ )
+ )
+ static member StarFinal2<'A>(s1 : string, conv, s2 : string) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (star1 : int) (star2 : int) (a : 'A) ->
+ let env = env()
+ env.Write s1
+ env.Write (conv a star1 star2: string)
+ env.Write s2
+ env.Finalize()
+ )
+ )
+
+ static member StarChained1<'A, 'Tail>(s1 : string, conv, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (star1 : int) (a : 'A) ->
+ let env() =
+ let env = env()
+ env.Write s1
+ env.Write(conv a star1 : string)
+ env
+ next env : 'Tail
+ )
+ )
+ static member StarChained2<'A, 'Tail>(s1 : string, conv, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) =
+ (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) ->
+ (fun (star1 : int) (star2 : int) (a : 'A) ->
+ let env() =
+ let env = env()
+ env.Write s1
+ env.Write(conv a star1 star2 : string)
+ env
+ next env : 'Tail
+ )
+ )
+
+ let inline (===) a b = Object.ReferenceEquals(a, b)
+ let invariantCulture = System.Globalization.CultureInfo.InvariantCulture
+
+ let inline boolToString v = if v then "true" else "false"
+ let inline stringToSafeString v = if v = null then "" else v
+
+ [<Literal>]
+ let DefaultPrecision = 6
+
+ let getFormatForFloat (ch : char) (prec : int) = ch.ToString() + prec.ToString()
+ let normalizePrecision prec = min (max prec 0) 99
+
+ /// Contains helpers to convert printer functions to functions that prints value with respect to specified justification
+ /// There are two kinds to printers:
+ /// 'T -> string - converts value to string - used for strings, basic integers etc..
+ /// string -> 'T -> string - converts value to string with given format string - used by numbers with floating point, typically precision is set via format string
+ /// To support both categories there are two entry points:
+ /// - withPadding - adapts first category
+ /// - withPaddingFormatted - adapts second category
+ module Padding =
+ /// pad here is function that converts T to string with respect of justification
+ /// basic - function that converts T to string without appying justification rules
+ /// adaptPaddedFormatted returns boxed function that has various number of arguments depending on if width\precision flags has '*' value
+ let inline adaptPaddedFormatted (spec : FormatSpecifier) getFormat (basic : string -> 'T -> string) (pad : string -> int -> 'T -> string) =
+ if spec.IsStarWidth then
+ if spec.IsStarPrecision then
+ // width=*, prec=*
+ box(fun v width prec ->
+ let fmt = getFormat (normalizePrecision prec)
+ pad fmt width v
+ )
+ else
+ // width=*, prec=?
+ let prec = if spec.IsPrecisionSpecified then normalizePrecision spec.Precision else DefaultPrecision
+ let fmt = getFormat prec
+ box(fun v width ->
+ pad fmt width v
+ )
+ elif spec.IsStarPrecision then
+ if spec.IsWidthSpecified then
+ // width=val, prec=*
+ box(fun v prec ->
+ let fmt = getFormat prec
+ pad fmt spec.Width v
+ )
+ else
+ // width=X, prec=*
+ box(fun v prec ->
+ let fmt = getFormat prec
+ basic fmt v
+ )
+ else
+ let prec = if spec.IsPrecisionSpecified then normalizePrecision spec.Precision else DefaultPrecision
+ let fmt = getFormat prec
+ if spec.IsWidthSpecified then
+ // width=val, prec=*
+ box(fun v ->
+ pad fmt spec.Width v
+ )
+ else
+ // width=X, prec=*
+ box(fun v ->
+ basic fmt v
+ )
+
+ /// pad here is function that converts T to string with respect of justification
+ /// basic - function that converts T to string without appying justification rules
+ /// adaptPadded returns boxed function that has various number of arguments depending on if width flags has '*' value
+ let inline adaptPadded (spec : FormatSpecifier) (basic : 'T -> string) (pad : int -> 'T -> string) =
+ if spec.IsStarWidth then
+ // width=*, prec=?
+ box(fun v width ->
+ pad width v
+ )
+ else
+ if spec.IsWidthSpecified then
+ // width=val, prec=*
+ box(fun v ->
+ pad spec.Width v
+ )
+ else
+ // width=X, prec=*
+ box(fun v ->
+ basic v
+ )
+
+ let inline withPaddingFormatted (spec : FormatSpecifier) getFormat (defaultFormat : string) (f : string -> 'T -> string) left right =
+ if not (spec.IsWidthSpecified || spec.IsPrecisionSpecified) then
+ box (f defaultFormat)
+ else
+ if isLeftJustify spec.Flags then
+ adaptPaddedFormatted spec getFormat f left
+ else
+ adaptPaddedFormatted spec getFormat f right
+
+ let inline withPadding (spec : FormatSpecifier) (f : 'T -> string) left right =
+ if not (spec.IsWidthSpecified) then
+ box f
+ else
+ if isLeftJustify spec.Flags then
+ adaptPadded spec f left
+ else
+ adaptPadded spec f right
- type buf = System.Text.StringBuilder
-
- let stringOfChar (c:char) = System.Char.ToString(c)
- let stringOfInt (i:int) = i.ToString()
-
- [<NoEquality; NoComparison>]
- type PrintfInfo =
- { mutable leftJustify : bool;
- mutable numPrefixIfPos : char option;
- mutable addZeros : bool; }
-
- let outputSignAndLeftSpace(outputChar,info,pos,width,numDigits) =
- let used =
- if pos then
- match info.numPrefixIfPos with
- | None -> 0
- | Some _ -> 1
- else 1
- let len = numDigits + used
- if not info.leftJustify && not info.addZeros then
- match width with
- | None -> ()
- | Some w ->
- for i = 1 to (w - len) do
- outputChar ' ';
- begin
- if pos then
- match info.numPrefixIfPos with
- | None -> ()
- | Some c -> outputChar c
- else outputChar '-';
- end;
- if not info.leftJustify && info.addZeros then
- match width with
- | None -> ()
- | Some w ->
- for i = 1 to (w - len) do
- outputChar (if info.addZeros then '0' else ' ');
- used
-
- let decode (c:char) = System.Convert.ToInt32(c)
- let encode (x:int) = System.Convert.ToChar(x)
-
- let outputDigit(outputChar,intFormatChar,digit) =
- let digitc =
- if digit < 10
- then decode '0' + digit
- else decode (if intFormatChar = 'x' then 'a' else 'A') + (digit - 10)
- outputChar (encode digitc)
-
- let outputSpace(outputChar,width,len) =
- match width with
- | None -> ()
- | Some width ->
- for i = 1 to (width - len) do
- outputChar ' ';
-
- let outputZeros(outputChar,width,len) =
- match width with
- | None -> ()
- | Some width ->
- for i = 1 to (width - len) do
- outputChar '0'
-
- let outputRightSpace(outputChar,leftJustify,width,len) =
- if leftJustify then outputSpace(outputChar,width,len)
-
- let outputUInt64(outputChar,intFormatChar,width,info,(n:uint64)) =
- let nbase = match intFormatChar with 'o' -> 8uL | 'x' | 'X' -> 16uL | _ -> 10uL
- let numDigits =
- let mutable numDigits = 1
- let mutable nval = n / nbase
- while nval > 0UL do
- numDigits <- numDigits + 1;
- nval <- nval / nbase;
- numDigits
- let topdiv =
- let mutable topdiv = 1UL
- for i = 1 to numDigits - 1 do
- topdiv <- topdiv * nbase;
- topdiv
-
- let len = numDigits + (outputSignAndLeftSpace(outputChar,info,true,width,numDigits))
+ let inline isNumber (x: ^T) =
+ not (^T: (static member IsPositiveInfinity: 'T -> bool) x) && not (^T: (static member IsNegativeInfinity: 'T -> bool) x) && not (^T: (static member IsNaN: 'T -> bool) x)
+
+ let inline isInteger n =
+ n % LanguagePrimitives.GenericOne = LanguagePrimitives.GenericZero
+
+ let inline isPositive n =
+ n >= LanguagePrimitives.GenericZero
+
+ /// contains functions to handle left\right justifications for non-numeric types (strings\bools)
+ module Basic =
+ let inline leftJustify f padChar =
+ fun (w : int) v ->
+ (f v : string).PadRight(w, padChar)
+
+ let inline rightJustify f padChar =
+ fun (w : int) v ->
+ (f v : string).PadLeft(w, padChar)
+
+
+ /// contains functions to handle left\right and no justification case for numbers
+ module GenericNumber =
+ /// handles right justification when pad char = '0'
+ /// this case can be tricky:
+ /// - negative numbers, -7 should be printed as '-007', not '00-7'
+ /// - positive numbers when prefix for positives is set: 7 should be '+007', not '00+7'
+ let inline rightJustifyWithZeroAsPadChar (str : string) isNumber isPositive w (prefixForPositives : string) =
+ System.Diagnostics.Debug.Assert(prefixForPositives.Length = 0 || prefixForPositives.Length = 1)
+ if isNumber then
+ if isPositive then
+ prefixForPositives + (if w = 0 then str else str.PadLeft(w - prefixForPositives.Length, '0')) // save space to
+ else
+ if str.[0] = '-' then
+ let str = str.Substring(1)
+ "-" + (if w = 0 then str else str.PadLeft(w - 1, '0'))
+ else
+ str.PadLeft(w, '0')
+ else
+ str.PadLeft(w, ' ')
+
+ /// handler right justification when pad char = ' '
+ let inline rightJustifyWithSpaceAsPadChar (str : string) isNumber isPositive w (prefixForPositives : string) =
+ System.Diagnostics.Debug.Assert(prefixForPositives.Length = 0 || prefixForPositives.Length = 1)
+ (if isNumber && isPositive then prefixForPositives + str else str).PadLeft(w, ' ')
- let mutable residue = n
- let mutable divisor = topdiv
- while divisor > 0UL do
- let digit = residue / divisor
- outputDigit(outputChar,intFormatChar, int32(int64 digit));
- residue <- residue % divisor;
- divisor <- divisor / nbase;
- outputRightSpace(outputChar,info.leftJustify,width,len)
-
- let outputInt64(outputChar,intFormatChar,width,info,(n:int64)) =
- let nbase = match intFormatChar with 'o' -> 8L | 'x' | 'X' -> 16L | _ -> 10L
- let numDigits =
- let mutable numDigits = 1
- let mutable nval = if n >= 0L then n / nbase else - (n / nbase)
- while nval > 0L do
- numDigits <- numDigits + 1;
- nval <- nval / nbase;
- numDigits
- let topdiv =
- let mutable topdiv = 1L
- for i = 1 to numDigits - 1 do
- topdiv <- topdiv * nbase;
- topdiv
+ /// handles left justification with formatting with 'G'\'g' - either for decimals or with 'g'\'G' is explicitly set
+ let inline leftJustifyWithGFormat (str : string) isNumber isInteger isPositive w (prefixForPositives : string) padChar =
+ if isNumber then
+ let str = if isPositive then prefixForPositives + str else str
+ // NOTE: difference - for 'g' format we use isInt check to detect situations when '5.0' is printed as '5'
+ // in this case we need to override padding and always use ' ', otherwise we'll produce incorrect results
+ if isInteger then
+ str.PadRight(w, ' ') // don't pad integer numbers with '0' when 'g' format is specified (may yield incorrect results)
+ else
+ str.PadRight(w, padChar) // non-integer => string representation has point => can pad with any character
+ else
+ str.PadRight(w, ' ') // pad NaNs with ' '
+
+ let inline leftJustifyWithNonGFormat (str : string) isNumber isPositive w (prefixForPositives : string) padChar =
+ if isNumber then
+ let str = if isPositive then prefixForPositives + str else str
+ str.PadRight(w, padChar)
+ else
+ str.PadRight(w, ' ') // pad NaNs with ' '
- let len = numDigits + (outputSignAndLeftSpace(outputChar,info,(n >= 0L),width,numDigits) )
+ /// processes given string based depending on values isNumber\isPositive
+ let inline noJustificationCore (str : string) isNumber isPositive prefixForPositives =
+ if isNumber && isPositive then prefixForPositives + str
+ else str
- let mutable residue =
- if n = System.Int64.MinValue then System.Int64.MaxValue
- elif n < 0L then - n
- else n
- let mutable divisor = topdiv
- while divisor > 0L do
- let digit =
- if n = System.Int64.MinValue && divisor = 1L
- then (match intFormatChar with 'd' | 'i' -> 8L | _ -> 100L) // nb. special case for min_int
- else residue / divisor
- outputDigit(outputChar,intFormatChar,int32 digit);
- residue <- residue % divisor;
- divisor <- divisor / nbase;
- outputRightSpace(outputChar,info.leftJustify,width,len)
-
- // The general technique used this file is to interpret
- // a format string and use reflection to construct a function value that matches
- // the specification of the format string.
- //
- // Generics add some serious complications here - we have to generate
- // a function value of exactly the right runtime type, though the most
- // natural scheme is to produce one of type 'obj -> obj'. We get around
- // this by using a semi-reflective approach to creating and invoking
- // function values of the right type. This comes with some
- // overheads (though they are not too bad) and thus could and should be
- // optimized in some special cases, e.g. where a format string
- // just contains a single simple format specifier such as '%x'
-#if FX_ATLEAST_PORTABLE
- let staticInvokeFlags = BindingFlags.Public ||| BindingFlags.Static
-#else
- let staticInvokeFlags = BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Static
-#endif
- let mkFunctionValue (tys: System.Type[]) (impl:obj->obj) =
- FSharpValue.MakeFunction(FSharpType.MakeFunctionType(tys.[0],tys.[1]), impl)
-
- let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition()
- let mkFunTy a b = funTyC.MakeGenericType([| a;b |])
-
- let isNamedType(ty:System.Type) = not (ty.IsArray || ty.IsByRef || ty.IsPointer)
- let isFunctionType (ty1:System.Type) =
- isNamedType(ty1) && ty1.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(funTyC)
-
- let rec destFunTy (ty:System.Type) =
- if isFunctionType ty then
- ty, ty.GetGenericArguments()
- else
- match ty.BaseType with
- | null -> raise <| System.InvalidOperationException(SR.GetString(SR.printfNotAFunType))
- | b -> destFunTy b
-#if FX_ATLEAST_PORTABLE
- let instanceInvokeFlags = BindingFlags.Public ||| BindingFlags.Instance
-#else
- let instanceInvokeFlags = BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Instance
-#endif
- let invokeFunctionValue (f:obj) (x:obj) =
- let fTy,_ = destFunTy (f.GetType())
-#if FX_ATLEAST_PORTABLE
- let meth = fTy.GetMethod("Invoke",instanceInvokeFlags)
- meth.Invoke(f,[| x |])
-#else
-#if FX_NO_CULTURE_INFO_ARGS
- fTy.InvokeMember("Invoke",instanceInvokeFlags,(null:Binder),f,[| x |])
+ /// noJustification handler for f : 'T -> string - basic integer types
+ let inline noJustification f (prefix : string) isUnsigned =
+ if isUnsigned then
+ fun v -> noJustificationCore (f v) true true prefix
+ else
+ fun v -> noJustificationCore (f v) true (isPositive v) prefix
+
+ /// noJustification handler for f : string -> 'T -> string - floating point types
+ let inline noJustificationWithFormat f (prefix : string) =
+ fun (fmt : string) v -> noJustificationCore (f fmt v) true (isPositive v) prefix
+
+ /// leftJustify handler for f : 'T -> string - basic integer types
+ let inline leftJustify isGFormat f (prefix : string) padChar isUnsigned =
+ if isUnsigned then
+ if isGFormat then
+ fun (w : int) v ->
+ leftJustifyWithGFormat (f v) true (isInteger v) true w prefix padChar
+ else
+ fun (w : int) v ->
+ leftJustifyWithNonGFormat (f v) true true w prefix padChar
+ else
+ if isGFormat then
+ fun (w : int) v ->
+ leftJustifyWithGFormat (f v) true (isInteger v) (isPositive v) w prefix padChar
+ else
+ fun (w : int) v ->
+ leftJustifyWithNonGFormat (f v) true (isPositive v) w prefix padChar
+
+ /// leftJustify handler for f : string -> 'T -> string - floating point types
+ let inline leftJustifyWithFormat isGFormat f (prefix : string) padChar =
+ if isGFormat then
+ fun (fmt : string) (w : int) v ->
+ leftJustifyWithGFormat (f fmt v) true (isInteger v) (isPositive v) w prefix padChar
+ else
+ fun (fmt : string) (w : int) v ->
+ leftJustifyWithNonGFormat (f fmt v) true (isPositive v) w prefix padChar
+
+ /// rightJustify handler for f : 'T -> string - basic integer types
+ let inline rightJustify f (prefixForPositives : string) padChar isUnsigned =
+ if isUnsigned then
+ if padChar = '0' then
+ fun (w : int) v ->
+ rightJustifyWithZeroAsPadChar (f v) true true w prefixForPositives
+ else
+ System.Diagnostics.Debug.Assert((padChar = ' '))
+ fun (w : int) v ->
+ rightJustifyWithSpaceAsPadChar (f v) true true w prefixForPositives
+ else
+ if padChar = '0' then
+ fun (w : int) v ->
+ rightJustifyWithZeroAsPadChar (f v) true (isPositive v) w prefixForPositives
+
+ else
+ System.Diagnostics.Debug.Assert((padChar = ' '))
+ fun (w : int) v ->
+ rightJustifyWithSpaceAsPadChar (f v) true (isPositive v) w prefixForPositives
+
+ /// rightJustify handler for f : string -> 'T -> string - floating point types
+ let inline rightJustifyWithFormat f (prefixForPositives : string) padChar =
+ if padChar = '0' then
+ fun (fmt : string) (w : int) v ->
+ rightJustifyWithZeroAsPadChar (f fmt v) true (isPositive v) w prefixForPositives
+
+ else
+ System.Diagnostics.Debug.Assert((padChar = ' '))
+ fun (fmt : string) (w : int) v ->
+ rightJustifyWithSpaceAsPadChar (f fmt v) true (isPositive v) w prefixForPositives
+ module Float =
+ let inline noJustification f (prefixForPositives : string) =
+ fun (fmt : string) v ->
+ GenericNumber.noJustificationCore (f fmt v) (isNumber v) (isPositive v) prefixForPositives
+
+ let inline leftJustify isGFormat f (prefix : string) padChar =
+ if isGFormat then
+ fun (fmt : string) (w : int) v ->
+ GenericNumber.leftJustifyWithGFormat (f fmt v) (isNumber v) (isInteger v) (isPositive v) w prefix padChar
+ else
+ fun (fmt : string) (w : int) v ->
+ GenericNumber.leftJustifyWithNonGFormat (f fmt v) (isNumber v) (isPositive v) w prefix padChar
+
+ let inline rightJustify f (prefixForPositives : string) padChar =
+ if padChar = '0' then
+ fun (fmt : string) (w : int) v ->
+ GenericNumber.rightJustifyWithZeroAsPadChar (f fmt v) (isNumber v) (isPositive v) w prefixForPositives
+ else
+ System.Diagnostics.Debug.Assert((padChar = ' '))
+ fun (fmt : string) (w : int) v ->
+ GenericNumber.rightJustifyWithSpaceAsPadChar (f fmt v) (isNumber v) (isPositive v) w prefixForPositives
+
+ let isDecimalFormatSpecifier (spec : FormatSpecifier) =
+ spec.TypeChar = 'M'
+
+ let getPadAndPrefix allowZeroPadding (spec : FormatSpecifier) =
+ let padChar = if allowZeroPadding && isPadWithZeros spec.Flags then '0' else ' ';
+ let prefix =
+ if isPlusForPositives spec.Flags then "+"
+ elif isSpaceForPositives spec.Flags then " "
+ else ""
+ padChar, prefix
+
+ let isGFormat(spec : FormatSpecifier) =
+ isDecimalFormatSpecifier spec || System.Char.ToLower(spec.TypeChar) = 'g'
+
+ let inline basicWithPadding (spec : FormatSpecifier) f =
+ let padChar, _ = getPadAndPrefix false spec
+ Padding.withPadding spec f (Basic.leftJustify f padChar) (Basic.rightJustify f padChar)
+
+ let inline numWithPadding (spec : FormatSpecifier) isUnsigned f =
+ let allowZeroPadding = not (isLeftJustify spec.Flags) || isDecimalFormatSpecifier spec
+ let padChar, prefix = getPadAndPrefix allowZeroPadding spec
+ let isGFormat = isGFormat spec
+ Padding.withPadding spec (GenericNumber.noJustification f prefix isUnsigned) (GenericNumber.leftJustify isGFormat f prefix padChar isUnsigned) (GenericNumber.rightJustify f prefix padChar isUnsigned)
+
+ let inline decimalWithPadding (spec : FormatSpecifier) getFormat defaultFormat f =
+ let padChar, prefix = getPadAndPrefix true spec
+ let isGFormat = isGFormat spec
+ Padding.withPaddingFormatted spec getFormat defaultFormat (GenericNumber.noJustificationWithFormat f prefix) (GenericNumber.leftJustifyWithFormat isGFormat f prefix padChar) (GenericNumber.rightJustifyWithFormat f prefix padChar)
+
+ let inline floatWithPadding (spec : FormatSpecifier) getFormat defaultFormat f =
+ let padChar, prefix = getPadAndPrefix true spec
+ let isGFormat = isGFormat spec
+ Padding.withPaddingFormatted spec getFormat defaultFormat (Float.noJustification f prefix) (Float.leftJustify isGFormat f prefix padChar) (Float.rightJustify f prefix padChar)
+
+ let inline identity v = v
+ let inline toString v = (^T : (member ToString : IFormatProvider -> string)(v, invariantCulture))
+ let inline toFormattedString fmt = fun (v : ^T) -> (^T : (member ToString : string * IFormatProvider -> string)(v, fmt, invariantCulture))
+
+ let inline numberToString c spec alt unsignedConv =
+ if c = 'd' || c = 'i' then
+ numWithPadding spec false (alt >> toString : ^T -> string)
+ elif c = 'u' then
+ numWithPadding spec true (alt >> unsignedConv >> toString : ^T -> string)
+ elif c = 'x' then
+ numWithPadding spec true (alt >> toFormattedString "x" : ^T -> string)
+ elif c = 'X' then
+ numWithPadding spec true (alt >> toFormattedString "X" : ^T -> string )
+ elif c = 'o' then
+ numWithPadding spec true (fun (v : ^T) -> Convert.ToString(int64(unsignedConv (alt v)), 8))
+ else raise (ArgumentException())
+
+ type ObjectPrinter =
+ static member ObjectToString<'T>(spec : FormatSpecifier) =
+ basicWithPadding spec (fun (v : 'T) -> match box v with null -> "<null>" | x -> x.ToString())
+
+ static member GenericToStringCore(v : 'T, opts : Microsoft.FSharp.Text.StructuredPrintfImpl.FormatOptions, bindingFlags) =
+ // printfn %0A is considered to mean 'print width zero'
+ match box v with
+ | null -> "<null>"
+ | _ -> Microsoft.FSharp.Text.StructuredPrintfImpl.Display.anyToStringForPrintf opts bindingFlags v
+
+ static member GenericToString<'T>(spec : FormatSpecifier) =
+ let bindingFlags =
+#if FX_RESHAPED_REFLECTION
+ isPlusForPositives spec.Flags // true - show non-public
#else
- fTy.InvokeMember("Invoke",instanceInvokeFlags,(null:Binder),f,[| x |],CultureInfo.InvariantCulture(*FxCop:1304*))
+ if isPlusForPositives spec.Flags then BindingFlags.Public ||| BindingFlags.NonPublic
+ else BindingFlags.Public
#endif
-#endif
-
- let buildFunctionForOneArgPat (ty: System.Type) impl =
- let _,tys = destFunTy ty
- let rty = tys.[1]
- // PERF: this technique is a bit slow (e.g. in simple cases, like 'sprintf "%x"')
- mkFunctionValue tys (fun inp -> impl rty inp)
-
- let buildFunctionForTwoArgPat args ty i go =
- let _,tys1 = destFunTy ty
- let rty1 = tys1.[1]
- let _,tys2 = destFunTy rty1
- let rty2 = tys2.[1]
- mkFunctionValue tys1 (fun inpf ->
- mkFunctionValue tys2 (fun inpx ->
- go (inpx::inpf::args) rty2 (i+1)))
-
- let buildFunctionForOneFunArgPat args ty i go =
- let _,tys1 = destFunTy ty
- let rty1 = tys1.[1]
- mkFunctionValue tys1 (fun inpf -> go (inpf::args) rty1 (i+1))
-
- let isDigit c = ('0' <= c && c <= '9')
- let rec parseFlags info (fmt:string) i =
- if i >= fmt.Length then raise <| System.ArgumentException (SR.GetString(SR.printfMissingFormatSpecifier));
- match fmt.[i] with
- | '-' -> info.leftJustify <- true; parseFlags info fmt (i+1)
- | '+' -> info.numPrefixIfPos <- Some '+'; parseFlags info fmt (i+1)
- | '0' -> info.addZeros <- true; parseFlags info fmt (i+1)
- | ' ' -> info.numPrefixIfPos <- Some ' '; parseFlags info fmt (i+1)
- | '#' -> raise <| System.ArgumentException (SR.GetString(SR.printfHashFormatSpecifierIllegal));
- | _ -> i
-
- let rec parseDigitsPrecision (fmt:string) len i =
- if i >= len then raise <| System.ArgumentException (SR.GetString(SR.printfPrecisonSpecifierIllegal));
- match fmt.[i] with
- | c when isDigit c -> parseDigitsPrecision fmt len (i+1)
- | _ -> i
-
- let parsePrecision (fmt:string) len i =
- if i >= len then raise <| System.ArgumentException (SR.GetString(SR.printfPrecisonSpecifierIllegal));
- match fmt.[i] with
- | c when isDigit c -> false,parseDigitsPrecision fmt len (i+1)
- | '*' -> true,(i+1)
- | _ -> false,i
-
- let rec parseSliceDotAndPrecision (fmt:string) len i =
- match fmt.[i] with
- | '.' ->
- let w1 = i
- let precisionArg,i = parsePrecision fmt len (i+1)
- w1,Some (precisionArg,i),i
- | _ -> i,None,i
-
- let rec parseSliceWidthAndPrecision (fmt:string) len i =
- if i >= len then raise <| System.ArgumentException (SR.GetString(SR.printfWidthSpecifierIllegal));
- match fmt.[i] with
- | c when isDigit c -> parseSliceWidthAndPrecision fmt len (i+1)
- | '*' -> true,parseSliceDotAndPrecision fmt len (i+1)
- | _ -> false,parseSliceDotAndPrecision fmt len i
- let invariantCulture = System.Globalization.CultureInfo.InvariantCulture
- let parseWidthAndPrecision fmt len i =
- let w0 = i
- let widthArg,(w1,w2,i) = parseSliceWidthAndPrecision fmt len i
- let width =
- if (w0 = w1) then None
- elif widthArg then Some(None)
- else Some (Some(System.Int32.Parse (fmt.[w0..w1-1],invariantCulture)) )
- let precision =
- match w2 with
- | None -> None
- | Some (precisionArg,w2') ->
- if precisionArg then Some(None)
- else Some (Some(System.Int32.Parse (fmt.[w1+1..w2'-1],invariantCulture)) )
- width,precision,i
-
- let newInfo ()=
- { leftJustify = false;
- numPrefixIfPos = None;
- addZeros = false; }
-
- let defaultInfo = newInfo()
-
- let formatString outputChar info width (s:string) isNum =
- match s with
- | null -> outputSpace(outputChar,width,0)
+ let useZeroWidth = isPadWithZeros spec.Flags
+ let opts =
+ let o = Microsoft.FSharp.Text.StructuredPrintfImpl.FormatOptions.Default
+ let o =
+ if useZeroWidth then { o with PrintWidth = 0}
+ elif spec.IsWidthSpecified then { o with PrintWidth = spec.Width}
+ else o
+ if spec.IsPrecisionSpecified then { o with PrintSize = spec.Precision}
+ else o
+ match spec.IsStarWidth, spec.IsStarPrecision with
+ | true, true ->
+ box (fun (v : 'T) (width : int) (prec : int) ->
+ let opts = { opts with PrintSize = prec }
+ let opts = if not useZeroWidth then { opts with PrintWidth = width} else opts
+ ObjectPrinter.GenericToStringCore(v, opts, bindingFlags)
+ )
+ | true, false ->
+ box (fun (v : 'T) (width : int) ->
+ let opts = if not useZeroWidth then { opts with PrintWidth = width} else opts
+ ObjectPrinter.GenericToStringCore(v, opts, bindingFlags)
+ )
+ | false, true ->
+ box (fun (v : 'T) (prec : int) ->
+ let opts = { opts with PrintSize = prec }
+ ObjectPrinter.GenericToStringCore(v, opts, bindingFlags)
+ )
+ | false, false ->
+ box (fun (v : 'T) ->
+ ObjectPrinter.GenericToStringCore(v, opts, bindingFlags)
+ )
+
+ let basicNumberToString (ty : Type) (spec : FormatSpecifier) =
+ System.Diagnostics.Debug.Assert(not spec.IsPrecisionSpecified, "not spec.IsPrecisionSpecified")
+
+ let ch = spec.TypeChar
+
+ match Type.GetTypeCode(ty) with
+ | TypeCode.Int32 -> numberToString ch spec identity (uint32 : int -> uint32)
+ | TypeCode.Int64 -> numberToString ch spec identity (uint64 : int64 -> uint64)
+ | TypeCode.Byte -> numberToString ch spec identity (byte : byte -> byte)
+ | TypeCode.SByte -> numberToString ch spec identity (byte : sbyte -> byte)
+ | TypeCode.Int16 -> numberToString ch spec identity (uint16 : int16 -> uint16)
+ | TypeCode.UInt16 -> numberToString ch spec identity (uint16 : uint16 -> uint16)
+ | TypeCode.UInt32 -> numberToString ch spec identity (uint32 : uint32 -> uint32)
+ | TypeCode.UInt64 -> numberToString ch spec identity (uint64 : uint64 -> uint64)
+ | _ ->
+ if ty === typeof<nativeint> then
+ if IntPtr.Size = 4 then
+ numberToString ch spec (fun (v : IntPtr) -> v.ToInt32()) uint32
+ else
+ numberToString ch spec (fun (v : IntPtr) -> v.ToInt64()) uint64
+ elif ty === typeof<unativeint> then
+ if IntPtr.Size = 4 then
+ numberToString ch spec (fun (v : UIntPtr) -> v.ToUInt32()) uint32
+ else
+ numberToString ch spec (fun (v : UIntPtr) -> v.ToUInt64()) uint64
+
+ else raise (ArgumentException(ty.Name + " not a basic integer type"))
+
+ let basicFloatToString ty spec =
+ let defaultFormat = getFormatForFloat spec.TypeChar DefaultPrecision
+ match Type.GetTypeCode(ty) with
+ | TypeCode.Single -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : float32) -> toFormattedString fmt v)
+ | TypeCode.Double -> floatWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : float) -> toFormattedString fmt v)
+ | TypeCode.Decimal -> decimalWithPadding spec (getFormatForFloat spec.TypeChar) defaultFormat (fun fmt (v : decimal) -> toFormattedString fmt v)
+ | _ -> raise (ArgumentException(ty.Name + " not a basic floating point type"))
+
+ let private NonPublicStatics = BindingFlags.NonPublic ||| BindingFlags.Static
+
+ let private getValueConverter (ty : Type) (spec : FormatSpecifier) : obj =
+ match spec.TypeChar with
+ | 'b' ->
+ System.Diagnostics.Debug.Assert(ty === typeof<bool>, "ty === typeof<bool>")
+ basicWithPadding spec boolToString
+ | 's' ->
+ System.Diagnostics.Debug.Assert(ty === typeof<string>, "ty === typeof<string>")
+ basicWithPadding spec stringToSafeString
+ | 'c' ->
+ System.Diagnostics.Debug.Assert(ty === typeof<char>, "ty === typeof<char>")
+ basicWithPadding spec (fun (c : char) -> c.ToString())
+ | 'M' ->
+ System.Diagnostics.Debug.Assert(ty === typeof<decimal>, "ty === typeof<decimal>")
+ decimalWithPadding spec (fun _ -> "G") "G" (fun fmt (v : decimal) -> toFormattedString fmt v) // %M ignores precision
+ | 'd' | 'i' | 'x' | 'X' | 'u' | 'o'->
+ basicNumberToString ty spec
+ | 'e' | 'E'
+ | 'f' | 'F'
+ | 'g' | 'G' ->
+ basicFloatToString ty spec
+ | 'A' ->
+ let mi = typeof<ObjectPrinter>.GetMethod("GenericToString", NonPublicStatics)
+ let mi = mi.MakeGenericMethod(ty)
+ mi.Invoke(null, [| box spec |])
+ | 'O' ->
+ let mi = typeof<ObjectPrinter>.GetMethod("ObjectToString", NonPublicStatics)
+ let mi = mi.MakeGenericMethod(ty)
+ mi.Invoke(null, [| box spec |])
| _ ->
- if not info.leftJustify then
- if isNum && info.addZeros then outputZeros(outputChar,width,s.Length)
- else outputSpace(outputChar,width,s.Length);
- s |> String.iter outputChar;
- if info.leftJustify then
- if isNum && info.addZeros then outputZeros(outputChar,width,s.Length)
- else outputSpace(outputChar,width,s.Length)
-
- let capture1 (fmt:string) i args ty (go : obj list -> System.Type -> int -> obj) : obj =
- let info = newInfo()
- let len = fmt.Length
- let i = parseFlags info fmt i
- let width,precision,i = parseWidthAndPrecision fmt len i
- let intFormatChar = fmt.[i]
-
- let captureCoreArgs args ty =
- match intFormatChar with
- | '%' -> go args ty (i+1)
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'l' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
- | 'n' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
- | 'L' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
-
- | 'U' ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'l' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
- | 'n' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
- | 'L' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+2))
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "U"))
-
- | 'f' | 'F' | 'e' | 'E' | 'g' | 'G' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'M' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 's' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'c' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'b' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
- | 'O' -> buildFunctionForOneArgPat ty (fun rty xobj -> go (xobj::args) rty (i+1))
- | 'A' -> buildFunctionForOneArgPat ty (fun rty xobj -> go (xobj::args) rty (i+1))
- | 'a' -> buildFunctionForTwoArgPat args ty i go
- | 't' -> buildFunctionForOneFunArgPat args ty i go
- | _ -> raise <| System.ArgumentException(SR.GetString1(SR.printfBadFormatSpecifier,intFormatChar.ToString()))
- let capturePrecisionArg args ty =
- match precision with
- | None | Some(Some _) -> captureCoreArgs args ty
- | Some(None) -> buildFunctionForOneArgPat ty (fun rty n -> captureCoreArgs (n :: args) rty)
- let captureWidthArg args ty =
- match width with
- | None | Some(Some _) -> capturePrecisionArg args ty
- | Some(None) -> buildFunctionForOneArgPat ty (fun rty n -> capturePrecisionArg (n :: args) rty)
- captureWidthArg args ty
+ raise (ArgumentException(SR.GetString(SR.printfBadFormatSpecifier)))
+
+ let extractCurriedArguments (ty : Type) n =
+ System.Diagnostics.Debug.Assert(n = 1 || n = 2 || n = 3, "n = 1 || n = 2 || n = 3")
+ let buf = Array.zeroCreate (n + 1)
+ let rec go (ty : Type) i =
+ if i < n then
+ match ty.GetGenericArguments() with
+ | [| argTy; retTy|] ->
+ buf.[i] <- argTy
+ go retTy (i + 1)
+ | _ -> failwith (String.Format("Expected function with {0} arguments", n))
+ else
+ System.Diagnostics.Debug.Assert((i = n), "i = n")
+ buf.[i] <- ty
+ buf
+ go ty 0
+
+ [<Literal>]
+ let ContinuationOnStack = -1
+
+ type private PrintfBuilderStack() =
+ let args = Stack(10)
+ let types = Stack(5)
+
+ let stackToArray size start count (s : Stack<_>) =
+ let arr = Array.zeroCreate size
+ for i = 0 to count - 1 do
+ arr.[start + i] <- s.Pop()
+ arr
+ member this.GetArgumentAndTypesAsArrays
+ (
+ argsArraySize, argsArrayStartPos, argsArrayTotalCount,
+ typesArraySize, typesArrayStartPos, typesArrayTotalCount
+ ) =
+ let argsArray = stackToArray argsArraySize argsArrayStartPos argsArrayTotalCount args
+ let typesArray = stackToArray typesArraySize typesArrayStartPos typesArrayTotalCount types
+ argsArray, typesArray
+
+ member this.PopContinuationWithType() =
+ System.Diagnostics.Debug.Assert(args.Count = 1, "args.Count = 1")
+ System.Diagnostics.Debug.Assert(types.Count = 1, "types.Count = 1")
+
+ let cont = args.Pop()
+ let contTy = types.Pop()
- let unboxAsInt64 (n:obj) =
- match n with
- | :? sbyte as x -> x |> int64
- | :? int16 as x -> x |> int64
- | :? int32 as x -> x |> int64
- | :? nativeint as x -> x |> int64
- | :? int64 as x -> x
- | :? byte as x -> x |> uint64 |> int64
- | :? uint16 as x -> x |> uint64 |> int64
- | :? uint32 as x -> x |> uint64 |> int64
- | :? uint64 as x -> x |> int64
- | :? unativeint as x -> x |> uint64 |> int64
- | _ -> raise <| System.ArgumentException (SR.GetString(SR.printfBadIntegerForDynamicFomatter))
-
- let unboxAsUInt64 (n:obj) =
- let unsigned =
- match n with
- | :? sbyte as x -> x |> byte |> box
- | :? int16 as x -> x |> uint16 |> box
- | :? int32 as x -> x |> uint32 |> box
- | :? int64 as x -> x |> uint64 |> box
- | :? nativeint as x -> x |> unativeint |> box
- | _ -> n
- unboxAsInt64 unsigned |> uint64
-
- let formatOne (outa: 'c -> unit) (outputChar: char -> unit) (os : 'b) (fmt:string) i args : (int * obj list) =
- let info = newInfo()
- let len = fmt.Length
- let i = parseFlags info fmt i
- let width,precision,i = parseWidthAndPrecision fmt len i
- let intFormatChar = fmt.[i]
-
- let width,args =
- match width,args with
- | None,args -> None,args
- | Some(Some w),args -> Some w,args
- | Some(None),n::args -> Some (unbox n), args
- | _ -> raise <| System.ArgumentException (SR.GetString(SR.printfExpectedWidth))
-
- let precision,args =
- match precision,args with
- | None,args -> None,args
- | Some(Some w),args -> Some w,args
- | Some(None),n::args -> Some (unbox n), args
- | _ -> raise <| System.ArgumentException (SR.GetString(SR.printfExpectedPrecision))
-
- match intFormatChar,args with
- | '%',args ->
- outputChar intFormatChar; i+1, args
- | ('d' | 'i'),n::args ->
- match n with
- | (:? byte | :? uint16 | :? uint32 | :? uint64 | :? unativeint) ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- | _ ->
- outputInt64(outputChar,intFormatChar,width,info,(unboxAsInt64 n));
- i+1,args
- | ('o' | 'u' | 'x' | 'X'),n::args ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | ('l' | 'L'),n::args ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' ->
- outputInt64(outputChar,intFormatChar,width,info,(unboxAsInt64 n));
- i+1,args
- | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "n"))
- | 'n',n::args ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' ->
- outputInt64(outputChar,intFormatChar,width,info,(unboxAsInt64 n));
- i+1,args
- | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "l"))
- | 'U',n::args ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | 'l' ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "Ul"))
- | 'n' ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "Un"))
- | 'L' ->
- let i = i+1
- let intFormatChar = fmt.[i]
- match intFormatChar with
- | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
- outputUInt64(outputChar,intFormatChar,width,info,(unboxAsUInt64 n));
- i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "UL"))
- | _ -> raise <| System.ArgumentException (SR.GetString1(SR.printfSpecifierAfterIllegal, "U"))
-
- | ('f' | 'F' | 'e' | 'E' | 'g' | 'G'),n::args ->
- let s, number, positive =
- match n with
- | :? float as f -> f.ToString(stringOfChar intFormatChar + (match precision with None -> "6" | Some n -> stringOfInt (max (min n 99) 0)),invariantCulture), not (f = infinity || f = -infinity || System.Double.IsNaN f), f >= 0.
- | :? float32 as f -> f.ToString(stringOfChar intFormatChar + (match precision with None -> "6" | Some n -> stringOfInt (max (min n 99) 0)),invariantCulture), not (f = infinityf || f = -infinityf || System.Single.IsNaN f), f >= 0.f
- | :? decimal as f -> f.ToString(stringOfChar intFormatChar + (match precision with None -> "6" | Some n -> stringOfInt (max (min n 99) 0)),invariantCulture), true, f >= 0M
- | _ -> raise <| System.ArgumentException (SR.GetString(SR.printfBadFloatValue))
-
- let s = match info.numPrefixIfPos with Some c when positive -> stringOfChar c + s | _ -> s
- formatString outputChar info width s number;
- i+1,args
- | 'M',n::args ->
- let d = (unbox n : System.Decimal)
- let s = d.ToString("G",invariantCulture)
- let s = match info.numPrefixIfPos with Some c when d >= 0M -> stringOfChar c + s | _ -> s
- formatString outputChar info width s true;
- i+1,args
- | 's',nobj::args -> formatString outputChar info width (unbox nobj) false; i+1,args
- | 'c',nobj::args -> formatString outputChar info width (stringOfChar (unbox nobj)) false; i+1,args
- | 'b',nobj::args -> formatString outputChar info width (if (unbox nobj) then "true" else "false") false; i+1,args
- | 'O',xobj::args -> formatString outputChar info width (match xobj with null -> "<null>" | _ -> xobj.ToString()) false; i+1,args
- | 'A',xobj::args ->
- let bindingFlags =
- match info.numPrefixIfPos with
- | None -> BindingFlags.Public // Default see Public only
- | Some '+' -> BindingFlags.Public ||| BindingFlags.NonPublic // %+A, sees anything possible
- | Some c -> failwith ("internal: %A has an unexpected numeric prefix '" + string c + "'")
- let opts = FormatOptions.Default
- let opts = match width with None -> opts | Some w -> { opts with PrintWidth = w }
- // printfn %0A is considered to mean 'print width zero'
- let opts = if info.addZeros then { opts with PrintWidth = 0 } else opts
+ cont, contTy
+
+ member this.PopValueUnsafe() = args.Pop()
+
+ member this.PushContinuationWithType (cont : obj, contTy : Type) =
+ System.Diagnostics.Debug.Assert(this.IsEmpty, "this.IsEmpty")
+ System.Diagnostics.Debug.Assert(
+ (
+ let _arg, retTy = Microsoft.FSharp.Reflection.FSharpType.GetFunctionElements(cont.GetType())
+ contTy.IsAssignableFrom retTy
+ ),
+ "incorrect type"
+ )
+
+ this.PushArgumentWithType(cont, contTy)
+
+ member this.PushArgument(value : obj) =
+ args.Push value
+
+ member this.PushArgumentWithType(value : obj, ty) =
+ args.Push value
+ types.Push ty
+
+ member this.HasContinuationOnStack(expectedNumberOfArguments) =
+ types.Count = expectedNumberOfArguments + 1
+
+ member this.IsEmpty =
+ System.Diagnostics.Debug.Assert(args.Count = types.Count, "args.Count = types.Count")
+ args.Count = 0
+
+ /// Parses format string and creates result printer function.
+ /// First it recursively consumes format string up to the end, then during unwinding builds printer using PrintfBuilderStack as storage for arguments.
+ /// idea of implementation is very simple: every step can either push argument to the stack (if current block of 5 format specifiers is not yet filled)
+ // or grab the content of stack, build intermediate printer and push it back to stack (so it can later be consumed by as argument)
+ type private PrintfBuilder<'S, 'Re, 'Res>() =
+
+ let mutable count = 0
+
+ let verifyMethodInfoWasTaken (mi : System.Reflection.MemberInfo) =
+ if mi = null then
+ ignore (System.Diagnostics.Debugger.Launch())
- let opts = match precision with None -> opts | Some w -> { opts with PrintSize = w }
- let txt =
- match xobj with
- | null -> "<null>"
- | _ ->
- Display.anyToStringForPrintf opts bindingFlags xobj
-
- txt |> String.iter outputChar;
- i+1,args
- | 'a',fobj::xobj::args ->
- outa (unbox (invokeFunctionValue (invokeFunctionValue fobj (box os)) xobj));
- i+1,args
- | 't',f::args -> outa ((unbox f) os); i+1,args
- | _ -> raise <| System.ArgumentException (SR.GetString(SR.printfBadFormatSpecifier))
-
-
- let gprintf (initialize : unit -> 'b * ('c -> unit) * (char -> unit) * (unit -> 'd)) (fmt : PrintfFormat<'a,'b,'c,'d>) : 'a =
- let fmt = fmt.Value
- match fmt with
- // optimize some common cases
- | "%s" -> unbox (box (fun (s:string) -> let _,_,outputChar,finalize = initialize() in formatString outputChar defaultInfo None s false; finalize()))
- // | "%x" -> unbox (box (fun (n:int) -> let os,outa,outputChar,finalize = initialize() in outputUInt64 outputChar 'x' None defaultInfo (int32_to_uint64 n); finalize()))
- // | "%d" -> unbox (box (fun (n:int) -> let os,outa,outputChar,finalize = initialize() in outputInt64 outputChar 'd' None defaultInfo (int32_to_int64 n); finalize()))
- | _ ->
- let len = fmt.Length
-
- /// After all arguments are captures we reinterpret and execute the actions
- let run args =
- let os,outa,outputChar,finalize = initialize()
- let rec go args i =
- if i >= len || (fmt.[i] = '%' && i+1 >= len) then (box (finalize()))
- elif System.Char.IsSurrogatePair(fmt,i) then
- outputChar fmt.[i];
- outputChar fmt.[i+1];
- go args (i+2)
+ let buildSpecialChained(spec : FormatSpecifier, argTys : Type[], prefix : string, tail : obj, retTy) =
+ if spec.TypeChar = 'a' then
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("LittleAChained", NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod([| argTys.[1]; retTy |])
+ let args = [| box prefix; tail |]
+ mi.Invoke(null, args)
+ elif spec.TypeChar = 't' then
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("TChained", NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod([| retTy |])
+ let args = [| box prefix; tail |]
+ mi.Invoke(null, args)
+ else
+ System.Diagnostics.Debug.Assert(spec.IsStarPrecision || spec.IsStarWidth , "spec.IsStarPrecision || spec.IsStarWidth ")
+
+ let n = if spec.IsStarWidth = spec.IsStarPrecision then 2 else 1
+ let argTy = argTys.[argTys.Length - 2]
+
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("StarChained" + (n.ToString()), NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod([| argTy; retTy |])
+ let conv = getValueConverter argTy spec
+ let args = [| box prefix; box conv; tail |]
+ mi.Invoke(null, args)
+
+ let buildSpecialFinal(spec : FormatSpecifier, argTys : Type[], prefix : string, suffix : string) =
+ if spec.TypeChar = 'a' then
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("LittleAFinal", NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod(argTys.[1] : Type)
+ let args = [| box prefix; box suffix |]
+ mi.Invoke(null, args)
+ elif spec.TypeChar = 't' then
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("TFinal", NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let args = [| box prefix; box suffix |]
+ mi.Invoke(null, args)
+ else
+ System.Diagnostics.Debug.Assert(spec.IsStarPrecision || spec.IsStarWidth , "spec.IsStarPrecision || spec.IsStarWidth ")
+
+ let n = if spec.IsStarWidth = spec.IsStarPrecision then 2 else 1
+ let argTy = argTys.[argTys.Length - 2]
+
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("StarFinal" + (n.ToString()), NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod(argTy)
+ let conv = getValueConverter argTy spec
+ let args = [| box prefix; box conv; box suffix |]
+ mi.Invoke(null, args)
+
+ let buildPlainFinal(args : obj[], argTypes : Type[]) =
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("Final" + (argTypes.Length.ToString()), NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod(argTypes)
+ mi.Invoke(null, args)
+
+ let buildPlainChained(args : obj[], argTypes : Type[]) =
+ let mi = typeof<Specializations<'S, 'Re, 'Res>>.GetMethod("Chained" + ((argTypes.Length - 1).ToString()), NonPublicStatics)
+ verifyMethodInfoWasTaken mi
+ let mi = mi.MakeGenericMethod(argTypes)
+ mi.Invoke(null, args)
+
+ let builderStack = PrintfBuilderStack()
+
+ let ContinuationOnStack = -1
+
+ let buildPlain numberOfArgs prefix =
+ let n = numberOfArgs * 2
+ let hasCont = builderStack.HasContinuationOnStack numberOfArgs
+
+ let extra = if hasCont then 1 else 0
+ let plainArgs, plainTypes =
+ builderStack.GetArgumentAndTypesAsArrays(n + 1, 1, n, (numberOfArgs + extra), 0, numberOfArgs)
+
+ plainArgs.[0] <- box prefix
+
+ if hasCont then
+ let cont, contTy = builderStack.PopContinuationWithType()
+ plainArgs.[plainArgs.Length - 1] <- cont
+ plainTypes.[plainTypes.Length - 1] <- contTy
+
+ buildPlainChained(plainArgs, plainTypes)
+ else
+ buildPlainFinal(plainArgs, plainTypes)
+
+ let rec parseFromFormatSpecifier (prefix : string) (s : string) (funcTy : Type) i : int =
+
+ if i >= s.Length then 0
+ else
+
+ System.Diagnostics.Debug.Assert(s.[i] = '%', "s.[i] = '%'")
+ count <- count + 1
+
+ let flags, i = FormatString.parseFlags s (i + 1)
+ let width, i = FormatString.parseWidth s i
+ let precision, i = FormatString.parsePrecision s i
+ let typeChar, i = FormatString.parseTypeChar s i
+ let spec = { TypeChar = typeChar; Precision = precision; Flags = flags; Width = width}
+
+ let next = FormatString.findNextFormatSpecifier s i
+ let suffix = s.Substring(i, next - i)
+
+ let argTys =
+ let n =
+ if spec.TypeChar = 'a' then 2
+ elif spec.IsStarWidth || spec.IsStarPrecision then
+ if spec.IsStarWidth = spec.IsStarPrecision then 3
+ else 2
+ else 1
+ extractCurriedArguments funcTy n
+
+ let retTy = argTys.[argTys.Length - 1]
+
+ let numberOfArgs = parseFromFormatSpecifier suffix s retTy next
+
+ if spec.TypeChar = 'a' || spec.TypeChar = 't' || spec.IsStarWidth || spec.IsStarPrecision then
+ if numberOfArgs = ContinuationOnStack then
+
+ let cont, contTy = builderStack.PopContinuationWithType()
+ let currentCont = buildSpecialChained(spec, argTys, prefix, cont, contTy)
+ builderStack.PushContinuationWithType(currentCont, funcTy)
+
+ ContinuationOnStack
+ else
+ if numberOfArgs = 0 then
+ System.Diagnostics.Debug.Assert(builderStack.IsEmpty, "builderStack.IsEmpty")
+
+ let currentCont = buildSpecialFinal(spec, argTys, prefix, suffix)
+ builderStack.PushContinuationWithType(currentCont, funcTy)
+ ContinuationOnStack
else
+
+
+ let hasCont = builderStack.HasContinuationOnStack(numberOfArgs)
+
+ let expectedNumberOfItemsOnStack = numberOfArgs * 2
+ let sizeOfTypesArray =
+ if hasCont then numberOfArgs + 1
+ else numberOfArgs
+
+ let plainArgs, plainTypes =
+ builderStack.GetArgumentAndTypesAsArrays(expectedNumberOfItemsOnStack + 1, 1, expectedNumberOfItemsOnStack, sizeOfTypesArray, 0, numberOfArgs )
+
+ plainArgs.[0] <- box suffix
+
+ let next =
+ if hasCont then
+ let nextCont, nextContTy = builderStack.PopContinuationWithType()
+ plainArgs.[plainArgs.Length - 1] <- nextCont
+ plainTypes.[plainTypes.Length - 1] <- nextContTy
+ buildPlainChained(plainArgs, plainTypes)
+ else
+ buildPlainFinal(plainArgs, plainTypes)
+
+ let next = buildSpecialChained(spec, argTys, prefix, next, retTy)
+ builderStack.PushContinuationWithType(next, funcTy)
+
+ ContinuationOnStack
+ else
+ if numberOfArgs = ContinuationOnStack then
+ let idx = argTys.Length - 2
+ builderStack.PushArgument suffix
+ builderStack.PushArgumentWithType((getValueConverter argTys.[idx] spec), argTys.[idx])
+ 1
+ else
+ builderStack.PushArgument suffix
+ builderStack.PushArgumentWithType((getValueConverter argTys.[0] spec), argTys.[0])
- match fmt.[i] with
- | '%' ->
- let i,args = formatOne outa outputChar os fmt (i+1) args
- go args i
- | c ->
- outputChar c; go args (i+1)
- go args 0
-
- /// Function to capture the arguments and then run.
- let rec capture args ty i =
- if i >= len || (fmt.[i] = '%' && i+1 >= len) then
- run (List.rev args)
- elif System.Char.IsSurrogatePair(fmt,i) then
- capture args ty (i+2)
+ if numberOfArgs = MaxArgumentsInSpecialization - 1 then
+ let cont = buildPlain (numberOfArgs + 1) prefix
+ builderStack.PushContinuationWithType(cont, funcTy)
+ ContinuationOnStack
+ else
+ numberOfArgs + 1
+
+ let parseFormatString (s : string) (funcTy : System.Type) : obj =
+ let prefixPos = FormatString.findNextFormatSpecifier s 0
+ if prefixPos = s.Length then
+ box (fun (env : unit -> PrintfEnv<'S, 'Re, 'Res>) ->
+ let env = env()
+ env.Write s
+ env.Finalize()
+ )
+ else
+ let prefix = if prefixPos = 0 then "" else s.Substring(0, prefixPos)
+ let n = parseFromFormatSpecifier prefix s funcTy prefixPos
+
+ if n = ContinuationOnStack || n = 0 then
+ builderStack.PopValueUnsafe()
+ else
+ buildPlain n prefix
+
+ member this.Build<'T>(s : string) : PrintfFactory<'S, 'Re, 'Res, 'T> * int =
+ parseFormatString s typeof<'T> :?> _, (2 * count + 1) // second component is used in SprintfEnv as value for internal buffer
+
+ /// Type of element that is stored in cache
+ /// Pair: factory for the printer + number of text blocks that printer will produce (used to preallocate buffers)
+ type CachedItem<'T, 'State, 'Residue, 'Result> = PrintfFactory<'State, 'Residue, 'Result, 'T> * int
+
+ /// 2-level cache.
+ /// 1st-level stores last value that was consumed by the current thread in thread-static field thus providing shortcuts for scenarios when
+ /// printf is called in tight loop
+ /// 2nd level is global dictionary that maps format string to the corresponding PrintfFactory
+ type Cache<'T, 'State, 'Residue, 'Result>() =
+ static let generate(fmt) = PrintfBuilder<'State, 'Residue, 'Result>().Build<'T>(fmt)
+#if FSHARP_CORE_4_5
+ static let mutable map = System.Collections.Concurrent.ConcurrentDictionary<string, CachedItem<'T, 'State, 'Residue, 'Result>>()
+ static let getOrAddFunc = Func<_, _>(generate)
+#else
+ static let mutable map = Dictionary<string, CachedItem<'T, 'State, 'Residue, 'Result>>()
+#endif
+
+ static let get(key : string) =
+#if FSHARP_CORE_4_5
+ map.GetOrAdd(key, getOrAddFunc)
+#else
+ lock map (fun () ->
+ let mutable res = Unchecked.defaultof<_>
+ if map.TryGetValue(key, &res) then res
else
- match fmt.[i] with
- | '%' ->
- let i = i+1
- capture1 fmt i args ty capture
- | _ ->
- capture args ty (i+1)
+ let v =
+#if DEBUG
+ try
+ generate(key)
+ with
+ e -> raise (ArgumentException("PRINTF::" + key, e))
+#else
+ generate(key)
+#endif
+ map.Add(key, v)
+ v
+ )
+#endif
- (unbox (capture [] (typeof<'a>) 0) : 'a)
+ [<DefaultValue; ThreadStatic>]
+ static val mutable private last : string * CachedItem<'T, 'State, 'Residue, 'Result>
+
+ static member Get(key : Format<'T, 'State, 'Residue, 'Result>) =
+ if not (Cache<'T, 'State, 'Residue, 'Result>.last === null)
+ && key.Value.Equals (fst Cache<'T, 'State, 'Residue, 'Result>.last) then
+ snd Cache<'T, 'State, 'Residue, 'Result>.last
+ else
+ let v = get(key.Value)
+ Cache<'T, 'State, 'Residue, 'Result>.last <- (key.Value, v)
+ v
+
+ type StringPrintfEnv<'Result>(k, n) =
+ inherit PrintfEnv<unit, string, 'Result>(())
+
+ let buf : string[] = Array.zeroCreate n
+ let mutable ptr = 0
+
+ override this.Finalize() : 'Result = k (String.Concat(buf))
+ override this.Write(s : string) =
+ buf.[ptr] <- s
+ ptr <- ptr + 1
+ override this.WriteT(s) = this.Write s
+
+ type StringBuilderPrintfEnv<'Result>(k, buf) =
+ inherit PrintfEnv<Text.StringBuilder, unit, 'Result>(buf)
+ override this.Finalize() : 'Result = k ()
+ override this.Write(s : string) = ignore(buf.Append(s))
+ override this.WriteT(()) = ()
+
+ type TextWriterPrintfEnv<'Result>(k, tw : IO.TextWriter) =
+ inherit PrintfEnv<IO.TextWriter, unit, 'Result>(tw)
+ override this.Finalize() : 'Result = k()
+ override this.Write(s : string) = tw.Write s
+ override this.WriteT(()) = ()
+
+ let inline doPrintf fmt f =
+ let formatter, n = Cache<_, _, _, _>.Get fmt
+ let env() = f(n)
+ formatter env
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
-module Printf =
+module Printf =
- open System.Text
- open System.Diagnostics
open PrintfImpl
- type BuilderFormat<'T,'Result> = Format<'T, StringBuilder, unit, 'Result>
+ type BuilderFormat<'T,'Result> = Format<'T, System.Text.StringBuilder, unit, 'Result>
type StringFormat<'T,'Result> = Format<'T, unit, string, 'Result>
- type TextWriterFormat<'T,'Result> = Format<'T, TextWriter, unit, 'Result>
+ type TextWriterFormat<'T,'Result> = Format<'T, System.IO.TextWriter, unit, 'Result>
type BuilderFormat<'T> = BuilderFormat<'T,unit>
type StringFormat<'T> = StringFormat<'T,string>
type TextWriterFormat<'T> = TextWriterFormat<'T,unit>
-#if EXTRAS_FOR_SILVERLIGHT_COMPILER
- let outWriter = ref System.Console.Out
- let errorWriter = ref System.Console.Error
+ [<CompiledName("PrintFormatToStringThen")>]
+ let ksprintf continutation (format : StringFormat<'T, 'Result>) : 'T =
+ doPrintf format (fun n ->
+ StringPrintfEnv(continutation, n) :> PrintfEnv<_, _, _>
+ )
- let setWriter (out : System.IO.TextWriter) = outWriter := out
- let setError (error : System.IO.TextWriter) = errorWriter := error
-#endif
-
[<CompiledName("PrintFormatToStringThen")>]
- let ksprintf (f : string -> 'd) (fp : StringFormat<'a,'d>) =
- let init () =
- let buf = new StringBuilder()
- let outputChar (c:char) = ignore (buf.Append(c))
- let outa (s:string) = ignore (buf.Append(s))
- let finish () = f (buf.ToString())
- (),outa,outputChar,finish
- PrintfImpl.gprintf init fp
+ let sprintf (format : StringFormat<'T>) = ksprintf id format
[<CompiledName("PrintFormatThen")>]
let kprintf f fmt = ksprintf f fmt
- let kprintf_imperative f handle outputChar fmt =
- let init () =
- let outa () = ()
- handle,outa,outputChar,f
- PrintfImpl.gprintf init fmt
-
[<CompiledName("PrintFormatToStringBuilderThen")>]
- let kbprintf f (buf: StringBuilder) fmt = kprintf_imperative f buf (fun c -> ignore (buf.Append(c))) fmt
-
+ let kbprintf f (buf: System.Text.StringBuilder) fmt =
+ doPrintf fmt (fun _ ->
+ StringBuilderPrintfEnv(f, buf) :> PrintfEnv<_, _, _>
+ )
+
[<CompiledName("PrintFormatToTextWriterThen")>]
- let kfprintf f os fmt = kprintf_imperative f (os :> TextWriter) (fun c -> ignore (os.Write(c))) fmt
-
- [<CompiledName("PrintFormatToStringThen")>]
- let sprintf fmt = ksprintf (fun x -> x) fmt
-
- [<CompiledName("PrintFormatToStringThenFail")>]
- let failwithf fmt = ksprintf failwith fmt
+ let kfprintf f os fmt =
+ doPrintf fmt (fun _ ->
+ TextWriterPrintfEnv(f, os) :> PrintfEnv<_, _, _>
+ )
[<CompiledName("PrintFormatToStringBuilder")>]
- let bprintf buf fmt = kbprintf (fun _ -> ()) buf fmt
+ let bprintf buf fmt = kbprintf ignore buf fmt
[<CompiledName("PrintFormatToTextWriter")>]
- let fprintf (os: TextWriter) fmt = kfprintf (fun _ -> ()) os fmt
+ let fprintf (os: System.IO.TextWriter) fmt = kfprintf ignore os fmt
[<CompiledName("PrintFormatLineToTextWriter")>]
- let fprintfn (os: TextWriter) fmt = kfprintf (fun _ -> os.WriteLine()) os fmt
+ let fprintfn (os: System.IO.TextWriter) fmt = kfprintf (fun _ -> os.WriteLine()) os fmt
+
+ [<CompiledName("PrintFormatToStringThenFail")>]
+ let failwithf fmt = ksprintf failwith fmt
#if FX_NO_SYSTEM_CONSOLE
#else
#if EXTRAS_FOR_SILVERLIGHT_COMPILER
+ let outWriter = ref System.Console.Out
+ let errorWriter = ref System.Console.Error
+
+ let setWriter (out : System.IO.TextWriter) = outWriter := out
+ let setError (error : System.IO.TextWriter) = errorWriter := error
+
[<CompiledName("PrintFormat")>]
let printf fmt = fprintf (!outWriter) fmt
@@ -648,6 +1307,4 @@ module Printf =
[<CompiledName("PrintFormatLineToError")>]
let eprintfn fmt = fprintfn System.Console.Error fmt
#endif
-#endif
-
-
+#endif
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Core/quotations.fs b/src/fsharp/FSharp.Core/quotations.fs
index e2b3022..c4c213c 100755
--- a/src/fsharp/FSharp.Core/quotations.fs
+++ b/src/fsharp/FSharp.Core/quotations.fs
@@ -30,6 +30,12 @@ open Microsoft.FSharp.Text.StructuredPrintfImpl.LayoutOps
#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation
+#if FX_RESHAPED_REFLECTION
+open PrimReflectionAdapters
+open ReflectionAdapters
+type BindingFlags = ReflectionAdapters.BindingFlags
+#endif
+
//--------------------------------------------------------------------------
// RAW quotations - basic data types
//--------------------------------------------------------------------------
@@ -61,7 +67,11 @@ module Helpers =
let staticBindingFlags = BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly
let staticOrInstanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly
let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly
- let publicOrPrivateBindingFlags = System.Reflection.BindingFlags.Public ||| System.Reflection.BindingFlags.NonPublic
+#if FX_RESHAPED_REFLECTION
+ let publicOrPrivateBindingFlags = true
+#else
+ let publicOrPrivateBindingFlags = BindingFlags.Public ||| BindingFlags.NonPublic
+#endif
let isDelegateType (typ:Type) =
if typ.IsSubclassOf(typeof<Delegate>) then
@@ -81,6 +91,8 @@ module Helpers =
| null -> nullArg argName
| _ -> ()
+ let getTypesFromParamInfos (infos : ParameterInfo[]) = infos |> Array.map (fun pi -> pi.ParameterType)
+
open Helpers
@@ -844,6 +856,14 @@ module Patterns =
//-------------------------------------------------------------------------
// General Method Binder
+ /// Usually functions in modules are not overloadable so having name is enough to recover the function.
+ /// However type extensions break this assumption - it is possible to have multiple extension methods in module that will have the same name.
+ /// This type is used to denote different binding results so we can distinguish the latter case and retry binding later when more information is available.
+ [<NoEquality; NoComparison>]
+ type ModuleDefinitionBindingResult<'T, 'R> =
+ | Unique of 'T
+ | Ambiguous of 'R
+
let typeEquals (s:Type) (t:Type) = s.Equals(t)
let typesEqual (ss:Type list) (tt:Type list) =
(ss.Length = tt.Length) && List.forall2 typeEquals ss tt
@@ -914,12 +934,92 @@ module Patterns =
match ty.GetProperty(nm,staticBindingFlags) with
| null -> raise <| System.InvalidOperationException (SR.GetString2(SR.QcannotBindProperty, nm, ty.ToString()))
| res -> res
-
-
+
+ // tries to locate unique function in a given type
+ // in case of multiple candidates returns None so bindModuleFunctionWithCallSiteArgs will be used for more precise resolution
let bindModuleFunction (ty:Type,nm) =
- match ty.GetMethod(nm,staticBindingFlags) with
- | null -> raise <| System.InvalidOperationException (SR.GetString2(SR.QcannotBindFunction, nm, ty.ToString()))
- | res -> res
+ match ty.GetMethods(staticBindingFlags) |> Array.filter (fun mi -> mi.Name = nm) with
+ | [||] -> raise <| System.InvalidOperationException (SR.GetString2(SR.QcannotBindFunction, nm, ty.ToString()))
+ | [| res |] -> Some res
+ | _ -> None
+
+ let bindModuleFunctionWithCallSiteArgs (ty:Type, nm, argTypes : Type list, tyArgs : Type list) =
+ let argTypes = List.toArray argTypes
+ let tyArgs = List.toArray tyArgs
+ let methInfo =
+ try
+#if FX_ATLEAST_PORTABLE
+ match ty.GetMethod(nm, argTypes) with
+#else
+ match ty.GetMethod(nm,staticOrInstanceBindingFlags,null, argTypes,null) with
+#endif
+ | null -> None
+ | res -> Some(res)
+ with :? AmbiguousMatchException -> None
+ match methInfo with
+ | Some methInfo -> methInfo
+ | _ ->
+ // narrow down set of candidates by removing methods with a different name\number of arguments\number of type parameters
+ let candidates =
+ ty.GetMethods(staticBindingFlags)
+ |> Array.filter(fun mi ->
+ mi.Name = nm &&
+ mi.GetParameters().Length = argTypes.Length &&
+ let methodTyArgCount = if mi.IsGenericMethod then mi.GetGenericArguments().Length else 0
+ methodTyArgCount = tyArgs.Length
+ )
+ let fail() = raise <| System.InvalidOperationException (SR.GetString2(SR.QcannotBindFunction, nm, ty.ToString()))
+ match candidates with
+ | [||] -> fail()
+ | [| solution |] -> solution
+ | candidates ->
+ let solution =
+ // no type arguments - just perform pairwise comparison of type in methods signature and argument type from the callsite
+ if tyArgs.Length = 0 then
+ candidates
+ |> Array.tryFind(fun mi ->
+ let paramTys = mi.GetParameters() |> Array.map (fun pi -> pi.ParameterType)
+ Array.forall2 (=) argTypes paramTys
+ )
+ else
+ let FAIL = -1
+ let MATCH = 2
+ let GENERIC_MATCH = 1
+ // if signature has type arguments then it is possible to have several candidates like
+ // - Foo(_ : 'a)
+ // - Foo(_ : int)
+ // and callsite
+ // - Foo<int>(_ : int)
+ // here instantiation of first method we'll have two similar signatures
+ // however compiler will pick second one and we must do the same.
+
+ // here we compute weights for every signature
+ // for every parameter type:
+ // - non-matching with actual argument type stops computation and return FAIL as the final result
+ // - exact match with actual argument type adds MATCH value to the final result
+ // - parameter type is generic that after instantiation matches actual argument type adds GENERIC_MATCH to the final result
+ // - parameter type is generic that after instantiation doesn't actual argument type stops computation and return FAIL as the final result
+ let weight (mi : MethodInfo) =
+ let parameters = mi.GetParameters()
+ let rec iter i acc =
+ if i >= argTypes.Length then acc
+ else
+ let param = parameters.[i]
+ if param.ParameterType.IsGenericParameter then
+ let actualTy = tyArgs.[param.ParameterType.GenericParameterPosition]
+ if actualTy = argTypes.[i] then iter (i + 1) (acc + GENERIC_MATCH) else FAIL
+ else
+ if param.ParameterType = argTypes.[i] then iter (i + 1) (acc + MATCH) else FAIL
+ iter 0 0
+ let solution, weight =
+ candidates
+ |> Array.map (fun mi -> mi, weight mi)
+ |> Array.maxBy snd
+ if weight = FAIL then None
+ else Some solution
+ match solution with
+ | Some mi -> mi
+ | None -> fail()
let mkNamedType (tc:Type,tyargs) =
match tyargs with
@@ -933,13 +1033,50 @@ module Patterns =
let inst (tyargs:Type list) (i: Instantiable<'T>) = i (fun idx -> tyargs.[idx]) // Note, O(n) looks, but #tyargs is always small
+ let bindPropBySearchIfCandidateIsNull (ty : Type) propName retType argTypes candidate =
+ match candidate with
+ | null ->
+ let props =
+ ty.GetProperties(staticOrInstanceBindingFlags)
+ |> Array.filter (fun pi ->
+ let paramTypes = getTypesFromParamInfos (pi.GetIndexParameters())
+ pi.Name = propName &&
+ pi.PropertyType = retType &&
+ Array.length argTypes = paramTypes.Length &&
+ Array.forall2 (=) argTypes paramTypes
+ )
+ match props with
+ | [| pi |] -> pi
+ | _ -> null
+ | pi -> pi
+
+ let bindCtorBySearchIfCandidateIsNull (ty : Type) argTypes candidate =
+ match candidate with
+ | null ->
+ let ctors =
+ ty.GetConstructors(instanceBindingFlags)
+ |> Array.filter (fun ci ->
+ let paramTypes = getTypesFromParamInfos (ci.GetParameters())
+ Array.length argTypes = paramTypes.Length &&
+ Array.forall2 (=) argTypes paramTypes
+ )
+ match ctors with
+ | [| ctor |] -> ctor
+ | _ -> null
+ | ctor -> ctor
+
+
let bindProp (tc,propName,retType,argTypes,tyargs) =
// We search in the instantiated type, rather than searching the generic type.
let typ = mkNamedType(tc,tyargs)
let argtyps : Type list = argTypes |> inst tyargs
let retType : Type = retType |> inst tyargs |> removeVoid
#if FX_ATLEAST_PORTABLE
- typ.GetProperty(propName, retType, Array.ofList argtyps) |> checkNonNullResult ("propName", SR.GetString1(SR.QfailedToBindProperty, propName)) // fxcop may not see "propName" as an arg
+ try
+ typ.GetProperty(propName, staticOrInstanceBindingFlags)
+ with :? AmbiguousMatchException -> null // more than one property found with the specified name and matching binding constraints - return null to initiate manual search
+ |> bindPropBySearchIfCandidateIsNull typ propName retType (Array.ofList argtyps)
+ |> checkNonNullResult ("propName", SR.GetString1(SR.QfailedToBindProperty, propName)) // fxcop may not see "propName" as an arg
#else
typ.GetProperty(propName, staticOrInstanceBindingFlags, null, retType, Array.ofList argtyps, null) |> checkNonNullResult ("propName", SR.GetString1(SR.QfailedToBindProperty, propName)) // fxcop may not see "propName" as an arg
#endif
@@ -950,7 +1087,10 @@ module Patterns =
let bindGenericCtor (tc:Type,argTypes:Instantiable<Type list>) =
let argtyps = instFormal (getGenericArguments tc) argTypes
#if FX_ATLEAST_PORTABLE
- tc.GetConstructor(Array.ofList argtyps) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
+ let argTypes = Array.ofList argtyps
+ tc.GetConstructor(argTypes)
+ |> bindCtorBySearchIfCandidateIsNull tc argTypes
+ |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
#else
tc.GetConstructor(instanceBindingFlags,null,Array.ofList argtyps,null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
#endif
@@ -958,7 +1098,10 @@ module Patterns =
let typ = mkNamedType(tc,tyargs)
let argtyps = argTypes |> inst tyargs
#if FX_ATLEAST_PORTABLE
- typ.GetConstructor(Array.ofList argtyps) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
+ let argTypes = Array.ofList argtyps
+ typ.GetConstructor(argTypes)
+ |> bindCtorBySearchIfCandidateIsNull typ argTypes
+ |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
#else
typ.GetConstructor(instanceBindingFlags,null,Array.ofList argtyps,null) |> checkNonNullResult ("tc", SR.GetString(SR.QfailedToBindConstructor)) // fxcop may not see "tc" as an arg
#endif
@@ -1114,7 +1257,11 @@ module Patterns =
if a = "" then mscorlib
elif a = "." then st.localAssembly
else
+#if FX_RESHAPED_REFLECTION
+ match System.Reflection.Assembly.Load(AssemblyName(a)) with
+#else
match System.Reflection.Assembly.Load(a) with
+#endif
| null -> raise <| System.InvalidOperationException(SR.GetString1(SR.QfailedToBindAssembly, a.ToString()))
| ass -> ass
@@ -1165,8 +1312,15 @@ module Patterns =
match tag with
| 0 -> u_tup3 u_constSpec u_dtypes (u_list u_Expr) st
|> (fun (a,b,args) (env:BindingEnv) ->
+ let args = List.map (fun e -> e env) args
+ let a =
+ match a with
+ | Unique v -> v
+ | Ambiguous f ->
+ let argTys = List.map typeOf args
+ f argTys
let tyargs = b env.typeInst
- E(CombTerm(a tyargs, List.map (fun e -> e env) args )))
+ E(CombTerm(a tyargs, args )))
| 1 -> let x = u_VarRef st
(fun env -> E(VarTerm (x env)))
| 2 -> let a = u_VarDecl st
@@ -1202,8 +1356,11 @@ module Patterns =
and u_ModuleDefn st =
let (ty,nm,isProp) = u_tup3 u_NamedType u_string u_bool st
- if isProp then StaticPropGetOp(bindModuleProperty(ty,nm))
- else StaticMethodCallOp(bindModuleFunction(ty,nm))
+ if isProp then Unique(StaticPropGetOp(bindModuleProperty(ty,nm)))
+ else
+ match bindModuleFunction(ty, nm) with
+ | Some mi -> Unique(StaticMethodCallOp(mi))
+ | None -> Ambiguous(fun argTypes tyargs -> StaticMethodCallOp(bindModuleFunctionWithCallSiteArgs(ty, nm, argTypes, tyargs)))
and u_MethodInfoData st =
u_tup5 u_NamedType (u_list u_dtype) u_dtype u_string u_int st
@@ -1219,8 +1376,9 @@ module Patterns =
match tag with
| 0 ->
match u_ModuleDefn st with
- | StaticMethodCallOp(minfo) -> (minfo :> MethodBase)
- | StaticPropGetOp(pinfo) -> (pinfo.GetGetMethod(true) :> MethodBase)
+ | Unique(StaticMethodCallOp(minfo)) -> (minfo :> MethodBase)
+ | Unique(StaticPropGetOp(pinfo)) -> (pinfo.GetGetMethod(true) :> MethodBase)
+ | Ambiguous(_) -> raise (System.Reflection.AmbiguousMatchException())
| _ -> failwith "unreachable"
| 1 ->
let data = u_MethodInfoData st
@@ -1235,61 +1393,68 @@ module Patterns =
and u_constSpec st =
let tag = u_byte_as_int st
- match tag with
- | 0 -> u_void st |> (fun () NoTyArgs -> IfThenElseOp)
- | 1 -> u_ModuleDefn st |> (fun op tyargs ->
- match op with
- | StaticMethodCallOp(minfo) -> StaticMethodCallOp(instMeth(minfo,tyargs))
- // OK to throw away the tyargs here since this only non-generic values in modules get represented by static properties
- | op -> op)
- | 2 -> u_void st |> (fun () NoTyArgs -> LetRecOp)
- | 3 -> u_NamedType st |> (fun x tyargs -> NewRecordOp (mkNamedType(x,tyargs)))
- | 4 -> u_RecdField st |> (fun prop tyargs -> InstancePropGetOp(prop tyargs))
- | 5 -> u_UnionCaseInfo st |> (fun unionCase tyargs -> NewUnionCaseOp(unionCase tyargs))
- | 6 -> u_UnionCaseField st |> (fun prop tyargs -> InstancePropGetOp(prop tyargs) )
- | 7 -> u_UnionCaseInfo st |> (fun unionCase tyargs -> UnionCaseTestOp(unionCase tyargs))
- | 8 -> u_void st |> (fun () (OneTyArg(tyarg)) -> NewTupleOp tyarg)
- | 9 -> u_int st |> (fun x (OneTyArg(tyarg)) -> TupleGetOp (tyarg,x))
- // Note, these get type args because they may be the result of reading literal field constants
- | 11 -> u_bool st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
- | 12 -> u_string st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
- | 13 -> u_float32 st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
- | 14 -> u_double st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 15 -> u_char st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 16 -> u_sbyte st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 17 -> u_byte st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 18 -> u_int16 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 19 -> u_uint16 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 20 -> u_int32 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 21 -> u_uint32 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 22 -> u_int64 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 23 -> u_uint64 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
- | 24 -> u_void st |> (fun () NoTyArgs -> mkLiftedValueOpG ((), typeof<unit>))
- | 25 -> u_PropInfoData st |> (fun (a,b,c,d) tyargs -> let pinfo = bindProp(a,b,c,d,tyargs) in if pinfoIsStatic pinfo then StaticPropGetOp(pinfo) else InstancePropGetOp(pinfo))
- | 26 -> u_CtorInfoData st |> (fun (a,b) tyargs -> NewObjectOp (bindCtor(a,b,tyargs)))
- | 28 -> u_void st |> (fun () (OneTyArg(ty)) -> CoerceOp ty)
- | 29 -> u_void st |> (fun () NoTyArgs -> SequentialOp)
- | 30 -> u_void st |> (fun () NoTyArgs -> ForIntegerRangeLoopOp)
- | 31 -> u_MethodInfoData st |> (fun p tyargs -> let minfo = bindMeth(p,tyargs) in if minfo.IsStatic then StaticMethodCallOp(minfo) else InstanceMethodCallOp(minfo))
- | 32 -> u_void st |> (fun () (OneTyArg(ty)) -> NewArrayOp ty)
- | 33 -> u_void st |> (fun () (OneTyArg(ty)) -> NewDelegateOp ty)
- | 34 -> u_void st |> (fun () NoTyArgs -> WhileLoopOp)
- | 35 -> u_void st |> (fun () NoTyArgs -> LetOp)
- | 36 -> u_RecdField st |> (fun prop tyargs -> InstancePropSetOp(prop tyargs))
- | 37 -> u_tup2 u_NamedType u_string st |> (fun (a,b) tyargs -> let finfo = bindField(a,b,tyargs) in if finfo.IsStatic then StaticFieldGetOp(finfo) else InstanceFieldGetOp(finfo))
- | 38 -> u_void st |> (fun () NoTyArgs -> LetRecCombOp)
- | 39 -> u_void st |> (fun () NoTyArgs -> AppOp)
- | 40 -> u_void st |> (fun () (OneTyArg(ty)) -> ValueOp(null,ty))
- | 41 -> u_void st |> (fun () (OneTyArg(ty)) -> DefaultValueOp(ty))
- | 42 -> u_PropInfoData st |> (fun (a,b,c,d) tyargs -> let pinfo = bindProp(a,b,c,d,tyargs) in if pinfoIsStatic pinfo then StaticPropSetOp(pinfo) else InstancePropSetOp(pinfo))
- | 43 -> u_tup2 u_NamedType u_string st |> (fun (a,b) tyargs -> let finfo = bindField(a,b,tyargs) in if finfo.IsStatic then StaticFieldSetOp(finfo) else InstanceFieldSetOp(finfo))
- | 44 -> u_void st |> (fun () NoTyArgs -> AddressOfOp)
- | 45 -> u_void st |> (fun () NoTyArgs -> AddressSetOp)
- | 46 -> u_void st |> (fun () (OneTyArg(ty)) -> TypeTestOp(ty))
- | 47 -> u_void st |> (fun () NoTyArgs -> TryFinallyOp)
- | 48 -> u_void st |> (fun () NoTyArgs -> TryWithOp)
- | 49 -> u_void st |> (fun () NoTyArgs -> VarSetOp)
- | _ -> failwithf "u_constSpec, unrecognized tag %d" tag
+ if tag = 1 then
+ let bindModuleDefn r tyargs =
+ match r with
+ | StaticMethodCallOp(minfo) -> StaticMethodCallOp(instMeth(minfo,tyargs))
+ // OK to throw away the tyargs here since this only non-generic values in modules get represented by static properties
+ | x -> x
+ match u_ModuleDefn st with
+ | Unique(r) -> Unique(bindModuleDefn r)
+ | Ambiguous(f) -> Ambiguous(fun argTypes tyargs -> bindModuleDefn (f argTypes tyargs) tyargs)
+ else
+ let constSpec =
+ match tag with
+ | 0 -> u_void st |> (fun () NoTyArgs -> IfThenElseOp)
+ | 2 -> u_void st |> (fun () NoTyArgs -> LetRecOp)
+ | 3 -> u_NamedType st |> (fun x tyargs -> NewRecordOp (mkNamedType(x,tyargs)))
+ | 4 -> u_RecdField st |> (fun prop tyargs -> InstancePropGetOp(prop tyargs))
+ | 5 -> u_UnionCaseInfo st |> (fun unionCase tyargs -> NewUnionCaseOp(unionCase tyargs))
+ | 6 -> u_UnionCaseField st |> (fun prop tyargs -> InstancePropGetOp(prop tyargs) )
+ | 7 -> u_UnionCaseInfo st |> (fun unionCase tyargs -> UnionCaseTestOp(unionCase tyargs))
+ | 8 -> u_void st |> (fun () (OneTyArg(tyarg)) -> NewTupleOp tyarg)
+ | 9 -> u_int st |> (fun x (OneTyArg(tyarg)) -> TupleGetOp (tyarg,x))
+ // Note, these get type args because they may be the result of reading literal field constants
+ | 11 -> u_bool st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
+ | 12 -> u_string st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
+ | 13 -> u_float32 st |> (fun x (OneTyArg(tyarg)) -> mkLiftedValueOpG (x, tyarg))
+ | 14 -> u_double st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 15 -> u_char st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 16 -> u_sbyte st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 17 -> u_byte st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 18 -> u_int16 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 19 -> u_uint16 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 20 -> u_int32 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 21 -> u_uint32 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 22 -> u_int64 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 23 -> u_uint64 st |> (fun a (OneTyArg(tyarg)) -> mkLiftedValueOpG (a, tyarg))
+ | 24 -> u_void st |> (fun () NoTyArgs -> mkLiftedValueOpG ((), typeof<unit>))
+ | 25 -> u_PropInfoData st |> (fun (a,b,c,d) tyargs -> let pinfo = bindProp(a,b,c,d,tyargs) in if pinfoIsStatic pinfo then StaticPropGetOp(pinfo) else InstancePropGetOp(pinfo))
+ | 26 -> u_CtorInfoData st |> (fun (a,b) tyargs -> NewObjectOp (bindCtor(a,b,tyargs)))
+ | 28 -> u_void st |> (fun () (OneTyArg(ty)) -> CoerceOp ty)
+ | 29 -> u_void st |> (fun () NoTyArgs -> SequentialOp)
+ | 30 -> u_void st |> (fun () NoTyArgs -> ForIntegerRangeLoopOp)
+ | 31 -> u_MethodInfoData st |> (fun p tyargs -> let minfo = bindMeth(p,tyargs) in if minfo.IsStatic then StaticMethodCallOp(minfo) else InstanceMethodCallOp(minfo))
+ | 32 -> u_void st |> (fun () (OneTyArg(ty)) -> NewArrayOp ty)
+ | 33 -> u_void st |> (fun () (OneTyArg(ty)) -> NewDelegateOp ty)
+ | 34 -> u_void st |> (fun () NoTyArgs -> WhileLoopOp)
+ | 35 -> u_void st |> (fun () NoTyArgs -> LetOp)
+ | 36 -> u_RecdField st |> (fun prop tyargs -> InstancePropSetOp(prop tyargs))
+ | 37 -> u_tup2 u_NamedType u_string st |> (fun (a,b) tyargs -> let finfo = bindField(a,b,tyargs) in if finfo.IsStatic then StaticFieldGetOp(finfo) else InstanceFieldGetOp(finfo))
+ | 38 -> u_void st |> (fun () NoTyArgs -> LetRecCombOp)
+ | 39 -> u_void st |> (fun () NoTyArgs -> AppOp)
+ | 40 -> u_void st |> (fun () (OneTyArg(ty)) -> ValueOp(null,ty))
+ | 41 -> u_void st |> (fun () (OneTyArg(ty)) -> DefaultValueOp(ty))
+ | 42 -> u_PropInfoData st |> (fun (a,b,c,d) tyargs -> let pinfo = bindProp(a,b,c,d,tyargs) in if pinfoIsStatic pinfo then StaticPropSetOp(pinfo) else InstancePropSetOp(pinfo))
+ | 43 -> u_tup2 u_NamedType u_string st |> (fun (a,b) tyargs -> let finfo = bindField(a,b,tyargs) in if finfo.IsStatic then StaticFieldSetOp(finfo) else InstanceFieldSetOp(finfo))
+ | 44 -> u_void st |> (fun () NoTyArgs -> AddressOfOp)
+ | 45 -> u_void st |> (fun () NoTyArgs -> AddressSetOp)
+ | 46 -> u_void st |> (fun () (OneTyArg(ty)) -> TypeTestOp(ty))
+ | 47 -> u_void st |> (fun () NoTyArgs -> TryFinallyOp)
+ | 48 -> u_void st |> (fun () NoTyArgs -> TryWithOp)
+ | 49 -> u_void st |> (fun () NoTyArgs -> VarSetOp)
+ | _ -> failwithf "u_constSpec, unrecognized tag %d" tag
+ Unique constSpec
let u_ReflectedDefinition = u_tup2 u_MethodBase u_Expr
let u_ReflectedDefinitions = u_list u_ReflectedDefinition
@@ -1396,17 +1561,117 @@ module Patterns =
#if FX_NO_REFLECTION_METADATA_TOKENS // not available on Compact Framework
[<StructuralEquality; NoComparison>]
type ReflectedDefinitionTableKey =
- | Key of System.Type * int * System.Type[]
+ // Key is declaring type * type parameters count * name * parameter types * return type
+ // Registered reflected definitions can contain generic methods or constructors in generic types,
+ // however TryGetReflectedDefinition can be queried with concrete instantiations of the same methods that doesnt contain type parameters.
+ // To make these two cases match we apply the following transformations:
+ // 1. if declaring type is generic - key will contain generic type definition, otherwise - type itself
+ // 2. if method is instantiation of generic one - pick parameters from generic method definition, otherwise - from methods itself
+ // 3 if method is constructor and declaring type is generic then we'll use the following trick to treat C<'a>() and C<int>() as the same type
+ // - we resolve method handle of the constructor using generic type definition - as a result for constructor from instantiated type we obtain matching constructor in generic type definition
+ | Key of System.Type * int * string * System.Type[] * System.Type
static member GetKey(methodBase:MethodBase) =
-#if FX_NO_REFLECTION_MODULES
- Key(methodBase.DeclaringType,
- (if methodBase.IsGenericMethod then methodBase.GetGenericArguments().Length else 0),
- methodBase.GetParameters() |> Array.map (fun p -> p.ParameterType))
+ let isGenericType = methodBase.DeclaringType.IsGenericType
+ let declaringType =
+ if isGenericType then
+ methodBase.DeclaringType.GetGenericTypeDefinition()
+ else methodBase.DeclaringType
+ let tyArgsCount =
+ if methodBase.IsGenericMethod then
+ methodBase.GetGenericArguments().Length
+ else 0
+#if FX_RESHAPED_REFLECTION
+ // this is very unfortunate consequence of limited Reflection capabilities on .NETCore
+ // what we want: having MethodBase for some concrete method or constructor we would like to locate corresponding MethodInfo\ConstructorInfo from the open generic type (cannonical form).
+ // It is necessary to build the key for the table of reflected definitions: reflection definition is saved for open generic type but user may request it using
+ // arbitrary instantiation.
+ let findMethodInOpenGenericType (mb : ('T :> MethodBase)) : 'T =
+ let candidates =
+ let bindingFlags =
+ (if mb.IsPublic then BindingFlags.Public else BindingFlags.NonPublic) |||
+ (if mb.IsStatic then BindingFlags.Static else BindingFlags.Instance)
+ let candidates : MethodBase[] =
+ downcast (
+ if mb.IsConstructor then
+ box (declaringType.GetConstructors(bindingFlags))
+ else
+ box (declaringType.GetMethods(bindingFlags))
+ )
+ candidates |> Array.filter (fun c ->
+ c.Name = mb.Name &&
+ (c.GetParameters().Length) = (mb.GetParameters().Length) &&
+ (c.IsGenericMethod = mb.IsGenericMethod) &&
+ (if c.IsGenericMethod then c.GetGenericArguments().Length = mb.GetGenericArguments().Length else true)
+ )
+ let solution =
+ if candidates.Length = 0 then failwith "Unexpected, failed to locate matching method"
+ elif candidates.Length = 1 then candidates.[0]
+ else
+ // here we definitely know that candidates
+ // a. has matching name
+ // b. has the same number of arguments
+ // c. has the same number of type parameters if any
+
+ let originalParameters = mb.GetParameters()
+ let originalTypeArguments = mb.DeclaringType.GetGenericArguments()
+ let EXACT_MATCHING_COST = 2
+ let GENERIC_TYPE_MATCHING_COST = 1
+
+ // loops through the parameters and computes the rate of the current candidate.
+ // having the argument:
+ // - rate is increased on EXACT_MATCHING_COST if type of argument that candidate has at position i exactly matched the type of argument for the original method.
+ // - rate is increased on GENERIC_TYPE_MATCHING_COST if candidate has generic argument at given position and its type matched the type of argument for the original method.
+ // - otherwise rate will be 0
+ let evaluateCandidate (mb : MethodBase) : int =
+ let parameters = mb.GetParameters()
+ let rec loop i resultSoFar =
+ if i >= parameters.Length then resultSoFar
+ else
+ let p = parameters.[i]
+ let orig = originalParameters.[i]
+ if p.ParameterType = orig.ParameterType then loop (i + 1) (resultSoFar + EXACT_MATCHING_COST) // exact matching
+ elif p.ParameterType.IsGenericParameter && p.ParameterType.DeclaringType = mb.DeclaringType then
+ let pos = p.ParameterType.GenericParameterPosition
+ if originalTypeArguments.[pos] = orig.ParameterType then loop (i + 1) (resultSoFar + GENERIC_TYPE_MATCHING_COST)
+ else 0
+ else
+ 0
+
+ loop 0 0
+
+ Array.maxBy evaluateCandidate candidates
+
+ solution :?> 'T
+#endif
+ match methodBase with
+ | :? MethodInfo as mi ->
+ let mi =
+ if mi.IsGenericMethod then
+ let mi = mi.GetGenericMethodDefinition()
+ if isGenericType then
+#if FX_RESHAPED_REFLECTION
+ findMethodInOpenGenericType mi
#else
- Key(methodBase.DeclaringType.Module.ModuleHandle,
- (if methodBase.IsGenericMethod then methodBase.GetGenericArguments().Length else 0),
- methodBase.GetParameters() |> Array.map (fun p -> p.Type))
-#endif
+ MethodBase.GetMethodFromHandle(mi.MethodHandle, declaringType.TypeHandle) :?> MethodInfo
+#endif
+ else
+ mi
+ else mi
+ let paramTypes = mi.GetParameters() |> getTypesFromParamInfos
+ Key(declaringType, tyArgsCount, methodBase.Name, paramTypes, mi.ReturnType)
+ | :? ConstructorInfo as ci ->
+ let mi =
+ if isGenericType then
+#if FX_RESHAPED_REFLECTION
+ findMethodInOpenGenericType ci
+#else
+ MethodBase.GetMethodFromHandle(ci. MethodHandle, declaringType.TypeHandle) :?> ConstructorInfo // convert ctor with concrete args to ctor with generic args
+#endif
+ else
+ ci
+ let paramTypes = mi.GetParameters() |> getTypesFromParamInfos
+ Key(declaringType, tyArgsCount, methodBase.Name, paramTypes, declaringType)
+ | _ -> failwith "Unexpected MethodBase type, %A" (methodBase.GetType()) // per MSDN ConstructorInfo and MethodInfo are the only derived types from MethodBase
#else
[<StructuralEquality; NoComparison>]
type ReflectedDefinitionTableKey =
@@ -1847,4 +2112,4 @@ module ExprShape =
| HoleTerm _ -> invalidArg "expr" (SR.GetString(SR.QunexpectedHole))
loop (e :> Expr)
-#endif
\ No newline at end of file
+#endif
diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs
index 406ffe2..6a160ed 100755
--- a/src/fsharp/FSharp.Core/reflect.fs
+++ b/src/fsharp/FSharp.Core/reflect.fs
@@ -12,8 +12,222 @@
// Reflection on F# values. Analyze an object to see if it the representation
// of an F# value.
+#if FX_RESHAPED_REFLECTION
+
+namespace Microsoft.FSharp.Core
+
+open System
+open System.Reflection
+
+open Microsoft.FSharp.Core
+open Microsoft.FSharp.Core.Operators
+open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
+open Microsoft.FSharp.Collections
+open Microsoft.FSharp.Primitives.Basics
+
+module ReflectionAdapters =
+
+ [<Flags>]
+ type BindingFlags =
+ | DeclaredOnly = 2
+ | Instance = 4
+ | Static = 8
+ | Public = 16
+ | NonPublic = 32
+ let inline hasFlag (flag : BindingFlags) f = (f &&& flag) = flag
+ let isDeclaredFlag f = hasFlag BindingFlags.DeclaredOnly f
+ let isPublicFlag f = hasFlag BindingFlags.Public f
+ let isStaticFlag f = hasFlag BindingFlags.Static f
+ let isInstanceFlag f = hasFlag BindingFlags.Instance f
+ let isNonPublicFlag f = hasFlag BindingFlags.NonPublic f
+
+ [<System.Flags>]
+ type TypeCode =
+ | Int32 = 0
+ | Int64 = 1
+ | Byte = 2
+ | SByte = 3
+ | Int16 = 4
+ | UInt16 = 5
+ | UInt32 = 6
+ | UInt64 = 7
+ | Single = 8
+ | Double = 9
+ | Decimal = 10
+ | Other = 11
+
+ let isAcceptable bindingFlags isStatic isPublic =
+ // 1. check if member kind (static\instance) was specified in flags
+ ((isStaticFlag bindingFlags && isStatic) || (isInstanceFlag bindingFlags && not isStatic)) &&
+ // 2. check if member accessibility was specified in flags
+ ((isPublicFlag bindingFlags && isPublic) || (isNonPublicFlag bindingFlags && not isPublic))
+
+ let publicFlags = BindingFlags.Public ||| BindingFlags.Instance ||| BindingFlags.Static
+
+ let commit (results : _[]) =
+ match results with
+ | [||] -> null
+ | [| m |] -> m
+ | _ -> raise (AmbiguousMatchException())
+
+ let canUseAccessor (accessor : MethodInfo) nonPublic =
+ box accessor <> null && (accessor.IsPublic || nonPublic)
+
+ open PrimReflectionAdapters
+
+ type System.Type with
+ member this.GetNestedType (name, bindingFlags) =
+ // MSDN: http://msdn.microsoft.com/en-us/library/0dcb3ad5.aspx
+ // The following BindingFlags filter flags can be used to define which nested types to include in the search:
+ // You must specify either BindingFlags.Public or BindingFlags.NonPublic to get a return.
+ // Specify BindingFlags.Public to include public nested types in the search.
+ // Specify BindingFlags.NonPublic to include non-public nested types (that is, private, internal, and protected nested types) in the search.
+ // This method returns only the nested types of the current type. It does not search the base classes of the current type.
+ // To find types that are nested in base classes, you must walk the inheritance hierarchy, calling GetNestedType at each level.
+ let nestedTyOpt =
+ this.GetTypeInfo().DeclaredNestedTypes
+ |> Seq.tryFind (fun nestedTy ->
+ nestedTy.Name = name && (
+ (isPublicFlag bindingFlags && nestedTy.IsNestedPublic) ||
+ (isNonPublicFlag bindingFlags && (nestedTy.IsNestedPrivate || nestedTy.IsNestedFamily || nestedTy.IsNestedAssembly || nestedTy.IsNestedFamORAssem || nestedTy.IsNestedFamANDAssem))
+ )
+ )
+ |> Option.map (fun ti -> ti.AsType())
+ defaultArg nestedTyOpt null
+ // use different sources based on Declared flag
+ member this.GetMethods(bindingFlags) =
+ (if isDeclaredFlag bindingFlags then this.GetTypeInfo().DeclaredMethods else this.GetRuntimeMethods())
+ |> Seq.filter (fun m -> isAcceptable bindingFlags m.IsStatic m.IsPublic)
+ |> Seq.toArray
+ // use different sources based on Declared flag
+ member this.GetFields(bindingFlags) =
+ (if isDeclaredFlag bindingFlags then this.GetTypeInfo().DeclaredFields else this.GetRuntimeFields())
+ |> Seq.filter (fun f -> isAcceptable bindingFlags f.IsStatic f.IsPublic)
+ |> Seq.toArray
+ // use different sources based on Declared flag
+ member this.GetProperties(?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags publicFlags
+ (if isDeclaredFlag bindingFlags then this.GetTypeInfo().DeclaredProperties else this.GetRuntimeProperties())
+ |> Seq.filter (fun pi->
+ let mi = if pi.GetMethod <> null then pi.GetMethod else pi.SetMethod
+ assert (mi <> null)
+ isAcceptable bindingFlags mi.IsStatic mi.IsPublic
+ )
+ |> Seq.toArray
+ // use different sources based on Declared flag
+ member this.GetMethod(name, ?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags publicFlags
+ this.GetMethods(bindingFlags)
+ |> Array.filter(fun m -> m.Name = name)
+ |> commit
+ // use different sources based on Declared flag
+ member this.GetProperty(name, bindingFlags) =
+ this.GetProperties(bindingFlags)
+ |> Array.filter (fun pi -> pi.Name = name)
+ |> commit
+ member this.IsGenericTypeDefinition = this.GetTypeInfo().IsGenericTypeDefinition
+ member this.GetGenericArguments() =
+ if this.IsGenericTypeDefinition then this.GetTypeInfo().GenericTypeParameters
+ elif this.IsGenericType then this.GenericTypeArguments
+ else [||]
+ member this.BaseType = this.GetTypeInfo().BaseType
+ member this.GetConstructor(parameterTypes : Type[]) =
+ this.GetTypeInfo().DeclaredConstructors
+ |> Seq.filter (fun ci ->
+ let parameters = ci.GetParameters()
+ (parameters.Length = parameterTypes.Length) &&
+ (parameterTypes, parameters) ||> Array.forall2 (fun ty pi -> pi.ParameterType.Equals ty)
+ )
+ |> Seq.toArray
+ |> commit
+ // MSDN: returns an array of Type objects representing all the interfaces implemented or inherited by the current Type.
+ member this.GetInterfaces() = this.GetTypeInfo().ImplementedInterfaces |> Seq.toArray
+ member this.GetConstructors(?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags publicFlags
+ // type initializer will also be included in resultset
+ this.GetTypeInfo().DeclaredConstructors
+ |> Seq.filter (fun ci -> isAcceptable bindingFlags ci.IsStatic ci.IsPublic)
+ |> Seq.toArray
+ member this.GetMethods() = this.GetMethods(publicFlags)
+ member this.Assembly = this.GetTypeInfo().Assembly
+ member this.IsSubclassOf(otherTy : Type) = this.GetTypeInfo().IsSubclassOf(otherTy)
+ member this.IsEnum = this.GetTypeInfo().IsEnum;
+ member this.GetField(name, bindingFlags) =
+ this.GetFields(bindingFlags)
+ |> Array.filter (fun fi -> fi.Name = name)
+ |> commit
+ member this.GetProperty(name, propertyType, parameterTypes : Type[]) =
+ this.GetProperties()
+ |> Array.filter (fun pi ->
+ pi.Name = name &&
+ pi.PropertyType = propertyType &&
+ (
+ let parameters = pi.GetIndexParameters()
+ (parameters.Length = parameterTypes.Length) &&
+ (parameterTypes, parameters) ||> Array.forall2 (fun ty pi -> pi.ParameterType.Equals ty)
+ )
+ )
+ |> commit
+ static member GetTypeCode(ty : Type) =
+ if typeof<System.Int32>.Equals ty then TypeCode.Int32
+ elif typeof<System.Int64>.Equals ty then TypeCode.Int64
+ elif typeof<System.Byte>.Equals ty then TypeCode.Byte
+ elif ty = typeof<System.SByte> then TypeCode.SByte
+ elif ty = typeof<System.Int16> then TypeCode.Int16
+ elif ty = typeof<System.UInt16> then TypeCode.UInt16
+ elif ty = typeof<System.UInt32> then TypeCode.UInt32
+ elif ty = typeof<System.UInt64> then TypeCode.UInt64
+ elif ty = typeof<System.Single> then TypeCode.Single
+ elif ty = typeof<System.Double> then TypeCode.Double
+ elif ty = typeof<System.Decimal> then TypeCode.Decimal
+ else TypeCode.Other
+
+ type System.Reflection.MemberInfo with
+ member this.GetCustomAttributes(attrTy, inherits) : obj[] = downcast box(CustomAttributeExtensions.GetCustomAttributes(this, attrTy, inherits) |> Seq.toArray)
+
+ type System.Reflection.MethodInfo with
+ member this.GetCustomAttributes(inherits : bool) : obj[] = downcast box(CustomAttributeExtensions.GetCustomAttributes(this, inherits) |> Seq.toArray)
+
+ type System.Reflection.PropertyInfo with
+ member this.GetGetMethod(nonPublic) =
+ let mi = this.GetMethod
+ if canUseAccessor mi nonPublic then mi
+ else null
+ member this.GetSetMethod(nonPublic) =
+ let mi = this.SetMethod
+ if canUseAccessor mi nonPublic then mi
+ else null
+
+ type System.Reflection.Assembly with
+ member this.GetTypes() =
+ this.DefinedTypes
+ |> Seq.map (fun ti -> ti.AsType())
+ |> Seq.toArray
+
+ type System.Delegate with
+ static member CreateDelegate(delegateType, methodInfo : MethodInfo) = methodInfo.CreateDelegate(delegateType)
+ static member CreateDelegate(delegateType, obj : obj, methodInfo : MethodInfo) = methodInfo.CreateDelegate(delegateType, obj)
+
+#endif
+
namespace Microsoft.FSharp.Reflection
+module internal ReflectionUtils =
+
+ open Microsoft.FSharp.Core.Operators
+
+#if FX_RESHAPED_REFLECTION
+ type BindingFlags = Microsoft.FSharp.Core.ReflectionAdapters.BindingFlags
+#else
+ type BindingFlags = System.Reflection.BindingFlags
+#endif
+
+ let toBindingFlags allowAccessToNonPublicMembers =
+ if allowAccessToNonPublicMembers then
+ BindingFlags.NonPublic ||| BindingFlags.Public
+ else
+ BindingFlags.Public
+
open System
open System.Globalization
open System.Reflection
@@ -27,10 +241,20 @@ module internal Impl =
let debug = false
+#if FX_RESHAPED_REFLECTION
+
+ open PrimReflectionAdapters
+ open ReflectionAdapters
+
+#endif
+
+ let getBindingFlags allowAccess = ReflectionUtils.toBindingFlags (defaultArg allowAccess false)
+
let inline checkNonNull argName (v: 'T) =
match box v with
| null -> nullArg argName
| _ -> ()
+
let emptyArray arr = (Array.length arr = 0)
let nonEmptyArray arr = Array.length arr > 0
@@ -53,7 +277,6 @@ module internal Impl =
//-----------------------------------------------------------------
// GENERAL UTILITIES
-
#if FX_ATLEAST_PORTABLE
let instancePropertyFlags = BindingFlags.Instance
let staticPropertyFlags = BindingFlags.Static
@@ -80,7 +303,6 @@ module internal Impl =
//-----------------------------------------------------------------
// ATTRIBUTE DECOMPILATION
-
let tryFindCompilationMappingAttribute (attrs:obj[]) =
match attrs with
| null | [| |] -> None
@@ -93,9 +315,9 @@ module internal Impl =
| Some a -> a
#if FX_NO_CUSTOMATTRIBUTEDATA
- let tryFindCompilationMappingAttributeFromType (typ:Type) = tryFindCompilationMappingAttribute ( typ.GetCustomAttributes (typeof<CompilationMappingAttribute>,false))
- let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof<CompilationMappingAttribute>,false))
- let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = findCompilationMappingAttribute (info.GetCustomAttributes (typeof<CompilationMappingAttribute>,false))
+ let tryFindCompilationMappingAttributeFromType (typ:Type) = tryFindCompilationMappingAttribute ( typ.GetCustomAttributes(typeof<CompilationMappingAttribute>, false))
+ let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = tryFindCompilationMappingAttribute (info.GetCustomAttributes(typeof<CompilationMappingAttribute>, false))
+ let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = findCompilationMappingAttribute (info.GetCustomAttributes(typeof<CompilationMappingAttribute>, false))
#else
let cmaName = typeof<CompilationMappingAttribute>.FullName
let assemblyName = typeof<CompilationMappingAttribute>.Assembly.GetName().Name
@@ -165,8 +387,7 @@ module internal Impl =
| Some (flags,_n,_vn) -> Some flags
//-----------------------------------------------------------------
- // UNION DECOMPILATION
-
+ // UNION DECOMPILATION
// Get the type where the type definitions are stored
let getUnionCasesTyp (typ: Type, _bindingFlags) =
@@ -211,7 +432,20 @@ module internal Impl =
let tagField = tagFields |> Array.pick (fun (i,f) -> if i = tag then Some f else None)
if tagFields.Length = 1 then
typ
- else
+ else
+ // special case: two-cased DU annotated with CompilationRepresentation(UseNullAsTrueValue)
+ // in this case it will be compiled as one class: return self type for non-nullary case and null for nullary
+ let isTwoCasedDU =
+ if tagFields.Length = 2 then
+ match typ.GetCustomAttributes(typeof<CompilationRepresentationAttribute>, false) with
+ | [|:? CompilationRepresentationAttribute as attr|] ->
+ (attr.Flags &&& CompilationRepresentationFlags.UseNullAsTrueValue) = CompilationRepresentationFlags.UseNullAsTrueValue
+ | _ -> false
+ else
+ false
+ if isTwoCasedDU then
+ typ
+ else
let casesTyp = getUnionCasesTyp (typ, bindingFlags)
let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary
match caseTyp with
@@ -617,12 +851,17 @@ module internal Impl =
let checkTupleType(argName,tupleType) =
checkNonNull argName tupleType;
if not (isTupleType tupleType) then invalidArg argName (SR.GetString1(SR.notATupleType, tupleType.FullName))
+
+#if FX_RESHAPED_REFLECTION
+open ReflectionAdapters
+type BindingFlags = ReflectionAdapters.BindingFlags
+#endif
[<Sealed>]
type UnionCaseInfo(typ: System.Type, tag:int) =
// Cache the tag -> name map
let mutable names = None
- let getMethInfo() = Impl.getUnionCaseConstructorMethod (typ,tag,BindingFlags.Public ||| BindingFlags.NonPublic)
+ let getMethInfo() = Impl.getUnionCaseConstructorMethod (typ, tag, BindingFlags.Public ||| BindingFlags.NonPublic)
member x.Name =
match names with
| None -> (let conv = Impl.getUnionTagConverter (typ,BindingFlags.Public ||| BindingFlags.NonPublic) in names <- Some conv; conv tag)
@@ -660,13 +899,14 @@ type FSharpType =
static member IsRecord(typ:Type,?bindingFlags) =
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+
Impl.checkNonNull "typ" typ;
Impl.isRecordType (typ,bindingFlags)
static member IsUnion(typ:Type,?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkNonNull "typ" typ;
let typ = Impl.getTypeOfReprType (typ ,BindingFlags.Public ||| BindingFlags.NonPublic)
- let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.isUnionType (typ,bindingFlags)
static member IsFunction(typ:Type) =
@@ -701,7 +941,7 @@ type FSharpType =
static member GetRecordFields(recordType:Type,?bindingFlags) =
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkRecordType("recordType",recordType,bindingFlags);
- Impl.fieldPropsOfRecordType(recordType,bindingFlags)
+ Impl.fieldPropsOfRecordType(recordType,bindingFlags)
static member GetUnionCases (unionType:Type,?bindingFlags) =
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
@@ -711,7 +951,7 @@ type FSharpType =
Impl.getUnionTypeTagNameMap(unionType,bindingFlags) |> Array.mapi (fun i _ -> UnionCaseInfo(unionType,i))
static member IsExceptionRepresentation(exceptionType:Type, ?bindingFlags) =
- let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+ let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkNonNull "exceptionType" exceptionType;
Impl.isExceptionRepr(exceptionType,bindingFlags)
@@ -742,8 +982,8 @@ type FSharpValue =
info.GetValue(record,null)
static member GetRecordFields(record:obj,?bindingFlags) =
- Impl.checkNonNull "record" record;
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+ Impl.checkNonNull "record" record;
let typ = record.GetType()
if not (Impl.isRecordType(typ,bindingFlags)) then invalidArg "record" (SR.GetString(SR.objIsNotARecord));
Impl.getRecordReader (typ,bindingFlags) record
@@ -814,21 +1054,22 @@ type FSharpValue =
Impl.getTupleConstructorInfo (tupleType)
static member MakeUnion(unionCase:UnionCaseInfo,args: obj [],?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkNonNull "unionCase" unionCase;
- let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.getUnionCaseConstructor (unionCase.DeclaringType,unionCase.Tag,bindingFlags) args
static member PreComputeUnionConstructor (unionCase:UnionCaseInfo,?bindingFlags) =
- Impl.checkNonNull "unionCase" unionCase;
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+ Impl.checkNonNull "unionCase" unionCase;
Impl.getUnionCaseConstructor (unionCase.DeclaringType,unionCase.Tag,bindingFlags)
static member PreComputeUnionConstructorInfo(unionCase:UnionCaseInfo, ?bindingFlags) =
- Impl.checkNonNull "unionCase" unionCase;
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
- Impl.getUnionCaseConstructorMethod (unionCase.DeclaringType,unionCase.Tag,bindingFlags)
+ Impl.checkNonNull "unionCase" unionCase;
+ Impl.getUnionCaseConstructorMethod (unionCase.DeclaringType,unionCase.Tag,bindingFlags)
static member GetUnionFields(obj:obj,unionType:Type,?bindingFlags) =
+ let bindingFlags = defaultArg bindingFlags BindingFlags.Public
let ensureType (typ:Type,obj:obj) =
match typ with
| null ->
@@ -837,7 +1078,6 @@ type FSharpValue =
| _ -> obj.GetType()
| _ -> typ
//System.Console.WriteLine("typ1 = {0}",box unionType)
- let bindingFlags = defaultArg bindingFlags BindingFlags.Public
let unionType = ensureType(unionType,obj)
//System.Console.WriteLine("typ2 = {0}",box unionType)
Impl.checkNonNull "unionType" unionType;
@@ -847,7 +1087,7 @@ type FSharpValue =
let tag = Impl.getUnionTagReader (unionType,bindingFlags) obj
let flds = Impl.getUnionCaseRecordReader (unionType,tag,bindingFlags) obj
UnionCaseInfo(unionType,tag), flds
-
+
static member PreComputeUnionTagReader(unionType: Type,?bindingFlags) : (obj -> int) =
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkNonNull "unionType" unionType;
@@ -855,6 +1095,7 @@ type FSharpValue =
Impl.checkUnionType(unionType,bindingFlags);
Impl.getUnionTagReader (unionType ,bindingFlags)
+
static member PreComputeUnionTagMemberInfo(unionType: Type,?bindingFlags) =
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
Impl.checkNonNull "unionType" unionType;
@@ -863,17 +1104,96 @@ type FSharpValue =
Impl.getUnionTagMemberInfo(unionType ,bindingFlags)
static member PreComputeUnionReader(unionCase: UnionCaseInfo,?bindingFlags) : (obj -> obj[]) =
- Impl.checkNonNull "unionCase" unionCase;
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+ Impl.checkNonNull "unionCase" unionCase;
let typ = unionCase.DeclaringType
- Impl.getUnionCaseRecordReader (typ,unionCase.Tag,bindingFlags)
-
+ Impl.getUnionCaseRecordReader (typ,unionCase.Tag,bindingFlags)
static member GetExceptionFields(exn:obj, ?bindingFlags) =
- Impl.checkNonNull "exn" exn;
let bindingFlags = defaultArg bindingFlags BindingFlags.Public
+ Impl.checkNonNull "exn" exn;
let typ = exn.GetType()
Impl.checkExnType(typ,bindingFlags);
Impl.getRecordReader (typ,bindingFlags) exn
+module FSharpReflectionExtensions =
+
+ type FSharpType with
+
+ static member GetExceptionFields(exceptionType:Type, ?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.GetExceptionFields(exceptionType, bindingFlags)
+
+ static member IsExceptionRepresentation(exceptionType:Type, ?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.IsExceptionRepresentation(exceptionType, bindingFlags)
+
+ static member GetUnionCases (unionType:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.GetUnionCases(unionType, bindingFlags)
+
+ static member GetRecordFields(recordType:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.GetRecordFields(recordType, bindingFlags)
+
+ static member IsUnion(typ:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.IsUnion(typ, bindingFlags)
+
+ static member IsRecord(typ:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpType.IsRecord(typ, bindingFlags)
+
+ type FSharpValue with
+ static member MakeRecord(recordType:Type,args,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.MakeRecord(recordType, args, bindingFlags)
+
+ static member GetRecordFields(record:obj,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.GetRecordFields(record, bindingFlags)
+
+ static member PreComputeRecordReader(recordType:Type,?allowAccessToPrivateRepresentation) : (obj -> obj[]) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeRecordReader(recordType, bindingFlags)
+
+ static member PreComputeRecordConstructor(recordType:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeRecordConstructor(recordType, bindingFlags)
+
+ static member PreComputeRecordConstructorInfo(recordType:Type, ?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeRecordConstructorInfo(recordType, bindingFlags)
+
+ static member MakeUnion(unionCase:UnionCaseInfo,args: obj [],?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.MakeUnion(unionCase, args, bindingFlags)
+
+ static member PreComputeUnionConstructor (unionCase:UnionCaseInfo,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeUnionConstructor(unionCase, bindingFlags)
+
+ static member PreComputeUnionConstructorInfo(unionCase:UnionCaseInfo, ?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeUnionConstructorInfo(unionCase, bindingFlags)
+
+ static member PreComputeUnionTagMemberInfo(unionType: Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeUnionTagMemberInfo(unionType, bindingFlags)
+
+ static member GetUnionFields(obj:obj,unionType:Type,?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.GetUnionFields(obj, unionType, bindingFlags)
+
+ static member PreComputeUnionTagReader(unionType: Type,?allowAccessToPrivateRepresentation) : (obj -> int) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeUnionTagReader(unionType, bindingFlags)
+
+ static member PreComputeUnionReader(unionCase: UnionCaseInfo,?allowAccessToPrivateRepresentation) : (obj -> obj[]) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.PreComputeUnionReader(unionCase, bindingFlags)
+
+ static member GetExceptionFields(exn:obj, ?allowAccessToPrivateRepresentation) =
+ let bindingFlags = Impl.getBindingFlags allowAccessToPrivateRepresentation
+ FSharpValue.GetExceptionFields(exn, bindingFlags)
diff --git a/src/fsharp/FSharp.Core/reflect.fsi b/src/fsharp/FSharp.Core/reflect.fsi
index 6ce9de9..db0824d 100755
--- a/src/fsharp/FSharp.Core/reflect.fsi
+++ b/src/fsharp/FSharp.Core/reflect.fsi
@@ -59,16 +59,6 @@ type UnionCaseInfo =
/// such as records, unions and tuples.</summary>
type FSharpValue =
- /// <summary>Creates an instance of a record type.</summary>
- ///
- /// <remarks>Assumes the given input is a record type.</remarks>
- /// <param name="recordType">The type of record to make.</param>
- /// <param name="values">The array of values to initialize the record.</param>
- /// <param name="bindingFlags">Optional binding flags for the record.</param>
- /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
- /// <returns>The created record.</returns>
- static member MakeRecord: recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj
-
/// <summary>Reads a field from a record value.</summary>
///
/// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
@@ -77,16 +67,6 @@ type FSharpValue =
/// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
/// <returns>The field from the record.</returns>
static member GetRecordField: record:obj * info:PropertyInfo -> obj
-
- /// <summary>Reads all the fields from a record value.</summary>
- ///
- /// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
- /// <param name="record">The record object.</param>
- /// <param name="bindingFlags">Optional binding flags for the record.</param>
- /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
- /// <returns>The array of fields from the record.</returns>
- static member GetRecordFields: record:obj * ?bindingFlags:BindingFlags -> obj[]
-
/// <summary>Precompute a function for reading a particular field from a record.
/// Assumes the given type is a RecordType with a field of the given name.
@@ -100,6 +80,27 @@ type FSharpValue =
/// <returns>A function to read the specified field from the record.</returns>
static member PreComputeRecordFieldReader : info:PropertyInfo -> (obj -> obj)
+#if FX_RESHAPED_REFLECTION
+#else
+ /// <summary>Creates an instance of a record type.</summary>
+ ///
+ /// <remarks>Assumes the given input is a record type.</remarks>
+ /// <param name="recordType">The type of record to make.</param>
+ /// <param name="values">The array of values to initialize the record.</param>
+ /// <param name="bindingFlags">Optional binding flags for the record.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>The created record.</returns>
+ static member MakeRecord: recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj
+
+ /// <summary>Reads all the fields from a record value.</summary>
+ ///
+ /// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
+ /// <param name="record">The record object.</param>
+ /// <param name="bindingFlags">Optional binding flags for the record.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>The array of fields from the record.</returns>
+ static member GetRecordFields: record:obj * ?bindingFlags:BindingFlags -> obj[]
+
/// <summary>Precompute a function for reading all the fields from a record. The fields are returned in the
/// same order as the fields reported by a call to Microsoft.FSharp.Reflection.Type.GetInfo for
/// this type.</summary>
@@ -115,8 +116,6 @@ type FSharpValue =
/// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
/// <returns>An optimized reader for the given record type.</returns>
static member PreComputeRecordReader : recordType:Type * ?bindingFlags:BindingFlags -> (obj -> obj[])
-
-
/// <summary>Precompute a function for constructing a record value. </summary>
///
/// <remarks>Assumes the given type is a RecordType.
@@ -191,6 +190,16 @@ type FSharpValue =
/// <returns>The description of the constructor of the given union case.</returns>
static member PreComputeUnionConstructorInfo: unionCase:UnionCaseInfo * ?bindingFlags:BindingFlags -> MethodInfo
+ /// <summary>Reads all the fields from a value built using an instance of an F# exception declaration</summary>
+ ///
+ /// <remarks>Assumes the given input is an F# exception value. If not, ArgumentException is raised.</remarks>
+ /// <param name="exn">The exception instance.</param>
+ /// <param name="bindingFlags">Optional binding flags.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not an F# exception.</exception>
+ /// <returns>The fields from the given exception.</returns>
+ static member GetExceptionFields: exn:obj * ?bindingFlags:BindingFlags -> obj[]
+#endif
+
/// <summary>Creates an instance of a tuple type</summary>
///
/// <remarks>Assumes at least one element is given. If not, ArgumentException is raised.</remarks>
@@ -260,20 +269,12 @@ type FSharpValue =
/// <returns>A typed function from the given dynamic implementation.</returns>
static member MakeFunction : functionType:Type * implementation:(obj -> obj) -> obj
- /// <summary>Reads all the fields from a value built using an instance of an F# exception declaration</summary>
- ///
- /// <remarks>Assumes the given input is an F# exception value. If not, ArgumentException is raised.</remarks>
- /// <param name="exn">The exception instance.</param>
- /// <param name="bindingFlags">Optional binding flags.</param>
- /// <exception cref="System.ArgumentException">Thrown when the input type is not an F# exception.</exception>
- /// <returns>The fields from the given exception.</returns>
- static member GetExceptionFields: exn:obj * ?bindingFlags:BindingFlags -> obj[]
-
-
[<AbstractClass; Sealed>]
/// <summary>Contains operations associated with constructing and analyzing F# types such as records, unions and tuples</summary>
type FSharpType =
+#if FX_RESHAPED_REFLECTION
+#else
/// <summary>Reads all the fields from a record value, in declaration order</summary>
///
/// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
@@ -291,6 +292,36 @@ type FSharpType =
/// <returns>An array of descriptions of the cases of the given union type.</returns>
static member GetUnionCases: unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo[]
+
+ /// <summary>Return true if the <c>typ</c> is a representation of an F# record type </summary>
+ /// <param name="typ">The type to check.</param>
+ /// <param name="bindingFlags">Optional binding flags.</param>
+ /// <returns>True if the type check succeeds.</returns>
+ static member IsRecord: typ:Type * ?bindingFlags:BindingFlags -> bool
+
+ /// <summary>Returns true if the <c>typ</c> is a representation of an F# union type or the runtime type of a value of that type</summary>
+ /// <param name="typ">The type to check.</param>
+ /// <param name="bindingFlags">Optional binding flags.</param>
+ /// <returns>True if the type check succeeds.</returns>
+ static member IsUnion: typ:Type * ?bindingFlags:BindingFlags -> bool
+
+ /// <summary>Reads all the fields from an F# exception declaration, in declaration order</summary>
+ ///
+ /// <remarks>Assumes <c>exceptionType</c> is an exception representation type. If not, ArgumentException is raised.</remarks>
+ /// <param name="exceptionType">The exception type to read.</param>
+ /// <param name="bindingFlags">Optional binding flags.</param>
+ /// <exception cref="System.ArgumentException">Thrown if the given type is not an exception.</exception>
+ /// <returns>An array containing the PropertyInfo of each field in the exception.</returns>
+ static member GetExceptionFields: exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo[]
+
+ /// <summary>Returns true if the <c>typ</c> is a representation of an F# exception declaration</summary>
+ /// <param name="exceptionType">The type to check.</param>
+ /// <param name="bindingFlags">Optional binding flags.</param>
+ /// <returns>True if the type check is an F# exception.</returns>
+ static member IsExceptionRepresentation: exceptionType:Type * ?bindingFlags:BindingFlags -> bool
+
+#endif
+
/// <summary>Returns a <c>System.Type</c> representing the F# function type with the given domain and range</summary>
/// <param name="domain">The input type of the function.</param>
/// <param name="range">The output type of the function.</param>
@@ -317,17 +348,6 @@ type FSharpType =
/// <returns>True if the type check succeeds.</returns>
static member IsModule: typ:Type -> bool
- /// <summary>Return true if the <c>typ</c> is a representation of an F# record type </summary>
- /// <param name="typ">The type to check.</param>
- /// <param name="bindingFlags">Optional binding flags.</param>
- /// <returns>True if the type check succeeds.</returns>
- static member IsRecord: typ:Type * ?bindingFlags:BindingFlags -> bool
-
- /// <summary>Returns true if the <c>typ</c> is a representation of an F# union type or the runtime type of a value of that type</summary>
- /// <param name="typ">The type to check.</param>
- /// <param name="bindingFlags">Optional binding flags.</param>
- /// <returns>True if the type check succeeds.</returns>
- static member IsUnion: typ:Type * ?bindingFlags:BindingFlags -> bool
/// <summary>Gets the tuple elements from the representation of an F# tuple type.</summary>
/// <param name="tupleType">The input tuple type.</param>
@@ -339,24 +359,258 @@ type FSharpType =
/// <returns>A tuple of the domain and range types of the input function.</returns>
static member GetFunctionElements : functionType:Type -> Type * Type
- /// <summary>Reads all the fields from an F# exception declaration, in declaration order</summary>
- ///
- /// <remarks>Assumes <c>exceptionType</c> is an exception representation type. If not, ArgumentException is raised.</remarks>
- /// <param name="exceptionType">The exception type to read.</param>
- /// <param name="bindingFlags">Optional binding flags.</param>
- /// <exception cref="System.ArgumentException">Thrown if the given type is not an exception.</exception>
- /// <returns>An array containing the PropertyInfo of each field in the exception.</returns>
- static member GetExceptionFields: exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo[]
+[<AutoOpen>]
+module FSharpReflectionExtensions =
+ type FSharpValue with
+ /// <summary>Creates an instance of a record type.</summary>
+ ///
+ /// <remarks>Assumes the given input is a record type.</remarks>
+ /// <param name="recordType">The type of record to make.</param>
+ /// <param name="values">The array of values to initialize the record.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flags that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>The created record.</returns>
+ static member MakeRecord: recordType:Type * values:obj [] * ?allowAccessToPrivateRepresentation : bool -> obj
+ /// <summary>Reads all the fields from a record value.</summary>
+ ///
+ /// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
+ /// <param name="record">The record object.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>The array of fields from the record.</returns>
+ static member GetRecordFields: record:obj * ?allowAccessToPrivateRepresentation : bool -> obj[]
+
+ /// <summary>Precompute a function for reading all the fields from a record. The fields are returned in the
+ /// same order as the fields reported by a call to Microsoft.FSharp.Reflection.Type.GetInfo for
+ /// this type.</summary>
+ ///
+ /// <remarks>Assumes the given type is a RecordType.
+ /// If not, ArgumentException is raised during pre-computation.
+ ///
+ /// Using the computed function will typically be faster than executing a corresponding call to Value.GetInfo
+ /// because the path executed by the computed function is optimized given the knowledge that it will be
+ /// used to read values of the given type.</remarks>
+ /// <param name="recordType">The type of record to read.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>An optimized reader for the given record type.</returns>
+ static member PreComputeRecordReader : recordType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj -> obj[])
+ /// <summary>Precompute a function for constructing a record value. </summary>
+ ///
+ /// <remarks>Assumes the given type is a RecordType.
+ /// If not, ArgumentException is raised during pre-computation.</remarks>
+ /// <param name="recordType">The type of record to construct.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a record type.</exception>
+ /// <returns>A function to construct records of the given type.</returns>
+ static member PreComputeRecordConstructor : recordType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj[] -> obj)
+
+ /// <summary>Get a ConstructorInfo for a record type</summary>
+ /// <param name="recordType">The record type.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>A ConstructorInfo for the given record type.</returns>
+ static member PreComputeRecordConstructorInfo: recordType:Type * ?allowAccessToPrivateRepresentation : bool-> ConstructorInfo
+
+ /// <summary>Create a union case value.</summary>
+ /// <param name="unionCase">The description of the union case to create.</param>
+ /// <param name="args">The array of arguments to construct the given case.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>The constructed union case.</returns>
+ static member MakeUnion: unionCase:UnionCaseInfo * args:obj [] * ?allowAccessToPrivateRepresentation : bool-> obj
+
+ /// <summary>Identify the union case and its fields for an object</summary>
+ ///
+ /// <remarks>Assumes the given input is a union case value. If not, ArgumentException is raised.
+ ///
+ /// If the type is not given, then the runtime type of the input object is used to identify the
+ /// relevant union type. The type should always be given if the input object may be null. For example,
+ /// option values may be represented using the 'null'.</remarks>
+ /// <param name="value">The input union case.</param>
+ /// <param name="unionType">The union type containing the value.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a union case value.</exception>
+ /// <returns>The description of the union case and its fields.</returns>
+ static member GetUnionFields: value:obj * unionType:Type * ?allowAccessToPrivateRepresentation : bool -> UnionCaseInfo * obj []
+
+ /// <summary>Assumes the given type is a union type.
+ /// If not, ArgumentException is raised during pre-computation.</summary>
+ ///
+ /// <remarks>Using the computed function is more efficient than calling GetUnionCase
+ /// because the path executed by the computed function is optimized given the knowledge that it will be
+ /// used to read values of the given type.</remarks>
+ /// <param name="unionType">The type of union to optimize reading.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>An optimized function to read the tags of the given union type.</returns>
+ static member PreComputeUnionTagReader : unionType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj -> int)
+
+ /// <summary>Precompute a property or static method for reading an integer representing the case tag of a union type.</summary>
+ /// <param name="unionType">The type of union to read.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>The description of the union case reader.</returns>
+ static member PreComputeUnionTagMemberInfo : unionType:Type * ?allowAccessToPrivateRepresentation : bool -> MemberInfo
+
+ /// <summary>Precomputes a function for reading all the fields for a particular discriminator case of a union type</summary>
+ ///
+ /// <remarks>Using the computed function will typically be faster than executing a corresponding call to GetFields</remarks>
+ /// <param name="unionCase">The description of the union case to read.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>A function to for reading the fields of the given union case.</returns>
+ static member PreComputeUnionReader : unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> (obj -> obj[])
+
+ /// <summary>Precomputes a function for constructing a discriminated union value for a particular union case. </summary>
+ /// <param name="unionCase">The description of the union case.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>A function for constructing values of the given union case.</returns>
+ static member PreComputeUnionConstructor : unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> (obj[] -> obj)
+
+ /// <summary>A method that constructs objects of the given case</summary>
+ /// <param name="unionCase">The description of the union case.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>The description of the constructor of the given union case.</returns>
+ static member PreComputeUnionConstructorInfo: unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> MethodInfo
+
+ /// <summary>Reads all the fields from a value built using an instance of an F# exception declaration</summary>
+ ///
+ /// <remarks>Assumes the given input is an F# exception value. If not, ArgumentException is raised.</remarks>
+ /// <param name="exn">The exception instance.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not an F# exception.</exception>
+ /// <returns>The fields from the given exception.</returns>
+ static member GetExceptionFields: exn:obj * ?allowAccessToPrivateRepresentation : bool -> obj[]
+
+ type FSharpType with
+ /// <summary>Reads all the fields from a record value, in declaration order</summary>
+ ///
+ /// <remarks>Assumes the given input is a record value. If not, ArgumentException is raised.</remarks>
+ /// <param name="recordType">The input record type.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>An array of descriptions of the properties of the record type.</returns>
+ static member GetRecordFields: recordType:Type * ?allowAccessToPrivateRepresentation : bool -> PropertyInfo[]
+
+ /// <summary>Gets the cases of a union type.</summary>
+ ///
+ /// <remarks>Assumes the given type is a union type. If not, ArgumentException is raised during pre-computation.</remarks>
+ /// <param name="unionType">The input union type.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown when the input type is not a union type.</exception>
+ /// <returns>An array of descriptions of the cases of the given union type.</returns>
+ static member GetUnionCases: unionType:Type * ?allowAccessToPrivateRepresentation : bool -> UnionCaseInfo[]
+
+
+ /// <summary>Return true if the <c>typ</c> is a representation of an F# record type </summary>
+ /// <param name="typ">The type to check.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>True if the type check succeeds.</returns>
+ static member IsRecord: typ:Type * ?allowAccessToPrivateRepresentation : bool -> bool
+
+ /// <summary>Returns true if the <c>typ</c> is a representation of an F# union type or the runtime type of a value of that type</summary>
+ /// <param name="typ">The type to check.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>True if the type check succeeds.</returns>
+ static member IsUnion: typ:Type * ?allowAccessToPrivateRepresentation : bool -> bool
+
+ /// <summary>Reads all the fields from an F# exception declaration, in declaration order</summary>
+ ///
+ /// <remarks>Assumes <c>exceptionType</c> is an exception representation type. If not, ArgumentException is raised.</remarks>
+ /// <param name="exceptionType">The exception type to read.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <exception cref="System.ArgumentException">Thrown if the given type is not an exception.</exception>
+ /// <returns>An array containing the PropertyInfo of each field in the exception.</returns>
+ static member GetExceptionFields: exceptionType:Type * ?allowAccessToPrivateRepresentation : bool -> PropertyInfo[]
+
+ /// <summary>Returns true if the <c>typ</c> is a representation of an F# exception declaration</summary>
+ /// <param name="exceptionType">The type to check.</param>
+ /// <param name="allowAccessToPrivateRepresentation">Optional flag that denotes accessibility of the private representation.</param>
+ /// <returns>True if the type check is an F# exception.</returns>
+ static member IsExceptionRepresentation: exceptionType:Type * ?allowAccessToPrivateRepresentation : bool -> bool
+
+#if FX_RESHAPED_REFLECTION
+
+namespace Microsoft.FSharp.Core
- /// <summary>Returns true if the <c>typ</c> is a representation of an F# exception declaration</summary>
- /// <param name="exceptionType">The type to check.</param>
- /// <param name="bindingFlags">Optional binding flags.</param>
- /// <returns>True if the type check is an F# exception.</returns>
- static member IsExceptionRepresentation: exceptionType:Type * ?bindingFlags:BindingFlags -> bool
+open System
+open System.Reflection
+
+module internal ReflectionAdapters =
+
+ [<System.Flags>]
+ type BindingFlags =
+ | DeclaredOnly = 2
+ | Instance = 4
+ | Static = 8
+ | Public = 16
+ | NonPublic = 32
+
+ val isDeclaredFlag : BindingFlags -> bool
+ val isPublicFlag : BindingFlags -> bool
+ val isStaticFlag : BindingFlags -> bool
+ val isInstanceFlag : BindingFlags -> bool
+ val isNonPublicFlag : BindingFlags -> bool
+ val isAcceptable : BindingFlags -> isStatic : bool -> isPublic : bool -> bool
+
+ [<System.Flags>]
+ type TypeCode =
+ | Int32 = 0
+ | Int64 = 1
+ | Byte = 2
+ | SByte = 3
+ | Int16 = 4
+ | UInt16 = 5
+ | UInt32 = 6
+ | UInt64 = 7
+ | Single = 8
+ | Double = 9
+ | Decimal = 10
+ | Other = 11
+
+ type System.Type with
+ member GetNestedType : name : string * bindingFlags : BindingFlags -> Type
+ member GetMethods : bindingFlags : BindingFlags -> MethodInfo[]
+ member GetFields : bindingFlags : BindingFlags -> FieldInfo[]
+ member GetProperties : ?bindingFlags : BindingFlags -> PropertyInfo[]
+ member GetMethod : name : string * ?bindingFlags : BindingFlags -> MethodInfo
+ member GetProperty : name : string * bindingFlags : BindingFlags -> PropertyInfo
+ member IsGenericTypeDefinition : bool
+ member GetGenericArguments : unit -> Type[]
+ member BaseType : Type
+ member GetConstructor : parameterTypes : Type[] -> ConstructorInfo
+ member GetInterfaces : unit -> Type[]
+ member GetConstructors : ?bindingFlags : BindingFlags -> ConstructorInfo[]
+ member GetMethods : unit -> MethodInfo[]
+ member Assembly : Assembly
+ member IsSubclassOf : Type -> bool
+ member IsEnum : bool
+ member GetField : string * BindingFlags -> FieldInfo
+ member GetProperty : string * Type * Type[] -> PropertyInfo
+ static member GetTypeCode : System.Type -> TypeCode
+
+ type System.Reflection.Assembly with
+ member GetTypes : unit -> Type[]
+
+ type System.Reflection.MemberInfo with
+ member GetCustomAttributes : attributeType : Type * inherits : bool -> obj[]
+
+ type System.Reflection.MethodInfo with
+ member GetCustomAttributes : inherits : bool -> obj[]
+
+ type System.Reflection.PropertyInfo with
+ member GetGetMethod : bool -> MethodInfo
+ member GetSetMethod : bool -> MethodInfo
+
+ type System.Delegate with
+ static member CreateDelegate : Type * MethodInfo -> System.Delegate
+ static member CreateDelegate : Type * obj * MethodInfo -> System.Delegate
+
+#endif
+
+namespace Microsoft.FSharp.Reflection
-#if SILVERLIGHT
-[<Class>]
-type DynamicFunction<'T1,'T2> =
- inherit FSharpFunc<obj -> obj, obj>
- new : unit -> DynamicFunction<'T1,'T2>
+open Microsoft.FSharp.Core
+
+module internal ReflectionUtils =
+#if FX_RESHAPED_REFLECTION
+ type BindingFlags = ReflectionAdapters.BindingFlags
+#else
+ type BindingFlags = System.Reflection.BindingFlags
#endif
+ val toBindingFlags : allowAccessToNonPublicMembers : bool -> BindingFlags
\ No newline at end of file
diff --git a/src/fsharp/FSharp.Core/seq.fs b/src/fsharp/FSharp.Core/seq.fs
index 2ec7a32..8237c89 100755
--- a/src/fsharp/FSharp.Core/seq.fs
+++ b/src/fsharp/FSharp.Core/seq.fs
@@ -229,7 +229,7 @@ namespace Microsoft.FSharp.Collections
if !index = unstarted then notStarted()
if !index = completed then alreadyFinished()
match box !current with
- | null -> current := Lazy.Create(fun () -> f !index);
+ | null -> current := Lazy<_>.Create(fun () -> f !index);
| _ -> ()
// forced or re-forced immediately.
(!current).Force()
diff --git a/src/fsharp/FSharp.Data.TypeProviders/Util.fsi b/src/fsharp/FSharp.Data.TypeProviders/Util.fsi
index 1994d78..bc4e1b5 100755
--- a/src/fsharp/FSharp.Data.TypeProviders/Util.fsi
+++ b/src/fsharp/FSharp.Data.TypeProviders/Util.fsi
@@ -13,9 +13,6 @@ module internal Util =
val dataSvcUtilExe : unit -> string
val edmGenExe : unit -> string
val svcUtilExe : unit -> string
- val xsdExe : unit -> string
-
- val sdkPath : unit -> string
val sdkUtil : string -> string
diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj
index eef30c5..c76e639 100755
--- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj
+++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -29,7 +19,7 @@
<ProjectGuid>{9D7C9060-9263-40EB-8FE3-1E4E3C6D941C}</ProjectGuid>
<AllowCrossTargeting>true</AllowCrossTargeting>
<OtherFlags>$(OtherFlags) --stackReserveSize:4096000</OtherFlags>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v2.0</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v2.0</TargetFrameworkVersion>
</PropertyGroup>
<ItemGroup>
<Compile Include="..\fscmain.fs">
@@ -42,7 +32,7 @@
<Reference Include="System" />
<Reference Include="System.Windows.Forms" />
<Reference Include="System.Runtime.Remoting" />
- <Reference Include="System.Numerics" Condition="'$(TargetFramework)' == 'net40' OR '$(TargetFramework)' == 'mono40'" />
+ <Reference Include="System.Numerics" Condition="'$(TargetFramework)'=='net40'" />
<ProjectReference Include="..\FSharp.Compiler-proto\FSharp.Compiler-proto.fsproj">
<Project>{33E0FB8C-93DC-4AD7-9DCD-9FBDA6C2F061}</Project>
<Name>FSharp.Compiler-proto</Name>
diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj
index b4b8e44..829b339 100755
--- a/src/fsharp/Fsc/Fsc.fsproj
+++ b/src/fsharp/Fsc/Fsc.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -27,7 +17,7 @@
<AssemblyName>fsc</AssemblyName>
<DefineConstants>EXTENSIONTYPING;COMPILER;$(DefineConstants)</DefineConstants>
<AllowCrossTargeting>true</AllowCrossTargeting>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v2.0</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v2.0</TargetFrameworkVersion>
<OtherFlags>$(OtherFlags) --warnon:1182</OtherFlags>
</PropertyGroup>
<ItemGroup>
diff --git a/src/fsharp/InternalFileSystemUtils.fs b/src/fsharp/InternalFileSystemUtils.fs
index 3a4384c..1f1b8c8 100755
--- a/src/fsharp/InternalFileSystemUtils.fs
+++ b/src/fsharp/InternalFileSystemUtils.fs
@@ -33,6 +33,11 @@ open System
open System.IO
open System.Diagnostics
+type internal File() =
+ static member SafeExists filename = FileSystem.SafeExists filename
+ //static member SafeNewFileStream(filename:string,mode:FileMode,access:FileAccess,share:FileShare) =
+ // FileSystem new FileStream(filename,mode,access,share)
+
type internal Path() =
static member IsInvalidDirectory(path:string) =
diff --git a/src/fsharp/InternalFileSystemUtils.fsi b/src/fsharp/InternalFileSystemUtils.fsi
index 65acd27..cf718bd 100755
--- a/src/fsharp/InternalFileSystemUtils.fsi
+++ b/src/fsharp/InternalFileSystemUtils.fsi
@@ -13,6 +13,10 @@
namespace Internal.Utilities.FileSystem
[<Class>]
+ type internal File =
+ static member SafeExists : filename:string -> bool
+
+ [<Class>]
type internal Path =
static member IsInvalidDirectory : path:string -> bool
static member IsInvalidPath : path:string -> bool
diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs
index 8f2690a..61cd758 100755
--- a/src/fsharp/NicePrint.fs
+++ b/src/fsharp/NicePrint.fs
@@ -669,8 +669,8 @@ module private PrintTypes =
if denv.showAttributes then
// Don't display DllImport attributes in generated signatures
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_DllImportAttribute >> not)
- let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_ContextStaticAttribute >> not)
- let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_ThreadStaticAttribute >> not)
+ let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_ContextStaticAttribute >> not)
+ let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_ThreadStaticAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_EntryPointAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_MarshalAsAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_ReflectedDefinitionAttribute >> not)
@@ -1190,12 +1190,17 @@ module InfoMemberPrinting =
// Container.Method(argName1:argType1, ..., argNameN:argTypeN) : retType
let private formatMethInfoToBufferCSharpStyle amap m denv os (minfo:MethInfo) minst =
let retTy = minfo.GetFSharpReturnTy(amap, m, minst)
- outputTyconRef denv os (tcrefOfAppTy amap.g minfo.EnclosingType);
+ if minfo.IsExtensionMember then
+ bprintf os "(%s) " (FSComp.SR.typeInfoExtension())
+ if isAppTy amap.g minfo.EnclosingType then
+ outputTyconRef denv os (tcrefOfAppTy amap.g minfo.EnclosingType)
+ else
+ outputTy denv os minfo.EnclosingType
if minfo.IsConstructor then
bprintf os "("
else
bprintf os "."
- outputTypars denv minfo.LogicalName os minfo.FormalMethodTypars;
+ outputTypars denv minfo.LogicalName os minfo.FormalMethodTypars
bprintf os "("
let paramDatas = minfo.GetParamDatas (amap, m, minst)
paramDatas |> List.iter (List.iteri (fun i arg ->
@@ -1205,15 +1210,19 @@ module InfoMemberPrinting =
outputTy denv os retTy
- // Prettify this baby
- let prettifyILMethInfo (amap:Import.ImportMap) m (minfo:MethInfo) = function
- | ILMethInfo(ILTypeInfo(tcref,tref,tinst,tdef),extInfo,mdef,_) ->
- let _,tys,_ = PrettyTypes.PrettifyTypesN amap.g (tinst @ minfo.FormalMethodInst)
- let tinst,minst = List.chop tinst.Length tys
- let minfo = ILMethInfo.Create (amap, m, ILTypeInfo(tcref,tref,tinst,tdef), extInfo, None, mdef)
- minfo,minst
- | ILFSMethInfo _ as ilminfo ->
- ILMeth(amap.g,ilminfo,None),[]
+ // Prettify this baby
+ let prettifyILMethInfo (amap:Import.ImportMap) m (minfo:MethInfo) ilMethInfo =
+ match ilMethInfo with
+ | ILMethInfo(_, apparentTy,None, mdef,_) ->
+ let _,tys,_ = PrettyTypes.PrettifyTypesN amap.g (apparentTy :: minfo.FormalMethodInst)
+ let apparentTyR,minst = List.headAndTail tys
+ let minfo = MethInfo.CreateILMeth (amap, m, apparentTyR, mdef)
+ minfo, minst
+ | ILMethInfo (_, apparentTy,Some declaringTyconRef,mdef,_) ->
+ let _,tys,_ = PrettyTypes.PrettifyTypesN amap.g (apparentTy :: minfo.FormalMethodInst)
+ let apparentTyR,minst = List.headAndTail tys
+ let minfo = MethInfo.CreateILExtensionMeth(amap, m, apparentTyR, declaringTyconRef, minfo.ExtensionMemberPriorityOption, mdef)
+ minfo, minst
/// Format a method to a buffer using "standalone" display style.
@@ -1222,16 +1231,21 @@ module InfoMemberPrinting =
/// The formats differ between .NET/provided methods and F# methods. Surprisingly people don't really seem
/// to notice this, or they find it helpful. It feels that moving from this position should not be done lightly.
//
- // For F# members, we use layoutValOrMemberm which gives:
+ // For F# members:
// new : unit -> retType
// new : argName1:argType1 * ... * argNameN:argTypeN -> retType
// Container.Method : unit -> retType
// Container.Method : argName1:argType1 * ... * argNameN:argTypeN -> retType
//
+ // For F# extension members:
+ // ApparentContainer.Method : argName1:argType1 * ... * argNameN:argTypeN -> retType
+ //
// For C# and provided members:
// Container(argName1:argType1, ..., argNameN:argTypeN) : retType
// Container.Method(argName1:argType1, ..., argNameN:argTypeN) : retType
//
+ // For C# extension members:
+ // ApparentContainer.Method(argName1:argType1, ..., argNameN:argTypeN) : retType
let formatMethInfoToBufferFreeStyle amap m denv os minfo =
match minfo with
| DefaultStructCtor(g,_typ) ->
@@ -1240,7 +1254,6 @@ module InfoMemberPrinting =
| FSMeth(_,_,vref,_) ->
vref.Deref |> PrintTastMemberOrVals.layoutValOrMember { denv with showMemberContainers=true; } |> bufferL os
| ILMeth(_,ilminfo,_) ->
- // Prettify first
let minfo,minst = prettifyILMethInfo amap m minfo ilminfo
formatMethInfoToBufferCSharpStyle amap m denv os minfo minst
#if EXTENSIONTYPING
@@ -1264,34 +1277,49 @@ module private TastDefinitionPrinting =
let nameL = wordL tycon.DisplayName
let nameL = layoutAccessibility denv tycon.Accessibility nameL // "type-accessibility"
let tps =
- match PartitionValTypars denv.g v with
+ match PartitionValTyparsForApparentEnclosingType denv.g v with
| Some(_,memberParentTypars,_,_,_) -> memberParentTypars
- | None -> []
+ | None -> []
let lhsL = wordL "type" ^^ layoutTyparDecls denv nameL tycon.IsPrefixDisplay tps
(lhsL ^^ wordL "with") @@-- (PrintTastMemberOrVals.layoutValOrMember denv v)
let layoutExtensionMembers denv vs =
- aboveListL (List.map (layoutExtensionMember denv) vs)
+ aboveListL (List.map (layoutExtensionMember denv) vs)
+
+ let layoutRecdField addAccess denv (fld:RecdField) =
+ let lhs = wordL fld.Name
+ let lhs = (if addAccess then layoutAccessibility denv fld.Accessibility lhs else lhs)
+ let lhs = if fld.IsMutable then wordL "mutable" --- lhs else lhs
+ (lhs ^^ rightL ":") --- layoutType denv fld.FormalType
+
+ let layoutUnionOrExceptionField denv isGenerated i (fld : RecdField) =
+ if isGenerated i fld then layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 2 fld.FormalType
+ else layoutRecdField false denv fld
+
+ let isGeneratedUnionCaseField pos (f : RecdField) =
+ if pos < 0 then f.Name = "Item"
+ else f.Name = "Item" + string (pos + 1)
+
+ let isGeneratedExceptionField pos (f : RecdField) =
+ f.Name = "Data" + (string pos)
- let layoutUnionCaseArgTypes denv argtys =
- sepListL (wordL "*") (List.map (layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 2) argtys)
+ let layoutUnionCaseFields denv isUnionCase fields =
+ match fields with
+ | [f] when isUnionCase -> layoutUnionOrExceptionField denv isGeneratedUnionCaseField -1 f
+ | _ ->
+ let isGenerated = if isUnionCase then isGeneratedUnionCaseField else isGeneratedExceptionField
+ sepListL (wordL "*") (List.mapi (layoutUnionOrExceptionField denv isGenerated) fields)
let layoutUnionCase denv prefixL ucase =
let nmL = wordL (DemangleOperatorName ucase.Id.idText)
//let nmL = layoutAccessibility denv ucase.Accessibility nmL
- match ucase.RecdFields |> List.map (fun rfld -> rfld.FormalType) with
+ match ucase.RecdFields with
| [] -> (prefixL ^^ nmL)
- | argtys -> (prefixL ^^ nmL ^^ wordL "of") --- layoutUnionCaseArgTypes denv argtys
+ | fields -> (prefixL ^^ nmL ^^ wordL "of") --- layoutUnionCaseFields denv true fields
let layoutUnionCases denv ucases =
let prefixL = wordL "|" // See bug://2964 - always prefix in case preceeded by accessibility modifier
List.map (layoutUnionCase denv prefixL) ucases
-
- let layoutRecdField addAccess denv (fld:RecdField) =
- let lhs = wordL fld.Name
- let lhs = (if addAccess then layoutAccessibility denv fld.Accessibility lhs else lhs)
- let lhs = if fld.IsMutable then wordL "mutable" --- lhs else lhs
- (lhs ^^ rightL ":") --- layoutType denv fld.FormalType
/// When to force a break? "type tyname = <HERE> repn"
/// When repn is class or datatype constructors (not single one).
@@ -1615,7 +1643,7 @@ module private TastDefinitionPrinting =
| TExnFresh r ->
match r.TrueFieldsAsList with
| [] -> emptyL
- | r -> wordL "of" --- layoutUnionCaseArgTypes denv (r |> List.map (fun rfld -> rfld.FormalType))
+ | r -> wordL "of" --- layoutUnionCaseFields denv false r
exnL ^^ reprL
@@ -1770,11 +1798,14 @@ let stringOfMethInfo amap m denv d = bufs (fun buf -> InfoMemberPrinting.formatM
/// Convert a ParamData to a string
let stringOfParamData denv paramData = bufs (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData)
-
let outputILTypeRef denv os x = x |> PrintIL.layoutILTypeRef denv |> bufferL os
let outputExnDef denv os x = x |> TastDefinitionPrinting.layoutExnDefn denv |> bufferL os
let stringOfTyparConstraints denv x = x |> PrintTypes.layoutConstraintsWithInfo denv SimplifyTypes.typeSimplificationInfo0 |> showL
let outputTycon denv infoReader ad m (* width *) os x = TastDefinitionPrinting.layoutTycon denv infoReader ad m true (wordL "type") x (* |> Layout.squashTo width *) |> bufferL os
+let outputUnionCases denv os x = x |> TastDefinitionPrinting.layoutUnionCaseFields denv true |> bufferL os
+/// Pass negative number as pos in case of single cased discriminated unions
+let isGeneratedUnionCaseField pos f = TastDefinitionPrinting.isGeneratedUnionCaseField pos f
+let isGeneratedExceptionField pos f = TastDefinitionPrinting.isGeneratedExceptionField pos f
let stringOfTyparConstraint denv tpc = stringOfTyparConstraints denv [tpc]
let stringOfTy denv x = x |> PrintTypes.layoutType denv |> showL
let prettyStringOfTy denv x = x |> PrintTypes.layoutPrettyType denv |> showL
diff --git a/src/fsharp/ReferenceResolution.fs b/src/fsharp/ReferenceResolution.fs
index a3f1913..a2ea037 100755
--- a/src/fsharp/ReferenceResolution.fs
+++ b/src/fsharp/ReferenceResolution.fs
@@ -27,6 +27,8 @@ module internal MSBuildResolver =
type ResolutionEnvironment = CompileTimeLike | RuntimeLike | DesigntimeLike
#if SILVERLIGHT
+ let HighestInstalledNetFrameworkVersionMajorMinor() =
+ 4,"v5.0"
#else
open System
open Microsoft.Build.Tasks
@@ -63,17 +65,94 @@ module internal MSBuildResolver =
| null -> System.Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF
| s -> s
PF + @"\Reference Assemblies\Microsoft\Framework\.NETFramework"
-
+
+
let ReplaceFrameworkVariables(dirs) =
let windowsFramework = System.Environment.GetEnvironmentVariable("windir")+ @"\Microsoft.NET\Framework"
let referenceAssemblies = DotNetFrameworkReferenceAssembliesRootDirectory
dirs|>List.map(fun (d:string)->d.Replace("{WindowsFramework}",windowsFramework).Replace("{ReferenceAssemblies}",referenceAssemblies))
-
+
+
+ // ATTENTION!: the following code needs to be updated every time we are switching to the new MSBuild version because new .NET framework version was released
+ // 1. List of frameworks
+ // 2. DeriveTargetFrameworkDirectoriesFor45Plus
+ // 3. HighestInstalledNetFrameworkVersionMajorMinor
+ // 4. GetPathToDotNetFramework
+ [<Literal>]
+ let private Net10 = "v1.0"
+ [<Literal>]
+ let private Net11 = "v1.1"
+ [<Literal>]
+ let private Net20 = "v2.0"
+ [<Literal>]
+ let private Net30 = "v3.0"
+ [<Literal>]
+ let private Net35 = "v3.5"
+ [<Literal>]
+ let private Net40 = "v4.0"
+ [<Literal>]
+ let private Net45 = "v4.5"
+ [<Literal>]
+ let private Net451 = "v4.5.1"
+
+ let SupportedNetFrameworkVersions = set [ Net20; Net30; Net35; Net40; Net45; Net451; (*SL only*) "v5.0" ]
+
+ let GetPathToDotNetFramework(v) =
+#if FX_ATLEAST_45
+ let v =
+ match v with
+ | Net11 -> Some TargetDotNetFrameworkVersion.Version11
+ | Net20 -> Some TargetDotNetFrameworkVersion.Version20
+ | Net30 -> Some TargetDotNetFrameworkVersion.Version30
+ | Net35 -> Some TargetDotNetFrameworkVersion.Version35
+ | Net40 -> Some TargetDotNetFrameworkVersion.Version40
+ | Net45 -> Some TargetDotNetFrameworkVersion.Version45
+ | Net451 -> Some TargetDotNetFrameworkVersion.Version451
+ | _ -> assert false; None
+ match v with
+ | Some v ->
+ match ToolLocationHelper.GetPathToDotNetFramework v with
+ | null -> []
+ | x -> [x]
+ | _ -> []
+#else
+ // FX_ATLEAST_45 is not defined is required for step when we build compiler with proto compiler and this branch should not be hit
+ assert false
+ []
+#endif
+
+ let DeriveTargetFrameworkDirectoriesFor40Plus(version) =
+ // starting with .Net 4.0, the runtime dirs (WindowsFramework) are never used by MSBuild RAR
+ let v =
+ match version with
+ | Net40 -> Some TargetDotNetFrameworkVersion.Version40
+#if FX_ATLEAST_45
+ | Net45 -> Some TargetDotNetFrameworkVersion.Version45
+ | Net451 -> Some TargetDotNetFrameworkVersion.Version451
+#endif
+ | _ -> assert false; None // unknown version - some parts in the code are not synced
+ match v with
+ | Some v ->
+ match ToolLocationHelper.GetPathToDotNetFrameworkReferenceAssemblies v with
+ | null -> []
+ | x -> [x]
+ | None -> []
+
+ /// Determine the default "frameworkVersion" (which is passed into MSBuild resolve).
+ /// This code uses MSBuild to determine version of the highest installed framework.
+ let HighestInstalledNetFrameworkVersionMajorMinor() =
+#if FX_ATLEAST_45
+ if box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version451)) <> null then 4, Net451
+ elif box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version45)) <> null then 4, Net45
+ else 4, Net40 // version is 4.0 assumed since this code is running.
+#else
+ // FX_ATLEAST_45 is not defined is required for step when we build compiler with proto compiler and this branch should not be hit
+ 4, Net40
+#endif
/// Derive the target framework directories.
let DeriveTargetFrameworkDirectories
- (targetFrameworkVersion:string, // e.g. v2.0, v3.0, v3.5, v4.0 etc
- excludeNonExecutableAssemblies:bool, // True when the assembly must be executable and not just a stub meta assembly.
+ (targetFrameworkVersion:string, // e.g. v2.0, v3.0, v3.5, v4.0 etc
logmessage:string->unit) =
let targetFrameworkVersion =
if not(targetFrameworkVersion.StartsWith("v",StringComparison.Ordinal)) then "v"^targetFrameworkVersion
@@ -81,14 +160,12 @@ module internal MSBuildResolver =
let FrameworkStartsWith(short) =
targetFrameworkVersion.StartsWith(short,StringComparison.Ordinal)
let result =
- if FrameworkStartsWith("v1.0") then ReplaceFrameworkVariables([@"{WindowsFramework}\v1.0.3705"])
- else if FrameworkStartsWith("v1.1") then ReplaceFrameworkVariables([@"{WindowsFramework}\v1.1.4322"])
- else if FrameworkStartsWith("v2.0") then ReplaceFrameworkVariables([@"{WindowsFramework}\v2.0.50727"])
- else if FrameworkStartsWith("v3.0") then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"])
- else if FrameworkStartsWith("v3.5") then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v3.5"; @"{WindowsFramework}\v3.5"; @"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"])
- else if FrameworkStartsWith("v4.0") then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.0"]) // starting with .Net 4.0, the runtime dirs (WindowsFramework) are never used by MSBuild RAR
- else if FrameworkStartsWith("v4.5") then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.5"])
- else (ignore(excludeNonExecutableAssemblies); [])
+ if FrameworkStartsWith(Net10) then ReplaceFrameworkVariables([@"{WindowsFramework}\v1.0.3705"])
+ else if FrameworkStartsWith(Net11) then ReplaceFrameworkVariables([@"{WindowsFramework}\v1.1.4322"])
+ else if FrameworkStartsWith(Net20) then ReplaceFrameworkVariables([@"{WindowsFramework}\v2.0.50727"])
+ else if FrameworkStartsWith(Net30) then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"])
+ else if FrameworkStartsWith(Net35) then ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v3.5"; @"{WindowsFramework}\v3.5"; @"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"])
+ else DeriveTargetFrameworkDirectoriesFor40Plus(targetFrameworkVersion)
let result = result |> Array.ofList
logmessage (sprintf "Derived target framework directories for version %s are: %s" targetFrameworkVersion (String.Join(",", result)))
@@ -187,9 +264,8 @@ module internal MSBuildResolver =
rar.BuildEngine <- engine
// Derive target framework directory if none was supplied.
- let excludeNonExecutableAssemblies = (resolutionEnvironment = RuntimeLike)
let targetFrameworkDirectories =
- if targetFrameworkDirectories=[] then DeriveTargetFrameworkDirectories(targetFrameworkVersion,excludeNonExecutableAssemblies,logmessage)
+ if targetFrameworkDirectories=[] then DeriveTargetFrameworkDirectories(targetFrameworkVersion, logmessage)
else targetFrameworkDirectories |> Array.ofList
// Filter for null and zero length, and escape backslashes so legitimate path characters aren't mistaken for
@@ -240,7 +316,8 @@ module internal MSBuildResolver =
[sprintf "{Registry:%s,%s,%s%s}" frameworkRegistryBase targetFrameworkVersion assemblyFoldersSuffix assemblyFoldersConditions] @ // Like {Registry:Software\Microsoft\.NETFramework,v2.0,AssemblyFoldersEx}
["{AssemblyFolders}"] @
[outputDirectory] @
- ["{GAC}"]
+ ["{GAC}"] @
+ GetPathToDotNetFramework targetFrameworkVersion // use path to implementation assemblies as the last resort
rar.SearchPaths <- searchPaths |> Array.ofList
diff --git a/src/fsharp/ReferenceResolution.fsi b/src/fsharp/ReferenceResolution.fsi
index 58aea2b..2110873 100755
--- a/src/fsharp/ReferenceResolution.fsi
+++ b/src/fsharp/ReferenceResolution.fsi
@@ -14,6 +14,9 @@ namespace Microsoft.FSharp.Compiler
module internal MSBuildResolver =
exception ResolutionFailure
+
+ val SupportedNetFrameworkVersions : Set<string>
+ val HighestInstalledNetFrameworkVersionMajorMinor : unit -> int * string
/// Describes the location where the reference was found.
type ResolvedFrom =
diff --git a/src/fsharp/Salsa/VsMocks.fs b/src/fsharp/Salsa/VsMocks.fs
index 481ece0..4bdff51 100755
--- a/src/fsharp/Salsa/VsMocks.fs
+++ b/src/fsharp/Salsa/VsMocks.fs
@@ -1407,6 +1407,7 @@ module internal VsMocks =
let vsTargetFrameworkAssemblies30 = vsTargetFrameworkAssembliesN 0x30000u
let vsTargetFrameworkAssemblies35 = vsTargetFrameworkAssembliesN 0x30005u
let vsTargetFrameworkAssemblies40 = vsTargetFrameworkAssembliesN 0x40000u
+ let vsTargetFrameworkAssemblies45 = vsTargetFrameworkAssembliesN 0x40005u
let vsFrameworkMultiTargeting =
{ new IVsFrameworkMultiTargeting with
@@ -1458,26 +1459,38 @@ module internal VsMocks =
}
let MakeVsSolutionBuildManagerAndConfigChangeNotifier() =
- let id = ref 0u
- let listeners = new Dictionary<uint32,IVsUpdateSolutionEvents>()
+ let mkEventsStorage () =
+ let listeners = Dictionary()
+ let id = ref 0u
+ let add l =
+ let cookie = !id
+ listeners.Add(cookie, l)
+ id := !id + 1u
+ cookie
+ let remove v =
+ listeners.Remove(v) |> ignore
+ let enumerate() = listeners.Values
+ add, remove, enumerate
+
+ let add1, remove1, enumerate1 = mkEventsStorage()
+ let add2, remove2, _ = mkEventsStorage()
let configDict = new Dictionary<IVsHierarchy,string>()
let configChangeNotifier(h : IVsHierarchy, s : string) =
if configDict.ContainsKey(h) then
configDict.[h] <- s
else
configDict.Add(h,s)
- for kvp in listeners do
- kvp.Value.OnActiveProjectCfgChange(h) |> ignore
+ for (kvp : IVsUpdateSolutionEvents) in enumerate1() do
+ kvp.OnActiveProjectCfgChange(h) |> ignore
let vsSolutionBuildManager =
{ new IVsSolutionBuildManager with
member x.DebugLaunch(grfLaunch) = err(__LINE__)
member x.StartSimpleUpdateSolutionConfiguration(dwFlags, dwDefQueryResults, fSuppressUI) = err(__LINE__)
member x.AdviseUpdateSolutionEvents( pIVsUpdateSolutionEvents, outpdwCookie : byref<uint32> ) =
- listeners.Add(!id, pIVsUpdateSolutionEvents)
- id := !id + 1u
+ outpdwCookie <- add1 pIVsUpdateSolutionEvents
0
member x.UnadviseUpdateSolutionEvents(dwCookie) =
- listeners.Remove(dwCookie) |> ignore
+ remove1 dwCookie
0
member x.UpdateSolutionConfigurationIsActive(pfIsActive) = err(__LINE__)
member x.CanCancelUpdateSolutionConfiguration(pfCanCancel) = err(__LINE__)
@@ -1502,7 +1515,8 @@ module internal VsMocks =
member x.set_StartupProject( pHierarchy) = err(__LINE__)
member x.GetProjectDependencies( pHier, celt, rgpHier, pcActual) = err(__LINE__)
interface IVsSolutionBuildManager2 with
- member x.AdviseUpdateSolutionEvents(_pIVsUpdateSolutionEvents, _pdwCookie) =
+ member x.AdviseUpdateSolutionEvents(pIVsUpdateSolutionEvents, pdwCookie) =
+ pdwCookie <- add2 pIVsUpdateSolutionEvents
0
member x.CalculateProjectDependencies() = err(__LINE__)
member x.CanCancelUpdateSolutionConfiguration(_pfCanCancel) = err(__LINE__)
@@ -1518,7 +1532,9 @@ module internal VsMocks =
member x.StartSimpleUpdateSolutionConfiguration(_dwFlags, _dwDefQueryResults, _fSuppressUI) = err(__LINE__)
member x.StartUpdateProjectConfigurations(_cProjs, _rgpHierProjs, _dwFlags, _fSuppressUI) = err(__LINE__)
member x.StartUpdateSpecificProjectConfigurations(_cProjs, _rgpHier, _rgpcfg, _rgdwCleanFlags, _rgdwBuildFlags, _rgdwDeployFlags, _dwFlags, _fSuppressUI) = err(__LINE__)
- member x.UnadviseUpdateSolutionEvents(_dwCookie) = err(__LINE__)
+ member x.UnadviseUpdateSolutionEvents(dwCookie) =
+ remove2 dwCookie
+ 0
member x.UpdateSolutionConfigurationIsActive(_pfIsActive) = err(__LINE__)
member x.get_CodePage(_puiCodePage) = err(__LINE__)
member x.get_IsDebug(_pfIsDebug) = err(__LINE__)
@@ -1580,6 +1596,11 @@ module internal VsMocks =
sp.AddService(typeof<SVsTargetFrameworkAssemblies>, box vsTargetFrameworkAssemblies40, false)
sp.AddService(typeof<SVsFrameworkMultiTargeting>, box vsFrameworkMultiTargeting, false)
sp, ccn
+ let MakeMockServiceProviderAndConfigChangeNotifier45() =
+ let sp, ccn = MakeMockServiceProviderAndConfigChangeNotifierNoTargetFrameworkAssembliesService()
+ sp.AddService(typeof<SVsTargetFrameworkAssemblies>, box vsTargetFrameworkAssemblies45, false)
+ sp.AddService(typeof<SVsFrameworkMultiTargeting>, box vsFrameworkMultiTargeting, false)
+ sp, ccn
// This is the mock thing that all tests, except the multitargeting tests call.
// By default, let it use the 4.0 assembly version.
@@ -1615,7 +1636,7 @@ module internal VsActual =
let vsInstallDir =
#if FX_ATLEAST_45
- let key = @"SOFTWARE\Microsoft\VisualStudio\11.0"
+ let key = @"SOFTWARE\Microsoft\VisualStudio\12.0"
#else
let key = @"SOFTWARE\Microsoft\VisualStudio\10.0"
#endif
diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs
index 564bdb9..5a36f04 100755
--- a/src/fsharp/ast.fs
+++ b/src/fsharp/ast.fs
@@ -603,12 +603,12 @@ and
| DotSet of SynExpr * LongIdentWithDots * SynExpr * range
/// F# syntax: expr.[expr,...,expr]
- | DotIndexedGet of SynExpr * SynExpr list * range * range
+ | DotIndexedGet of SynExpr * SynIndexerArg list * range * range
/// DotIndexedSet (objectExpr, indexExprs, valueExpr, rangeOfLeftOfSet, rangeOfDot, rangeOfWholeExpr)
///
/// F# syntax: expr.[expr,...,expr] <- expr
- | DotIndexedSet of SynExpr * SynExpr list * SynExpr * range * range * range
+ | DotIndexedSet of SynExpr * SynIndexerArg list * SynExpr * range * range * range
/// F# syntax: Type.Items(e1) <- e2 , rarely used named-property-setter notation, e.g. Foo.Bar.Chars(3) <- 'a'
| NamedIndexedPropertySet of LongIdentWithDots * SynExpr * SynExpr * range
@@ -876,6 +876,14 @@ and
mkRange m.FileName start e
| SynExpr.Ident id -> id.idRange
+
+and
+ [<NoEquality; NoComparison; RequireQualifiedAccess>]
+ SynIndexerArg =
+ | Two of SynExpr * SynExpr
+ | One of SynExpr
+ member x.Range = match x with Two (e1,e2) -> unionRanges e1.Range e2.Range | One e -> e.Range
+ member x.Exprs = match x with Two (e1,e2) -> [e1;e2] | One e -> [e]
and
[<NoEquality; NoComparison; RequireQualifiedAccess>]
SynSimplePat =
@@ -921,6 +929,9 @@ and
| SimplePats of SynSimplePat list * range
| Typed of SynSimplePats * SynType * range
+and SynConstructorArgs =
+ | Pats of SynPat list
+ | NamePatPairs of (Ident * SynPat) list * range
and
[<NoEquality; NoComparison;RequireQualifiedAccess>]
SynPat =
@@ -931,7 +942,7 @@ and
| Attrib of SynPat * SynAttributes * range
| Or of SynPat * SynPat * range
| Ands of SynPat list * range
- | LongIdent of LongIdentWithDots * (* holds additional ident for tooling *) Ident option * SynValTyparDecls option (* usually None: temporary used to parse "f<'a> x = x"*) * SynPat list * SynAccess option * range
+ | LongIdent of LongIdentWithDots * (* holds additional ident for tooling *) Ident option * SynValTyparDecls option (* usually None: temporary used to parse "f<'a> x = x"*) * SynConstructorArgs * SynAccess option * range
| Tuple of SynPat list * range
| Paren of SynPat * range
| ArrayOrList of bool * SynPat list * range
@@ -1529,15 +1540,16 @@ let rec IsControlFlowExpression e =
| _ -> false
let mkAnonField (ty: SynType) = Field([],false,None,ty,false,PreXmlDoc.Empty,None,ty.Range)
+let mkNamedField (ident, ty: SynType) = Field([],false,Some ident,ty,false,PreXmlDoc.Empty,None,ty.Range)
let mkSynPatVar vis (id:Ident) = SynPat.Named (SynPat.Wild id.idRange,id,false,vis,id.idRange)
let mkSynThisPatVar (id:Ident) = SynPat.Named (SynPat.Wild id.idRange,id,true,None,id.idRange)
-let mkSynPatMaybeVar lidwd vis m = SynPat.LongIdent (lidwd,None,None,[],vis,m)
+let mkSynPatMaybeVar lidwd vis m = SynPat.LongIdent (lidwd,None,None,SynConstructorArgs.Pats [],vis,m)
/// Extract the argument for patterns corresponding to the declaration of 'new ... = ...'
let (|SynPatForConstructorDecl|_|) x =
match x with
- | SynPat.LongIdent (LongIdentWithDots([_],_),_,_,[arg],_,_) -> Some arg
+ | SynPat.LongIdent (LongIdentWithDots([_],_),_,_, SynConstructorArgs.Pats [arg],_,_) -> Some arg
| _ -> None
/// Recognize the '()' in 'new()'
@@ -1585,7 +1597,7 @@ let rec SimplePatOfPat (synArgNameGenerator: SynArgNameGenerator) p =
let m = p.Range
let isCompGen,altNameRefCell,id,item =
match p with
- | SynPat.LongIdent(LongIdentWithDots([id],_),_,None,[],None,_) ->
+ | SynPat.LongIdent(LongIdentWithDots([id],_),_,None, SynConstructorArgs.Pats [],None,_) ->
// The pattern is 'V' or some other capitalized identifier.
// It may be a real variable, in which case we want to maintain its name.
// But it may also be a nullary union case or some other identifier.
@@ -1672,7 +1684,8 @@ let PushCurriedPatternsToExpr synArgNameGenerator wholem isMember pats rhs =
/// Helper for parsing the inline IL fragments.
#if NO_INLINE_IL_PARSER
let ParseAssemblyCodeInstructions _s m =
- errorR(Error((193,"Inline IL not valid in a hosted environment"),m)) ; [| |]
+ errorR(Error((193,"Inline IL not valid in a hosted environment"),m))
+ [| |]
#else
let ParseAssemblyCodeInstructions s m =
try Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser.ilInstrs
@@ -1682,11 +1695,12 @@ let ParseAssemblyCodeInstructions s m =
errorR(Error(FSComp.SR.astParseEmbeddedILError(), m)); [| |]
#endif
+
/// Helper for parsing the inline IL fragments.
#if NO_INLINE_IL_PARSER
let ParseAssemblyCodeType _s m =
- // REVIEW: break out into a resource
- errorR(Error((193,"Inline IL not valid in a hosted environment"),m)) ; IL.ecmaILGlobals.typ_Object
+ errorR(Error((193,"Inline IL not valid in a hosted environment"),m))
+ IL.EcmaILGlobals.typ_Object
#else
let ParseAssemblyCodeType s m =
try Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser.ilType
@@ -1694,9 +1708,10 @@ let ParseAssemblyCodeType s m =
(UnicodeLexing.StringAsLexbuf s)
with RecoverableParseError ->
errorR(Error(FSComp.SR.astParseEmbeddedILTypeError(),m));
- IL.ecmaILGlobals.typ_Object
+ IL.EcmaILGlobals.typ_Object
#endif
+
//------------------------------------------------------------------------
// AST constructors
//------------------------------------------------------------------------
@@ -1722,20 +1737,33 @@ let mkSynApp3 f x1 x2 x3 m = mkSynApp1 (mkSynApp2 f x1 x2 m) x3 m
let mkSynApp4 f x1 x2 x3 x4 m = mkSynApp1 (mkSynApp3 f x1 x2 x3 m) x4 m
let mkSynApp5 f x1 x2 x3 x4 x5 m = mkSynApp1 (mkSynApp4 f x1 x2 x3 x4 m) x5 m
let mkSynDotParenSet m a b c = mkSynTrifix m parenSet a b c
-let mkSynDotBrackGet m mDot a b = SynExpr.DotIndexedGet(a,[b],mDot,m)
+let mkSynDotBrackGet m mDot a b = SynExpr.DotIndexedGet(a,[SynIndexerArg.One b],mDot,m)
let mkSynQMarkSet m a b c = mkSynTrifix m qmarkSet a b c
-let mkSynDotBrackSliceGet m mDot arr (x,y) =
- SynExpr.DotIndexedGet(arr,[x;y],mDot,m)
-
-let mkSynDotBrackSlice2Get m mDot arr (x1,y1) (x2,y2) =
- SynExpr.DotIndexedGet(arr,[x1;y1;x2;y2],mDot,m)
-
-let mkSynDotBrackSlice3Get m mDot arr (x1,y1) (x2,y2) (x3,y3) =
- SynExpr.DotIndexedGet(arr,[x1;y1;x2;y2;x3;y3],mDot,m)
-
-let mkSynDotBrackSlice4Get m mDot arr (x1,y1) (x2,y2) (x3,y3) (x4,y4) =
- SynExpr.DotIndexedGet(arr,[x1;y1;x2;y2;x3;y3;x4;y4],mDot,m)
+let mkSynDotBrackSliceGet m mDot arr sliceArg = SynExpr.DotIndexedGet(arr,[sliceArg],mDot,m)
+
+let mkSlice m mDot arr sliceArgs =
+ //let args = [ for arg in sliceArgs do
+ // match arg with
+ // | SynIndexerArg.Range (x1,x2) -> yield x1; yield x2
+ // | SynIndexerArg.One x -> yield x ]
+ SynExpr.DotIndexedGet(arr,sliceArgs,mDot,m)
+
+let mkSynDotBrackSlice2Get m mDot arr sliceArg1 sliceArg2 =
+ match sliceArg1, sliceArg2 with
+ | SynIndexerArg.One x1, SynIndexerArg.One x2 -> mkSynDotBrackGet m mDot arr (SynExpr.Tuple([x1;x2],[],unionRanges x1.Range x2.Range))
+ | _ -> mkSlice m mDot arr [ sliceArg1; sliceArg2 ]
+
+let mkSynDotBrackSlice3Get m mDot arr sliceArg1 sliceArg2 sliceArg3 =
+ match sliceArg1, sliceArg2, sliceArg3 with
+ | SynIndexerArg.One x1, SynIndexerArg.One x2, SynIndexerArg.One x3 -> mkSynDotBrackGet m mDot arr (SynExpr.Tuple([x1;x2;x3],[],unionRanges x1.Range x3.Range))
+ | _ -> mkSlice m mDot arr [ sliceArg1; sliceArg2; sliceArg3 ]
+
+let mkSynDotBrackSlice4Get m mDot arr sliceArg1 sliceArg2 sliceArg3 sliceArg4 =
+ match sliceArg1, sliceArg2, sliceArg3, sliceArg4 with
+ | SynIndexerArg.One x1, SynIndexerArg.One x2, SynIndexerArg.One x3, SynIndexerArg.One x4 -> mkSynDotBrackGet m mDot arr (SynExpr.Tuple([x1;x2;x3;x4],[],unionRanges x1.Range x4.Range))
+ | _ -> mkSlice m mDot arr [ sliceArg1; sliceArg2; sliceArg3; sliceArg4 ]
+
let mkSynDotParenGet lhsm dotm a b =
match b with
@@ -1937,12 +1965,12 @@ module SynInfo =
let infosForExplicitArgs =
match pat with
- | Some(SynPat.LongIdent(_,_,_,curriedArgs,_,_)) -> List.map InferSynArgInfoFromPat curriedArgs
+ | Some(SynPat.LongIdent(_,_,_, SynConstructorArgs.Pats curriedArgs,_,_)) -> List.map InferSynArgInfoFromPat curriedArgs
| _ -> []
let explicitArgsAreSimple =
match pat with
- | Some(SynPat.LongIdent(_,_,_,curriedArgs,_,_)) -> List.forall isSimplePattern curriedArgs
+ | Some(SynPat.LongIdent(_,_,_, SynConstructorArgs.Pats curriedArgs,_,_)) -> List.forall isSimplePattern curriedArgs
| _ -> true
let retInfo = InferSynReturnData retInfo
@@ -2247,10 +2275,10 @@ let rec synExprContainsError inpExpr =
| SynExpr.IfThenElse (e1,e2,e3opt,_,_,_,_) ->
walkExpr e1 || walkExpr e2 || walkExprOpt e3opt
| SynExpr.DotIndexedGet (e1,es,_,_) ->
- walkExpr e1 || walkExprs es
+ walkExpr e1 || walkExprs [ for e in es do yield! e.Exprs ]
| SynExpr.DotIndexedSet (e1,es,e2,_,_,_) ->
- walkExpr e1 || walkExprs es || walkExpr e2
+ walkExpr e1 || walkExprs [ for e in es do yield! e.Exprs ] || walkExpr e2
| SynExpr.DotNamedIndexedPropertySet (e1,_,e2,e3,_) ->
walkExpr e1 || walkExpr e2 || walkExpr e3
diff --git a/src/fsharp/build.fs b/src/fsharp/build.fs
index 0342c2c..c7a3b74 100755
--- a/src/fsharp/build.fs
+++ b/src/fsharp/build.fs
@@ -402,7 +402,7 @@ let warningOn err level specificWarnOn =
match n with
| 1182 -> false
| _ -> level >= GetWarningLevel err
-
+
let SplitRelatedErrors(err:PhasedError) =
let ToPhased(e) = {Exception=e; Phase = err.Phase}
let rec SplitRelatedException = function
@@ -1380,63 +1380,126 @@ let SanitizeFileName fileName implicitIncludeDir =
with _ ->
fileName
-(* used by fsc.exe and fsi.exe, but not by VS *)
-let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) =
- let outputWhere (showFullPaths,errorStyle) os m =
- if m = rangeStartup || m = rangeCmdArgs then ()
+type ErrorLocation =
+ {
+ Range : range
+ File : string
+ TextRepresentation : string
+ IsEmpty : bool
+ }
+
+type CanonicalInformation =
+ {
+ ErrorNumber : int
+ Subcategory : string
+ TextRepresentation : string
+ }
+
+type DetailedIssueInfo =
+ {
+ Location : ErrorLocation option
+ Canonical : CanonicalInformation
+ Message : string
+ }
+
+type ErrorOrWarning =
+ | Short of bool * string
+ | Long of bool * DetailedIssueInfo
+
+/// returns sequence that contains ErrorOrWarning for the given error + ErrorOrWarning for all related errors
+let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err:PhasedError) =
+ let outputWhere (showFullPaths,errorStyle) m =
+ if m = rangeStartup || m = rangeCmdArgs then
+ { Range = m; TextRepresentation = ""; IsEmpty = true; File = "" }
else
let file = m.FileName
let file = if showFullPaths then
Filename.fullpath implicitIncludeDir file
else
SanitizeFileName file implicitIncludeDir
- match errorStyle with
- | ErrorStyle.EmacsErrors -> Printf.bprintf os "File \"%s\", line %d, characters %d-%d: " (file.Replace("\\","/")) m.StartLine m.StartColumn m.EndColumn
- // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output
- | ErrorStyle.DefaultErrors -> Printf.bprintf os "%s(%d,%d): " (file.Replace('/',System.IO.Path.DirectorySeparatorChar)) m.StartLine (m.StartColumn + 1)
- // We may also want to change TestErrors to be 1-based
- | ErrorStyle.TestErrors -> Printf.bprintf os "%s(%d,%d-%d,%d): " (file.Replace("/","\\")) m.StartLine (m.StartColumn + 1) m.EndLine (m.EndColumn + 1)
- // Here, we want the complete range information so Project Systems can generate proper squiggles
- | ErrorStyle.VSErrors ->
- // Show prefix only for real files. Otherise, we just want a truncated error like:
- // parse error FS0031 : blah blah
- if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then
- Printf.bprintf os "%s(%d,%d,%d,%d): " (file.Replace("/","\\")) m.StartLine (m.StartColumn + 1) m.EndLine (m.EndColumn + 1)
-
+ let text, m, file =
+ match errorStyle with
+ | ErrorStyle.EmacsErrors ->
+ let file = file.Replace("\\","/")
+ (sprintf "File \"%s\", line %d, characters %d-%d: " file m.StartLine m.StartColumn m.EndColumn), m, file
+
+ // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output
+ | ErrorStyle.DefaultErrors ->
+ let file = file.Replace('/',System.IO.Path.DirectorySeparatorChar)
+ let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) m.End
+ (sprintf "%s(%d,%d): " file m.StartLine m.StartColumn), m, file
+
+ // We may also want to change TestErrors to be 1-based
+ | ErrorStyle.TestErrors ->
+ let file = file.Replace("/","\\")
+ let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) )
+ sprintf "%s(%d,%d-%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file
+
+ // Here, we want the complete range information so Project Systems can generate proper squiggles
+ | ErrorStyle.VSErrors ->
+ // Show prefix only for real files. Otherise, we just want a truncated error like:
+ // parse error FS0031 : blah blah
+ if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then
+ let file = file.Replace("/","\\")
+ let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) )
+ sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file
+ else
+ "", m, file
+ { Range = m; TextRepresentation = text; IsEmpty = false; File = file }
match err.Exception with
| ReportedError _ ->
dprintf "Unexpected ReportedError" (* this should actually never happen *)
+ Seq.empty
| StopProcessing ->
dprintf "Unexpected StopProcessing" (* this should actually never happen *)
+ Seq.empty
| _ ->
+ let errors = ResizeArray()
let report err =
let OutputWhere(err) =
- Printf.bprintf os "\n";
match RangeOfError err with
- | Some m -> outputWhere (showFullPaths,errorStyle) os m
- | None -> ()
+ | Some m -> Some(outputWhere (showFullPaths,errorStyle) m)
+ | None -> None
let OutputCanonicalInformation(err:PhasedError,subcategory, errorNumber) =
- match errorStyle with
- // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness.
- | ErrorStyle.VSErrors -> Printf.bprintf os "%s %s FS%04d: " subcategory (if warn then "warning" else "error") errorNumber;
- | _ -> Printf.bprintf os "%s FS%04d: " (if warn then "warning" else "error") (GetErrorNumber err);
+ let text =
+ match errorStyle with
+ // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness.
+ | ErrorStyle.VSErrors -> sprintf "%s %s FS%04d: " subcategory (if warn then "warning" else "error") errorNumber;
+ | _ -> sprintf "%s FS%04d: " (if warn then "warning" else "error") (GetErrorNumber err);
+ { ErrorNumber = errorNumber; Subcategory = subcategory; TextRepresentation = text}
let mainError,relatedErrors = SplitRelatedErrors err
- OutputWhere(mainError)
- OutputCanonicalInformation(mainError,err.Subcategory(),GetErrorNumber mainError)
- OutputPhasedError os mainError flattenErrors;
-
+ let where = OutputWhere(mainError)
+ let canonical = OutputCanonicalInformation(mainError,err.Subcategory(),GetErrorNumber mainError)
+ let message =
+ let os = System.Text.StringBuilder()
+ OutputPhasedError os mainError flattenErrors;
+ os.ToString()
+
+ let entry = { Location = where; Canonical = canonical; Message = message }
+
+ errors.Add ( ErrorOrWarning.Long( not warn, entry ) )
+
let OutputRelatedError(err) =
match errorStyle with
// Give a canonical string when --vserror.
| ErrorStyle.VSErrors ->
- OutputWhere(mainError) // mainError?
- OutputCanonicalInformation(err, err.Subcategory(),GetErrorNumber mainError) // Use main error for code
+ let relWhere = OutputWhere(mainError) // mainError?
+ let relCanonical = OutputCanonicalInformation(err, err.Subcategory(),GetErrorNumber mainError) // Use main error for code
+ let relMessage =
+ let os = System.Text.StringBuilder()
+ OutputPhasedError os err flattenErrors
+ os.ToString()
+
+ let entry = { Location = relWhere; Canonical = relCanonical; Message = relMessage}
+ errors.Add( ErrorOrWarning.Long (not warn, entry) )
+
+ | _ ->
+ let os = System.Text.StringBuilder()
OutputPhasedError os err flattenErrors
- | _ -> Printf.bprintf os "\n"; OutputPhasedError os err flattenErrors
-
+ errors.Add( ErrorOrWarning.Short((not warn), os.ToString()) )
relatedErrors |> List.iter OutputRelatedError
@@ -1449,6 +1512,25 @@ let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,err
)
#endif
| x -> report x
+
+ errors :> seq<_>
+
+/// used by fsc.exe and fsi.exe, but not by VS
+/// prints error and related errors to the specified StringBuilder
+let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) =
+
+ let errors = CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err)
+ for e in errors do
+ Printf.bprintf os "\n"
+ match e with
+ | Short(_, txt) ->
+ os.Append txt |> ignore
+ | Long(_, details) ->
+ match details.Location with
+ | Some l when not l.IsEmpty -> os.Append(l.TextRepresentation) |> ignore
+ | _ -> ()
+ os.Append( details.Canonical.TextRepresentation ) |> ignore
+ os.Append( details.Message ) |> ignore
let OutputErrorOrWarningContext prefix fileLineFn os err =
match RangeOfError err with
@@ -1470,9 +1552,19 @@ let OutputErrorOrWarningContext prefix fileLineFn os err =
//----------------------------------------------------------------------------
let GetFSharpCoreLibraryName () = "FSharp.Core"
+
#if SILVERLIGHT
+let GetFSharpCoreReferenceUsedByCompiler() = typeof<int list>.Assembly.FullName
let GetFsiLibraryName () = "FSharp.Compiler.Silverlight"
#else
+type internal TypeInThisAssembly = class end
+let GetFSharpCoreReferenceUsedByCompiler() =
+ let fsCoreName = GetFSharpCoreLibraryName()
+ typeof<TypeInThisAssembly>.Assembly.GetReferencedAssemblies()
+ |> Array.pick (fun name ->
+ if name.Name = fsCoreName then Some(name.ToString())
+ else None
+ )
let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings"
#endif
@@ -1486,10 +1578,10 @@ let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings"
let DefaultBasicReferencesForOutOfProjectSources =
[
#if SILVERLIGHT
- yield "System.dll"
- yield "System.Xml.dll"
- yield "System.Core.dll"
- yield "System.Net.dll"]
+ yield "System"
+ yield "System.Xml"
+ yield "System.Core"
+ yield "System.Net"]
#else
yield "System"
yield "System.Xml"
@@ -1517,10 +1609,10 @@ let DefaultBasicReferencesForOutOfProjectSources40 =
[ "System.Numerics" ]
// A set of assemblies to always consider to be system assemblies
-let SystemAssemblies (mscorlibAssemblyName, mscorlibVersion: System.Version, mscorlibIsSilverlight) =
+let SystemAssemblies (primaryAssembly, mscorlibVersion: System.Version, primaryAssemblyIsSilverlight) =
ignore mscorlibVersion
#if SILVERLIGHT
- [ yield mscorlibAssemblyName
+ [ yield primaryAssembly
yield GetFSharpCoreLibraryName()
yield "System"
yield "System.Xml"
@@ -1528,12 +1620,11 @@ let SystemAssemblies (mscorlibAssemblyName, mscorlibVersion: System.Version, msc
yield "System.Net"
yield "System.Observable" ]
#else
- [ yield mscorlibAssemblyName
+ [ yield primaryAssembly
yield GetFSharpCoreLibraryName()
yield "System"
- yield "System.Xml"
+ yield "System.Xml"
yield "System.Core"
- yield "System.Net"
yield "System.Runtime.Remoting"
yield "System.Runtime.Serialization.Formatters.Soap"
yield "System.Data"
@@ -1541,13 +1632,14 @@ let SystemAssemblies (mscorlibAssemblyName, mscorlibVersion: System.Version, msc
yield "System.Design"
yield "System.Messaging"
yield "System.Drawing"
+ yield "System.Net"
yield "System.Web"
yield "System.Web.Services"
yield "System.Windows.Forms"
// Include System.Observable in the potential-system-assembly set
// on WP7. Note that earlier versions of silverlight did not have this DLL, but
// it is OK to over-approximate the system assembly set.
- if mscorlibIsSilverlight then
+ if primaryAssemblyIsSilverlight then
yield "System.Observable"
if mscorlibVersion.Major >= 4 then
yield "System.Numerics"]
@@ -1561,39 +1653,16 @@ let SystemAssemblies (mscorlibAssemblyName, mscorlibVersion: System.Version, msc
let BasicReferencesForScriptLoadClosure =
#if SILVERLIGHT
["mscorlib.dll"; GetFSharpCoreLibraryName()+".dll" ] @ // Need to resolve these explicitly so they will be found in the reference assemblies directory which is where the .xml files are.
- DefaultBasicReferencesForOutOfProjectSources @
+ [ for x in DefaultBasicReferencesForOutOfProjectSources -> x + ".dll" ] @
[ GetFsiLibraryName()+".dll" ]
#else
["mscorlib"; GetFSharpCoreLibraryName () ] @ // Need to resolve these explicitly so they will be found in the reference assemblies directory which is where the .xml files are.
DefaultBasicReferencesForOutOfProjectSources @
- [ GetFsiLibraryName() ]
+ [ GetFsiLibraryName () ]
#endif
let (++) x s = x @ [s]
-/// Determine the default "frameworkVersion" (which is passed into MSBuild resolve).
-/// If this binary was built for v4, the return "v4.0" or "v4.5"
-/// If this binary was built for v2, the return "v3.5", "v3.5" or "v2.0" depending on what is installed.
-///
-/// See: Detecting which versions of the .NET framework are installed.
-/// http://blogs.msdn.com/aaronru/archive/2007/11/26/net-framework-3-5-rtm-detection-logic.aspx
-/// See: bug 4409.
-open Microsoft.Win32
-let highestInstalledNetFrameworkVersionMajorMinor() =
-#if SILVERLIGHT
-#if FX_ATLEAST_SILVERLIGHT_50
- System.Version(4,0,5,0),"v5.0"
-#else
- System.Version(2,0,5,0),"v2.0"
-#endif
-#else
- try
- let net45 = Registry.GetValue(@"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\.NETFramework\v4.0.30319\SKUs\.NETFramework,Version=v4.5","",1) = box 1
- if net45 then System.Version(4,0,0,0),"v4.5"
- else System.Version(4,0,0,0),"v4.0" // version is 4.0 assumed since this code is running.
- with e ->
- System.Version(4,0,0,0),"v4.0"
-#endif // SILVERLIGHT
//----------------------------------------------------------------------------
@@ -1692,8 +1761,140 @@ type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * Assem
type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted<ITypeProvider> list
#endif
+type ImportedBinary =
+ { FileName: string;
+ RawMetadata: ILModuleDef;
+#if EXTENSIONTYPING
+ ProviderGeneratedAssembly: System.Reflection.Assembly option
+ IsProviderGenerated: bool;
+ ProviderGeneratedStaticLinkMap : ProvidedAssemblyStaticLinkingMap option
+#endif
+ ILAssemblyRefs : ILAssemblyRef list;
+ ILScopeRef: ILScopeRef }
+
+type ImportedAssembly =
+ { ILScopeRef: ILScopeRef;
+ FSharpViewOfMetadata: CcuThunk;
+ AssemblyAutoOpenAttributes: string list;
+ AssemblyInternalsVisibleToAttributes: string list;
+#if EXTENSIONTYPING
+ IsProviderGenerated: bool
+ mutable TypeProviders: Tainted<Microsoft.FSharp.Core.CompilerServices.ITypeProvider> list;
+#endif
+ FSharpOptimizationData : Microsoft.FSharp.Control.Lazy<Option<Opt.LazyModuleInfo>> }
+
+type AvailableImportedAssembly =
+ | ResolvedImportedAssembly of ImportedAssembly
+ | UnresolvedImportedAssembly of string
+
+// Helps to perform 2-step initialization of the system runtime
+// Compiler heavily relies on ILGlobals structure that contains fundamental types.
+// For mscorlib based profiles everything was easy - all fundamental types were located in one assembly so initialization sequence was simple
+// - read mscorlib -> create ILGlobals (*) -> use ILGlobals to read remaining assemblies
+// For .NETCore everything is not so obvious because fundamental types now reside in different assemblies and this makes initialization more tricky:
+// - read system runtime -> create ILGlobals that is partially initialized (*) -> use ILGlobals to read remaining assemblies -> finish the initialization of ILGlobals using data from the previous step
+// BeginLoadingSystemRuntime -> (*) EndLoadingSystemRuntime
+type ISystemRuntimeCcuInitializer =
+ abstract BeginLoadingSystemRuntime : resolver : (AssemblyReference -> ImportedAssembly) * noDebug :bool -> ILGlobals * obj
+ abstract EndLoadingSystemRuntime : state : obj * resolver : (AssemblyReference -> ImportedAssembly) -> ImportedAssembly
+
+type NetCoreSystemRuntimeTraits(primaryAssembly) =
+
+ let valueOf name hole =
+ match hole with
+ | Some assembly -> assembly
+ | None -> failwithf "Internal compiler error: scope ref hole '%s' is not initialized" name
+
+ let mutable systemReflection = None
+ let mutable systemDiagnosticsDebug = None
+ let mutable systemLinqExpressions = None
+ let mutable systemCollections = None
+ let mutable systemRuntimeInteropServices = None
+
+ member this.FixupImportedAssemblies(systemReflectionRef, systemDiagnosticsDebugRef, systemLinqExpressionsRef, systemCollectionsRef, systemRuntimeInteropServicesRef) =
+ systemReflection <- Some systemReflectionRef
+ systemDiagnosticsDebug <- Some systemDiagnosticsDebugRef
+ systemLinqExpressions <- Some systemLinqExpressionsRef
+ systemCollections <- Some systemCollectionsRef
+ systemRuntimeInteropServices <- Some systemRuntimeInteropServicesRef
+
+ interface IPrimaryAssemblyTraits with
+ member this.ScopeRef = primaryAssembly
+ member this.SystemReflectionScopeRef = lazy ((valueOf "System.Reflection" systemReflection).FSharpViewOfMetadata.ILScopeRef)
+ member this.TypedReferenceTypeScopeRef = None
+ member this.RuntimeArgumentHandleTypeScopeRef = None
+ member this.SerializationInfoTypeScopeRef = None
+ member this.SecurityPermissionAttributeTypeScopeRef = None
+ member this.SystemDiagnosticsDebugScopeRef = lazy ((valueOf "System.Diagnostics.Debug" systemDiagnosticsDebug).FSharpViewOfMetadata.ILScopeRef)
+ member this.SystemRuntimeInteropServicesScopeRef = lazy ((valueOf "System.Runtime.InteropServices" systemRuntimeInteropServices).FSharpViewOfMetadata.ILScopeRef)
+ member this.IDispatchConstantAttributeScopeRef = None
+ member this.IUnknownConstantAttributeScopeRef = None
+ member this.ContextStaticAttributeScopeRef = None
+ member this.ThreadStaticAttributeScopeRef = None
+ member this.SystemLinqExpressionsScopeRef = lazy ((valueOf "System.Linq.Expressions" systemLinqExpressions).FSharpViewOfMetadata.ILScopeRef)
+ member this.SystemCollectionsScopeRef = lazy ((valueOf "System.Collections" systemCollections).FSharpViewOfMetadata.ILScopeRef)
+ member this.SpecialNameAttributeScopeRef = None
+ member this.NonSerializedAttributeScopeRef = None
+ member this.MarshalByRefObjectScopeRef = None
+ member this.ArgIteratorTypeScopeRef = None
+
+type PrimaryAssembly =
+ | Mscorlib
+ | NamedMscorlib of string
+ | DotNetCore
+
+ member this.Name =
+ match this with
+ | Mscorlib -> "mscorlib"
+ | DotNetCore -> "System.Runtime"
+ | NamedMscorlib name -> name
+
+ member this.GetSystemRuntimeInitializer(mkReference : string -> AssemblyReference) : ISystemRuntimeCcuInitializer =
+ let name = this.Name
+ let primaryAssemblyReference = mkReference name
+
+ match this with
+ | Mscorlib
+ | NamedMscorlib _->
+ {
+ new ISystemRuntimeCcuInitializer with
+ member this.BeginLoadingSystemRuntime(resolver, noData) =
+ let mscorlibRef = resolver primaryAssemblyReference
+ let traits = (IL.mkMscorlibBasedTraits mscorlibRef.FSharpViewOfMetadata.ILScopeRef)
+ (mkILGlobals traits (Some name) noData), box mscorlibRef
+ member this.EndLoadingSystemRuntime(state, _resolver) =
+ unbox state
+ }
+
+ | DotNetCore ->
+ let systemReflectionRef = mkReference "System.Reflection"
+ let systemDiagnosticsDebugRef = mkReference "System.Diagnostics.Debug"
+ let systemLinqExpressionsRef = mkReference "System.Linq.Expressions"
+ let systemCollectionsRef = mkReference "System.Collections"
+ let systemRuntimeInteropServicesRef = mkReference "System.Runtime.InteropServices"
+ {
+ new ISystemRuntimeCcuInitializer with
+ member this.BeginLoadingSystemRuntime(resolver, noData) =
+ let primaryAssembly = resolver primaryAssemblyReference
+ let traits = new NetCoreSystemRuntimeTraits(primaryAssembly.FSharpViewOfMetadata.ILScopeRef)
+ mkILGlobals traits (Some name) noData, box (primaryAssembly, traits)
+ member this.EndLoadingSystemRuntime(state, resolver) =
+ let (primaryAssembly : ImportedAssembly, traits : NetCoreSystemRuntimeTraits) = unbox state
+ // finish initialization of SystemRuntimeTraits
+ traits.FixupImportedAssemblies
+ (
+ systemReflectionRef = resolver systemReflectionRef,
+ systemDiagnosticsDebugRef = resolver systemDiagnosticsDebugRef,
+ systemRuntimeInteropServicesRef = resolver systemRuntimeInteropServicesRef,
+ systemLinqExpressionsRef = resolver systemLinqExpressionsRef,
+ systemCollectionsRef = resolver systemCollectionsRef
+ )
+ primaryAssembly
+ }
+
+
type TcConfigBuilder =
- { mutable mscorlibAssemblyName : string;
+ { mutable primaryAssembly : PrimaryAssembly;
mutable autoResolveOpenDirectivesToDlls: bool;
mutable noFeedback: bool;
mutable stackReserveSize: int32 option;
@@ -1832,7 +2033,15 @@ type TcConfigBuilder =
/// if true, indicates all type checking and code generation is in the context of fsi.exe
isInteractive : bool
- isInvalidationSupported : bool
+ isInvalidationSupported : bool
+
+ /// used to log sqm data
+ mutable sqmSessionGuid : System.Guid option
+ mutable sqmNumOfSourceFiles : int
+ sqmSessionStartedTime : int64
+
+ /// if true - every expression in quotations will be augmented with full debug info (filename, location in file)
+ mutable emitDebugInfoInQuotations : bool
}
@@ -1843,7 +2052,7 @@ type TcConfigBuilder =
if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then
failwith "Expected a valid defaultFSharpBinariesDir"
#endif
- { mscorlibAssemblyName = "mscorlib";
+ { primaryAssembly = PrimaryAssembly.Mscorlib; // defaut value, can be overridden using the command line switch
light = None;
noFeedback=false;
stackReserveSize=None;
@@ -1958,6 +2167,7 @@ type TcConfigBuilder =
optSettings = Opt.OptimizationSettings.Defaults
emitTailcalls = true
lcid = None
+ // See bug 6071 for product banner spec
productNameForBannerText = (FSComp.SR.buildProductName(FSharpEnvironment.DotNetBuildString))
showBanner = true
showTimes = false
@@ -1972,7 +2182,11 @@ type TcConfigBuilder =
noDebugData = false
isInteractive = isInteractive
isInvalidationSupported = isInvalidationSupported
- }
+ sqmSessionGuid = None
+ sqmNumOfSourceFiles = 0
+ sqmSessionStartedTime = System.DateTime.Now.Ticks
+ emitDebugInfoInQuotations = false
+ }
member tcConfigB.ResolveSourceFile(m,nm,pathLoadedFrom) =
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter)
@@ -1992,17 +2206,22 @@ type TcConfigBuilder =
let modname = try Filename.chopExtension basic with _ -> basic
modname+(ext())
| Some f,_ -> f
- let assemblyName =
+ let assemblyName, assemblyNameIsInvalid =
let baseName = fileNameOfPath outfile
+ let assemblyName = fileNameWithoutExtension baseName
if not (Filename.checkSuffix (String.lowercase baseName) (ext())) then
- errorR(Error(FSComp.SR.buildMismatchOutputExtension(),rangeCmdArgs));
- fileNameWithoutExtension baseName
+ errorR(Error(FSComp.SR.buildMismatchOutputExtension(),rangeCmdArgs))
+ assemblyName, true
+ else
+ assemblyName, false
let pdbfile : string option =
#if SILVERLIGHT
None
#else
if tcConfigB.debuginfo then
+ // assembly name is invalid, we've already reported the error so just skip pdb name checks
+ if assemblyNameIsInvalid then None else
#if NO_PDB_WRITER
Some (match tcConfigB.debugSymbolFile with None -> (Filename.chopExtension outfile)+ (if runningOnMono then ".mdb" else ".pdb") | Some f -> f)
#else
@@ -2097,13 +2316,15 @@ type TcConfigBuilder =
ri,fileNameOfPath ri,ILResourceAccess.Public
-let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt,pdbPathOption,mscorlibAssemblyName,noDebugData) =
+let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, pdbPathOption, primaryAssemblyName, noDebugData) =
let ilGlobals =
+ // ILScopeRef.Local can be used only for primary assembly (mscorlib or System.Runtime) itself
+ // Remaining assemblies should be opened using existing ilGlobals (so they can properly locate fundamental types)
match ilGlobalsOpt with
- | None -> mkILGlobals ILScopeRef.Local (Some mscorlibAssemblyName) noDebugData
+ | None -> mkILGlobals (IL.mkMscorlibBasedTraits ILScopeRef.Local) (Some primaryAssemblyName) noDebugData
| Some ilGlobals -> ilGlobals
- let opts = { ILBinaryReader.defaults with
- ILBinaryReader.ilGlobals=ilGlobals;
+
+ let opts = { ILBinaryReader.mkDefault ilGlobals with
// fsc.exe does not uses optimizeForMemory (hence keeps MORE caches in AbstractIL)
// fsi.exe does use optimizeForMemory (hence keeps FEWER caches in AbstractIL), because its long running
// Visual Studio does use optimizeForMemory (hence keeps FEWER caches in AbstractIL), because its long running
@@ -2131,7 +2352,7 @@ type AssemblyResolution =
match !this.ilAssemblyRef with
| Some(assref) -> assref
| None ->
- let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals=ecmaILGlobals;optimizeForMemory=false}
+ let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaILGlobals;optimizeForMemory=false} // ??
let reader = ILBinaryReader.OpenILModuleReader this.resolvedPath readerSettings
try
let assRef = mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly
@@ -2159,12 +2380,12 @@ let MakeScopeRefForIlModule (ilModule: ILModuleDef) =
let GetCustomAttributesOfIlModule (ilModule:ILModuleDef) =
(match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList
-let GetAutoOpenAttributes(ilModule) =
- ilModule |> GetCustomAttributesOfIlModule |> List.choose TryFindAutoOpenAttr
-
-let GetInternalsVisibleToAttributes ilModule =
- ilModule |> GetCustomAttributesOfIlModule |> List.choose TryFindInternalsVisibleToAttr
+let GetAutoOpenAttributes ilg ilModule =
+ ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindAutoOpenAttr ilg)
+let GetInternalsVisibleToAttributes ilg ilModule =
+ ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindInternalsVisibleToAttr ilg)
+
//----------------------------------------------------------------------------
// TcConfig
//--------------------------------------------------------------------------
@@ -2199,22 +2420,29 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
nameOfDll(r)
// Look for an explicit reference to mscorlib and use that to compute clrRoot and targetFrameworkVersion
- let mscorlibReference,mscorlibExplicitFilenameOpt = computeKnownDllReference(data.mscorlibAssemblyName)
- let fslibReference,fslibExplicitFilenameOpt = computeKnownDllReference(GetFSharpCoreLibraryName())
+ let primaryAssemblyReference, primaryAssemblyExplicitFilenameOpt = computeKnownDllReference(data.primaryAssembly.Name)
+ let fslibReference,fslibExplicitFilenameOpt =
+ let (_, fileNameOpt) as res = computeKnownDllReference(GetFSharpCoreLibraryName())
+ match fileNameOpt with
+ | None ->
+ // if FSharp.Core was not provided explicitly - use version that was referenced by compiler
+ AssemblyReference(range0, GetFSharpCoreReferenceUsedByCompiler()), None
+ | _ -> res
+ let primaryAssemblyCcuInitializer = data.primaryAssembly.GetSystemRuntimeInitializer(computeKnownDllReference >> fst)
- // If either mscorlib.dll or fsharp.core.dll are explicitly specified then we require the --noframework flag.
+ // If either mscorlib.dll/System.Runtime.dll or fsharp.core.dll are explicitly specified then we require the --noframework flag.
// The reason is that some non-default frameworks may not have the default dlls. For example, Client profile does
// not have System.Web.dll.
- do if ((mscorlibExplicitFilenameOpt.IsSome || fslibExplicitFilenameOpt.IsSome) && data.framework) then
+ do if ((primaryAssemblyExplicitFilenameOpt.IsSome || fslibExplicitFilenameOpt.IsSome) && data.framework) then
error(Error(FSComp.SR.buildExplicitCoreLibRequiresNoFramework("--noframework"),rangeStartup))
- let clrRootValue,(mscorlibVersion,targetFrameworkVersionValue),mscorlibIsSilverlight =
- match mscorlibExplicitFilenameOpt with
- | Some(mscorlibFilename) ->
- let filename = ComputeMakePathAbsolute data.implicitIncludeDir mscorlibFilename
+ let clrRootValue, (mscorlibVersion,targetFrameworkVersionValue), primaryAssemblyIsSilverlight =
+ match primaryAssemblyExplicitFilenameOpt with
+ | Some(primaryAssemblyFilename) ->
+ let filename = ComputeMakePathAbsolute data.implicitIncludeDir primaryAssemblyFilename
try
- let ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None,data.mscorlibAssemblyName,data.noDebugData)
+ let ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None, data.primaryAssembly.Name, data.noDebugData)
try
let ilModule = ilReader.ILModuleDef
@@ -2237,7 +2465,8 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
with _ ->
error(Error(FSComp.SR.buildCannotReadAssembly(filename),rangeStartup))
| _ ->
- None, highestInstalledNetFrameworkVersionMajorMinor(), false
+ let v1,_ = MSBuildResolver.HighestInstalledNetFrameworkVersionMajorMinor()
+ None, (System.Version(int v1, 0, 0, 0), sprintf "v%d.0" v1), false
// Note: anycpu32bitpreferred can only be used with .Net version 4.5 and above
// but now there is no way to discriminate between 4.0 and 4.5,
@@ -2245,18 +2474,18 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
do if data.prefer32Bit && mscorlibVersion.Major < 4 then
error(Error(FSComp.SR.invalidPlatformTargetForOldFramework(),rangeCmdArgs))
- let systemAssemblies = SystemAssemblies (data.mscorlibAssemblyName, mscorlibVersion, mscorlibIsSilverlight)
+ let systemAssemblies = SystemAssemblies (data.primaryAssembly.Name, mscorlibVersion, primaryAssemblyIsSilverlight)
// Check that the referenced version of FSharp.Core.dll matches the referenced version of mscorlib.dll
let checkFSharpBinaryCompatWithMscorlib filename (ilAssemblyRefs: ILAssemblyRef list) explicitFscoreVersionToCheckOpt m =
let isfslib = fileNameOfPath filename = GetFSharpCoreLibraryName() + ".dll"
- match ilAssemblyRefs |> List.tryFind (fun aref -> aref.Name = data.mscorlibAssemblyName) with
+ match ilAssemblyRefs |> List.tryFind (fun aref -> aref.Name = data.primaryAssembly.Name) with
| Some aref ->
match aref.Version with
| Some(v1,_,_,_) ->
if isfslib && ((v1 < 4us) <> (mscorlibVersion.Major < 4)) then
// the versions mismatch, however they are allowed to mismatch in one case:
- if mscorlibIsSilverlight && mscorlibVersion.Major=5 // SL5
+ if primaryAssemblyIsSilverlight && mscorlibVersion.Major=5 // SL5
&& (match explicitFscoreVersionToCheckOpt with
| Some(v1,v2,v3,_) -> v1=2us && v2=3us && v3=5us // we build SL5 against portable FSCore 2.3.5.0
| None -> true) // the 'None' code path happens after explicit FSCore was already checked, from now on SL5 path is always excepted
@@ -2281,7 +2510,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
| Some(fslibFilename) ->
let filename = ComputeMakePathAbsolute data.implicitIncludeDir fslibFilename
try
- let ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None,data.mscorlibAssemblyName,data.noDebugData)
+ let ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None, data.primaryAssembly.Name, data.noDebugData)
try
checkFSharpBinaryCompatWithMscorlib filename ilReader.ILAssemblyRefs ilReader.ILModuleDef.ManifestOfAssembly.Version rangeStartup;
let fslibRoot = Path.GetDirectoryName(FileSystem.GetFullPathShim(filename))
@@ -2295,9 +2524,9 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
data.defaultFSharpBinariesDir
member x.TargetMscorlibVersion = mscorlibVersion
- member x.TargetIsSilverlight = mscorlibIsSilverlight
+ member x.TargetIsSilverlight = primaryAssemblyIsSilverlight
- member x.mscorlibAssemblyName = data.mscorlibAssemblyName
+ member x.primaryAssembly = data.primaryAssembly
member x.autoResolveOpenDirectivesToDlls = data.autoResolveOpenDirectivesToDlls
member x.noFeedback = data.noFeedback
member x.stackReserveSize = data.stackReserveSize
@@ -2415,6 +2644,11 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
member x.noDebugData = data.noDebugData
member x.isInteractive = data.isInteractive
member x.isInvalidationSupported = data.isInvalidationSupported
+ member x.emitDebugInfoInQuotations = data.emitDebugInfoInQuotations
+ member x.sqmSessionGuid = data.sqmSessionGuid
+ member x.sqmNumOfSourceFiles = data.sqmNumOfSourceFiles
+ member x.sqmSessionStartedTime = data.sqmSessionStartedTime
+
static member Create(builder,validate) =
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter)
TcConfig(builder,validate)
@@ -2439,9 +2673,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
// When running on Mono we lead everyone to believe we're doing .NET 4.0 compilation
// by default.
if runningOnMono then
- let sysDir = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory()
- let mono40SysDir = Path.Combine(Path.GetDirectoryName sysDir, "4.0")
- [mono40SysDir]
+ [System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory()]
else
try
match tcConfig.resolutionEnvironment with
@@ -2528,7 +2760,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
if isNetModule then ""
else
try
- let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals=ecmaILGlobals;optimizeForMemory=false}
+ let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaILGlobals;optimizeForMemory=false}
let reader = ILBinaryReader.OpenILModuleReader resolved readerSettings
try
let assRef = mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly
@@ -2735,8 +2967,8 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
#endif // SILVERLIGHT
- member tcConfig.MscorlibDllReference() = mscorlibReference
-
+ member tcConfig.PrimaryAssemblyDllReference() = primaryAssemblyReference
+ member tcConfig.GetPrimaryAssemblyCcuInitializer() = primaryAssemblyCcuInitializer
member tcConfig.CoreLibraryDllReference() = fslibReference
@@ -2800,7 +3032,9 @@ type ErrorLoggerFilteringByScopedPragmas (checkFile,scopedPragmas,errorLogger:Er
(not checkFile || m.FileIndex = pragmaRange.FileIndex) &&
Range.posGeq m.Start pragmaRange.Start))
| None -> true
- if report then errorLogger.WarnSink(err);
+ if report then errorLogger.WarnSink(err);
+ override x.ErrorNumbers = errorLogger.ErrorNumbers
+ override x.WarningNumbers = errorLogger.WarningNumbers
let GetErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) =
(ErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) :> ErrorLogger)
@@ -2969,7 +3203,7 @@ let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaul
// - if you have a #line directive, e.g.
// # 1000 "Line01.fs"
// then it also asserts. But these are edge cases that can be fixed later, e.g. in bug 4651.
- //System.Diagnostics.Debug.Assert(FileSystem.IsPathRootedShim(filename), sprintf "should be absolute: '%s'" filename)
+ //System.Diagnostics.Debug.Assert(System.IO.Path.IsPathRooted(filename), sprintf "should be absolute: '%s'" filename)
let lower = String.lowercase filename
// Delay sending errors and warnings until after the file is parsed. This gives us a chance to scrape the
// #nowarn declarations for the file
@@ -3112,13 +3346,13 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres
static member GetAllDllReferences (tcConfig:TcConfig) =
- [ yield tcConfig.MscorlibDllReference()
+ [ yield tcConfig.PrimaryAssemblyDllReference()
if not tcConfig.compilingFslib then
yield tcConfig.CoreLibraryDllReference()
if tcConfig.framework then
for s in DefaultBasicReferencesForOutOfProjectSources do
- yield AssemblyReference(rangeStartup,s)
+ yield AssemblyReference(rangeStartup,s+".dll")
if tcConfig.framework || tcConfig.addVersionSpecificFrameworkReferences then
// For out-of-project context, then always reference some extra DLLs on .NET 4.0
@@ -3256,32 +3490,6 @@ let WriteOptimizationData (tcGlobals, file, ccu,modulInfo) =
// Relink blobs of saved data by fixing up ccus.
//--------------------------------------------------------------------------
-type ImportedBinary =
- { FileName: string;
- RawMetadata: ILModuleDef;
-#if EXTENSIONTYPING
- ProviderGeneratedAssembly: System.Reflection.Assembly option
- IsProviderGenerated: bool;
- ProviderGeneratedStaticLinkMap : ProvidedAssemblyStaticLinkingMap option
-#endif
- ILAssemblyRefs : ILAssemblyRef list;
- ILScopeRef: ILScopeRef }
-
-type ImportedAssembly =
- { ILScopeRef: ILScopeRef;
- FSharpViewOfMetadata: CcuThunk;
- AssemblyAutoOpenAttributes: string list;
- AssemblyInternalsVisibleToAttributes: string list;
-#if EXTENSIONTYPING
- IsProviderGenerated: bool
- mutable TypeProviders: Tainted<Microsoft.FSharp.Core.CompilerServices.ITypeProvider> list;
-#endif
- FSharpOptimizationData : Microsoft.FSharp.Control.Lazy<Option<Opt.LazyModuleInfo>> }
-
-type AvailableImportedAssembly =
- | ResolvedImportedAssembly of ImportedAssembly
- | UnresolvedImportedAssembly of string
-
let availableToOptionalCcu = function
| ResolvedCcu(ccu) -> Some(ccu)
| UnresolvedCcu _ -> None
@@ -3456,8 +3664,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let fileName = aname.Name + ".dll"
let bytes = assembly.PApplyWithProvider((fun (assembly,provider) -> assembly.GetManifestModuleContents(provider)), m).PUntaint(id,m)
let ilModule,ilAssemblyRefs =
- let opts = { ILBinaryReader.defaults with
- ILBinaryReader.ilGlobals= g.ilg
+ let opts = { ILBinaryReader.mkDefault g.ilg with
ILBinaryReader.optimizeForMemory=true
ILBinaryReader.pdbPath = None }
let reader = ILBinaryReader.OpenILModuleReaderFromBytes fileName bytes opts
@@ -3486,7 +3693,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
FileName = Some fileName
MemberSignatureEquality = (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll g ty1 ty2)
ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty)
- TypeForwarders = lazy Map.empty }
+ TypeForwarders = Map.empty }
let ccu = CcuThunk.Create(ilShortAssemName,ccuData)
let ccuinfo =
@@ -3552,10 +3759,9 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
else
None
else
- None
-
+ None
- let ilILBinaryReader = OpenILBinary(filename,tcConfig.optimizeForMemory,tcConfig.openBinariesInMemory,ilGlobalsOpt,pdbPathOption,tcConfig.mscorlibAssemblyName,tcConfig.noDebugData)
+ let ilILBinaryReader = OpenILBinary(filename,tcConfig.optimizeForMemory,tcConfig.openBinariesInMemory,ilGlobalsOpt,pdbPathOption, tcConfig.primaryAssembly.Name, tcConfig.noDebugData)
tcImports.AttachDisposeAction(fun _ -> ILBinaryReader.CloseILModuleReader ilILBinaryReader);
ilILBinaryReader.ILModuleDef, ilILBinaryReader.ILAssemblyRefs
@@ -3693,14 +3899,23 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let startingErrorCount = CompileThreadStatic.ErrorLogger.ErrorCount
let providerAssemblies =
moduleAttributes
- |> List.choose TryDecodeTypeProviderAssemblyAttr
+ |> List.choose (TryDecodeTypeProviderAssemblyAttr (defaultArg ilGlobalsOpt EcmaILGlobals))
// If no design-time assembly is specified, use the runtime assembly
|> List.map (function null -> Path.GetFileNameWithoutExtension fileNameOfRuntimeAssembly | s -> s)
|> Set.ofList
if providerAssemblies.Count > 0 then
- let systemRuntimeAssemblyVersion = tcConfig.TargetMscorlibVersion
+#if SILVERLIGHT
+ let systemRuntimeAssemblyVersion : System.Version = tcConfig.TargetMscorlibVersion
+#else
+ let systemRuntimeAssemblyVersion : System.Version =
+ let primaryAssemblyRef = tcConfig.PrimaryAssemblyDllReference()
+ let resolution = tcConfig.ResolveLibWithDirectories(primaryAssemblyRef)
+ // MSDN: this method causes the file to be opened and closed, but the assembly is not added to this domain
+ let name = System.Reflection.AssemblyName.GetAssemblyName(resolution.resolvedPath)
+ name.Version
+#endif
let providers =
[ for assemblyName in providerAssemblies do
@@ -3799,11 +4014,14 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let auxModuleLoader = tcImports.MkLoaderForMultiModuleIlAssemblies m
let invalidateCcu = new Event<_>()
let ccu = Import.ImportILAssembly(tcImports.GetImportMap,m,auxModuleLoader,ilScopeRef,tcConfig.implicitIncludeDir, Some filename,ilModule,invalidateCcu.Publish)
+
+ let ilg = defaultArg ilGlobalsOpt EcmaILGlobals
+
let ccuinfo =
{ FSharpViewOfMetadata=ccu;
ILScopeRef = ilScopeRef;
- AssemblyAutoOpenAttributes = GetAutoOpenAttributes(ilModule);
- AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes(ilModule);
+ AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilg ilModule;
+ AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilg ilModule;
#if EXTENSIONTYPING
IsProviderGenerated = false;
TypeProviders = [];
@@ -3911,7 +4129,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
#endif
UsesQuotations = minfo.usesQuotations
MemberSignatureEquality= (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2)
- TypeForwarders = match ilModule.Manifest with | Some manifest -> ImportILAssemblyTypeForwarders(tcImports.GetImportMap,m,manifest.ExportedTypes) | None -> lazy Map.empty })
+ TypeForwarders = match ilModule.Manifest with | Some manifest -> ImportILAssemblyTypeForwarders(tcImports.GetImportMap,m,manifest.ExportedTypes) | None -> Map.empty })
let optdata =
lazy
@@ -3923,11 +4141,12 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let data = GetOptimizationData (filename, ilScopeRef, ilModule, info)
let res = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(m,nm,lookupOnly=false)))
if verbose then dprintf "found optimization data for CCU %s\n" ccuName
- Some res)
+ Some res)
+ let ilg = defaultArg ilGlobalsOpt EcmaILGlobals
let ccuinfo =
{ FSharpViewOfMetadata=ccu
- AssemblyAutoOpenAttributes = GetAutoOpenAttributes(ilModule)
- AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes(ilModule)
+ AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilg ilModule
+ AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilg ilModule
FSharpOptimizationData=optdata
#if EXTENSIONTYPING
IsProviderGenerated = false
@@ -3979,9 +4198,10 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
ILAssemblyRefs = ilAssemblyRefs }
tcImports.RegisterDll(dllinfo)
let attrs = GetCustomAttributesOfIlModule ilModule
+ let ilg = defaultArg ilGlobalsOpt EcmaILGlobals
let phase2 =
if (List.exists IsSignatureDataVersionAttr attrs) then
- if not (List.exists (IsMatchingSignatureDataVersionAttr (IL.parseILVersion Internal.Utilities.FSharpEnvironment.FSharpBinaryMetadataFormatRevision)) attrs) then
+ if not (List.exists (IsMatchingSignatureDataVersionAttr ilg (IL.parseILVersion Internal.Utilities.FSharpEnvironment.FSharpBinaryMetadataFormatRevision)) attrs) then
errorR(Error(FSComp.SR.buildDifferentVersionMustRecompile(filename),m))
tcImports.PrepareToImportReferencedIlDll tpApprovalsRef m filename displayPSTypeProviderSecurityDialogBlockingUI dllinfo
else
@@ -4116,20 +4336,25 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,frameworkDLLs,[])
let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,nonFrameworkDLLs,[])
- // mscorlib gets loaded first.
- let mscorlibReference = tcConfig.MscorlibDllReference()
-
// Note: TcImports are disposable - the caller owns this object and must dispose
let frameworkTcImports = new TcImports(tcConfigP,tcResolutions,None,None)
+ let resolveAssembly r =
+ // use existing resolutions before trying to search in known folders
+ let resolution =
+ match tcResolutions.TryFindByOriginalReference r with
+ | Some r -> r
+ | None ->
+ match tcAltResolutions.TryFindByOriginalReference r with
+ | Some r -> r
+ | None -> tcConfig.ResolveLibWithDirectories r
+ match frameworkTcImports.RegisterAndImportReferencedAssemblies(None, [resolution]) with
+ | (_, [ResolvedImportedAssembly(ccu)]) -> ccu
+ | _ -> error(InternalError("BuildFoundationalTcImports: no ccu for " + r.Text, rangeStartup))
- let sysCcu =
- let mscorlibResolution = tcConfig.ResolveLibWithDirectories(mscorlibReference)
- //printfn "mscorlibResolution= %s" mscorlibResolution.resolvedPath
- match frameworkTcImports.RegisterAndImportReferencedAssemblies(None, [mscorlibResolution]) with
- | (_, [ResolvedImportedAssembly(sysCcu)]) -> sysCcu
- | _ -> error(InternalError("BuildFoundationalTcImports: no sysCcu for "+mscorlibReference.Text,rangeStartup))
- let ilGlobals = mkILGlobals sysCcu.FSharpViewOfMetadata.ILScopeRef (Some tcConfig.mscorlibAssemblyName) tcConfig.noDebugData
+ let ccuInitializer = tcConfig.GetPrimaryAssemblyCcuInitializer()
+ let ilGlobals, state = ccuInitializer.BeginLoadingSystemRuntime(resolveAssembly, tcConfig.noDebugData)
frameworkTcImports.SetILGlobals ilGlobals
+ let sysCcu = ccuInitializer.EndLoadingSystemRuntime(state, resolveAssembly)
// Load the rest of the framework DLLs all at once (they may be mutually recursive)
frameworkTcImports.DoRegisterAndImportReferencedAssemblies (None, tcResolutions.GetAssemblyResolutions())
@@ -4176,7 +4401,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
let search =
seq { yield sysCcu.FSharpViewOfMetadata;
yield! frameworkTcImports.GetCcusInDeclOrder()
- for dllName in SystemAssemblies (tcConfig.mscorlibAssemblyName, tcConfig.TargetMscorlibVersion, tcConfig.TargetIsSilverlight) do
+ for dllName in SystemAssemblies (tcConfig.primaryAssembly.Name, tcConfig.TargetMscorlibVersion, tcConfig.TargetIsSilverlight) do
match frameworkTcImports.CcuTable.TryFind dllName with
| Some sysCcu -> yield sysCcu.FSharpViewOfMetadata
| None -> () }
@@ -4189,14 +4414,14 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
// Silverlight 4.0 will have some of these fixes, but their version number is 2.0.5.0.
// If we ever modify the compiler to run on Silverlight, we'll need to update this mechanism.
let using40environment =
- match ilGlobals.mscorlibScopeRef.AssemblyRef.Version with
+ match ilGlobals.traits.ScopeRef.AssemblyRef.Version with
| Some (v1, _v2, _v3, _v4) -> v1 >= 4us
| _ -> true
// OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals
let tcGlobals = mkTcGlobals(tcConfig.compilingFslib,sysCcu.FSharpViewOfMetadata,ilGlobals,fslibCcu,
tcConfig.implicitIncludeDir,tcConfig.mlCompatibility,using40environment,tcConfig.indirectCallArrayMethods,
- tcConfig.isInteractive,getTypeCcu)
+ tcConfig.isInteractive,getTypeCcu, tcConfig.emitDebugInfoInQuotations)
#if DEBUG
// the global_g reference cell is used only for debug printing
@@ -4472,7 +4697,7 @@ module private ScriptPreprocessClosure =
let projectDir = Path.GetDirectoryName(filename)
let isInteractive = (codeContext = CodeContext.Evaluation)
let isInvalidationSupported = (codeContext = CodeContext.Editing)
-
+ // always use primary assembly = mscorlib for scripts
let tcConfigB = TcConfigBuilder.CreateNew(Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler.Value, true (* optimize for memory *), projectDir, isInteractive, isInvalidationSupported)
BasicReferencesForScriptLoadClosure |> List.iter(fun f->tcConfigB.AddReferencedAssemblyByPath(range0,f)) // Add script references
tcConfigB.resolutionEnvironment <-
@@ -4745,7 +4970,7 @@ let TypecheckInitialState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImpo
ILScopeRef=ILScopeRef.Local
Contents=ccuType
MemberSignatureEquality= (Tastops.typeEquivAux EraseAll tcGlobals)
- TypeForwarders=lazy Map.empty })
+ TypeForwarders=Map.empty })
(* OK, is this is the F# library CCU then fix it up. *)
if tcConfig.compilingFslib then
diff --git a/src/fsharp/build.fsi b/src/fsharp/build.fsi
index 63fa573..3190192 100755
--- a/src/fsharp/build.fsi
+++ b/src/fsharp/build.fsi
@@ -86,12 +86,40 @@ type ErrorStyle =
val RangeOfError : PhasedError -> range option
+val GetErrorNumber : PhasedError -> int
val SplitRelatedErrors : PhasedError -> PhasedError * PhasedError list
val OutputPhasedError : StringBuilder -> PhasedError -> bool -> unit
val SanitizeFileName : filename:string -> implicitIncludeDir:string -> string
val OutputErrorOrWarning : implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * warning:bool -> StringBuilder -> PhasedError -> unit
val OutputErrorOrWarningContext : prefix:string -> fileLineFunction:(string -> int -> string) -> StringBuilder -> PhasedError -> unit
+type ErrorLocation =
+ {
+ Range : range
+ File : string
+ TextRepresentation : string
+ IsEmpty : bool
+ }
+
+type CanonicalInformation =
+ {
+ ErrorNumber : int
+ Subcategory : string
+ TextRepresentation : string
+ }
+
+type DetailedIssueInfo =
+ {
+ Location : ErrorLocation option
+ Canonical : CanonicalInformation
+ Message : string
+ }
+
+type ErrorOrWarning =
+ | Short of bool * string
+ | Long of bool * DetailedIssueInfo
+
+val CollectErrorOrWarning : implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * warning:bool * PhasedError -> seq<ErrorOrWarning>
//----------------------------------------------------------------------------
// Options and configuration
@@ -138,6 +166,12 @@ exception InternalCommandLineOption of string * range
exception HashLoadedSourceHasIssues of (*warnings*) exn list * (*errors*) exn list * range
exception HashLoadedScriptConsideredSource of range
+type PrimaryAssembly =
+ | Mscorlib
+ | NamedMscorlib of string
+ | DotNetCore
+ member Name : string
+
type AssemblyReference =
| AssemblyReference of range * string
member Range : range
@@ -185,7 +219,7 @@ type VersionFlag =
type TcConfigBuilder =
- { mutable mscorlibAssemblyName: string;
+ { mutable primaryAssembly : PrimaryAssembly;
mutable autoResolveOpenDirectivesToDlls: bool;
mutable noFeedback: bool;
mutable stackReserveSize: int32 option;
@@ -306,8 +340,19 @@ type TcConfigBuilder =
/// If true, indicates all type checking and code generation is in the context of fsi.exe
isInteractive : bool
- isInvalidationSupported : bool }
- static member CreateNew : defaultFSharpBinariesDir: string * optimizeForMemory: bool * implicitIncludeDir: string * isInteractive: bool * isInvalidationSupported: bool -> TcConfigBuilder
+ isInvalidationSupported : bool
+ mutable sqmSessionGuid : System.Guid option
+ mutable sqmNumOfSourceFiles : int
+ sqmSessionStartedTime : int64
+ mutable emitDebugInfoInQuotations : bool }
+
+ static member CreateNew :
+ defaultFSharpBinariesDir: string *
+ optimizeForMemory: bool *
+ implicitIncludeDir: string *
+ isInteractive: bool *
+ isInvalidationSupported: bool -> TcConfigBuilder
+
member DecideNames : string list -> outfile: string * pdbfile: string option * assemblyName: string
member TurnWarningOff : range * string -> unit
member TurnWarningOn : range * string -> unit
@@ -323,7 +368,7 @@ type TcConfigBuilder =
[<Sealed>]
// Immutable TcConfig
type TcConfig =
- member mscorlibAssemblyName: string;
+ member primaryAssembly: PrimaryAssembly
member autoResolveOpenDirectivesToDlls: bool;
member noFeedback: bool;
member stackReserveSize: int32 option;
@@ -345,7 +390,6 @@ type TcConfig =
member conditionalCompilationDefines: string list;
member subsystemVersion : int * int
member useHighEntropyVA : bool
-
member referencedDLLs: AssemblyReference list;
member optimizeForMemory: bool;
member inputCodePage: int option;
@@ -454,6 +498,11 @@ type TcConfig =
member ResolveSourceFile : range * string * string -> string
/// File system query based on TcConfig settings
member MakePathAbsolute : string -> string
+
+ member sqmSessionGuid : System.Guid option
+ member sqmNumOfSourceFiles : int
+ member sqmSessionStartedTime : int64
+
static member Create : TcConfigBuilder * validate: bool -> TcConfig
member TargetMscorlibVersion : System.Version
@@ -629,8 +678,6 @@ val ParseCompilerOptions : (string -> unit) -> CompilerOptionBlock list -> strin
val ReportWarning : int -> int list -> int list -> PhasedError -> bool
val ReportWarningAsError : int -> int list -> int list -> int list -> int list -> bool -> PhasedError -> bool
-val highestInstalledNetFrameworkVersionMajorMinor : unit -> System.Version * string
-
//----------------------------------------------------------------------------
// #load closure
//--------------------------------------------------------------------------
diff --git a/src/fsharp/check.fs b/src/fsharp/check.fs
index b50e186..286d7d3 100755
--- a/src/fsharp/check.fs
+++ b/src/fsharp/check.fs
@@ -871,7 +871,7 @@ and CheckAttribArgExpr cenv env expr =
| Const.String _ -> ()
| _ ->
if cenv.reportErrors then
- errorR (Error (FSComp.SR.tastConstantCannotBeCustomAttribute(), m))
+ errorR (Error (FSComp.SR.tastNotAConstantExpression(), m))
| Expr.Op(TOp.Array,[_elemTy],args,_m) ->
List.iter (CheckAttribArgExpr cenv env) args
@@ -941,17 +941,9 @@ and AdjustAccess isHidden (cpath: unit -> CompilationPath) access =
and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,e,_) as bind) =
//printfn "visiting %s..." v.DisplayName
match TryGetActivePatternInfo (mkLocalValRef v) with
- | Some _ ->
- let vty = v.TauType
- let vtps = v.Typars |> Zset.ofList typarOrder
- if not (isFunTy cenv.g v.TauType) then
- errorR(Error(FSComp.SR.activePatternIdentIsNotFunctionTyped(v.LogicalName),v.Range))
- let argtys,resty = stripFunTy cenv.g vty
- let argtps,restps= (freeInTypes CollectTypars argtys).FreeTypars,(freeInType CollectTypars resty).FreeTypars
- // Error if an active pattern is generic in type variables that only occur in the result Choice<_,...>.
- // Note: The test restricts to v.Typars since typars from the closure are considered fixed.
- if not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps)) then
- errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(v.LogicalName),v.Range))
+ | Some _apinfo when _apinfo.ActiveTags.Length > 1 ->
+ if doesActivePatternHaveFreeTypars cenv.g (mkLocalValRef v) then
+ errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(v.LogicalName),v.Range))
| _ -> ()
match cenv.potentialUnboundUsesOfVals.TryFind v.Stamp with
@@ -1058,8 +1050,8 @@ let CheckTopBinding cenv env (TBind(v,e,_) as bind) =
not v.IsMutable &&
// Literals always have fields
not (HasFSharpAttribute cenv.g cenv.g.attrib_LiteralAttribute v.Attribs) &&
- not (HasFSharpAttribute cenv.g cenv.g.attrib_ThreadStaticAttribute v.Attribs) &&
- not (HasFSharpAttribute cenv.g cenv.g.attrib_ContextStaticAttribute v.Attribs) &&
+ not (HasFSharpAttributeOpt cenv.g cenv.g.attrib_ThreadStaticAttribute v.Attribs) &&
+ not (HasFSharpAttributeOpt cenv.g cenv.g.attrib_ContextStaticAttribute v.Attribs) &&
// Having a field makes the binding a static initialization trigger
IsSimpleSyntacticConstantExpr cenv.g e &&
// Check the thing is actually compiled as a property
@@ -1114,14 +1106,11 @@ let CheckTopBinding cenv env (TBind(v,e,_) as bind) =
| None -> false
| Some arity -> List.sum arity.AritiesOfArgs - v.NumObjArgs <= 0 && arity.NumTypars = 0
- // Unions with one alternative use "Item", "Item1", "Item2" etc. But only if these
- // are properties without arguments.
+ // In unions user cannot define properties that clash with generated ones
if tcref.UnionCasesArray.Length = 1 && hasNoArgs then
let ucase1 = tcref.UnionCasesArray.[0]
- let nFields = ucase1.RecdFieldsArray.Length
- for i in 0 .. nFields - 1 do
- let propName = if nFields <= 1 then "Item" else "Item"+string (i+1)
- if nm = propName then error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),propName,ucase1.Range));
+ for f in ucase1.RecdFieldsArray do
+ if f.Name = nm then error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),f.Name,ucase1.Range));
// Default augmentation contains the nasty 'Case<UnionCase>' etc.
let prefix = "New"
@@ -1471,9 +1460,11 @@ let CheckTopImpl (g,amap,reportErrors,infoReader,internalsVisibleToPaths,viewCcu
// See primEntityRefEq.
cenv.g.system_Void_tcref.TryDeref |> ignore
cenv.g.byref_tcr.TryDeref |> ignore
- cenv.g.system_TypedReference_tcref.TryDeref |> ignore
- cenv.g.system_ArgIterator_tcref.TryDeref |> ignore
- cenv.g.system_RuntimeArgumentHandle_tcref.TryDeref |> ignore
+
+ let resolve = function Some(t : TyconRef) -> ignore(t.TryDeref) | _ -> ()
+ resolve cenv.g.system_TypedReference_tcref
+ resolve cenv.g.system_ArgIterator_tcref
+ resolve cenv.g.system_RuntimeArgumentHandle_tcref
let env =
{ sigToImplRemapInfo=[]
diff --git a/src/fsharp/creflect.fs b/src/fsharp/creflect.fs
index 7843541..443d7bf 100755
--- a/src/fsharp/creflect.fs
+++ b/src/fsharp/creflect.fs
@@ -51,7 +51,8 @@ type cenv =
typeSplices: ResizeArray<Tast.Typar> ;
// Accumulate the expression splices into here
exprSplices: ResizeArray<Expr>
- isReflectedDefinition : IsReflectedDefinition }
+ isReflectedDefinition : IsReflectedDefinition
+ mutable emitDebugInfoInQuotations : bool }
@@ -61,8 +62,8 @@ let mk_cenv (g,amap,scope,isReflectedDefinition) =
amap=amap
typeSplices = new ResizeArray<_>()
exprSplices = new ResizeArray<_>()
- isReflectedDefinition = isReflectedDefinition }
-
+ isReflectedDefinition = isReflectedDefinition
+ emitDebugInfoInQuotations = g.emitDebugInfoInQuotations }
type QuotationTranslationEnv =
{ //Map from Val to binding index
@@ -126,11 +127,70 @@ let (|ModuleValueOrMemberUse|_|) cenv expr =
| _ ->
None
loop expr []
-
+
+let (|SimpleArrayLoopUpperBound|_|) expr =
+ match expr with
+ | Expr.Op(TOp.ILAsm([AI_sub], _), _, [Expr.Op(TOp.ILAsm([I_ldlen; AI_conv ILBasicType.DT_I4], _), _, _, _); Expr.Const(Const.Int32 1, _, _) ], _) -> Some ()
+ | _ -> None
+
+let (|SimpleArrayLoopBody|_|) g expr =
+ match expr with
+ | Expr.Lambda(_, a, b, ([_] as args), Expr.Let(TBind(forVarLoop, Expr.Op(TOp.ILAsm([I_ldelem_any(ILArrayShape [(Some 0, None)], _)], _), [elemTy], [arr; idx], m1), seqPoint), body, m2, freeVars), m, ty) ->
+ let body = Expr.Let(TBind(forVarLoop, mkCallArrayGet g m1 elemTy arr idx, seqPoint), body, m2, freeVars)
+ let expr = Expr.Lambda(newUnique(), a, b, args, body, m, ty)
+ Some (arr, elemTy, expr)
+ | _ -> None
+
+let (|ObjectInitializationCheck|_|) g expr =
+ // recognize "if this.init@ < 1 then failinit"
+ match expr with
+ | Expr.Match
+ (
+ _, _,
+ TDSwitch
+ (
+ Expr.Op(TOp.ILAsm([AI_clt], _), _, [Expr.Op(TOp.ValFieldGet((RFRef(_, name))), _, [Expr.Val(selfRef, NormalValUse, _)], _); Expr.Const(Const.Int32 1, _, _)], _), _, _, _
+ ),
+ [| TTarget([], Expr.App(Expr.Val(failInitRef, _, _), _, _, _, _), _); _ |], _, resultTy
+ ) when
+ IsCompilerGeneratedName name &&
+ name.StartsWith "init" &&
+ selfRef.BaseOrThisInfo = MemberThisVal &&
+ valRefEq g failInitRef (ValRefForIntrinsic g.fail_init_info) &&
+ isUnitTy g resultTy -> Some()
+ | _ -> None
let isSplice g vref = valRefEq g vref g.splice_expr_vref || valRefEq g vref g.splice_raw_expr_vref
-let rec ConvExpr cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.ExprData =
+let rec EmitDebugInfoIfNecessary cenv env m astExpr : QP.ExprData =
+ // do not emit debug info if emitDebugInfoInQuotations = false or it was already written for the given expression
+ if cenv.emitDebugInfoInQuotations && not (QP.isAttributedExpression astExpr) then
+ cenv.emitDebugInfoInQuotations <- false
+ try
+ let mk_tuple g m es = mkTupled g m es (List.map (tyOfExpr g) es)
+
+ let rangeExpr =
+ mk_tuple cenv.g m
+ [ mkString cenv.g m m.FileName;
+ mkInt cenv.g m m.StartLine;
+ mkInt cenv.g m m.StartColumn;
+ mkInt cenv.g m m.EndLine;
+ mkInt cenv.g m m.EndColumn; ]
+ let attrExpr =
+ mk_tuple cenv.g m
+ [ mkString cenv.g m "DebugRange"; rangeExpr ]
+ let attrExprR = ConvExprCore cenv env attrExpr
+
+ QP.mkAttributedExpression(astExpr, attrExprR)
+ finally
+ cenv.emitDebugInfoInQuotations <- true
+ else
+ astExpr
+
+and ConvExpr cenv env (expr : Expr) =
+ EmitDebugInfoIfNecessary cenv env expr.Range (ConvExprCore cenv env expr)
+
+and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.ExprData =
// Eliminate integer 'for' loops
let expr = DetectFastIntegerForLoops cenv.g expr
@@ -316,7 +376,9 @@ let rec ConvExpr cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.ExprData
| Expr.Match (_spBind,m,dtree,tgs,_,retTy) ->
let typR = ConvType cenv env m retTy
ConvDecisionTree cenv env tgs typR dtree
-
+
+ // initialization check
+ | Expr.Sequential(ObjectInitializationCheck cenv.g, x1, NormalSeq, _, _) -> ConvExpr cenv env x1
| Expr.Sequential (x0,x1,NormalSeq,_,_) -> QP.mkSequential(ConvExpr cenv env x0, ConvExpr cenv env x1)
| Expr.Obj (_,typ,_,_,[TObjExprMethod(TSlotSig(_,ctyp, _,_,_,_),_,tps,[tmvs],e,_) as tmethod],_,m) when isDelegateTy cenv.g typ ->
let f = mkLambdas m tps tmvs (e,GetFSharpViewOfReturnType cenv.g (returnTyOfMethod cenv.g tmethod))
@@ -382,7 +444,7 @@ let rec ConvExpr cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.ExprData
| TOp.ILAsm([ I_throw ],_),_,[arg1] ->
let raiseExpr = mkCallRaise cenv.g m (tyOfExpr cenv.g expr) arg1
- ConvExpr cenv env raiseExpr
+ ConvExpr cenv env raiseExpr
| TOp.ILAsm(_il,_),_,_ ->
wfail(Error(FSComp.SR.crefQuotationsCantContainInlineIL(), m))
@@ -463,6 +525,12 @@ let rec ConvExpr cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.ExprData
| TOp.While _,[],[Expr.Lambda(_,_,_,[_],test,_,_);Expr.Lambda(_,_,_,[_],body,_,_)] ->
QP.mkWhileLoop(ConvExpr cenv env test, ConvExpr cenv env body)
+
+ | TOp.For(_, FSharpForLoopUp), [], [Expr.Lambda(_,_,_,[_], lim0,_,_); Expr.Lambda(_,_,_,[_], SimpleArrayLoopUpperBound, lm,_); SimpleArrayLoopBody cenv.g (arr, elemTy, body)] ->
+ let lim1 =
+ let len = mkCallArrayLength cenv.g lm elemTy arr // Array.length arr
+ mkCallSubtractionOperator cenv.g lm cenv.g.int32_ty len (Expr.Const(Const.Int32 1, m, cenv.g.int32_ty)) // len - 1
+ QP.mkForLoop(ConvExpr cenv env lim0, ConvExpr cenv env lim1, ConvExpr cenv env body)
| TOp.For(_,dir),[],[Expr.Lambda(_,_,_,[_],lim0,_,_);Expr.Lambda(_,_,_,[_],lim1,_,_);body] ->
match dir with
@@ -512,7 +580,10 @@ and ConvLdfld cenv env m (fspec: ILFieldSpec) enclTypeArgs args =
let argsR = ConvLValueArgs cenv env args
QP.mkFieldGet( (parentTyconR, fspec.Name),tyargsR, argsR)
-and ConvRFieldGet cenv env m rfref tyargs args =
+and ConvRFieldGet cenv env m rfref tyargs args =
+ EmitDebugInfoIfNecessary cenv env m (ConvRFieldGetCore cenv env m rfref tyargs args)
+
+and private ConvRFieldGetCore cenv env m rfref tyargs args =
let tyargsR = ConvTypes cenv env m tyargs
let argsR = ConvLValueArgs cenv env args
let ((parentTyconR,fldOrPropName) as projR) = ConvRecdFieldRef cenv rfref m
@@ -557,8 +628,10 @@ and ConvLValueArgs cenv env args =
| obj::rest -> ConvLValueExpr cenv env obj :: ConvExprs cenv env rest
| [] -> []
-// This function has to undo the work of mkExprAddrOfExpr
and ConvLValueExpr cenv env expr =
+ EmitDebugInfoIfNecessary cenv env expr.Range (ConvLValueExprCore cenv env expr)
+// This function has to undo the work of mkExprAddrOfExpr
+and ConvLValueExprCore cenv env expr =
match expr with
| Expr.Op(op,tyargs,args,m) ->
match op, args, tyargs with
@@ -576,8 +649,10 @@ and ConvLValueExpr cenv env expr =
| _ -> ConvExpr cenv env expr
| _ -> ConvExpr cenv env expr
+and ConvObjectModelCall cenv env m callInfo =
+ EmitDebugInfoIfNecessary cenv env m (ConvObjectModelCallCore cenv env m callInfo)
-and ConvObjectModelCall cenv env m (isPropGet,isPropSet,isNewObj,parentTyconR,methArgTypesR,methRetTypeR,methName,tyargs,numGenericArgs,callArgs) =
+and ConvObjectModelCallCore cenv env m (isPropGet,isPropSet,isNewObj,parentTyconR,methArgTypesR,methRetTypeR,methName,tyargs,numGenericArgs,callArgs) =
let tyargsR = ConvTypes cenv env m tyargs
let callArgsR = ConvLValueArgs cenv env callArgs
@@ -604,6 +679,8 @@ and ConvObjectModelCall cenv env m (isPropGet,isPropSet,isNewObj,parentTyconR,me
tyargsR, callArgsR)
and ConvModuleValueApp cenv env m (vref:ValRef) tyargs (args: Expr list list) =
+ EmitDebugInfoIfNecessary cenv env m (ConvModuleValueAppCore cenv env m vref tyargs args)
+and ConvModuleValueAppCore cenv env m (vref:ValRef) tyargs (args: Expr list list) =
match vref.ActualParent with
| ParentNone -> failwith "ConvModuleValueApp"
| Parent(tcref) ->
@@ -618,6 +695,9 @@ and ConvExprs cenv env args =
List.map (ConvExpr cenv env) args
and ConvValRef holeOk cenv env m (vref:ValRef) tyargs =
+ EmitDebugInfoIfNecessary cenv env m (ConvValRefCore holeOk cenv env m vref tyargs)
+
+and private ConvValRefCore holeOk cenv env m (vref:ValRef) tyargs =
let v = vref.Deref
if env.isinstVals.ContainsVal v then
let (ty,e) = env.isinstVals.[v]
@@ -735,46 +815,47 @@ and ConvDecisionTree cenv env tgs typR x =
match dfltOpt with
| Some d -> ConvDecisionTree cenv env tgs typR d
| None -> wfail(Error(FSComp.SR.crefQuotationsCantContainThisPatternMatch(), m))
-
- (csl,acc) ||> List.foldBack (fun (TCase(discrim,dtree)) acc ->
- match discrim with
- | Test.UnionCase (ucref, tyargs) ->
- let e1R = ConvExpr cenv env e1
- let ucR = ConvUnionCaseRef cenv ucref m
- let tyargsR = ConvTypes cenv env m tyargs
- QP.mkCond (QP.mkSumTagTest (ucR, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
- | Test.Const (Const.Bool true) ->
- let e1R = ConvExpr cenv env e1
- QP.mkCond (e1R, ConvDecisionTree cenv env tgs typR dtree, acc)
- | Test.Const (Const.Bool false) ->
- let e1R = ConvExpr cenv env e1
- // Note, reverse the branches
- QP.mkCond (e1R, acc, ConvDecisionTree cenv env tgs typR dtree)
- | Test.Const c ->
- let ty = tyOfExpr cenv.g e1
- let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (c, m, ty))
- let eqR = ConvExpr cenv env eq
- QP.mkCond (eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
- | Test.IsNull ->
- // Decompile cached isinst tests
- match e1 with
- | Expr.Val(vref,_,_) when env.isinstVals.ContainsVal vref.Deref ->
- let (ty,e) = env.isinstVals.[vref.Deref]
- let tyR = ConvType cenv env m ty
- let eR = ConvExpr cenv env e
- // note: reverse the branches - a null test is a failure of an isinst test
- QP.mkCond (QP.mkTypeTest (tyR,eR), acc, ConvDecisionTree cenv env tgs typR dtree)
- | _ ->
+ let converted =
+ (csl,acc) ||> List.foldBack (fun (TCase(discrim,dtree)) acc ->
+ match discrim with
+ | Test.UnionCase (ucref, tyargs) ->
+ let e1R = ConvExpr cenv env e1
+ let ucR = ConvUnionCaseRef cenv ucref m
+ let tyargsR = ConvTypes cenv env m tyargs
+ QP.mkCond (QP.mkSumTagTest (ucR, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
+ | Test.Const (Const.Bool true) ->
+ let e1R = ConvExpr cenv env e1
+ QP.mkCond (e1R, ConvDecisionTree cenv env tgs typR dtree, acc)
+ | Test.Const (Const.Bool false) ->
+ let e1R = ConvExpr cenv env e1
+ // Note, reverse the branches
+ QP.mkCond (e1R, acc, ConvDecisionTree cenv env tgs typR dtree)
+ | Test.Const c ->
let ty = tyOfExpr cenv.g e1
- let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (Const.Zero, m, ty))
+ let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (c, m, ty))
let eqR = ConvExpr cenv env eq
QP.mkCond (eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
- | Test.IsInst (_srcty, tgty) ->
- let e1R = ConvExpr cenv env e1
- QP.mkCond (QP.mkTypeTest (ConvType cenv env m tgty, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
- | Test.ActivePatternCase _ -> wfail(InternalError( "Test.ActivePatternCase test in quoted expression",m))
- | Test.ArrayLength _ -> wfail(Error(FSComp.SR.crefQuotationsCantContainArrayPatternMatching(), m))
- )
+ | Test.IsNull ->
+ // Decompile cached isinst tests
+ match e1 with
+ | Expr.Val(vref,_,_) when env.isinstVals.ContainsVal vref.Deref ->
+ let (ty,e) = env.isinstVals.[vref.Deref]
+ let tyR = ConvType cenv env m ty
+ let eR = ConvExpr cenv env e
+ // note: reverse the branches - a null test is a failure of an isinst test
+ QP.mkCond (QP.mkTypeTest (tyR,eR), acc, ConvDecisionTree cenv env tgs typR dtree)
+ | _ ->
+ let ty = tyOfExpr cenv.g e1
+ let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (Const.Zero, m, ty))
+ let eqR = ConvExpr cenv env eq
+ QP.mkCond (eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
+ | Test.IsInst (_srcty, tgty) ->
+ let e1R = ConvExpr cenv env e1
+ QP.mkCond (QP.mkTypeTest (ConvType cenv env m tgty, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
+ | Test.ActivePatternCase _ -> wfail(InternalError( "Test.ActivePatternCase test in quoted expression",m))
+ | Test.ArrayLength _ -> wfail(Error(FSComp.SR.crefQuotationsCantContainArrayPatternMatching(), m))
+ )
+ EmitDebugInfoIfNecessary cenv env m converted
| TDSuccess (args,n) ->
let (TTarget(vars,rhs,_)) = tgs.[n]
// TAST stores pattern bindings in reverse order for some reason
@@ -880,27 +961,15 @@ and ConvReturnType cenv envinner m retTy =
| None -> mkVoidTy
| Some ty -> ConvType cenv envinner m ty
-let ConvExprPublic (g,amap,scope,isReflectedDefintion) env e =
- let cenv = mk_cenv (g,amap,scope,isReflectedDefintion)
- let astExpr = ConvExpr cenv env e
- // Add the outer debug range attribute
+let ConvExprPublic (g,amap,scope,isReflectedDefintion) env (e) =
+ let cenv = mk_cenv (g,amap,scope,isReflectedDefintion)
let astExpr =
- let m = e.Range
- let mk_tuple g m es = mkTupled g m es (List.map (tyOfExpr g) es)
+ let astExpr = ConvExpr cenv env e
+ // always emit debug info for the top level expression
+ cenv.emitDebugInfoInQuotations <- true
+ // EmitDebugInfoIfNecessary will check if astExpr is already augmented with debug info and won't wrap it twice
+ EmitDebugInfoIfNecessary cenv env e.Range astExpr
- let rangeExpr =
- mk_tuple cenv.g m
- [ mkString cenv.g m m.FileName;
- mkInt cenv.g m m.StartLine;
- mkInt cenv.g m m.StartColumn;
- mkInt cenv.g m m.EndLine;
- mkInt cenv.g m m.EndColumn; ]
- let attrExpr =
- mk_tuple cenv.g m
- [ mkString cenv.g m "DebugRange"; rangeExpr ]
- let attrExprR = ConvExpr cenv env attrExpr
-
- QP.mkAttributedExpression(astExpr,attrExprR)
cenv.typeSplices |> ResizeArray.toList |> List.map mkTyparTy,
cenv.exprSplices |> ResizeArray.toList,
astExpr
diff --git a/src/fsharp/csolve.fs b/src/fsharp/csolve.fs
index 4dc71f0..6a88855 100755
--- a/src/fsharp/csolve.fs
+++ b/src/fsharp/csolve.fs
@@ -114,7 +114,7 @@ let FreshenTypars m tpsorig =
tptys
let FreshenMethInfo m (minfo:MethInfo) =
- let _,_,tptys = FreshMethInst m (minfo.GetFormalTyparsOfEnclosingType m) minfo.ActualTypeInst minfo.FormalMethodTypars
+ let _,_,tptys = FreshMethInst m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars
tptys
@@ -167,6 +167,7 @@ type ConstraintSolverState =
type ConstraintSolverEnv =
{
SolverState: ConstraintSolverState;
+ MatchingOnly : bool
m: range;
EquivEnv: TypeEquivEnv;
DisplayEnv : DisplayEnv
@@ -178,6 +179,8 @@ type ConstraintSolverEnv =
let MakeConstraintSolverEnv css m denv =
{ SolverState=css;
m=m;
+ // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved
+ MatchingOnly=false;
EquivEnv=TypeEquivEnv.Empty;
DisplayEnv = denv }
@@ -305,6 +308,12 @@ let FilterEachThenUndo f meths =
| None -> None
| Some warns -> Some (calledMeth,warns.Length))
+let ShowAccessDomain ad =
+ match ad with
+ | AccessibleFromEverywhere -> "public"
+ | AccessibleFrom(_,_) -> "accessible"
+ | AccessibleFromSomeFSharpCode -> "public, protected or internal"
+ | AccessibleFromSomewhere -> ""
//-------------------------------------------------------------------------
// Solve
@@ -471,7 +480,6 @@ let DivRoundDown x y =
/// where 'u is a fresh measure variable, and iterate.
let rec UnifyMeasureWithOne (csenv:ConstraintSolverEnv) trace ms =
- if verbose then dprintf " UnifyMeasureWithOne...%s\n" ("ms = " ^ Layout.showL(typeL (TType_measure ms)));
let (rigidVars,nonRigidVars) = (ListMeasureVarOccsWithNonZeroExponents ms) |> List.partition (fun (v,_) -> v.Rigidity = TyparRigidity.Rigid)
let expandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g true ms
let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms
@@ -500,7 +508,6 @@ let rec UnifyMeasureWithOne (csenv:ConstraintSolverEnv) trace ms =
/// Imperatively unify unit-of-measure expression ms1 against ms2
let UnifyMeasures (csenv:ConstraintSolverEnv) trace ms1 ms2 =
- if verbose then dprintf "UnifyMeasures...%s\n" ("ms1 = "^Layout.showL(typeL (TType_measure ms1))^", ms2 = "^Layout.showL(typeL (TType_measure ms2)));
UnifyMeasureWithOne csenv trace (MeasureProd(ms1,MeasureInv ms2))
@@ -508,7 +515,6 @@ let UnifyMeasures (csenv:ConstraintSolverEnv) trace ms1 ms2 =
/// We make substitutions for vars, which are the (remaining) bound variables
/// in the scheme that we wish to simplify.
let SimplifyMeasure g vars ms =
- if verbose then dprintf ("SimplifyMeasure ms = %s generalizable = %s\n") (Layout.showL (typeL (TType_measure ms))) (String.concat "," (List.map (fun tp -> Layout.showL (typeL (mkTyparTy tp))) vars));
let rec simp vars =
match FindMinimumMeasureExponent (List.filter (fun (_,e) -> e<>0) (List.map (fun v -> (v, MeasureVarExponent v ms)) vars)) with
| [] ->
@@ -537,7 +543,6 @@ let SimplifyMeasure g vars ms =
// Generalizable are the unit-of-measure variables that remain to be simplified. Generalized
// is a list of unit-of-measure variables that have already been generalized.
let rec SimplifyMeasuresInType g resultFirst ((generalizable, generalized) as param) ty =
- if verbose then dprintf ("SimplifyMeasuresInType ty = %s generalizable = %s\n") (Layout.showL (typeL ty)) (String.concat "," (List.map (fun tp -> Layout.showL (typeL (mkTyparTy tp))) generalizable));
match stripTyparEqns ty with
| TType_ucase(_,l)
| TType_app (_,l)
@@ -548,7 +553,6 @@ let rec SimplifyMeasuresInType g resultFirst ((generalizable, generalized) as pa
| TType_forall (_,tau) -> SimplifyMeasuresInType g resultFirst param tau
| TType_measure unt ->
let (generalizable', newlygeneralized) = SimplifyMeasure g generalizable unt
- if verbose then dprintf "newlygeneralized = %s\n" (match newlygeneralized with None -> "none" | Some tp -> Layout.showL (typeL (mkTyparTy tp)));
match newlygeneralized with
| None -> (generalizable', generalized)
| Some v -> (generalizable', v::generalized)
@@ -632,7 +636,6 @@ let CheckWarnIfRigid (csenv:ConstraintSolverEnv) ty1 (r:Typar) ty =
/// Add the constraint "ty1 = ty" to the constraint problem, where ty1 is a type variable.
/// Propagate all effects of adding this constraint, e.g. to solve other variables
let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty =
- if verbose then dprintf "--> SolveTyparEqualsTyp...%s\n" ("ty1 = "^Layout.showL(typeL ty1)^", ty = "^Layout.showL(typeL ty));
let m = csenv.m
let denv = csenv.DisplayEnv
DepthCheck ndeep m ++ (fun () ->
@@ -645,7 +648,7 @@ let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty =
if occursCheck csenv.g r ty then ErrorD (ConstraintSolverInfiniteTypes(denv,ty1,ty,m,m2)) else
// Note: warn _and_ continue!
- CheckWarnIfRigid (csenv:ConstraintSolverEnv) ty1 r ty ++ (fun () ->
+ CheckWarnIfRigid csenv ty1 r ty ++ (fun () ->
// Record the solution before we solve the constraints, since
// We may need to make use of the equation when solving the constraints.
@@ -707,8 +710,6 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty
/// Add the constraint "ty1 = ty2" to the constraint problem.
/// Propagate all effects of adding this constraint, e.g. to solve type variables
and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) ty1 ty2 =
- if verbose then dprintf "SolveTypEqualsTyp ndeep @ %a\n" outputRange csenv.m;
-(* dprintf "SolveTypEqualsTyp ty1=%s ty2=%s\n" (showL (typeL ty1)) (showL (typeL ty2)); *)
let ndeep = ndeep + 1
let aenv = csenv.EquivEnv
let g = csenv.g
@@ -722,10 +723,10 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace
| TType_var tp1, TType_var tp2 when typarEq tp1 tp2 || (aenv.EquivTypars.ContainsKey tp1 && typeEquiv g aenv.EquivTypars.[tp1] ty2) -> CompleteD
| TType_var tp1, TType_var tp2 when PreferUnifyTypar tp1 tp2 -> SolveTyparEqualsTyp csenv ndeep m2 trace sty1 ty2
- | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp2 tp1 -> SolveTyparEqualsTyp csenv ndeep m2 trace sty2 ty1
+ | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp2 tp1 && not csenv.MatchingOnly -> SolveTyparEqualsTyp csenv ndeep m2 trace sty2 ty1
| TType_var r, _ when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsTyp csenv ndeep m2 trace sty1 ty2
- | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsTyp csenv ndeep m2 trace sty2 ty1
+ | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) && not csenv.MatchingOnly -> SolveTyparEqualsTyp csenv ndeep m2 trace sty2 ty1
// Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1>
| (_, TType_app (tc2,[ms])) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms]))
@@ -746,8 +747,6 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace
SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty1 rty2
| TType_ucase (uc1,l1) ,TType_ucase (uc2,l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypEqualsTypEqns csenv ndeep m2 trace l1 l2
-
-
| _ -> localAbortD
and SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace ty1 ty2 =
@@ -794,8 +793,8 @@ and SolveTypSubsumesTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTra
SolveTypSubsumesTyp csenv ndeep m2 trace aenv.EquivTypars.[tp1] ty2
| TType_var r1, TType_var r2 when typarEq r1 r2 -> CompleteD
- | _, TType_var r (* when not (rigid_of_typar r) *) -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1
- | TType_var _ , _ (* | _, TType_var r *) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace ty1 ty2
+ | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1
+ | TType_var _ , _ -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace ty1 ty2
| TType_tuple l1 ,TType_tuple l2 -> SolveTypEqualsTypEqns csenv ndeep m2 trace l1 l2 (* nb. can unify since no variance *)
| TType_fun (d1,r1) ,TType_fun (d2,r2) -> SolveFunTypEqn csenv ndeep m2 trace d1 d2 r1 r2 (* nb. can unify since no variance *)
| TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2
@@ -821,6 +820,8 @@ and SolveTypSubsumesTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTra
// 'a[] :> IList<'b> ---> 'a = 'b
// 'a[] :> ICollection<'b> ---> 'a = 'b
// 'a[] :> IEnumerable<'b> ---> 'a = 'b
+ // 'a[] :> IReadOnlyList<'b> ---> 'a = 'b
+ // 'a[] :> IReadOnlyCollection<'b> ---> 'a = 'b
// Note we don't support co-variance on array types nor
// the special .NET conversions for these types
if
@@ -829,6 +830,8 @@ and SolveTypSubsumesTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTra
(let tcr1 = tcrefOfAppTy g ty1
tyconRefEq g tcr1 g.tcref_System_Collections_Generic_IList ||
tyconRefEq g tcr1 g.tcref_System_Collections_Generic_ICollection ||
+ tyconRefEq g tcr1 g.tcref_System_Collections_Generic_IReadOnlyList ||
+ tyconRefEq g tcr1 g.tcref_System_Collections_Generic_IReadOnlyCollection ||
tyconRefEq g tcr1 g.tcref_System_Collections_Generic_IEnumerable)) then
let _,tinst = destAppTy g ty1
@@ -894,8 +897,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
let ndeep = ndeep + 1
DepthCheck ndeep m ++ (fun () ->
- if verbose then dprintf "-----------------------------\nResolve trait for %s\n" nm;
-
// Remove duplicates from the set of types in the support
let tys = ListSet.setify (typeAEquiv g aenv) tys
// Rebuild the trait info after removing duplicates
@@ -917,8 +918,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
let argtys = if memFlags.IsInstance then List.tail argtys else argtys
let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo
-
- if verbose then minfos |> List.iter (fun minfo -> dprintf "Possible overload: %s\n" (NicePrint.stringOfMethInfo amap m denv minfo));
match minfos,tys,memFlags.IsInstance,nm,argtys with
| _,_,false,("op_Division" | "op_Multiply"),[argty1;argty2]
@@ -982,7 +981,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
| _,_,false,("op_Addition" | "op_Subtraction" | "op_Modulus"),[argty1;argty2]
when // Ignore any explicit +/- overloads from any basic integral types
- (isNil (minfos |> List.filter (fun minfo -> not(isIntegerTy g minfo.EnclosingType ))) &&
+ (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.EnclosingType ) &&
( (IsNumericOrIntegralEnumType g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2))
|| (IsNumericOrIntegralEnumType g argty2 || (nm = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1)))) ->
SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () ->
@@ -1156,7 +1155,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
| Some (RecdFieldItem rfinfo)
when (isGetProp || rfinfo.RecdField.IsMutable) &&
(rfinfo.IsStatic = not memFlags.IsInstance) &&
- IsRecdFieldAccessible AccessibleFromEverywhere rfinfo.RecdFieldRef &&
+ IsRecdFieldAccessible amap m AccessibleFromEverywhere rfinfo.RecdFieldRef &&
not rfinfo.LiteralValue.IsSome &&
not rfinfo.RecdField.IsCompilerGenerated ->
Some (TTraitSolvedRecdProp (rfinfo, isSetProp))
@@ -1206,14 +1205,11 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty,m,false,dummyExpr))
let minst = FreshenMethInfo m minfo
let objtys = minfo.GetObjArgTypes(amap, m, minst)
- MakeCalledMeth(csenv.InfoReader,false, FreshenMethInfo, m,AccessibleFromEverywhere,minfo,minst,minst,None,objtys,[(callerArgs,[])],false, false))
- (* dprintf " ---> calling ResolveOverloading, nm = %s, ty = '%s'\n" nm (Layout.showL (typeL ty)); *)
+ CalledMeth<Expr>(csenv.InfoReader,false,FreshenMethInfo,m,AccessibleFromEverywhere,minfo,minst,minst,None,objtys,[(callerArgs,[])],false,false))
let methOverloadResult,errors =
CollectThenUndo (fun trace -> ResolveOverloading csenv (WithTrace(trace)) nm ndeep true (0,0) AccessibleFromEverywhere calledMethGroup false (Some rty))
- if verbose then dprintf " <--- called ResolveOverloading, ok? = %b\n" (isSome (CheckNoErrorsAndGetWarnings errors));
-
match recdPropSearch, methOverloadResult with
| Some a, None ->
// OK, the constraint is solved by a record property
@@ -1222,7 +1218,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep
// OK, the constraint is solved.
// Re-run without undo to commit the inference equations. Throw errors away
let minfo = calledMeth.Method
- if verbose then dprintf " ---> constraint solved, calling ResolveOverloading a second time, without undo, minfo = %s\n" (NicePrint.stringOfMethInfo amap m denv minfo);
let _,errors = ResolveOverloading csenv trace nm ndeep true (0,0) AccessibleFromEverywhere calledMethGroup false (Some rty)
errors ++ (fun () ->
@@ -1275,16 +1270,17 @@ and RecordMemberConstraintSolution css m trace traitInfo res =
/// Convert a MethInfo into the data we save in the TAST
and MemberConstraintSolutionOfMethInfo css m minfo minst =
match minfo with
- | ILMeth(_,ILMethInfo(ILTypeInfo(tcref,tref,tinst,_),extOpt,mdef,_),_) ->
- let mref = IL.mkRefToILMethod (tref,mdef)
- ILMethSln(mkAppTy tcref tinst,extOpt,mref,minst)
- | ILMeth _ -> error(InternalError("this extension method on F# types was the unexpected solution to a trait constraint",m))
+ | ILMeth(_,ilMeth,_) ->
+ let mref = IL.mkRefToILMethod (ilMeth.DeclaringTyconRef.CompiledRepresentationForNamedType,ilMeth.RawMetadata)
+ let iltref = ilMeth.DeclaringTyconRefOption |> Option.map (fun tcref -> tcref.CompiledRepresentationForNamedType)
+ ILMethSln(ilMeth.ApparentEnclosingType,iltref,mref,minst)
| FSMeth(_,typ,vref,_) ->
FSMethSln(typ,vref,minst)
| MethInfo.DefaultStructCtor _ ->
error(InternalError("the default struct constructor was the unexpected solution to a trait constraint",m))
#if EXTENSIONTYPING
- | ProvidedMeth(g,mi,amap,m) ->
+ | ProvidedMeth(amap,mi,_,m) ->
+ let g = amap.g
let minst = [] // GENERIC TYPE PROVIDERS: for generics, we would have an minst here
let allArgVars, allArgs = minfo.GetParamTypes(amap, m, minst) |> List.concat |> List.mapi (fun i ty -> mkLocal m ("arg"+string i) ty) |> List.unzip
let objArgVars, objArgs = (if minfo.IsInstance then [mkLocal m "this" minfo.EnclosingType] else []) |> List.unzip
@@ -1321,12 +1317,16 @@ and TransactMemberConstraintSolution traitInfo trace sln =
/// Only consider overload resolution if canonicalizing or all the types are now nominal.
/// That is, don't perform resolution if more nominal information may influence the set of available overloads
-and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys,_,memFlags,argtys,rty,soln) as traitInfo) =
+and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys,_,memFlags,argtys,rty,soln) as traitInfo) : MethInfo list =
let results =
if permitWeakResolution || isNil (GetSupportOfMemberConstraint csenv traitInfo) then
let m = csenv.m
- let g = csenv.g
- let minfos = tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m)
+ let minfos =
+ match memFlags.MemberKind with
+ | MemberKind.Constructor ->
+ tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m)
+ | _ ->
+ tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m)
/// Merge the sets so we don't get the same minfo from each side
/// We merge based on whether minfos use identical metadata or not.
@@ -1334,7 +1334,7 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution
/// between potential overloads because a generic instantiation derived from the left hand type differs
/// to a generic instantiation for an operator based on the right hand type.
- let minfos = List.fold (ListSet.unionFavourLeft (MethInfosUseIdenticalDefinitions g)) (List.head minfos) (List.tail minfos)
+ let minfos = List.fold (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) (List.head minfos) (List.tail minfos)
minfos
else
[]
@@ -1373,8 +1373,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per
let tpn = tp.Stamp
let cxs = cxst.FindAll tpn
if isNil cxs then ResultD false else
-
- if verbose then dprintf "SolveRelevantMemberConstraintsForTypar #cxs = %d, m = %a\n" cxs.Length outputRange csenv.m;
+
cxs |> List.iter (fun _ -> cxst.Remove tpn);
assert (isNil (cxst.FindAll tpn));
@@ -1403,9 +1402,6 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup
let tpn = tp.Stamp
let cxs = cxst.FindAll tpn
- if verbose then dprintf "AddMemberConstraint: tpn = %d, #cxs = %d, m = %a\n" tpn cxs.Length outputRange csenv.m;
- if verbose && cxs.Length > 10 then
- cxs |> List.iter (fun (cx,_) -> dprintf " --> cx = %s, fvs = %s\n" (Layout.showL (traitL cx)) (Layout.showL (typarsL (GetFreeTyparsOfMemberConstraint csenv cx))));
// check the constraint is not already listed for this type variable
if not (cxs |> List.exists (fun (traitInfo2,_) -> traitsAEquiv g aenv traitInfo traitInfo2)) then
@@ -1450,7 +1446,6 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint =
let rty2 = GetFSharpViewOfReturnType g rty2
Iterate2D (SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace) argtys1 argtys2 ++ (fun () ->
SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty1 rty2 ++ (fun () ->
- if verbose then dprintf "\n-------------\nmerged constraint for %s, tp = %s\n---------\n" nm1 (Layout.showL (typarDeclL tp));
CompleteD))
| (TyparConstraint.CoercesTo(ty1,_),
@@ -1788,7 +1783,14 @@ and SolveTypRequiresDefaultConstructor (csenv:ConstraintSolverEnv) ndeep m2 trac
ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresNonAbstract(NicePrint.minimalStringOfType denv typ),m,m2))
else
CompleteD
- elif isAppTy g ty && (tcrefOfAppTy g ty).PreEstablishedHasDefaultConstructor then
+ elif isAppTy g ty &&
+ (
+ let tcref = tcrefOfAppTy g ty
+ tcref.PreEstablishedHasDefaultConstructor ||
+ // F# 3.1 feature: records with CLIMutable attribute should satisfy 'default constructor' constraint
+ (tcref.IsRecordTycon && HasFSharpAttribute g g.attrib_CLIMutableAttribute tcref.Attribs)
+ )
+ then
CompleteD
else
ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresPublicDefaultConstructor(NicePrint.minimalStringOfType denv typ),m,m2))
@@ -1804,24 +1806,20 @@ and CanMemberSigsMatchUpToCheck
subsumeTypes // used to compare the "obj" type
(subsumeArg: CalledArg -> CallerArg<_> -> OperationResult<unit>) // used to compare the arguments for compatibility
reqdRetTyOpt
- calledMeth : ImperativeOperationResult =
+ (calledMeth:CalledMeth<_>) : ImperativeOperationResult =
let g = csenv.g
let amap = csenv.amap
let m = csenv.m
- let (CalledMeth(minfo,
- minst,
- uminst,
- callerObjArgTys,
- _,
- methodRetTy,
- assignedNamedProps,
- _,
- _,
- _,
- unnamedCalledOptArgs,
- unnamedCalledOutArgs)) = calledMeth
+ let minfo = calledMeth.Method
+ let minst = calledMeth.CalledTyArgs
+ let uminst = calledMeth.CallerTyArgs
+ let callerObjArgTys = calledMeth.CallerObjArgTys
+ let methodRetTy = calledMeth.ReturnType
+ let assignedItemSetters = calledMeth.AssignedItemSetters
+ let unnamedCalledOptArgs = calledMeth.UnnamedCalledOptArgs
+ let unnamedCalledOutArgs = calledMeth.UnnamedCalledOutArgs
// First equate the method instantiation (if any) with the method type parameters
if minst.Length <> uminst.Length then ErrorD(Error(FSComp.SR.csTypeInstantiationLengthMismatch(),m)) else
@@ -1847,23 +1845,23 @@ and CanMemberSigsMatchUpToCheck
if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then ErrorD(Error(FSComp.SR.csArgumentLengthMismatch(),m)) else
Iterate2D subsumeArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs)) ++ (fun () ->
(calledMeth.ParamArrayCalledArgOpt |> OptionD (fun calledArg ->
- if isArray1DTy g calledArg.Type then
- let ety = destArrayTy g calledArg.Type
+ if isArray1DTy g calledArg.CalledArgumentType then
+ let ety = destArrayTy g calledArg.CalledArgumentType
calledMeth.ParamArrayCallerArgs |> OptionD (IterateD (fun callerArg -> subsumeArg (CalledArg((0,0),false,NotOptional,false,None,ety)) callerArg))
else
CompleteD)
) ++ (fun () ->
(calledMeth.ArgSets |> IterateD (fun argSet ->
- argSet.AssignedNamedArgs |> IterateD (fun (AssignedCalledArg(_,called,caller)) -> subsumeArg called caller))) ++ (fun () ->
- (assignedNamedProps |> IterateD (fun (AssignedItemSetter(_,item,caller)) ->
+ argSet.AssignedNamedArgs |> IterateD (fun arg -> subsumeArg arg.CalledArg arg.CallerArg))) ++ (fun () ->
+ (assignedItemSetters |> IterateD (fun (AssignedItemSetter(_,item,caller)) ->
let name, calledArgTy =
match item with
| AssignedPropSetter(_,pminfo,pminst) ->
let calledArgTy = List.head (List.head (pminfo.GetParamTypes(amap, m, pminst)))
pminfo.LogicalName, calledArgTy
- | AssignedIlFieldSetter(finfo) ->
+ | AssignedILFieldSetter(finfo) ->
(* Get or set instance IL field *)
let calledArgTy = finfo.FieldType(amap,m)
finfo.FieldName, calledArgTy
@@ -1887,7 +1885,7 @@ and CanMemberSigsMatchUpToCheck
if isNil unnamedCalledOutArgs then
methodRetTy
else
- let outArgTys = unnamedCalledOutArgs |> List.map (fun (CalledArg(_,_,_,_,_,argty)) -> destByrefTy g argty)
+ let outArgTys = unnamedCalledOutArgs |> List.map (fun calledArg -> destByrefTy g calledArg.CalledArgumentType)
if isUnitTy g methodRetTy then mkTupledTy g outArgTys
else mkTupledTy g (methodRetTy :: outArgTys)
unifyTypes reqdRetTy methodRetTy )))))
@@ -1899,70 +1897,8 @@ and CanMemberSigsMatchUpToCheck
//-------------------------------------------------------------------------
-// F# supports three adhoc conversions at method callsites (note C# supports more, though ones
-// such as implicit conversions interact badly with type inference).
-//
-// 1. The use of "(fun x y -> ...)" when a delegate it expected. This is not part of
-// the ":>" coercion relationship or inference constraint problem as
-// such, but is a special rule applied only to method arguments.
-//
-// The function AdjustCalledArgType detects this case based on types and needs to know that the type being applied
-// is a function type.
-//
-// 2. The use of "(fun x y -> ...)" when Expression<delegate> it expected. This is similar to above.
-//
-// 3. Two ways to pass a value where a byref is expected. The first (default)
-// is to use a reference cell, and the interior address is taken automatically
-// The second is an explicit use of the "address-of" operator "&e". Here we detect the second case,
-// and record the presence of the sytnax "&e" in the pre-inferred actual type for the method argument.
-// The function AdjustCalledArgType detects this and refuses to apply the default byref-to-ref transformation.
-//
-// The function AdjustCalledArgType also adjusts for optional arguments.
-and AdjustCalledArgType (csenv:ConstraintSolverEnv) isConstraint (CalledArg(_,_,optArgInfo,_,_,calledArgTy)) (CallerArg(callerArgTy,m,isOptCallerArg,_)) =
- // #424218 - when overload resolution is part of constraint solving - do not perform type-directed conversions
- if isConstraint then calledArgTy
- else
- (* If the called method argument is a byref type, then the caller may provide a byref or ref *)
- let g = csenv.g
- if isByrefTy g calledArgTy then
- if isByrefTy g callerArgTy then
- calledArgTy
- else
- mkRefCellTy g (destByrefTy g calledArgTy)
- else
- // If the called method argument is a delegate type, then the caller may provide a function
- let calledArgTy =
- let adjustDelegateTy calledTy =
- let (SigOfFunctionForDelegate(_,delArgTys,_,fty)) = GetSigOfFunctionForDelegate csenv.InfoReader calledTy m AccessibleFromSomeFSharpCode
- let delArgTys = (if isNil delArgTys then [g.unit_ty] else delArgTys)
- if (fst (stripFunTy g callerArgTy)).Length = delArgTys.Length
- then fty
- else calledArgTy
-
- if isDelegateTy g calledArgTy && isFunTy g callerArgTy then
- adjustDelegateTy calledArgTy
- elif isLinqExpressionTy g calledArgTy && isFunTy g callerArgTy then
- let origArgTy = calledArgTy
- let calledArgTy = destLinqExpressionTy g calledArgTy
- if isDelegateTy g calledArgTy then
- adjustDelegateTy calledArgTy
- else
- // BUG 435170: called arg is Expr<'t> where 't is not delegate - such conversion is not legal -> return original type
- origArgTy
- else calledArgTy
-
- // Adjust the called argument type to take into account whether the caller's argument is M(?arg=Some(3)) or M(arg=1)
- // If the called method argument is optional with type Option<T>, then the caller may provide a T, unless their argument is propogating-optional (i.e. isOptCallerArg)
- let calledArgTy =
- match optArgInfo with
- | NotOptional -> calledArgTy
- | CalleeSide when not isOptCallerArg && isOptionTy g calledArgTy -> destOptionTy g calledArgTy
- | CalleeSide | CallerSide _ -> calledArgTy
- calledArgTy
-
-
and private DefinitelyEquiv (csenv:ConstraintSolverEnv) isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) =
- let calledArgTy = AdjustCalledArgType csenv isConstraint calledArg callerArg
+ let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg
if not (typeEquiv csenv.g calledArgTy callerArgTy) then ErrorD(Error(FSComp.SR.csArgumentTypesDoNotMatch(),m)) else
CompleteD
@@ -1981,19 +1917,20 @@ and ArgsMustSubsumeOrConvert
ndeep
trace
isConstraint
- (CalledArg(_,isParamArrayArg,_,_,_,_) as calledArg)
- (CallerArg(callerArgTy,m,_,_) as callerArg) =
+ (calledArg: CalledArg)
+ (callerArg: CallerArg<'T>) =
let g = csenv.g
let amap = csenv.amap
- let calledArgTy = AdjustCalledArgType csenv isConstraint calledArg callerArg
- SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArgTy ++ (fun () ->
+ let m = callerArg.Range
+ let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg
+ SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArg.Type ++ (fun () ->
- if isParamArrayArg &&
+ if calledArg.IsParamArray &&
isAppTy g calledArgTy &&
(let _,tinstf = destAppTy g calledArgTy
tinstf.Length = 1 &&
- TypesFeasiblyEquiv ndeep g amap m (List.head tinstf) callerArgTy)
+ TypesFeasiblyEquiv ndeep g amap m (List.head tinstf) callerArg.Type)
then
ErrorD(Error(FSComp.SR.csMethodExpectsParams(),m))
else
@@ -2006,14 +1943,14 @@ and MustUnifyInsideUndo csenv ndeep trace ty1 ty2 =
SolveTypEqualsTypWithReport csenv ndeep csenv.m (WithTrace trace) ty1 ty2
and ArgsMustSubsumeOrConvertInsideUndo (csenv:ConstraintSolverEnv) ndeep trace isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) =
- let calledArgTy = AdjustCalledArgType csenv isConstraint calledArg callerArg
+ let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg
SolveTypSubsumesTypWithReport csenv ndeep m (WithTrace trace) calledArgTy callerArgTy
and TypesMustSubsumeOrConvertInsideUndo (csenv:ConstraintSolverEnv) ndeep trace m calledArgTy callerArgTy =
SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArgTy
and ArgsEquivInsideUndo (csenv:ConstraintSolverEnv) _trace isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) =
- let calledArgTy = AdjustCalledArgType csenv isConstraint calledArg callerArg
+ let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg
if not (typeEquiv csenv.g calledArgTy callerArgTy) then ErrorD(Error(FSComp.SR.csArgumentTypesDoNotMatch(),m)) else
CompleteD
@@ -2024,7 +1961,7 @@ and ReportNoCandidatesError (csenv:ConstraintSolverEnv) (nUnnamedCallerArgs,nNam
let denv = csenv.DisplayEnv
match (calledMethGroup |> List.partition (CalledMeth.GetMethod >> IsMethInfoAccessible amap m ad)),
- (calledMethGroup |> List.partition (fun cmeth -> cmeth.HasCorrectObjArgs(amap,m,ad))),
+ (calledMethGroup |> List.partition (fun cmeth -> cmeth.HasCorrectObjArgs(m))),
(calledMethGroup |> List.partition (fun cmeth -> cmeth.HasCorrectArity)),
(calledMethGroup |> List.partition (fun cmeth -> cmeth.HasCorrectGenericArity)),
(calledMethGroup |> List.partition (fun cmeth -> cmeth.AssignsAllNamedArgs)) with
@@ -2032,14 +1969,14 @@ and ReportNoCandidatesError (csenv:ConstraintSolverEnv) (nUnnamedCallerArgs,nNam
// No version accessible
| ([],others),_,_,_,_ ->
if nonNil others then
- ErrorD (Error (FSComp.SR.csMemberIsNotAccessible2(methodName, (showAccessDomain ad)), m))
+ ErrorD (Error (FSComp.SR.csMemberIsNotAccessible2(methodName, (ShowAccessDomain ad)), m))
else
- ErrorD (Error (FSComp.SR.csMemberIsNotAccessible(methodName, (showAccessDomain ad)), m))
+ ErrorD (Error (FSComp.SR.csMemberIsNotAccessible(methodName, (ShowAccessDomain ad)), m))
| _,([],(cmeth::_)),_,_,_ ->
// Check all the argument types.
- if (cmeth.CalledObjArgTys(amap,m).Length <> 0) then
+ if (cmeth.CalledObjArgTys(m).Length <> 0) then
ErrorD(Error (FSComp.SR.csMethodIsNotAStaticMethod(methodName),m))
else
ErrorD(Error (FSComp.SR.csMethodIsNotAnInstanceMethod(methodName),m))
@@ -2096,7 +2033,7 @@ and ReportNoCandidatesError (csenv:ConstraintSolverEnv) (nUnnamedCallerArgs,nNam
// Many methods, all with incorrect number of generic arguments
| _,_,_,([],(cmeth :: _)),_ ->
- let msg = FSComp.SR.csIncorrectGenericInstantiation((showAccessDomain ad), methodName, cmeth.NumCallerTyArgs)
+ let msg = FSComp.SR.csIncorrectGenericInstantiation((ShowAccessDomain ad), methodName, cmeth.NumCallerTyArgs)
ErrorD (Error (msg,m))
// Many methods of different arities, all incorrect
| _,_,([],(cmeth :: _)),_,_ ->
@@ -2105,14 +2042,14 @@ and ReportNoCandidatesError (csenv:ConstraintSolverEnv) (nUnnamedCallerArgs,nNam
| _ ->
let msg =
if nNamedCallerArgs = 0 then
- FSComp.SR.csNoMemberTakesTheseArguments((showAccessDomain ad), methodName, nUnnamedCallerArgs)
+ FSComp.SR.csNoMemberTakesTheseArguments((ShowAccessDomain ad), methodName, nUnnamedCallerArgs)
else
let s = calledMethGroup |> List.map (fun cmeth -> cmeth.UnassignedNamedArgs |> List.map (fun na -> na.Name)|> Set.ofList) |> Set.intersectMany
if s.IsEmpty then
- FSComp.SR.csNoMemberTakesTheseArguments2((showAccessDomain ad), methodName, nUnnamedCallerArgs, nNamedCallerArgs)
+ FSComp.SR.csNoMemberTakesTheseArguments2((ShowAccessDomain ad), methodName, nUnnamedCallerArgs, nNamedCallerArgs)
else
let sample = s.MinimumElement
- FSComp.SR.csNoMemberTakesTheseArguments3((showAccessDomain ad), methodName, nUnnamedCallerArgs, sample)
+ FSComp.SR.csNoMemberTakesTheseArguments3((ShowAccessDomain ad), methodName, nUnnamedCallerArgs, sample)
ErrorD (Error (msg,m))
@@ -2136,7 +2073,7 @@ and ResolveOverloading
let denv = csenv.DisplayEnv
let isOpConversion = (methodName = "op_Explicit" || methodName = "op_Implicit")
// See what candidates we have based on name and arity
- let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(g,amap,m,ad))
+ let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m,ad))
let calledMethOpt, errors =
match calledMethGroup,candidates with
@@ -2247,20 +2184,20 @@ and ResolveOverloading
(ty1,ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1)
/// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule
- let compareArg (CalledArg(_,_,_,_,_,argType1))
- (CalledArg(_,_,_,_,_,argType2)) =
- let c = compareTypes argType1 argType2
+ let compareArg (calledArg1:CalledArg) (calledArg2:CalledArg) =
+ let c = compareTypes calledArg1.CalledArgumentType calledArg2.CalledArgumentType
if c <> 0 then c else
// Func<_> is always considered better than any other delegate type
- let c = (argType1, argType2) ||> compareCond (fun ty1 ty2 ->
- (match tryDestAppTy csenv.g ty1 with
- | Some tcref1 when
- (tcref1.DisplayName = "Func" &&
- (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) &&
- isDelegateTy g ty1 &&
- isDelegateTy g ty2) -> true
- | _ -> false))
+ let c =
+ (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 ->
+ match tryDestAppTy csenv.g ty1 with
+ | Some tcref1 ->
+ tcref1.DisplayName = "Func" &&
+ (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) &&
+ isDelegateTy g ty1 &&
+ isDelegateTy g ty2
+ | _ -> false)
if c <> 0 then c else
0
@@ -2279,7 +2216,7 @@ and ResolveOverloading
// Prefer methods with more precise param array arg type
let c =
if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then
- compareTypes (candidate.ParamArrayElementType(g)) (other.ParamArrayElementType(g))
+ compareTypes candidate.ParamArrayElementType other.ParamArrayElementType
else
0
if c <> 0 then c else
@@ -2302,8 +2239,8 @@ and ResolveOverloading
// THis matches C#, where all extension members are treated and resolved as "static" methods calls
let cs =
(if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then
- let objArgTys1 = candidate.CalledObjArgTys(amap,m)
- let objArgTys2 = other.CalledObjArgTys(amap,m)
+ let objArgTys1 = candidate.CalledObjArgTys(m)
+ let objArgTys2 = other.CalledObjArgTys(m)
if objArgTys1.Length = objArgTys2.Length then
List.map2 compareTypes objArgTys1 objArgTys2
else
@@ -2331,7 +2268,7 @@ and ResolveOverloading
// between extension methods, prefer most recently opened
let c =
if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then
- compare candidate.Method.Priority other.Method.Priority
+ compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority
else
0
if c <> 0 then c else
@@ -2405,18 +2342,16 @@ let UnifyUniqueOverloading
callerArgCounts
methodName
ad
- (calledMethGroup:CalledMeth<Expr> list)
+ (calledMethGroup:CalledMeth<SynExpr> list)
reqdRetTy // The expected return type, if known
=
- let g = csenv.g
- let amap = csenv.amap
let m = csenv.m
- (* See what candidates we have based on name and arity *)
- let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(g,amap,m,ad))
+ // See what candidates we have based on name and arity
+ let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m,ad))
let ndeep = 0
match calledMethGroup,candidates with
| _,[calledMeth] ->
- (* Only one candidate found - we thus know the types we expect of arguments *)
+ // Only one candidate found - we thus know the types we expect of arguments
CanMemberSigsMatchUpToCheck
csenv
true // permitOptArgs
@@ -2443,7 +2378,6 @@ let EliminateConstraintsForGeneralizedTypars csenv trace (generalizedTypars: Typ
let cxst = csenv.SolverState.ExtraCxs
let cxs = cxst.FindAll tpn
if isNil cxs then () else
- if verbose then dprintf "EliminateConstraintsForGeneralizedTypars: #cxs = %d, m = %a\n" cxs.Length outputRange csenv.m;
cxs |> List.iter (fun cx ->
cxst.Remove tpn;
match trace with
@@ -2479,9 +2413,19 @@ let UndoIfFailed f =
let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 =
UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2)
+let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 =
+ let csenv = MakeConstraintSolverEnv css m denv
+ let csenv = { csenv with MatchingOnly = true }
+ UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2)
+
let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 =
UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2)
+let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 =
+ let csenv = MakeConstraintSolverEnv css m denv
+ let csenv = { csenv with MatchingOnly = true }
+ UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2)
+
let AddCxTypeMustSubsumeType denv css m trace ty1 ty2 =
@@ -2551,12 +2495,15 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait
| Some sln ->
match sln with
| ILMethSln(typ,extOpt,mref,minst) ->
- let tcref,tinst = destAppTy g typ
- let scoref,enc,tdef = tcref.ILTyconInfo
- let mdef = IL.resolveILMethodRef tdef mref
- let tref = IL.mkRefForNestedILTypeDef scoref (enc,tdef)
- let mtps = Import.ImportILGenericParameters (fun () -> amap) m scoref tinst mdef.GenericParams
- Choice1Of4 (ILMeth(g,ILMethInfo(ILTypeInfo(tcref,tref,tinst,tdef),extOpt,mdef,mtps),None),minst)
+ let tcref,_tinst = destAppTy g typ
+ let mdef = IL.resolveILMethodRef tcref.ILTyconRawMetadata mref
+ let ilMethInfo =
+ match extOpt with
+ | None -> MethInfo.CreateILMeth(amap,m,typ,mdef)
+ | Some ilActualTypeRef ->
+ let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef
+ MethInfo.CreateILExtensionMeth(amap, m, typ, actualTyconRef, None, mdef)
+ Choice1Of4 (ilMethInfo,minst)
| FSMethSln(typ, vref,minst) ->
Choice1Of4 (FSMeth(g,typ,vref,None),minst)
| FSRecdFieldSln(tinst,rfref,isSetProp) ->
diff --git a/src/fsharp/csolve.fsi b/src/fsharp/csolve.fsi
index b49f27a..dd199cd 100755
--- a/src/fsharp/csolve.fsi
+++ b/src/fsharp/csolve.fsi
@@ -80,16 +80,19 @@ val SolveTyparEqualsTyp : ConstraintSolverEnv -> int -> ran
val SolveTypEqualsTypKeepAbbrevs : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult<unit>
val CanonicalizeRelevantMemberConstraints : ConstraintSolverEnv -> int -> OptionalTrace -> Typars -> OperationResult<unit>
val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> bool -> int * int -> AccessorDomain -> Typrelns.CalledMeth<Expr> list -> bool -> TType option -> Typrelns.CalledMeth<Expr> option * OperationResult<unit>
-val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> Typrelns.CalledMeth<Expr> list -> TType -> OperationResult<bool>
+val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> Typrelns.CalledMeth<SynExpr> list -> TType -> OperationResult<bool>
val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit
+//val AdjustCalledArgType : TcGlobals -> InfoReader -> bool -> Typrelns.CalledArg -> Typrelns.CallerArg<'T> -> TType
val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit
val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult<unit>
val AddCxTypeEqualsType : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit
val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool
+val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool
val AddCxTypeMustSubsumeType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit
val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool
+val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool
val AddCxMethodConstraint : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit
val AddCxTypeMustSupportNull : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit
val AddCxTypeMustSupportComparison : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit
diff --git a/src/fsharp/detuple.fs b/src/fsharp/detuple.fs
index a156f4a..2462367 100755
--- a/src/fsharp/detuple.fs
+++ b/src/fsharp/detuple.fs
@@ -425,7 +425,7 @@ let rebuildTS g m ts vs =
match vs,ts with
| [] ,UnknownTS -> internalError "rebuildTS: not enough fringe to build tuple"
| v::vs,UnknownTS -> vs,(exprForVal m v,v.Type)
- | vs ,TupleTS tss -> let vs,xtys = List.fmap rebuild vs tss
+ | vs ,TupleTS tss -> let vs,xtys = List.foldMap rebuild vs tss
let xs,tys = List.unzip xtys
let x = mkTupled g m xs tys
let ty = mkTupledTy g tys
diff --git a/src/fsharp/env.fs b/src/fsharp/env.fs
index 629062d..fd7879f 100755
--- a/src/fsharp/env.fs
+++ b/src/fsharp/env.fs
@@ -124,6 +124,7 @@ type public TcGlobals =
#else
ilxPubCloEnv : EraseIlxFuncs.cenv;
#endif
+ emitDebugInfoInQuotations : bool
compilingFslib: bool;
mlCompatibility : bool;
directoryToResolveRelativePaths : string;
@@ -247,8 +248,8 @@ type public TcGlobals =
system_Int32_typ : TType;
system_String_typ : TType;
system_Type_typ : TType;
- system_TypedReference_tcref : TyconRef;
- system_ArgIterator_tcref : TyconRef;
+ system_TypedReference_tcref : TyconRef option;
+ system_ArgIterator_tcref : TyconRef option;
system_Decimal_tcref : TyconRef;
system_SByte_tcref : TyconRef;
system_Int16_tcref : TyconRef;
@@ -264,11 +265,11 @@ type public TcGlobals =
system_UIntPtr_tcref : TyconRef;
system_Single_tcref : TyconRef;
system_Double_tcref : TyconRef;
- system_RuntimeArgumentHandle_tcref : TyconRef;
+ system_RuntimeArgumentHandle_tcref : TyconRef option;
system_RuntimeTypeHandle_typ : TType;
system_RuntimeMethodHandle_typ : TType;
- system_MarshalByRefObject_tcref : TyconRef;
- system_MarshalByRefObject_typ : TType;
+ system_MarshalByRefObject_tcref : TyconRef option;
+ system_MarshalByRefObject_typ : TType option;
system_Reflection_MethodInfo_typ : TType;
system_Array_tcref : TyconRef;
system_Object_tcref : TyconRef;
@@ -291,12 +292,12 @@ type public TcGlobals =
attrib_ProjectionParameterAttribute : BuiltinAttribInfo;
attrib_AttributeUsageAttribute : BuiltinAttribInfo;
attrib_ParamArrayAttribute : BuiltinAttribInfo;
- attrib_IDispatchConstantAttribute : BuiltinAttribInfo;
- attrib_IUnknownConstantAttribute : BuiltinAttribInfo;
+ attrib_IDispatchConstantAttribute : BuiltinAttribInfo option;
+ attrib_IUnknownConstantAttribute : BuiltinAttribInfo option;
attrib_SystemObsolete : BuiltinAttribInfo;
attrib_DllImportAttribute : BuiltinAttribInfo;
attrib_CompiledNameAttribute : BuiltinAttribInfo;
- attrib_NonSerializedAttribute : BuiltinAttribInfo;
+ attrib_NonSerializedAttribute : BuiltinAttribInfo option;
attrib_AutoSerializableAttribute : BuiltinAttribInfo;
attrib_StructLayoutAttribute : BuiltinAttribInfo;
attrib_TypeForwardedToAttribute : BuiltinAttribInfo;
@@ -307,22 +308,25 @@ type public TcGlobals =
attrib_InAttribute : BuiltinAttribInfo;
attrib_OutAttribute : BuiltinAttribInfo;
attrib_OptionalAttribute : BuiltinAttribInfo;
- attrib_ThreadStaticAttribute : BuiltinAttribInfo;
- attrib_SpecialNameAttribute : BuiltinAttribInfo;
+ attrib_ThreadStaticAttribute : BuiltinAttribInfo option;
+ attrib_SpecialNameAttribute : BuiltinAttribInfo option;
attrib_VolatileFieldAttribute : BuiltinAttribInfo;
- attrib_ContextStaticAttribute : BuiltinAttribInfo;
+ attrib_ContextStaticAttribute : BuiltinAttribInfo option;
attrib_FlagsAttribute : BuiltinAttribInfo;
attrib_DefaultMemberAttribute : BuiltinAttribInfo;
attrib_DebuggerDisplayAttribute : BuiltinAttribInfo;
attrib_DebuggerTypeProxyAttribute : BuiltinAttribInfo;
attrib_PreserveSigAttribute : BuiltinAttribInfo;
attrib_MethodImplAttribute : BuiltinAttribInfo;
- tcref_System_Collections_Generic_IList : TyconRef;
- tcref_System_Collections_Generic_ICollection : TyconRef;
- tcref_System_Collections_Generic_IEnumerable : TyconRef;
- tcref_System_Collections_IEnumerable : TyconRef;
- tcref_System_Collections_Generic_IEnumerator : TyconRef;
- tcref_System_Attribute : TyconRef;
+ attrib_ExtensionAttribute : BuiltinAttribInfo;
+ tcref_System_Collections_Generic_IList : TyconRef;
+ tcref_System_Collections_Generic_IReadOnlyList : TyconRef;
+ tcref_System_Collections_Generic_ICollection : TyconRef;
+ tcref_System_Collections_Generic_IReadOnlyCollection : TyconRef;
+ tcref_System_Collections_Generic_IEnumerable : TyconRef;
+ tcref_System_Collections_IEnumerable : TyconRef;
+ tcref_System_Collections_Generic_IEnumerator : TyconRef;
+ tcref_System_Attribute : TyconRef;
attrib_RequireQualifiedAccessAttribute : BuiltinAttribInfo;
attrib_EntryPointAttribute : BuiltinAttribInfo;
@@ -363,7 +367,7 @@ type public TcGlobals =
attrib_MeasureableAttribute : BuiltinAttribInfo;
attrib_NoDynamicInvocationAttribute : BuiltinAttribInfo;
- attrib_SecurityAttribute : BuiltinAttribInfo;
+ attrib_SecurityAttribute : BuiltinAttribInfo option;
attrib_SecurityCriticalAttribute : BuiltinAttribInfo;
attrib_SecuritySafeCriticalAttribute : BuiltinAttribInfo;
@@ -413,7 +417,7 @@ type public TcGlobals =
unchecked_subtraction_vref : ValRef;
unchecked_multiply_vref : ValRef;
unchecked_defaultof_vref : ValRef;
-
+ unchecked_subtraction_info : IntrinsicValRef
seq_info : IntrinsicValRef;
reraise_info : IntrinsicValRef;
reraise_vref : ValRef;
@@ -425,6 +429,7 @@ type public TcGlobals =
typedefof_info : IntrinsicValRef;
typedefof_vref : ValRef;
enum_vref : ValRef;
+ enumOfValue_vref : ValRef
new_decimal_info : IntrinsicValRef;
// 'outer' refers to 'before optimization has boiled away inlined functions'
@@ -515,6 +520,7 @@ type public TcGlobals =
array_get_info : IntrinsicValRef;
+ array_length_info : IntrinsicValRef;
array2D_get_info : IntrinsicValRef;
array3D_get_info : IntrinsicValRef;
array4D_get_info : IntrinsicValRef;
@@ -557,7 +563,7 @@ let global_g = ref (None : TcGlobals option)
#endif
let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePaths,mlCompatibility,
- using40environment,indirectCallArrayMethods,isInteractive,getTypeCcu) =
+ using40environment,indirectCallArrayMethods,isInteractive,getTypeCcu, emitDebugInfoInQuotations) =
let int_tcr = mk_MFCore_tcref fslibCcu "int"
let nativeint_tcr = mk_MFCore_tcref fslibCcu "nativeint"
let unativeint_tcr = mk_MFCore_tcref fslibCcu "unativeint"
@@ -638,6 +644,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
let decimal_ty = mkSysNonGenericTy sys "Decimal"
let unit_ty = mkNonGenericTy unit_tcr_nice
let system_Type_typ = mkSysNonGenericTy sys "Type"
+
let system_Reflection_MethodInfo_typ = mkSysNonGenericTy ["System";"Reflection"] "MethodInfo"
let nullable_tcr = mkSysTyconRef sys "Nullable`1"
@@ -806,10 +813,15 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
let mk_MFCore_attrib nm : BuiltinAttribInfo =
AttribInfo(mkILTyRef(IlxSettings.ilxFsharpCoreLibScopeRef (), nm),mk_MFCore_tcref fslibCcu nm)
-
- let mkMscorlibAttrib (nm:string) : BuiltinAttribInfo =
+
+ let mkAttrib (nm:string) scopeRef : BuiltinAttribInfo =
let path, typeName = splitILTypeName nm
- AttribInfo(mkILTyRef (ilg.mscorlibScopeRef,nm), mkSysTyconRef path typeName)
+ AttribInfo(mkILTyRef (scopeRef, nm), mkSysTyconRef path typeName)
+
+
+ let mkSystemRuntimeAttrib (nm:string) : BuiltinAttribInfo = mkAttrib nm ilg.traits.ScopeRef
+ let mkSystemRuntimeInteropServicesAttribute nm = mkAttrib nm (ilg.traits.SystemRuntimeInteropServicesScopeRef.Value)
+ let mkSystemDiagnosticsDebugAttribute nm = mkAttrib nm (ilg.traits.SystemDiagnosticsDebugScopeRef.Value)
let mk_doc filename = ILSourceDocument.Create(language=None, vendor=None, documentType=None, file=filename)
// Build the memoization table for files
@@ -831,6 +843,9 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
let less_than_or_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName "<=" ,None ,None ,[vara], mk_rel_sig varaTy)
let greater_than_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName ">" ,None ,None ,[vara], mk_rel_sig varaTy)
let greater_than_or_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName ">=" ,None ,None ,[vara], mk_rel_sig varaTy)
+
+ let enumOfValue_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "EnumOfValue" ,None ,None ,[vara; varb], ([[varaTy]], varbTy))
+
let generic_comparison_withc_outer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericComparisonWithComparer" ,None ,None ,[vara], mk_compare_withc_sig varaTy)
let generic_hash_withc_tuple2_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple2" ,None ,None ,[vara;varb], mk_hash_withc_sig (decodeTupleTy [varaTy; varbTy]))
let generic_hash_withc_tuple3_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple3" ,None ,None ,[vara;varb;varc], mk_hash_withc_sig (decodeTupleTy [varaTy; varbTy; varcTy]))
@@ -924,6 +939,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
let splice_raw_expr_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "op_SpliceUntyped" ,None ,None ,[vara], ([[mkRawQuotedExprTy]], varaTy))
let new_decimal_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "MakeDecimal" ,None ,None ,[], ([[int_ty]; [int_ty]; [int_ty]; [bool_ty]; [byte_ty]], decimal_ty))
let array_get_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetArray" ,None ,None ,[vara], ([[mkArrayType varaTy]; [int_ty]], varaTy))
+ let array_length_info = makeIntrinsicValRef(fslib_MFArrayModule_nleref, "length" ,None ,Some "Length" ,[vara], ([[mkArrayType varaTy]], varaTy))
let unpickle_quoted_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Deserialize" ,Some "Expr" ,None ,[], ([[system_Type_typ ;mkListTy system_Type_typ ;mkListTy mkRawQuotedExprTy ; mkArrayType byte_ty]], mkRawQuotedExprTy ))
let cast_quotation_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Cast" ,Some "Expr" ,None ,[vara], ([[mkRawQuotedExprTy]], mkQuotedExprTy varaTy))
let lift_value_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Value" ,Some "Expr" ,None ,[vara], ([[varaTy]], mkRawQuotedExprTy))
@@ -953,6 +969,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
knownFSharpCoreModules = knownFSharpCoreModules
compilingFslib = compilingFslib;
mlCompatibility = mlCompatibility;
+ emitDebugInfoInQuotations = emitDebugInfoInQuotations
directoryToResolveRelativePaths= directoryToResolveRelativePaths;
unionCaseRefEq = unionCaseRefEq;
valRefEq = valRefEq;
@@ -1064,9 +1081,9 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
system_String_typ = mkSysNonGenericTy sys "String";
system_Int32_typ = mkSysNonGenericTy sys "Int32";
system_Type_typ = system_Type_typ;
- system_TypedReference_tcref = mkSysTyconRef sys "TypedReference" ;
- system_ArgIterator_tcref = mkSysTyconRef sys "ArgIterator" ;
- system_RuntimeArgumentHandle_tcref = mkSysTyconRef sys "RuntimeArgumentHandle";
+ system_TypedReference_tcref = if ilg.traits.TypedReferenceTypeScopeRef.IsSome then Some(mkSysTyconRef sys "TypedReference") else None
+ system_ArgIterator_tcref = if ilg.traits.ArgIteratorTypeScopeRef.IsSome then Some(mkSysTyconRef sys "ArgIterator") else None
+ system_RuntimeArgumentHandle_tcref = if ilg.traits.RuntimeArgumentHandleTypeScopeRef.IsSome then Some (mkSysTyconRef sys "RuntimeArgumentHandle") else None;
system_SByte_tcref = mkSysTyconRef sys "SByte";
system_Decimal_tcref = mkSysTyconRef sys "Decimal";
system_Int16_tcref = mkSysTyconRef sys "Int16";
@@ -1085,8 +1102,9 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
system_RuntimeTypeHandle_typ = mkSysNonGenericTy sys "RuntimeTypeHandle";
system_RuntimeMethodHandle_typ = system_RuntimeMethodHandle_typ;
- system_MarshalByRefObject_tcref = mkSysTyconRef sys "MarshalByRefObject";
- system_MarshalByRefObject_typ = mkSysNonGenericTy sys "MarshalByRefObject";
+ system_MarshalByRefObject_tcref = if ilg.traits.MarshalByRefObjectScopeRef.IsSome then Some(mkSysTyconRef sys "MarshalByRefObject") else None
+ system_MarshalByRefObject_typ = if ilg.traits.MarshalByRefObjectScopeRef.IsSome then Some(mkSysNonGenericTy sys "MarshalByRefObject") else None
+
system_Reflection_MethodInfo_typ = system_Reflection_MethodInfo_typ;
system_Array_tcref = mkSysTyconRef sys "Array";
@@ -1118,7 +1136,9 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
tcref_System_Collections_Generic_IList = mkSysTyconRef sysGenerics "IList`1";
+ tcref_System_Collections_Generic_IReadOnlyList = mkSysTyconRef sysGenerics "IReadOnlyList`1";
tcref_System_Collections_Generic_ICollection = mkSysTyconRef sysGenerics "ICollection`1";
+ tcref_System_Collections_Generic_IReadOnlyCollection = mkSysTyconRef sysGenerics "IReadOnlyCollection`1";
tcref_System_Collections_IEnumerable = tcref_System_Collections_IEnumerable
tcref_System_Collections_Generic_IEnumerable = IEnumerable_tcr;
@@ -1126,36 +1146,37 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
tcref_System_Attribute = System_Attribute_tcr;
- attrib_AttributeUsageAttribute = mkMscorlibAttrib "System.AttributeUsageAttribute";
- attrib_ParamArrayAttribute = mkMscorlibAttrib "System.ParamArrayAttribute";
- attrib_IDispatchConstantAttribute = mkMscorlibAttrib "System.Runtime.CompilerServices.IDispatchConstantAttribute";
- attrib_IUnknownConstantAttribute = mkMscorlibAttrib "System.Runtime.CompilerServices.IUnknownConstantAttribute";
+ attrib_AttributeUsageAttribute = mkSystemRuntimeAttrib "System.AttributeUsageAttribute";
+ attrib_ParamArrayAttribute = mkSystemRuntimeAttrib "System.ParamArrayAttribute";
+ attrib_IDispatchConstantAttribute = if ilg.traits.IDispatchConstantAttributeScopeRef.IsSome then Some(mkSystemRuntimeAttrib "System.Runtime.CompilerServices.IDispatchConstantAttribute") else None
+ attrib_IUnknownConstantAttribute = if ilg.traits.IUnknownConstantAttributeScopeRef.IsSome then Some (mkSystemRuntimeAttrib "System.Runtime.CompilerServices.IUnknownConstantAttribute") else None
- attrib_SystemObsolete = mkMscorlibAttrib "System.ObsoleteAttribute";
- attrib_DllImportAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.DllImportAttribute";
- attrib_StructLayoutAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.StructLayoutAttribute";
- attrib_TypeForwardedToAttribute = mkMscorlibAttrib "System.Runtime.CompilerServices.TypeForwardedToAttribute";
- attrib_ComVisibleAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.ComVisibleAttribute";
- attrib_ComImportAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.ComImportAttribute";
- attrib_FieldOffsetAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.FieldOffsetAttribute" ;
- attrib_MarshalAsAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.MarshalAsAttribute";
- attrib_InAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.InAttribute" ;
- attrib_OutAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.OutAttribute" ;
- attrib_OptionalAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.OptionalAttribute" ;
- attrib_ThreadStaticAttribute = mkMscorlibAttrib "System.ThreadStaticAttribute";
- attrib_SpecialNameAttribute = mkMscorlibAttrib "System.Runtime.CompilerServices.SpecialNameAttribute";
+ attrib_SystemObsolete = mkSystemRuntimeAttrib "System.ObsoleteAttribute";
+ attrib_DllImportAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.DllImportAttribute";
+ attrib_StructLayoutAttribute = mkSystemRuntimeAttrib "System.Runtime.InteropServices.StructLayoutAttribute";
+ attrib_TypeForwardedToAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.TypeForwardedToAttribute";
+ attrib_ComVisibleAttribute = mkSystemRuntimeAttrib "System.Runtime.InteropServices.ComVisibleAttribute";
+ attrib_ComImportAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.ComImportAttribute";
+ attrib_FieldOffsetAttribute = mkSystemRuntimeAttrib "System.Runtime.InteropServices.FieldOffsetAttribute" ;
+ attrib_MarshalAsAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.MarshalAsAttribute";
+ attrib_InAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.InAttribute" ;
+ attrib_OutAttribute = mkSystemRuntimeAttrib "System.Runtime.InteropServices.OutAttribute" ;
+ attrib_OptionalAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.OptionalAttribute" ;
+ attrib_ThreadStaticAttribute = if ilg.traits.ThreadStaticAttributeScopeRef.IsSome then Some(mkSystemRuntimeAttrib "System.ThreadStaticAttribute") else None
+ attrib_SpecialNameAttribute = if ilg.traits.SpecialNameAttributeScopeRef.IsSome then Some(mkSystemRuntimeAttrib "System.Runtime.CompilerServices.SpecialNameAttribute") else None
attrib_VolatileFieldAttribute = mk_MFCore_attrib "VolatileFieldAttribute";
- attrib_ContextStaticAttribute = mkMscorlibAttrib "System.ContextStaticAttribute";
- attrib_FlagsAttribute = mkMscorlibAttrib "System.FlagsAttribute";
- attrib_DefaultMemberAttribute = mkMscorlibAttrib "System.Reflection.DefaultMemberAttribute";
- attrib_DebuggerDisplayAttribute = mkMscorlibAttrib "System.Diagnostics.DebuggerDisplayAttribute";
- attrib_DebuggerTypeProxyAttribute = mkMscorlibAttrib "System.Diagnostics.DebuggerTypeProxyAttribute";
- attrib_PreserveSigAttribute = mkMscorlibAttrib "System.Runtime.InteropServices.PreserveSigAttribute";
- attrib_MethodImplAttribute = mkMscorlibAttrib "System.Runtime.CompilerServices.MethodImplAttribute";
+ attrib_ContextStaticAttribute = if ilg.traits.ContextStaticAttributeScopeRef.IsSome then Some (mkSystemRuntimeAttrib "System.ContextStaticAttribute") else None;
+ attrib_FlagsAttribute = mkSystemRuntimeAttrib "System.FlagsAttribute";
+ attrib_DefaultMemberAttribute = mkSystemRuntimeAttrib "System.Reflection.DefaultMemberAttribute";
+ attrib_DebuggerDisplayAttribute = mkSystemDiagnosticsDebugAttribute "System.Diagnostics.DebuggerDisplayAttribute";
+ attrib_DebuggerTypeProxyAttribute = mkSystemDiagnosticsDebugAttribute "System.Diagnostics.DebuggerTypeProxyAttribute";
+ attrib_PreserveSigAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.PreserveSigAttribute";
+ attrib_MethodImplAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.MethodImplAttribute";
+ attrib_ExtensionAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.ExtensionAttribute";
attrib_ProjectionParameterAttribute = mk_MFCore_attrib "ProjectionParameterAttribute";
attrib_CustomOperationAttribute = mk_MFCore_attrib "CustomOperationAttribute";
- attrib_NonSerializedAttribute = mkMscorlibAttrib "System.NonSerializedAttribute";
+ attrib_NonSerializedAttribute = if ilg.traits.NonSerializedAttributeScopeRef.IsSome then Some(mkSystemRuntimeAttrib "System.NonSerializedAttribute") else None;
attrib_AutoSerializableAttribute = mk_MFCore_attrib "AutoSerializableAttribute";
attrib_RequireQualifiedAccessAttribute = mk_MFCore_attrib "RequireQualifiedAccessAttribute";
attrib_EntryPointAttribute = mk_MFCore_attrib "EntryPointAttribute";
@@ -1164,7 +1185,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
attrib_ExperimentalAttribute = mk_MFCore_attrib "ExperimentalAttribute";
attrib_UnverifiableAttribute = mk_MFCore_attrib "UnverifiableAttribute";
attrib_LiteralAttribute = mk_MFCore_attrib "LiteralAttribute";
- attrib_ConditionalAttribute = mkMscorlibAttrib "System.Diagnostics.ConditionalAttribute";
+ attrib_ConditionalAttribute = mkSystemRuntimeAttrib "System.Diagnostics.ConditionalAttribute";
attrib_OptionalArgumentAttribute = mk_MFCore_attrib "OptionalArgumentAttribute";
attrib_RequiresExplicitTypeArgumentsAttribute = mk_MFCore_attrib "RequiresExplicitTypeArgumentsAttribute";
attrib_DefaultValueAttribute = mk_MFCore_attrib "DefaultValueAttribute";
@@ -1195,9 +1216,9 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
attrib_MeasureAttribute = mk_MFCore_attrib "MeasureAttribute";
attrib_MeasureableAttribute = mk_MFCore_attrib "MeasureAnnotatedAbbreviationAttribute";
attrib_NoDynamicInvocationAttribute = mk_MFCore_attrib "NoDynamicInvocationAttribute";
- attrib_SecurityAttribute = mkMscorlibAttrib "System.Security.Permissions.SecurityAttribute"
- attrib_SecurityCriticalAttribute = mkMscorlibAttrib "System.Security.SecurityCriticalAttribute"
- attrib_SecuritySafeCriticalAttribute = mkMscorlibAttrib "System.Security.SecuritySafeCriticalAttribute"
+ attrib_SecurityAttribute = if ilg.traits.SecurityPermissionAttributeTypeScopeRef.IsSome then Some(mkSystemRuntimeAttrib"System.Security.Permissions.SecurityAttribute") else None
+ attrib_SecurityCriticalAttribute = mkSystemRuntimeAttrib "System.Security.SecurityCriticalAttribute"
+ attrib_SecuritySafeCriticalAttribute = mkSystemRuntimeAttrib "System.Security.SecuritySafeCriticalAttribute"
// Build a map that uses the "canonical" F# type names and TyconRef's for these
// in preference to the .NET type names. Doing this normalization is a fairly performance critical
@@ -1303,7 +1324,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
unchecked_subtraction_vref = ValRefForIntrinsic unchecked_subtraction_info;
unchecked_multiply_vref = ValRefForIntrinsic unchecked_multiply_info;
unchecked_defaultof_vref = ValRefForIntrinsic unchecked_defaultof_info;
-
+ unchecked_subtraction_info = unchecked_subtraction_info
compare_operator_vref = ValRefForIntrinsic compare_operator_info;
equals_operator_vref = ValRefForIntrinsic equals_operator_info;
equals_nullable_operator_vref = ValRefForIntrinsic equals_nullable_operator_info;
@@ -1328,9 +1349,11 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
typedefof_info = typedefof_info;
typedefof_vref = ValRefForIntrinsic typedefof_info;
enum_vref = ValRefForIntrinsic enum_info;
+ enumOfValue_vref = ValRefForIntrinsic enumOfValue_info;
range_op_vref = ValRefForIntrinsic range_op_info;
range_int32_op_vref = ValRefForIntrinsic range_int32_op_info;
//range_step_op_vref = ValRefForIntrinsic range_step_op_info;
+ array_length_info = array_length_info
array_get_vref = ValRefForIntrinsic array_get_info;
array2D_get_vref = ValRefForIntrinsic array2D_get_info;
array3D_get_vref = ValRefForIntrinsic array3D_get_info;
@@ -1427,6 +1450,6 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa
let public mkMscorlibAttrib g nm : BuiltinAttribInfo =
let path, typeName = splitILTypeName nm
- AttribInfo(mkILTyRef (g.ilg.mscorlibScopeRef,nm), g.mkSysTyconRef path typeName)
+ AttribInfo(mkILTyRef (g.ilg.traits.ScopeRef,nm), g.mkSysTyconRef path typeName)
diff --git a/src/fsharp/est.fs b/src/fsharp/est.fs
index 3dfc3c6..478b496 100755
--- a/src/fsharp/est.fs
+++ b/src/fsharp/est.fs
@@ -37,7 +37,7 @@ module internal ExtensionTyping =
let mutable theMostRecentFileNameWeChecked = None : string option
module internal ApprovalIO =
- let ApprovalsAbsoluteFileName = Path.Combine(System.Environment.GetFolderPath(System.Environment.SpecialFolder.LocalApplicationData), @"Microsoft\FSharp\3.0\type-providers.txt")
+ let ApprovalsAbsoluteFileName = Path.Combine(System.Environment.GetFolderPath(System.Environment.SpecialFolder.LocalApplicationData), @"Microsoft\VisualStudio\12.0\type-providers.txt")
let partiallyCanonicalizeFileName fn =
(new FileInfo(fn)).FullName // avoid some trivialities like double backslashes or spaces before slashes (but preserves others like casing distinctions), see also bug 206595
@@ -255,19 +255,17 @@ module internal ExtensionTyping =
Some (FileSystem.AssemblyLoadFrom designTimeAssemblyPath)
with e ->
raiseError e
- let loadFromGac () =
+ let loadFromGac() =
try
let asmName = System.Reflection.AssemblyName designTimeAssemblyNameString
Some (FileSystem.AssemblyLoad (asmName))
with e ->
raiseError e
-
if designTimeAssemblyNameString.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) then
loadFromDir designTimeAssemblyNameString
else
let name = AssemblyName designTimeAssemblyNameString
-
if name.Name.Equals(name.FullName, StringComparison.OrdinalIgnoreCase) then
let fileName = designTimeAssemblyNameString+".dll"
loadFromDir fileName
@@ -669,6 +667,7 @@ module internal ExtensionTyping =
#endif
member __.IsOptional = x.IsOptional
member __.RawDefaultValue = x.RawDefaultValue
+ member __.HasDefaultValue = x.Attributes.HasFlag(ParameterAttributes.HasDefault)
/// ParameterInfo.ParameterType cannot be null
member __.ParameterType = ProvidedType.CreateWithNullCheck ctxt "ParameterType" x.ParameterType
static member Create ctxt x = match x with null -> null | t -> ProvidedParameterInfo (t,ctxt)
diff --git a/src/fsharp/est.fsi b/src/fsharp/est.fsi
index a6333a7..65f107b 100755
--- a/src/fsharp/est.fsi
+++ b/src/fsharp/est.fsi
@@ -32,7 +32,7 @@ module internal ExtensionTyping =
module internal ApprovalIO =
val partiallyCanonicalizeFileName : string -> string
- /// location of approvals data file, e.g. C:\Users\username\AppData\Local\Microsoft\VisualStudio\11.0\type-providers.txt
+ /// location of approvals data file, e.g. C:\Users\username\AppData\Local\Microsoft\VisualStudio\12.0\type-providers.txt
val ApprovalsAbsoluteFileName : string
[<RequireQualifiedAccess>]
@@ -230,6 +230,7 @@ module internal ExtensionTyping =
member IsOut : bool
member IsOptional : bool
member RawDefaultValue : obj
+ member HasDefaultValue : bool
interface IProvidedCustomAttributeProvider
and [<AllowNullLiteral; Class; Sealed>]
diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs
index 2907467..4128d2a 100755
--- a/src/fsharp/fsc.fs
+++ b/src/fsharp/fsc.fs
@@ -43,6 +43,9 @@ open Microsoft.FSharp.Compiler.Ilxgen
#endif
open Microsoft.FSharp.Compiler.Ast
open Microsoft.FSharp.Compiler.ErrorLogger
+#if SQM_SUPPORT
+open Microsoft.FSharp.Compiler.SqmLogger
+#endif
open Microsoft.FSharp.Compiler.Range
open Microsoft.FSharp.Compiler.TypeChecker
open Microsoft.FSharp.Compiler.Infos
@@ -63,7 +66,6 @@ open Microsoft.FSharp.Compiler.ExtensionTyping
#nowarn "45" // This method will be made public in the underlying IL because it may implement an interface or override a method
-
///////////////////////////////////////////////////////////////////////////////////////////////////////////////
// This code has logic for a prefix of the compile that is also used by the project system to do the front-end
// logic that starts at command-line arguments and gets as far as importing all references (used for deciding
@@ -74,21 +76,95 @@ open Microsoft.FSharp.Compiler.ExtensionTyping
// Reporting - warnings, errors
//----------------------------------------------------------------------------
-/// Create an error logger that counts and prints errors
-let ErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exiter) =
+type ErrorLoggerThatAccumulatesErrors private (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, globalWarnLevel, specificWarnOn, specificWarnOff, specificWarnAsError, specificWarnAsWarn, globalWarnAsError) =
+ inherit ErrorLogger("ErrorLoggerThatAccumulatesErrors")
+ let messages = ResizeArray()
+ let mutable errorsCount = 0
+ new(tcConfigB : TcConfigBuilder) =
+ ErrorLoggerThatAccumulatesErrors(
+ tcConfigB.implicitIncludeDir,
+ tcConfigB.showFullPaths,
+ tcConfigB.flatErrors,
+ tcConfigB.errorStyle,
+ tcConfigB.globalWarnLevel,
+ tcConfigB.specificWarnOn,
+ tcConfigB.specificWarnOff,
+ tcConfigB.specificWarnAsError,
+ tcConfigB.specificWarnAsWarn,
+ tcConfigB.globalWarnAsError
+ )
+ new(tcConfig : TcConfig) =
+ ErrorLoggerThatAccumulatesErrors(
+ tcConfig.implicitIncludeDir,
+ tcConfig.showFullPaths,
+ tcConfig.flatErrors,
+ tcConfig.errorStyle,
+ tcConfig.globalWarnLevel,
+ tcConfig.specificWarnOn,
+ tcConfig.specificWarnOff,
+ tcConfig.specificWarnAsError,
+ tcConfig.specificWarnAsWarn,
+ tcConfig.globalWarnAsError
+ )
+ member this.ProcessMessage(err, isError) =
+ let writer = new System.IO.StringWriter()
+
+ let writeError err =
+ writeViaBufferWithEnvironmentNewLines writer (OutputErrorOrWarning (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, false)) err
+
+ let isError =
+ if isError then
+ writeError err
+ true
+ else
+ if (ReportWarningAsError globalWarnLevel specificWarnOff specificWarnOn specificWarnAsError specificWarnAsWarn globalWarnAsError err) then
+ writeError err
+ true
+ elif ReportWarning globalWarnLevel specificWarnOff specificWarnOn err then
+ writeViaBufferWithEnvironmentNewLines writer (OutputErrorOrWarning (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, true)) err
+ false
+ else
+ false // will not be used
+ let text = writer.ToString()
+ if text.Length <> 0 then Some (isError, text) else None
+
+ member this.GetMessages() = List.ofSeq messages
+ override this.ErrorSinkImpl(err) =
+ errorsCount <- errorsCount + 1
+ messages.Add(this.ProcessMessage(err, true).Value)
+ override this.WarnSinkImpl(warn) =
+ match this.ProcessMessage (warn, false) with
+ | Some ((isError, _) as res) ->
+ if isError then errorsCount <- errorsCount + 1
+ messages.Add(res)
+ | _ -> ()
+
+ override this.ErrorCount = errorsCount
+
+[<AbstractClass>]
+type ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB:TcConfigBuilder, exiter : Exiter, caption) =
+ inherit ErrorLogger(caption)
let errors = ref 0
+ let errorNumbers = ref []
+ let warningNumbers = ref []
+
+ abstract HandleIssue : tcConfigB : TcConfigBuilder * error : PhasedError * isWarning : bool -> unit
+ abstract HandleTooManyErrors : text : string -> unit
- { new ErrorLogger("ErrorLoggerThatQuitsAfterMaxErrors") with
- member x.ErrorSinkImpl(err) =
+ override x.ErrorCount = !errors
+ override x.ErrorSinkImpl(err) =
if !errors >= tcConfigB.maxErrors then
- DoWithErrorColor true (fun () -> Printf.eprintfn "%s" (FSComp.SR.fscTooManyErrors()))
+ x.HandleTooManyErrors(FSComp.SR.fscTooManyErrors())
+#if SQM_SUPPORT
+ SqmLoggerWithConfigBuilder tcConfigB !errorNumbers !warningNumbers
+#endif
exiter.Exit 1
- DoWithErrorColor false (fun () ->
- (writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,false)) err; stderr.WriteLine()));
+ x.HandleIssue(tcConfigB, err, false)
incr errors
+ errorNumbers := (GetErrorNumber err) :: !errorNumbers
match err.Exception with
| InternalError _
@@ -99,16 +175,31 @@ let ErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exit
| None -> System.Diagnostics.Debug.Assert(false,sprintf "Bug seen in compiler: %s" (err.ToString()))
| _ ->
()
- member x.WarnSinkImpl(err) =
- DoWithErrorColor true (fun () ->
- if (ReportWarningAsError tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn tcConfigB.specificWarnAsError tcConfigB.specificWarnAsWarn tcConfigB.globalWarnAsError err) then
- x.ErrorSink(err)
- elif ReportWarning tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn err then
- writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,true)) err;
- stderr.WriteLine())
- member x.ErrorCount = !errors }
-let ErrorLoggerInitial (tcConfigB:TcConfigBuilder, exiter : Exiter) = ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
+ override x.WarnSinkImpl(err) =
+ if (ReportWarningAsError tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn tcConfigB.specificWarnAsError tcConfigB.specificWarnAsWarn tcConfigB.globalWarnAsError err) then
+ x.ErrorSink(err)
+ elif ReportWarning tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn err then
+ x.HandleIssue(tcConfigB, err, true)
+ warningNumbers := (GetErrorNumber err) :: !warningNumbers
+
+ override x.WarningNumbers = !warningNumbers
+ override x.ErrorNumbers = !errorNumbers
+
+/// Create an error logger that counts and prints errors
+let ConsoleErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exiter) : ErrorLogger =
+ upcast {
+ new ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter, "ConsoleErrorLoggerThatQuitsAfterMaxErrors") with
+
+ member this.HandleTooManyErrors(text : string) =
+ DoWithErrorColor true (fun () -> Printf.eprintfn "%s" text)
+
+ member this.HandleIssue(tcConfigB, err, isWarning) =
+ DoWithErrorColor isWarning (fun () ->
+ (writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,isWarning)) err;
+ stderr.WriteLine())
+ );
+ }
// val TypeCheck : TcConfig * TcImports * TcGlobals * ErrorLogger * string * NiceNameGenerator * TypeChecker.TcEnv * Input list * Exiter ->
// TcState * TypeChecker.TopAttribs * Tast.TypedAssembly * TypeChecker.TcEnv
@@ -120,12 +211,17 @@ let TypeCheck (tcConfig,tcImports,tcGlobals,errorLogger:ErrorLogger,assemblyName
TypecheckClosedInputSet ((fun () -> errorLogger.ErrorCount > 0),tcConfig,tcImports,tcGlobals,None,tcInitialState,inputs)
with e ->
errorRecovery e rangeStartup
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+#endif
exiter.Exit 1
/// This error logger delays the messages it recieves. At the end, call ForwardDelayedErrorsAndWarnings
/// to send the held messages.
-type DelayAndForwardErrorLogger(exiter : Exiter) =
+type DelayAndForwardErrorLogger(exiter : Exiter, errorLoggerProvider : ErrorLoggerProvider) =
inherit ErrorLogger("DelayAndForwardErrorLogger")
+ let mapToErrorNumber items =
+ items |> Seq.map (fun (err,_) -> GetErrorNumber err) |> Seq.toList
let delayed = new ResizeArray<_>()
let errors = ref 0
override x.ErrorSinkImpl(e) =
@@ -142,9 +238,16 @@ type DelayAndForwardErrorLogger(exiter : Exiter) =
// Clear errors just reported. Keep errors count.
delayed.Clear()
member x.ForwardDelayedErrorsAndWarnings(tcConfigB:TcConfigBuilder) =
- let errorLogger = ErrorLoggerInitial(tcConfigB, exiter)
+ let errorLogger = errorLoggerProvider.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
x.ForwardDelayedErrorsAndWarnings(errorLogger)
- member x.FullErrorCount = !errors
+ member x.FullErrorCount = !errors
+ override x.WarningNumbers = delayed |> Seq.filter(fun (_, flag) -> flag = false) |> mapToErrorNumber
+ override x.ErrorNumbers = delayed |> Seq.filter(fun (_, flag) -> flag = true) |> mapToErrorNumber
+
+and [<AbstractClass>]
+ ErrorLoggerProvider() =
+ member this.CreateDelayAndForwardLogger(exiter) = DelayAndForwardErrorLogger(exiter, this)
+ abstract CreateErrorLoggerThatQuitsAfterMaxErrors : tcConfigBuilder : TcConfigBuilder * exiter : Exiter -> ErrorLogger
/// Check for .fsx and, if present, compute the load closure for of #loaded files.
let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexResourceManager) =
@@ -185,8 +288,26 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexR
List.rev !allSources
-let abortOnError (errorLogger:ErrorLogger, exiter : Exiter) =
- if errorLogger.ErrorCount > 0 then exiter.Exit 1
+let abortOnError (errorLogger:ErrorLogger, _tcConfig:TcConfig, exiter : Exiter) =
+ if errorLogger.ErrorCount > 0 then
+#if SQM_SUPPORT
+ SqmLoggerWithConfig _tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+#endif
+ exiter.Exit 1
+
+type DelayedDisposables() =
+ let items = Stack<System.IDisposable>()
+ member this.Register(i) = items.Push i
+ interface System.IDisposable with
+ member this.Dispose() =
+ let l = List.ofSeq items
+ items.Clear()
+ for i in l do
+ try i.Dispose() with _ -> ()
+
+type DefaultLoggerProvider() =
+ inherit ErrorLoggerProvider()
+ override this.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter) = ConsoleErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter)
// The project system needs to be able to somehow crack open assemblies to look for type providers in order to pop up the security dialog when necessary when a user does 'Build'.
// Rather than have the PS re-code that logic, it re-uses the existing code in the very front end of the compiler that parses the command-line and imports the referenced assemblies.
@@ -201,9 +322,11 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
displayBannerIfNeeded : TcConfigBuilder -> unit,
optimizeForMemory : bool,
exiter : Exiter,
- createErrorLogger: (TcConfigBuilder -> ErrorLogger))
+ errorLoggerProvider : ErrorLoggerProvider,
+ disposables : DelayedDisposables)
: TcGlobals * TcImports * TcImports * Tast.CcuThunk * Tast.TypedAssembly * TypeChecker.TopAttribs * TcConfig * string * string option * string * ErrorLogger
=
+
let tcConfigB = Build.TcConfigBuilder.CreateNew(defaultFSharpBinariesDir, optimizeForMemory, directoryBuildingFrom, isInteractive=false, isInvalidationSupported=false)
// Preset: --optimize+ -g --tailcalls+ (see 4505)
@@ -212,7 +335,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
SetTailcallSwitch tcConfigB On
// Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors)
- let delayForFlagsLogger = DelayAndForwardErrorLogger(exiter)
+ let delayForFlagsLogger = errorLoggerProvider.CreateDelayAndForwardLogger(exiter)// DelayAndForwardErrorLogger(exiter)
let _unwindEL_1 = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger)
// Share intern'd strings across all lexing/parsing
@@ -262,9 +385,13 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
with
e ->
errorRecovery e rangeStartup
+#if SQM_SUPPORT
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
-
+
+ tcConfigB.sqmNumOfSourceFiles <- sourceFiles.Length
tcConfigB.conditionalCompilationDefines <- "COMPILED" :: tcConfigB.conditionalCompilationDefines
displayBannerIfNeeded tcConfigB
@@ -274,11 +401,17 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
tcConfigB.DecideNames sourceFiles
with e ->
errorRecovery e rangeStartup
+#if SQM_SUPPORT
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
// DecideNames may give "no inputs" error. Abort on error at this point. bug://3911
- if not tcConfigB.continueAfterParseFailure && delayForFlagsLogger.FullErrorCount > 0 then
+ if not tcConfigB.continueAfterParseFailure && delayForFlagsLogger.FullErrorCount > 0 then
+#if SQM_SUPPORT
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
@@ -287,12 +420,13 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
try
TcConfig.Create(tcConfigB,validate=false)
with e ->
+#if SQM_SUPPORT
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
-
- // Create the real errorLogger now we know the --vserrors flag
- let errorLogger = createErrorLogger tcConfigB
+ let errorLogger = errorLoggerProvider.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
// Install the global error logger and never remove it. This logger does have all command-line flags considered.
let _unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger)
@@ -302,7 +436,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
// step - decideNames
if not tcConfigB.continueAfterParseFailure then
- abortOnError(errorLogger, exiter)
+ abortOnError(errorLogger, tcConfig, exiter)
let tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig =
@@ -315,7 +449,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
ensureReactive=false,
errorLogger=errorLogger,
keepGeneratedTypedAssembly=true)
- let tcState,topAttribs,typedAssembly,_tcEnv,tcImports,tcGlobals,tcConfig = builder.TypeCheck()
+ let tcState,topAttribs,typedAssembly,_tcEnv,tcImports,tcGlobals,tcConfig = builder.TypeCheck()
tcGlobals,tcImports,tcImports,tcState.Ccu,typedAssembly,topAttribs,tcConfig
else
@@ -325,6 +459,9 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
let sysRes,otherRes,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig)
let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes)
+ // register framework tcImports to be disposed in future
+ disposables.Register frameworkTcImports
+
// step - parse sourceFiles
ReportTime tcConfig "Parse inputs"
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse)
@@ -342,10 +479,14 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
)
with e ->
errorRecoveryNoRange e
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+#endif
exiter.Exit 1
+
if tcConfig.parseOnly then exiter.Exit 0
if not tcConfig.continueAfterParseFailure then
- abortOnError(errorLogger, exiter)
+ abortOnError(errorLogger, tcConfig, exiter)
if tcConfig.printAst then
inputs |> List.iter (fun (input,_filename) -> printf "AST:\n"; printfn "%+A" input; printf "\n")
@@ -358,8 +499,11 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
let tcImports = TcImports.BuildNonFrameworkTcImports(displayPSTypeProviderSecurityDialogBlockingUI,tcConfigP,tcGlobals,frameworkTcImports,otherRes,knownUnresolved)
tcGlobals,tcImports
+ // register tcImports to be disposed in future
+ disposables.Register tcImports
+
if not tcConfig.continueAfterParseFailure then
- abortOnError(errorLogger, exiter)
+ abortOnError(errorLogger, tcConfig, exiter)
if tcConfig.importAllReferencesOnly then exiter.Exit 0
@@ -373,7 +517,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
TypeCheck(tcConfig,tcImports,tcGlobals,errorLogger,assemblyName,NiceNameGenerator(),tcEnv0,inputs,exiter)
let generatedCcu = tcState.Ccu
- abortOnError(errorLogger, exiter)
+ abortOnError(errorLogger, tcConfig, exiter)
ReportTime tcConfig "Typechecked"
(tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig)
@@ -386,7 +530,9 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB
defaultFSharpBinariesDir : string,
directoryBuildingFrom : string,
exiter : Exiter) =
- let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter))
+
+ use d = new DelayedDisposables() // ensure that any resources that can be allocated in getTcImportsFromCommandLine will be correctly disposed
+
let tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger =
getTcImportsFromCommandLine(Some displayPSTypeProviderSecurityDialogBlockingUI, argv, defaultFSharpBinariesDir, directoryBuildingFrom, None, (fun _ -> ()),
(fun tcConfigB ->
@@ -400,8 +546,10 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB
tcConfigB.framework<-false
),
true, // optimizeForMemory - want small memory footprint in VS
- exiter,
- createErrorLogger)
+ exiter,
+ DefaultLoggerProvider(), // this function always use default set of loggers
+ d)
+
// we don't care about the result, we just called 'getTcImportsFromCommandLine' to have the effect of popping up the dialog if the TP is unknown
ignore(tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger)
@@ -565,6 +713,7 @@ let getModuleFileName() =
let defaultFSharpBinariesDir = Filename.directoryName (getModuleFileName())
#endif
+
let outpath outfile extn =
String.concat "." (["out"; Filename.chopExtension (Filename.fileNameOfPath outfile); extn])
@@ -581,7 +730,7 @@ type ILResource with
| ILResourceLocation.Local b -> b()
| _-> error(InternalError("Bytes",rangeStartup))
-let EncodeInterfaceData(tcConfig:TcConfig,tcGlobals,exportRemapping,generatedCcu,outfile,exiter:Exiter) =
+let EncodeInterfaceData(tcConfig:TcConfig,tcGlobals,exportRemapping,_errorLogger:ErrorLogger,generatedCcu,outfile,exiter:Exiter) =
try
if GenerateInterfaceData(tcConfig) then
if verbose then dprintfn "Generating interface data attribute...";
@@ -602,7 +751,10 @@ let EncodeInterfaceData(tcConfig:TcConfig,tcGlobals,exportRemapping,generatedCcu
else
[],[]
with e ->
- errorRecoveryNoRange e;
+ errorRecoveryNoRange e
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig _errorLogger.ErrorNumbers _errorLogger.WarningNumbers
+#endif
exiter.Exit 1
@@ -953,12 +1105,12 @@ module MainModuleBuilder =
mkILCustomAttrs
[ if not tcConfig.internConstantStrings then
yield mkILCustomAttribute tcGlobals.ilg
- (mkILTyRef (tcGlobals.ilg.mscorlibScopeRef, "System.Runtime.CompilerServices.CompilationRelaxationsAttribute"),
+ (mkILTyRef (tcGlobals.ilg.traits.ScopeRef, "System.Runtime.CompilerServices.CompilationRelaxationsAttribute"),
[tcGlobals.ilg.typ_Int32],[ILAttribElem.Int32( 8)], [])
yield! iattrs
yield! codegenResults.ilAssemAttrs
if Option.isSome pdbfile then
- yield (mkDebuggableAttributeV2 tcGlobals.ilg (tcConfig.jitTracking, tcConfig.ignoreSymbolStoreSequencePoints, disableJitOptimizations, false (* enableEnC *) )) ]
+ yield (tcGlobals.ilg.mkDebuggableAttributeV2 (tcConfig.jitTracking, tcConfig.ignoreSymbolStoreSequencePoints, disableJitOptimizations, false (* enableEnC *) )) ]
let tcVersion = tcConfig.version.GetVersionInfo(tcConfig.implicitIncludeDir)
let manifest =
@@ -1127,13 +1279,12 @@ module MainModuleBuilder =
#if SILVERLIGHT
""
#else
-
if not(tcConfig.win32manifest = "") then
tcConfig.win32manifest
elif not(tcConfig.includewin32manifest) || not(tcConfig.win32res = "") || runningOnMono then // don't embed a manifest if a native resource is being included
""
else
- match Build.highestInstalledNetFrameworkVersionMajorMinor() with
+ match MSBuildResolver.HighestInstalledNetFrameworkVersionMajorMinor() with
| _,"v4.0" -> System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + @"default.win32manifest"
| _,"v3.5" -> System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + @"..\v3.5\default.win32manifest"
| _,_ -> "" // only have default manifests for 3.5 and 4.0
@@ -1152,6 +1303,7 @@ module MainModuleBuilder =
yield! (ManifestResourceFormat.VS_MANIFEST_RESOURCE((FileSystem.ReadAllBytesShim win32Manifest), tcConfig.target = Dll))|]]
#endif
+
// Add attributes, version number, resources etc.
{mainModule with
StackReserveSize = tcConfig.stackReserveSize
@@ -1199,10 +1351,10 @@ module StaticLinker =
match m.Manifest with
| Some m -> yield m.Name
| _ -> () ]
-
+
// A rewriter which rewrites scope references to things in dependent assemblies to be local references
let rewriteExternalRefsToLocalRefs x =
- if assems.Contains(getNameOfScopeRef x) then ILScopeRef.Local else x
+ if assems.Contains (getNameOfScopeRef x) then ILScopeRef.Local else x
let savedResources =
let allResources = [ for (ccu,m) in dependentILModules do for r in m.Resources.AsList do yield (ccu, r) ]
@@ -1283,8 +1435,8 @@ module StaticLinker =
let mscorlib40 = tcConfig.compilingFslib20.Value // + @"\..\.NET Framework 4.0 Pre Beta\mscorlib.dll"
let ilBinaryReader =
- let opts = { ILBinaryReader.defaults with
- ilGlobals=mkILGlobals ILScopeRef.Local (Some tcConfig.mscorlibAssemblyName) tcConfig.noDebugData ;
+ let ilGlobals = mkILGlobals (IL.mkMscorlibBasedTraits ILScopeRef.Local) (Some ilGlobals.primaryAssemblyName) tcConfig.noDebugData
+ let opts = { ILBinaryReader.mkDefault (ilGlobals) with
optimizeForMemory=tcConfig.optimizeForMemory;
pdbPath = None; }
ILBinaryReader.OpenILModuleReader mscorlib40 opts
@@ -1305,7 +1457,7 @@ module StaticLinker =
elif tref.Name = "System.Environment" then
ILTypeRef.Create(ILScopeRef.Local, [], "Microsoft.FSharp.Core.PrivateEnvironment") //|> Morphs.morphILScopeRefsInILTypeRef (function ILScopeRef.Local -> ilGlobals.mscorlibScopeRef | x -> x)
else
- tref |> Morphs.morphILScopeRefsInILTypeRef (fun _ -> ilGlobals.mscorlibScopeRef) )
+ tref |> Morphs.morphILScopeRefsInILTypeRef (fun _ -> ilGlobals.traits.ScopeRef) )
// strip out System.Runtime.TargetedPatchingOptOutAttribute, which doesn't exist for 2.0
let fakeModule =
@@ -1606,11 +1758,17 @@ module StaticLinker =
// Glue all this stuff into ilxMainModule
let ilxMainModule,rewriteExternalRefsToLocalRefs =
StaticLinkILModules (tcConfig, ilGlobals, ilxMainModule, dependentILModules @ providerGeneratedILModules)
-
+
// Rewrite type and assembly references
let ilxMainModule =
+ let isMscorlib = ilGlobals.primaryAssemblyName = PrimaryAssembly.Mscorlib.Name
+ let validateTargetPlatform (scopeRef : ILScopeRef) =
+ let name = getNameOfScopeRef scopeRef
+ if (isMscorlib && name = PrimaryAssembly.DotNetCore.Name) || (not isMscorlib && name = PrimaryAssembly.Mscorlib.Name) then
+ error (Error(FSComp.SR.fscStaticLinkingNoProfileMismatches(), rangeCmdArgs))
+ scopeRef
let rewriteAssemblyRefsToMatchLibraries = NormalizeAssemblyRefs tcImports
- Morphs.morphILTypeRefsInILModuleMemoized ilGlobals (Morphs.morphILScopeRefsInILTypeRef (rewriteExternalRefsToLocalRefs >> rewriteAssemblyRefsToMatchLibraries)) ilxMainModule
+ Morphs.morphILTypeRefsInILModuleMemoized ilGlobals (Morphs.morphILScopeRefsInILTypeRef (validateTargetPlatform >> rewriteExternalRefsToLocalRefs >> rewriteAssemblyRefsToMatchLibraries)) ilxMainModule
#if DEBUG
// Print it out if requested
@@ -1639,7 +1797,7 @@ module FileWriter =
try
ILBinaryWriter.WriteILBinary
outfile
- { mscorlib=ilGlobals.mscorlibScopeRef;
+ { ilg = ilGlobals
pdbfile=pdbfile;
emitTailcalls= tcConfig.emitTailcalls;
showTimes=tcConfig.showTimes;
@@ -1669,7 +1827,10 @@ module FileWriter =
with Failure msg ->
error(Error(FSComp.SR.fscProblemWritingBinary(outfile,msg), rangeCmdArgs))
with e ->
- errorRecoveryNoRange e;
+ errorRecoveryNoRange e
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig _errorLogger.ErrorNumbers _errorLogger.WarningNumbers
+#endif
exiter.Exit 1
let WriteStatsFile (tcConfig:TcConfig,outfile) =
@@ -1727,7 +1888,13 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig) tcGlobals topAttrs =
| None -> tcConfig.container
SigningInfo (delaysign,signer,container)
-
+
+/// Checks if specified file name is absolute path. If yes - returns the name as is, otherwise makes full path using tcConfig.implicitIncludeDir as base.
+let expandFileNameIfNeeded (tcConfig : TcConfig) name =
+ if FileSystem.IsPathRootedShim name then name
+ else
+ System.IO.Path.Combine(tcConfig.implicitIncludeDir, name)
+
//----------------------------------------------------------------------------
// main - split up to make sure that we can GC the
// dead data at the end of each phase. We explicitly communicate arguments
@@ -1737,7 +1904,7 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig) tcGlobals topAttrs =
[<NoEquality; NoComparison>]
type Args<'a> = Args of 'a
-let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) =
+let main0(argv,bannerAlreadyPrinted,exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DelayedDisposables) =
// See Bug 735819
let lcidFromCodePage =
@@ -1779,15 +1946,23 @@ let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) =
),
false, // optimizeForMemory - fsc.exe can use as much memory as it likes to try to compile as fast as possible
exiter,
- createErrorLogger
+ errorLoggerProvider,
+ disposables
+
)
+ tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger, exiter
+
+// TcGlobals * TcImports * TcImports * CcuThunk * TypedAssembly * TopAttribs * TcConfig * string * string * string* ErrorLogger* Exiter
+let main1(tcGlobals,tcImports : TcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig : TcConfig, outfile,pdbfile,assemblyName,errorLogger, exiter : Exiter) =
+
+
if tcConfig.typeCheckOnly then exiter.Exit 0
use unwindPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.CodeGen)
let signingInfo = ValidateKeySigningAttributes tcConfig tcGlobals topAttrs
- abortOnError(errorLogger,exiter)
+ abortOnError(errorLogger,tcConfig,exiter)
// Build an updated errorLogger that filters according to the scopedPragmas. Then install
// it as the updated global error logger and never remove it
@@ -1818,7 +1993,10 @@ let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) =
if tcConfig.xmlDocOutputFile.IsSome then
XmlDocWriter.computeXmlDocSigs (tcGlobals,generatedCcu)
ReportTime tcConfig ("Write XML docs");
- tcConfig.xmlDocOutputFile |> Option.iter (fun xmlFile -> XmlDocWriter.writeXmlDoc (assemblyName,generatedCcu,xmlFile))
+ tcConfig.xmlDocOutputFile |> Option.iter ( fun xmlFile ->
+ let xmlFile = expandFileNameIfNeeded tcConfig xmlFile
+ XmlDocWriter.writeXmlDoc (assemblyName,generatedCcu,xmlFile)
+ )
ReportTime tcConfig ("Write HTML docs");
end;
@@ -1843,7 +2021,7 @@ let main2(Args(tcConfig,tcImports,frameworkTcImports : TcImports,tcGlobals,error
#endif
let sigDataAttributes,sigDataResources =
- EncodeInterfaceData(tcConfig,tcGlobals,exportRemapping,generatedCcu,outfile,exiter)
+ EncodeInterfaceData(tcConfig,tcGlobals,exportRemapping,errorLogger,generatedCcu,outfile,exiter)
if !progress && tcConfig.optSettings.jitOptUser = Some false then
dprintf "Note, optimizations are off.\n";
@@ -1856,10 +2034,10 @@ let main2(Args(tcConfig,tcImports,frameworkTcImports : TcImports,tcGlobals,error
let metadataVersion =
match tcConfig.metadataVersion with
| Some(v) -> v
- | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.mscorlibAssemblyName) with | Some(ib) -> ib.RawMetadata.MetadataVersion | _ -> ""
+ | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some(ib) -> ib.RawMetadata.MetadataVersion | _ -> ""
let optimizedImpls,optimizationData,_ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedAssembly)
- abortOnError(errorLogger,exiter)
+ abortOnError(errorLogger,tcConfig,exiter)
ReportTime tcConfig ("Encoding OptData");
let generatedOptData = EncodeOptimizationData(tcGlobals,tcConfig,outfile,exportRemapping,(generatedCcu,optimizationData))
@@ -1930,7 +2108,7 @@ let main2b(Args(tcConfig:TcConfig,tcImports,tcGlobals,errorLogger,generatedCcu:C
if tcConfig.writeGeneratedILFiles then StaticLinker.PrintModule (outpath outfile "ilx.txt") ilxMainModule;
#endif
- abortOnError(errorLogger,exiter)
+ abortOnError(errorLogger,tcConfig,exiter)
Args (tcConfig,errorLogger,staticLinker,ilGlobals,outfile,pdbfile,ilxMainModule,signingInfo,exiter)
@@ -1943,7 +2121,7 @@ let main2c(Args(tcConfig,errorLogger,staticLinker,ilGlobals,outfile,pdbfile,ilxM
ReportTime tcConfig "ILX -> IL (Funcs)";
let ilxMainModule = EraseIlxFuncs.ConvModule ilGlobals ilxMainModule
- abortOnError(errorLogger,exiter)
+ abortOnError(errorLogger,tcConfig,exiter)
Args(tcConfig,errorLogger,staticLinker,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter)
@@ -1951,15 +2129,23 @@ let main3(Args(tcConfig,errorLogger:ErrorLogger,staticLinker,ilGlobals,ilxMainMo
let ilxMainModule =
try staticLinker (ilxMainModule,outfile)
- with e -> errorRecoveryNoRange e; exiter.Exit 1
- abortOnError(errorLogger,exiter)
+ with e ->
+ errorRecoveryNoRange e
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+#endif
+ exiter.Exit 1
+
+ abortOnError(errorLogger,tcConfig,exiter)
Args (tcConfig,errorLogger,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter)
-let main4(Args(tcConfig,errorLogger,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter)) =
+let main4(Args(tcConfig,errorLogger:ErrorLogger,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter)) =
ReportTime tcConfig "Write .NET Binary"
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Output)
- let pdbfile = pdbfile |> Option.map FileSystem.GetFullPathShim
+ let outfile = expandFileNameIfNeeded tcConfig outfile
+
+ let pdbfile = pdbfile |> Option.map ((expandFileNameIfNeeded tcConfig) >> FileSystem.GetFullPathShim)
match dynamicAssemblyCreator with
| None -> FileWriter.EmitIL (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo,exiter)
| Some da -> da (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo);
@@ -1967,28 +2153,81 @@ let main4(Args(tcConfig,errorLogger,ilGlobals,ilxMainModule,outfile,pdbfile,sign
ReportTime tcConfig "Write Stats File"
FileWriter.WriteStatsFile (tcConfig,outfile)
- abortOnError(errorLogger,exiter)
+ abortOnError(errorLogger,tcConfig,exiter)
#if SILVERLIGHT
#else
if tcConfig.showLoadedAssemblies then
for a in System.AppDomain.CurrentDomain.GetAssemblies() do
dprintfn "%s" a.FullName
+
+#if SQM_SUPPORT
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+#endif
#endif
+
ReportTime tcConfig "Exiting"
-let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) =
- // Don's note: "GC of intermediate data is really, really important here"
- main1 (argv,bannerAlreadyPrinted,exiter,createErrorLogger)
+let compile arg =
+ main1 arg
|> main2
|> main2b
|> main2c
|> main3
|> main4
+let typecheckAndCompile(argv,bannerAlreadyPrinted,exiter:Exiter, errorLoggerProvider) =
+ // Don's note: "GC of intermediate data is really, really important here"
+ use d = new DelayedDisposables()
+ main0(argv,bannerAlreadyPrinted,exiter, errorLoggerProvider, d)
+ |> compile
+
+let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter) =
+ typecheckAndCompile(argv, bannerAlreadyPrinted, exiter, DefaultLoggerProvider())
+
+type CompilationOutput =
+ {
+ Errors : seq<ErrorOrWarning>
+ Warnings : seq<ErrorOrWarning>
+ }
+
+type InProcCompiler() =
+ member this.Compile(argv) =
+
+ let errors = ResizeArray()
+ let warnings = ResizeArray()
+
+ let loggerProvider = {
+ new ErrorLoggerProvider() with
+ member log.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter) =
+ upcast {
+ new ErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter, "InProcCompilerErrorLoggerThatQuitsAfterMaxErrors") with
+ member this.HandleTooManyErrors(text) = warnings.Add(ErrorOrWarning.Short(false, text))
+ member this.HandleIssue(tcConfigBuilder, err, isWarning) =
+ let errs = CollectErrorOrWarning(tcConfigBuilder.implicitIncludeDir, tcConfigBuilder.showFullPaths, tcConfigBuilder.flatErrors, tcConfigBuilder.errorStyle, isWarning, err)
+ let container = if isWarning then warnings else errors
+ container.AddRange(errs)
+ }
+ }
+ let exitCode = ref 0
+ let exiter = {
+ new Exiter with
+ member this.Exit n = exitCode := n; raise StopProcessing
+ }
+ try
+ typecheckAndCompile(argv, false, exiter, loggerProvider)
+ with
+ | StopProcessing -> ()
+ | ReportedError _ | WrappedError(ReportedError _,_) ->
+ exitCode := 1
+ ()
+
+ let output = { Warnings = warnings; Errors = errors}
+ !exitCode = 0, output
+
/// Collect the output from the stdout and stderr streams, character by character,
/// recording the console color used along the way.
-type OutputCollector() =
+type private OutputCollector() =
let output = ResizeArray()
let outWriter isOut =
{ new TextWriter() with
@@ -2049,8 +2288,7 @@ module FSharpResidentCompiler =
let exitCode =
try
Environment.CurrentDirectory <- pwd
- let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter))
- mainCompile (argv, true, exiter,createErrorLogger);
+ mainCompile (argv, true, exiter);
if !progress then printfn "server: finished compilation request, argv = %A" argv
0
with e ->
@@ -2224,5 +2462,40 @@ module FSharpResidentCompiler =
| None ->
None
+let main (fscServerExe, argv) =
+ let inline hasArgument name args =
+ args |> Array.exists (fun x -> x = ("--" + name) || x = ("/" + name))
+ let inline stripArgument name args =
+ args |> Array.filter (fun x -> x <> ("--" + name) && x <> ("/" + name))
+
+ // Check for --pause as the very first step so that a compiler can be attached here.
+ if hasArgument "pause" argv then
+ System.Console.WriteLine("Press any key to continue...")
+ System.Console.ReadKey() |> ignore
+
+ if runningOnMono && hasArgument "resident" argv then
+ let argv = stripArgument "resident" argv
+
+ if not (hasArgument "nologo" argv) then
+ printfn "%s" (FSComp.SR.buildProductName(FSharpEnvironment.FSharpTeamVersionNumber))
+ printfn "%s" (FSComp.SR.optsCopyright())
+
+ let exitCodeOpt = FSharpResidentCompiler.FSharpCompilationServer.TryCompileUsingServer (fscServerExe, argv)
+ match exitCodeOpt with
+ | Some exitCode -> exitCode
+ | None ->
+ mainCompile (argv, true, QuitProcessExiter)
+ 0
+
+ elif runningOnMono && hasArgument "server" argv then
+ // Install the right exiter so we can catch "StopProcessing" without exiting the server
+ let exiter = { new Exiter with member x.Exit n = raise StopProcessing }
+ FSharpResidentCompiler.FSharpCompilationServer.RunServer(exiter)
+ 0
+
+ else
+ mainCompile (argv, false, QuitProcessExiter)
+ 0
+
#endif // SILVERLIGHT
#endif // NO_COMPILER_BACKEND
diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi
index e450e19..4a3b017 100755
--- a/src/fsharp/fsc.fsi
+++ b/src/fsharp/fsc.fsi
@@ -2,13 +2,37 @@ module internal Microsoft.FSharp.Compiler.Driver
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Build
+open Microsoft.FSharp.Compiler.Env
+open Microsoft.FSharp.Compiler.Tast
+open Microsoft.FSharp.Compiler.TypeChecker
/// the F# project system calls this to pop up type provider security dialog if needed
val internal runFromCommandLineToImportingAssemblies : (string -> unit) * string[] * string * string * Exiter -> unit
#if NO_COMPILER_BACKEND
#else
+
+[<Class>]
+type ErrorLoggerThatAccumulatesErrors =
+ inherit ErrorLogger
+ new : TcConfigBuilder -> ErrorLoggerThatAccumulatesErrors
+ new : TcConfig -> ErrorLoggerThatAccumulatesErrors
+ member GetMessages : unit -> (bool * string) list
+ member ProcessMessage : PhasedError * bool -> (bool * string) option
+
+
/// fsc.exe calls this
-val mainCompile : argv : string[] * bannerAlreadyPrinted : bool * exiter : Exiter * createErrorLogger:(TcConfigBuilder -> ErrorLogger) -> unit
+val compile : TcGlobals * TcImports * TcImports * CcuThunk * TypedAssembly * TopAttribs * TcConfig * string * string option * string* ErrorLogger* Exiter -> unit
+val mainCompile : argv : string[] * bannerAlreadyPrinted : bool * exiter : Exiter -> unit
+
+type CompilationOutput =
+ {
+ Errors : seq<ErrorOrWarning>
+ Warnings : seq<ErrorOrWarning>
+ }
+
+type InProcCompiler =
+ new : unit -> InProcCompiler
+ member Compile : args : string[] -> bool * CompilationOutput
-#endif
\ No newline at end of file
+#endif
diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs
index ef28efe..9744a51 100755
--- a/src/fsharp/fscmain.fs
+++ b/src/fsharp/fscmain.fs
@@ -14,7 +14,7 @@
module internal Microsoft.FSharp.Compiler.CommandLineMain
open Microsoft.FSharp.Compiler
-open Microsoft.FSharp.Compiler.AbstractIL.IL (* runningOnMono *)
+open Microsoft.FSharp.Compiler.AbstractIL.IL // runningOnMono
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Driver
open Internal.Utilities
@@ -25,54 +25,19 @@ open System.Runtime.CompilerServices
type TypeInThisAssembly() = member x.Dummy = 1
-module Driver =
- let main argv =
- // Check for --pause as the very first step so that a compiler can be attached here.
- if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then
- System.Console.WriteLine("Press any key to continue...")
- System.Console.ReadKey() |> ignore
- if argv |> Array.exists (fun x -> x = "/resident" || x = "--resident") then
- let argv = argv |> Array.filter (fun x -> x <> "/resident" && x <> "--resident")
-
- if not (argv |> Array.exists (fun x -> x = "/nologo" || x = "--nologo")) then
- printfn "%s" (FSComp.SR.buildProductName(FSharpEnvironment.DotNetBuildString))
- printfn "%s" (FSComp.SR.optsCopyright())
-
- let fscServerExe = typeof<TypeInThisAssembly>.Assembly.Location
- let exitCodeOpt = FSharpResidentCompiler.FSharpCompilationServer.TryCompileUsingServer(fscServerExe,argv)
- match exitCodeOpt with
- | Some exitCode -> exitCode
- | None ->
- let exiter = QuitProcessExiter
- let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter))
- mainCompile (argv, true, exiter, createErrorLogger)
- 0
-
- elif argv |> Array.exists (fun x -> x = "/server" || x = "--server") then
- // Install the right exiter so we can catch "StopProcessing" without exiting the server
- let exiter = { new Exiter with member x.Exit n = raise StopProcessing }
- FSharpResidentCompiler.FSharpCompilationServer.RunServer(exiter)
- 0
-
- else
- let exiter = QuitProcessExiter
- let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter))
- mainCompile (argv, false, QuitProcessExiter, createErrorLogger)
- 0
-
-
-
[<Dependency("FSharp.Compiler",LoadHint.Always)>]
do ()
[<EntryPoint>]
let main(argv) =
+ System.Runtime.GCSettings.LatencyMode <- System.Runtime.GCLatencyMode.Batch
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter)
if not runningOnMono then Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *)
try
- Driver.main(Array.append [| "fsc.exe" |] argv);
+ let fscServerExe = typeof<TypeInThisAssembly>.Assembly.Location
+ Driver.main(fscServerExe, Array.append [| "fsc.exe" |] argv);
with e ->
errorRecovery e Microsoft.FSharp.Compiler.Range.range0;
1
diff --git a/src/fsharp/fscopts.fs b/src/fsharp/fscopts.fs
index e55f777..96cfb14 100755
--- a/src/fsharp/fscopts.fs
+++ b/src/fsharp/fscopts.fs
@@ -395,6 +395,12 @@ let noFrameworkFlag isFsc tcConfigB =
Some (FSComp.SR.optsNoframework()))
let advancedFlagsFsi tcConfigB = advancedFlagsBoth tcConfigB @ [noFrameworkFlag false tcConfigB]
+let setTargetProfile tcConfigB v =
+ tcConfigB.primaryAssembly <-
+ match v with
+ | "mscorlib" -> PrimaryAssembly.Mscorlib
+ | "netcore" -> PrimaryAssembly.DotNetCore
+ | _ -> error(Error(FSComp.SR.optsInvalidTargetProfile(v), rangeCmdArgs))
let advancedFlagsFsc tcConfigB =
advancedFlagsBoth tcConfigB @
@@ -422,6 +428,8 @@ let advancedFlagsFsc tcConfigB =
yield CompilerOption("highentropyva", tagNone, OptionSwitch (useHighEntropyVASwitch tcConfigB), None, Some (FSComp.SR.optsUseHighEntropyVA()))
yield CompilerOption("subsystemversion", tagString, OptionString (subSystemVersionSwitch tcConfigB), None, Some (FSComp.SR.optsSubSystemVersion()))
+ yield CompilerOption("targetprofile", tagString, OptionString (setTargetProfile tcConfigB), None, Some(FSComp.SR.optsTargetProfile()))
+ yield CompilerOption("quotations-debug", tagNone, OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = On), None, Some(FSComp.SR.optsEmitDebugInfoInQuotations()))
]
// OptionBlock: Internal options (internal use only)
@@ -451,9 +459,10 @@ let vsSpecificFlags (tcConfigB: TcConfigBuilder) =
CompilerOption("validate-type-providers", tagNone, OptionUnit (fun () -> tcConfigB.validateTypeProviders <- true), None, None);
CompilerOption("LCID", tagInt, OptionInt (fun n -> tcConfigB.lcid <- Some(n)), None, None);
CompilerOption("flaterrors", tagNone, OptionUnit (fun () -> tcConfigB.flatErrors <- true), None, None);
+ CompilerOption("sqmsessionguid", tagNone, OptionString (fun s -> tcConfigB.sqmSessionGuid <- try System.Guid(s) |> Some with e -> None), None, None);
CompilerOption("maxerrors", tagInt, OptionInt (fun n -> tcConfigB.maxErrors <- n), None, None); ]
-
-
+
+
let internalFlags (tcConfigB:TcConfigBuilder) =
[
CompilerOption("use-incremental-build", tagNone, OptionUnit (fun () -> tcConfigB.useIncrementalBuilder <- true), None, None)
@@ -480,7 +489,7 @@ let internalFlags (tcConfigB:TcConfigBuilder) =
CompilerOption("simulateException", tagNone, OptionString (fun s -> tcConfigB.simulateException <- Some(s)), Some(InternalCommandLineOption("--simulateException", rangeCmdArgs)), Some "Simulate an exception from some part of the compiler");
CompilerOption("stackReserveSize", tagNone, OptionString (fun s -> tcConfigB.stackReserveSize <- Some(int32 s)), Some(InternalCommandLineOption("--stackReserveSize", rangeCmdArgs)), Some ("for an exe, set stack reserve size"));
CompilerOption("tlr", tagInt, OptionInt (setFlag (fun v -> tcConfigB.doTLR <- v)), Some(InternalCommandLineOption("--tlr", rangeCmdArgs)), None);
- CompilerOption("mscorlibAssemblyName", tagNone, OptionString (fun s -> tcConfigB.mscorlibAssemblyName <- s), None, None);
+ CompilerOption("mscorlibAssemblyName", tagNone, OptionString (fun s -> tcConfigB.primaryAssembly <- PrimaryAssembly.NamedMscorlib s ), None, None);
CompilerOption("finalSimplify", tagInt, OptionInt (setFlag (fun v -> tcConfigB.doFinalSimplify <- v)), Some(InternalCommandLineOption("--finalSimplify", rangeCmdArgs)), None);
#if TLR_LIFT
CompilerOption("tlrlift", tagNone, OptionInt (setFlag (fun v -> Tlr.liftTLR := v)), Some(InternalCommandLineOption("--tlrlift", rangeCmdArgs)), None);
@@ -913,7 +922,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM
if tcConfig.doFinalSimplify then
//ReportTime tcConfig ("Final simplify pass");
let optEnvFinalSimplify,implFile, _ = Opt.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,implFile)
- //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile;
+ //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile;
implFile,optEnvFinalSimplify
else
implFile,optEnvFinalSimplify
@@ -1009,6 +1018,7 @@ let DoWithErrorColor isWarn f =
ignoreFailureOnMono1_1_16 (fun () -> Console.ForegroundColor <- c)
#endif
+
-
+
\ No newline at end of file
diff --git a/src/fsharp/fsi/FSIstrings.txt b/src/fsharp/fsi/FSIstrings.txt
index 4989c47..27babdc 100755
--- a/src/fsharp/fsi/FSIstrings.txt
+++ b/src/fsharp/fsi/FSIstrings.txt
@@ -16,6 +16,7 @@ fsiExec,"Exit fsi after loading the files or running the .fsx script given on th
fsiGui,"Execute interactions on a Windows Forms event loop (on by default)"
fsiQuiet,"Suppress fsi writing to stdout"
fsiReadline,"Support TAB completion in console (on by default)"
+fsiEmitDebugInfoInQuotations,"Emit debug information in quotations"
fsiBanner3,"For help type #help;;"
fsiConsoleProblem,"A problem occurred starting the F# Interactive process. This may be due to a known problem with background process console support for Unicode-enabled applications on some Windows systems. Try selecting Tools->Options->F# Interactive for Visual Studio and enter '--fsi-server-no-unicode'."
2301,fsiInvalidAssembly,"'%s' is not a valid assembly name"
@@ -40,6 +41,7 @@ fsiExit,"\n- Exit...\n"
fsiAbortingMainThread,"- Aborting main thread..."
fsiCouldNotInstallCtrlCHandler,"Failed to install ctrl-c handler - Ctrl-C handling will not be available. Error was:\n\t%s"
fsiDidAHashr,"--> Referenced '%s'"
+fsiDidAHashrWithLockWarning,"--> Referenced '%s' (file may be locked by F# Interactive process)"
fsiDidAHashI,"--> Added '%s' to library include path"
fsiTurnedTimingOn,"--> Timing now on"
fsiTurnedTimingOff,"--> Timing now off"
diff --git a/src/fsharp/fsi/Fsi.fsproj b/src/fsharp/fsi/Fsi.fsproj
index 302c955..c907b74 100755
--- a/src/fsharp/fsi/Fsi.fsproj
+++ b/src/fsharp/fsi/Fsi.fsproj
@@ -1,14 +1,4 @@
<?xml version="1.0" encoding="utf-8"?>
-<!--
-# Copyright (c) 2002-2011 Microsoft Corporation.
-#
-#
-#
-#
-#
-#
-# You must not remove this notice, or any other, from this software.
--->
<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<FSharpSourcesRoot>..\..</FSharpSourcesRoot>
@@ -27,7 +17,7 @@
<AssemblyName>fsi</AssemblyName>
<BaseAddress>0x0A000000</BaseAddress>
<DefineConstants>EXTENSIONTYPING;COMPILER;$(DefineConstants)</DefineConstants>
- <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20' or '$(TargetFramework)'=='mono20'">v3.5</TargetFrameworkVersion>
+ <TargetFrameworkVersion Condition="'$(TargetFramework)'=='net20'">v3.5</TargetFrameworkVersion>
<AllowCrossTargeting>true</AllowCrossTargeting>
<OtherFlags>$(OtherFlags) --warnon:1182</OtherFlags>
</PropertyGroup>
diff --git a/src/fsharp/fsi/fsi.exe.config b/src/fsharp/fsi/fsi.exe.config
index 6653e4e..10ef015 100755
--- a/src/fsharp/fsi/fsi.exe.config
+++ b/src/fsharp/fsi/fsi.exe.config
@@ -10,10 +10,24 @@
culture="neutral"/>
<bindingRedirect
oldVersion="2.0.0.0"
- newVersion="4.3.0.0"/>
+ newVersion="4.3.1.0"/>
<bindingRedirect
oldVersion="4.0.0.0"
- newVersion="4.3.0.0"/>
+ newVersion="4.3.1.0"/>
+ <bindingRedirect
+ oldVersion="4.3.0.0"
+ newVersion="4.3.1.0"/>
+ <!-- Old style portable -->
+ <bindingRedirect
+ oldVersion="2.3.5.0"
+ newVersion="4.3.1.0"/>
+ <bindingRedirect
+ oldVersion="2.3.5.1"
+ newVersion="4.3.1.0"/>
+ <!-- .NETCore portable -->
+ <bindingRedirect
+ oldVersion="3.3.1.0"
+ newVersion="4.3.1.0"/>
</dependentAssembly>
</assemblyBinding>
</runtime>
diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs
index 32759f9..4533578 100755
--- a/src/fsharp/fsi/fsi.fs
+++ b/src/fsharp/fsi/fsi.fs
@@ -83,7 +83,21 @@ open System.Runtime.CompilerServices
[<Dependency("FSharp.Core",LoadHint.Always)>] do ()
#endif
+
module Utilities =
+ type IAnyToLayoutCall =
+ abstract AnyToLayout : FormatOptions * obj -> Internal.Utilities.StructuredFormat.Layout
+ abstract FsiAnyToLayout : FormatOptions * obj -> Internal.Utilities.StructuredFormat.Layout
+
+ type private AnyToLayoutSpecialization<'T>() =
+ interface IAnyToLayoutCall with
+ member this.AnyToLayout(options, o : obj) = Internal.Utilities.StructuredFormat.Display.any_to_layout options (Unchecked.unbox o : 'T)
+ member this.FsiAnyToLayout(options, o : obj) = Internal.Utilities.StructuredFormat.Display.fsi_any_to_layout options (Unchecked.unbox o : 'T)
+
+ let getAnyToLayoutCall ty =
+ let specialized = typedefof<AnyToLayoutSpecialization<_>>.MakeGenericType [| ty |]
+ Activator.CreateInstance(specialized) :?> IAnyToLayoutCall
+
let callStaticMethod (ty:Type) name args =
#if SILVERLIGHT
ty.InvokeMember(name, (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, null, Array.ofList args)
@@ -129,15 +143,12 @@ type FsiTimeReporter(outWriter: TextWriter) =
let total = ptime.TotalProcessorTime - startTotal
let spanGC = [ for i in 0 .. numGC-> System.GC.CollectionCount(i) - startGC.[i] ]
let elapsed = stopwatch.Elapsed
- fprintfn outWriter "%s" (FSIstrings.SR.fsiTimeInfoMainString((sprintf "%02d:%02d:%02d.%03d" elapsed.Hours elapsed.Minutes elapsed.Seconds elapsed.Milliseconds),(sprintf "%02d:%02d:%02d.%03d" total.Hours total.Minutes total.Seconds total.Milliseconds),(String.concat ", " (List.mapi (sprintf "%s%d: %d" (FSIstrings.SR.fsiTimeInfoGCGenerationLabelSomeShorthandForTheWordGeneration())) spanGC))))
+ fprintfn outWriter "%s" (FSIstrings.SR.fsiTimeInfoMainString((sprintf "%02d:%02d:%02d.%03d" (int elapsed.TotalHours) elapsed.Minutes elapsed.Seconds elapsed.Milliseconds),(sprintf "%02d:%02d:%02d.%03d" (int total.TotalHours) total.Minutes total.Seconds total.Milliseconds),(String.concat ", " (List.mapi (sprintf "%s%d: %d" (FSIstrings.SR.fsiTimeInfoGCGenerationLabelSomeShorthandForTheWordGeneration())) spanGC))))
res
member tr.TimeOpIf flag f = if flag then tr.TimeOp f else f ()
#endif
-//----------------------------------------------------------------------------
-// value printing
-//----------------------------------------------------------------------------
type FsiValuePrinterMode =
| PrintExpr
@@ -238,17 +249,14 @@ type FsiValuePrinter(ilGlobals, generateDebugInfo, resolvePath, outWriter) =
// This will be more significant when we print values other then 'it'
//
try
- let ass = typeof<Internal.Utilities.StructuredFormat.Layout>.Assembly
- let displayModule = ass.GetType("Internal.Utilities.StructuredFormat.Display")
+ let anyToLayoutCall = Utilities.getAnyToLayoutCall ty
match printMode with
| PrintDecl ->
// When printing rhs of fsi declarations, use "fsi_any_to_layout".
// This will suppress some less informative values, by returning an empty layout. [fix 4343].
- Internal.Utilities.StructuredFormat.Display.fsi_any_to_layout |> ignore; // if you adjust this then adjust the dynamic reference too
- Utilities.callGenericStaticMethod displayModule "fsi_any_to_layout" [ty] [box opts; box x] |> unbox<Internal.Utilities.StructuredFormat.Layout>
+ anyToLayoutCall.FsiAnyToLayout(opts, x)
| PrintExpr ->
- Internal.Utilities.StructuredFormat.Display.any_to_layout |> ignore; // if you adjust this then adjust the dynamic reference too
- Utilities.callGenericStaticMethod displayModule "any_to_layout" [ty] [box opts; box x] |> unbox<Internal.Utilities.StructuredFormat.Layout>
+ anyToLayoutCall.AnyToLayout(opts, x)
with
| :? ThreadAbortException -> Layout.wordL ""
| e ->
@@ -547,6 +555,7 @@ type FsiCommandLineOptions(argv: string[], tcConfigB, fsiConsoleOutput: FsiConso
(* Renamed --readline and --no-readline to --tabcompletion:+|- *)
CompilerOption("readline",tagNone, OptionSwitch (function flag -> enableConsoleKeyProcessing <- (flag = On)),None,
Some (FSIstrings.SR.fsiReadline()));
+ CompilerOption("quotations-debug", tagNone, OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = On), None, Some(FSIstrings.SR.fsiEmitDebugInfoInQuotations()))
]);
]
@@ -1172,7 +1181,7 @@ type FsiIntellisenseProvider(tcGlobals, tcImports: TcImports) =
// Note: for the accessor domain we should use (AccessRightsOfEnv tcState.TcEnvFromImpls)
let ad = Infos.AccessibleFromSomeFSharpCode
let nItems = Nameres.ResolvePartialLongIdent ncenv tcState.TcEnvFromImpls.NameEnv (ConstraintSolver.IsApplicableMethApprox tcGlobals amap rangeStdin) rangeStdin ad lid false
- let names = nItems |> List.map (Nameres.DisplayNameOfItem tcGlobals)
+ let names = nItems |> List.map (fun d -> d.DisplayName tcGlobals)
let names = names |> List.filter (fun (name:string) -> name.StartsWith(stem,StringComparison.Ordinal))
names
@@ -1472,7 +1481,7 @@ module MagicAssemblyResolution =
| Some(assembly) -> OkResult([],Choice2Of2 assembly)
| None ->
- // Try to find the reference without an extension
+ // As a last resort, try to find the reference without an extension
match tcImports.TryFindExistingFullyQualifiedPathFromAssemblyRef(ILAssemblyRef.Create(simpleAssemName,None,None,false,None,None)) with
| Some(resolvedPath) ->
OkResult([],Choice1Of2 resolvedPath)
@@ -1681,7 +1690,10 @@ type FsiInteractionProcessor(tcConfigB,
| IHash (ParsedHashDirective(("reference" | "r"),[path],m),_) ->
let resolutions,istate = fsiDynamicCompiler.EvalRequireReference istate m path
- resolutions |> List.iter (fun ar -> fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiDidAHashr(ar.resolvedPath)))
+ resolutions |> List.iter (fun ar ->
+ let format = if fsiOptions.IsInteractiveServer then FSIstrings.SR.fsiDidAHashrWithLockWarning(ar.resolvedPath) else FSIstrings.SR.fsiDidAHashr(ar.resolvedPath)
+ fsiConsoleOutput.uprintnfnn "%s" format
+ )
istate,Completed
| IHash (ParsedHashDirective("I",[path],m),_) ->
@@ -2400,12 +2412,66 @@ type internal FsiEvaluationSession (argv:string[], inReader:TextReader, outWrite
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Interactive)
- let threadException exn =
+ let threadException isFromThreadException exn =
fsi.EventLoop.Invoke (
fun () ->
fprintfn fsiConsoleOutput.Error "%s" (exn.ToString())
errorLogger.SetError()
- errorLogger.AbortOnError()
+ try
+ errorLogger.AbortOnError()
+ with StopProcessing ->
+ // BUG 664864: Watson Clr20r3 across buckets with: Application FSIAnyCPU.exe from Dev11 RTM; Exception AE251Y0L0P2WC0QSWDZ0E2IDRYQTDSVB; FSIANYCPU.NI.EXE!Microsoft.FSharp.Compiler.Interactive.Shell+threadException
+ // reason: some window that use System.Windows.Forms.DataVisualization types (possible FSCharts) was created in FSI.
+ // at some moment one chart has raised InvalidArgumentException from OnPaint, this exception was intercepted by the code in higher layer and
+ // passed to Application.OnThreadException. FSI has already attached its own ThreadException handler, inside it will log the original error
+ // and then raise StopProcessing exception to unwind the stack (and possibly shut down current Application) and get to DriveFsiEventLoop.
+ // DriveFsiEventLoop handles StopProcessing by suppressing it and restarting event loop from the beginning.
+ // This schema works almost always except when FSI is started as 64 bit process (FsiAnyCpu) on Windows 7.
+
+ // http://msdn.microsoft.com/en-us/library/windows/desktop/ms633573(v=vs.85).aspx
+ // Remarks:
+ // If your application runs on a 32-bit version of Windows operating system, uncaught exceptions from the callback
+ // will be passed onto higher-level exception handlers of your application when available.
+ // The system then calls the unhandled exception filter to handle the exception prior to terminating the process.
+ // If the PCA is enabled, it will offer to fix the problem the next time you run the application.
+ // However, if your application runs on a 64-bit version of Windows operating system or WOW64,
+ // you should be aware that a 64-bit operating system handles uncaught exceptions differently based on its 64-bit processor architecture,
+ // exception architecture, and calling convention.
+ // The following table summarizes all possible ways that a 64-bit Windows operating system or WOW64 handles uncaught exceptions.
+ // 1. The system suppresses any uncaught exceptions.
+ // 2. The system first terminates the process, and then the Program Compatibility Assistant (PCA) offers to fix it the next time
+ // you run the application. You can disable the PCA mitigation by adding a Compatibility section to the application manifest.
+ // 3. The system calls the exception filters but suppresses any uncaught exceptions when it leaves the callback scope,
+ // without invoking the associated handlers.
+ // Behavior type 2 only applies to the 64-bit version of the Windows 7 operating system.
+
+ // NOTE: tests on Win8 box showed that 64 bit version of the Windows 8 always apply type 2 behavior
+
+ // Effectively this means that when StopProcessing exception is raised from ThreadException callback - it won't be intercepted in DriveFsiEventLoop.
+ // Instead it will be interpreted as unhandled exception and crash the whole process.
+
+ // FIX: detect if current process in 64 bit running on Windows 7 or Windows 8 and if yes - swallow the StopProcessing and ScheduleRestart instead.
+ // Visible behavior should not be different, previosuly exception unwinds the stack and aborts currently running Application.
+ // After that it will be intercepted and suppressed in DriveFsiEventLoop.
+ // Now we explicitly shut down Application so after execution of callback will be completed the control flow
+ // will also go out of WinFormsEventLoop.Run and again get to DriveFsiEventLoop => restart the loop. I'd like the fix to be as conservative as possible
+ // so we use special case for problematic case instead of just always scheduling restart.
+
+ // http://msdn.microsoft.com/en-us/library/windows/desktop/ms724832(v=vs.85).aspx
+ let os = Environment.OSVersion
+ // Win7 6.1
+ let isWindows7 = os.Version.Major = 6 && os.Version.Minor = 1
+ // Win8 6.2
+ let isWindows8Plus = os.Version >= Version(6, 2, 0, 0)
+ if isFromThreadException && ((isWindows7 && Environment.Is64BitProcess) || (Environment.Is64BitOperatingSystem && isWindows8Plus))
+#if DEBUG
+ // for debug purposes
+ && Environment.GetEnvironmentVariable("FSI_SCHEDULE_RESTART_WITH_ERRORS") = null
+#endif
+ then
+ fsi.EventLoop.ScheduleRestart()
+ else
+ reraise()
)
if fsiOptions.Interact then
@@ -2423,7 +2489,7 @@ type internal FsiEvaluationSession (argv:string[], inReader:TextReader, outWrite
// Route background exceptions to the exception handlers
AppDomain.CurrentDomain.UnhandledException.Add (fun args ->
match args.ExceptionObject with
- | :? System.Exception as err -> threadException err
+ | :? System.Exception as err -> threadException false err
| _ -> ());
if fsiOptions.Gui then
@@ -2433,7 +2499,7 @@ type internal FsiEvaluationSession (argv:string[], inReader:TextReader, outWrite
()
// Route GUI application exceptions to the exception handlers
- Application.add_ThreadException(new ThreadExceptionEventHandler(fun _ args -> threadException args.Exception));
+ Application.add_ThreadException(new ThreadExceptionEventHandler(fun _ args -> threadException true args.Exception));
if not runningOnMono then
try
@@ -2458,9 +2524,35 @@ type internal FsiEvaluationSession (argv:string[], inReader:TextReader, outWrite
// to be explicitly kept alive.
GC.KeepAlive fsiInterruptController.EventHandlers
-#endif // SILVERLIGHT
-
+
+let MainMain (argv:string[]) =
+ ignore argv
+ let argv = System.Environment.GetCommandLineArgs()
+
+ // When VFSI is running, set the input/output encoding to UTF8.
+ // Otherwise, unicode gets lost during redirection.
+ // It is required only under Net4.5 or above (with unicode console feature).
+ if FSharpEnvironment.IsRunningOnNetFx45OrAbove &&
+ argv |> Array.exists (fun x -> x.Contains "fsi-server") then
+ Console.InputEncoding <- System.Text.Encoding.UTF8
+ Console.OutputEncoding <- System.Text.Encoding.UTF8
+
+#if DEBUG
+ if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then
+ Console.WriteLine("Press any key to continue...")
+ Console.ReadKey() |> ignore
+
+ try
+ let fsi = FsiEvaluationSession (argv, Console.In, Console.Out, Console.Error)
+ fsi.Run()
+ with e -> printf "Exception by fsi.exe:\n%+A\n" e
+#else
+ let fsi = FsiEvaluationSession (argv, Console.In, Console.Out, Console.Error)
+ fsi.Run()
+#endif
+ 0
+#endif // SILVERLIGHT
diff --git a/src/fsharp/fsi/fsiAnyCPU.exe.config b/src/fsharp/fsi/fsiAnyCPU.exe.config
index 6653e4e..10ef015 100755
--- a/src/fsharp/fsi/fsiAnyCPU.exe.config
+++ b/src/fsharp/fsi/fsiAnyCPU.exe.config
@@ -10,10 +10,24 @@
culture="neutral"/>
<bindingRedirect
oldVersion="2.0.0.0"
- newVersion="4.3.0.0"/>
+ newVersion="4.3.1.0"/>
<bindingRedirect
oldVersion="4.0.0.0"
- newVersion="4.3.0.0"/>
+ newVersion="4.3.1.0"/>
+ <bindingRedirect
+ oldVersion="4.3.0.0"
+ newVersion="4.3.1.0"/>
+ <!-- Old style portable -->
+ <bindingRedirect
+ oldVersion="2.3.5.0"
+ newVersion="4.3.1.0"/>
+ <bindingRedirect
+ oldVersion="2.3.5.1"
+ newVersion="4.3.1.0"/>
+ <!-- .NETCore portable -->
+ <bindingRedirect
+ oldVersion="3.3.1.0"
+ newVersion="4.3.1.0"/>
</dependentAssembly>
</assemblyBinding>
</runtime>
diff --git a/src/fsharp/fsi/fsimain.fs b/src/fsharp/fsi/fsimain.fs
index 010da78..7cf6034 100755
--- a/src/fsharp/fsi/fsimain.fs
+++ b/src/fsharp/fsi/fsimain.fs
@@ -28,33 +28,8 @@ do()
// Mark the main thread as STAThread since it is a GUI thread
[<EntryPoint>]
[<STAThread()>]
-let MainMain argv =
- ignore argv
- let argv = System.Environment.GetCommandLineArgs()
-
- // When VFSI is running, set the input/output encoding to UTF8.
- // Otherwise, unicode gets lost during redirection.
- // It is required only under Net4.5 or above (with unicode console feature).
- if FSharpEnvironment.IsRunningOnNetFx45OrAbove &&
- argv |> Array.exists (fun x -> x.Contains "fsi-server") then
- Console.InputEncoding <- System.Text.Encoding.UTF8
- Console.OutputEncoding <- System.Text.Encoding.UTF8
-
-#if DEBUG
- if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then
- Console.WriteLine("Press any key to continue...")
- Console.ReadKey() |> ignore
-
- try
- let fsi = FsiEvaluationSession (argv, Console.In, Console.Out, Console.Error)
- fsi.Run()
- with e -> printf "Exception by fsi.exe:\n%+A\n" e
-#else
- let fsi = FsiEvaluationSession (argv, Console.In, Console.Out, Console.Error)
- fsi.Run()
-#endif
-
- 0
+let FsiMain argv =
+ MainMain argv
#endif // SILVERLIGHT
diff --git a/src/fsharp/ilxgen.fs b/src/fsharp/ilxgen.fs
index ce6463b..3b380bc 100755
--- a/src/fsharp/ilxgen.fs
+++ b/src/fsharp/ilxgen.fs
@@ -111,7 +111,7 @@ let ChooseFreeVarNames takenNames ts =
let names = Zset.add tn names
names,tn
let names = Zset.empty String.order |> Zset.addList takenNames
- let _names,ts = List.fmap chooseName names tns
+ let _names,ts = List.foldMap chooseName names tns
ts
let ilxgenGlobalNng = NiceNameGenerator ()
@@ -1504,7 +1504,7 @@ let GenConstArray cenv (cgbuf:CodeGenBuffer) eenv ilElementType (data:'a[]) (wri
let ilFieldName = CompilerGeneratedName ("field" + string(newUnique()))
let fty = ILType.Value vtspec
let ilFieldDef = mkILStaticField (ilFieldName,fty, None, Some bytes, ILMemberAccess.Assembly)
- let ilFieldDef = { ilFieldDef with CustomAttrs = mkILCustomAttrs [ mkDebuggerBrowsableNeverAttribute cenv.g.ilg ] }
+ let ilFieldDef = { ilFieldDef with CustomAttrs = mkILCustomAttrs [ cenv.g.ilg.mkDebuggerBrowsableNeverAttribute() ] }
let fspec = mkILFieldSpecInTy (mkILTyForCompLoc eenv.cloc,ilFieldName, fty)
CountStaticFieldDef();
cgbuf.mgbuf.AddFieldDef(fspec.EnclosingTypeRef,ilFieldDef);
@@ -1718,12 +1718,22 @@ let rec GenExpr cenv (cgbuf:CodeGenBuffer) eenv sp expr sequel =
| NoSequencePointAtDoBinding -> SPAlways
| NoSequencePointAtInvisibleBinding -> sp
| NoSequencePointAtStickyBinding -> SPSuppress
-
+
// Generate the body
GenExpr cenv cgbuf eenv spBody body (EndLocalScope(sequel,endScope))
| Expr.Lambda _ | Expr.TyLambda _ ->
GenLambda cenv cgbuf eenv false None expr sequel
+ | Expr.App(Expr.Val(vref, _, m) as v, _, tyargs, [], _) when
+ List.forall (isMeasureTy cenv.g) tyargs &&
+ (
+ // inline only values that are stored in local variables
+ match StorageForValRef m vref eenv with
+ | ValStorage.Local _ -> true
+ | _ -> false
+ ) ->
+ // application of local type functions with type parameters = measure types and body = local value - inine the body
+ GenExpr cenv cgbuf eenv sp v sequel
| Expr.App(f,fty,tyargs,args,m) ->
GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel
| Expr.Val(v,_,m) ->
@@ -2528,17 +2538,17 @@ and GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel =
if emitReflectionCode && fsiScoRefOpt.IsSome then
// System.Reflection.MethodInfo
- let methodInfoTyRef = ILTypeRef.Create(cenv.g.ilg.mscorlibScopeRef,[],"System.Reflection.MethodInfo")
+ let methodInfoTyRef = ILTypeRef.Create(cenv.g.ilg.traits.SystemReflectionScopeRef.Value,[],"System.Reflection.MethodInfo")
let methodInfoTySpec = ILTypeSpec.Create(methodInfoTyRef,emptyILGenericArgs)
let methodInfoTy = mkILBoxedType methodInfoTySpec
// System.Reflection.MethodBase
- let methodBaseTyRef = ILTypeRef.Create(cenv.g.ilg.mscorlibScopeRef,[],"System.Reflection.MethodBase")
+ let methodBaseTyRef = ILTypeRef.Create(cenv.g.ilg.traits.SystemReflectionScopeRef.Value,[],"System.Reflection.MethodBase")
let methodBaseTySpec = ILTypeSpec.Create(methodBaseTyRef,emptyILGenericArgs)
let methodBaseTy = mkILBoxedType methodBaseTySpec
// System.RuntimeMethodHandle
- let runtimeMethodHandleTyRef = ILTypeRef.Create(cenv.g.ilg.mscorlibScopeRef,[],"System.RuntimeMethodHandle")
+ let runtimeMethodHandleTyRef = ILTypeRef.Create(cenv.g.ilg.traits.ScopeRef,[],"System.RuntimeMethodHandle")
let runtimeMethodHandleTySpec = ILTypeSpec.Create(runtimeMethodHandleTyRef,emptyILGenericArgs)
let runtimeMethodHandleTy = ILType.Value runtimeMethodHandleTySpec
@@ -2563,9 +2573,10 @@ and GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel =
let findMethodSpec = ILMethodSpec.Create(methodFinderTy,findMethodRef,emptyILGenericArgs)
// System.RuntimeMethodHandle::GetFunctionPointer
+ // Some framework profiles don't expose RuntimeMethodHandle::GetFunctionPointer. However this code seems to be used only from FSI and FSI always use desktop version of framework - should be OK
let getFunctionPointerRef = mkILMethRef(runtimeMethodHandleTyRef,ILCallingConv.Instance,"GetFunctionPointer",0,[],cenv.g.ilg.typ_IntPtr)
- let getFunctionPointerSpec = ILMethodSpec.Create(runtimeMethodHandleTy,getFunctionPointerRef,emptyILGenericArgs)
-
+ let getFunctionPointerSpec = ILMethodSpec.Create(runtimeMethodHandleTy,getFunctionPointerRef,emptyILGenericArgs)
+
let typeofGenericArgs = ilTyArgs |> List.collect (fun ilt -> [mkTypeOfExpr cenv m ilt])
let getNameExprs = mspec.FormalArgTypes |> ILList.toList |> List.map (fun t -> mkGetNameExpr cenv t m)
@@ -4180,7 +4191,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod((TSlotSig(_,delega
and GenStaticOptimization cenv cgbuf eenv (constraints,e2,e3,_m) sequel =
let e =
- if DecideStaticOptimizations cenv.g constraints = 1 then e2
+ if DecideStaticOptimizations cenv.g constraints = StaticOptimizationAnswer.Yes then e2
else e3
GenExpr cenv cgbuf eenv SPSuppress e sequel
@@ -4763,15 +4774,9 @@ and GenBindAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) =
CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (I_call (Normalcall, ilGetterMethSpec, None));
GenSetStorage m cgbuf storage
- | StaticField (fspec, _, hasLiteralAttr, ilTyForProperty, ilPropName, fty, ilGetterMethRef, ilSetterMethRef, optShadowLocal) ->
+ | StaticField (fspec, vref, hasLiteralAttr, ilTyForProperty, ilPropName, fty, ilGetterMethRef, ilSetterMethRef, optShadowLocal) ->
let mut = vspec.IsMutable
- match mut,hasLiteralAttr,rhsExpr with
- | _,false,_ -> ()
- | true,true,_ -> errorR(Error(FSComp.SR.ilValuesWithLiteralAttributeCannotBeMutable(),m))
- | _,true,Expr.Const _ -> ()
- | _,true,_ -> errorR(Error(FSComp.SR.ilValuesWithLiteralAttributeMustBeSimple(),m))
-
let canTarget(targets, goal : System.AttributeTargets) =
match targets with
| None -> true
@@ -4782,10 +4787,9 @@ and GenBindAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) =
let access = ComputeMemberAccess (not hasLiteralAttr || IsHiddenVal eenv.sigToImplRemapInfo vspec)
let ilFieldDef = mkILStaticField (fspec.Name, fty, None, None, access)
let ilFieldDef =
- match hasLiteralAttr,rhsExpr with
- | false,_ -> ilFieldDef
- | true,Expr.Const(konst,m,_) -> { ilFieldDef with IsLiteral=true; LiteralValue= Some(GenFieldInit m konst) }
- | true,_ -> ilFieldDef (* error given above *)
+ match vref.LiteralValue with
+ | Some konst -> { ilFieldDef with IsLiteral=true; LiteralValue= Some(GenFieldInit m konst) }
+ | None -> ilFieldDef
let ilFieldDef =
let isClassInitializer = (cgbuf.MethodName = ".cctor")
@@ -4804,10 +4808,10 @@ and GenBindAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) =
let ilFieldDef =
{ ilFieldDef with
- CustomAttrs = mkILCustomAttrs (ilAttribs @ [ mkDebuggerBrowsableNeverAttribute cenv.g.ilg ]) }
+ CustomAttrs = mkILCustomAttrs (ilAttribs @ [ cenv.g.ilg.mkDebuggerBrowsableNeverAttribute() ]) }
+
[ (fspec.EnclosingTypeRef, ilFieldDef) ]
-
let ilTypeRefForProperty = ilTyForProperty.TypeRef
for (tref,ilFieldDef) in ilFieldDefs do
@@ -5230,7 +5234,7 @@ and GenMethodForBinding
let secDecls = if securityAttributes.Length > 0 then (mkILSecurityDecls permissionSets) else (emptyILSecurityDecls)
// Do not push the attributes to the method for events and properties
- let ilAttrsCompilerGenerated = if v.IsCompilerGenerated then [ mkCompilerGeneratedAttribute cenv.g.ilg ] else []
+ let ilAttrsCompilerGenerated = if v.IsCompilerGenerated then [ cenv.g.ilg.mkCompilerGeneratedAttribute() ] else []
let ilAttrsThatGoOnPrimaryItem =
[ yield! GenAttrs cenv eenv attrs
@@ -5308,7 +5312,8 @@ and GenMethodForBinding
let flagFixups = ComputeFlagFixupsForMemberBinding cenv (v,memberInfo)
let mdef = mkILGenericVirtualMethod (v.CompiledName,ILMemberAccess.Public,ilMethTypars,ilParams,ilReturn,ilMethodBody)
- let mdef = List.fold (fun mdef f -> f mdef) mdef flagFixups
+ let mdef = List.fold (fun mdef f -> f mdef) mdef flagFixups
+
// fixup can potentially change name of reflected definition that was already recorded - patch it if necessary
cgbuf.mgbuf.ReplaceNameOfReflectedDefinition(v, mdef.Name)
mdef
@@ -5435,9 +5440,18 @@ and GenGetVal cenv cgbuf eenv (v:ValRef,m) sequel =
and GenBindRhs cenv cgbuf eenv sp (vspec:Val) e =
match e with
| Expr.TyLambda _ | Expr.Lambda _ ->
- let isLocalTypeFunc = IsNamedLocalTypeFuncVal cenv.g vspec e
- let selfv = if isLocalTypeFunc then None else Some (mkLocalValRef vspec)
- GenLambda cenv cgbuf eenv isLocalTypeFunc selfv e Continue
+ match e with
+ | Expr.TyLambda(_, tyargs, body, _, _) when
+ (
+ tyargs |> List.forall (fun tp -> tp.IsErased) &&
+ (match StorageForVal vspec.Range vspec eenv with Local _ -> true | _ -> false)
+ ) ->
+ // type lambda with erased type arguments that is stored as local variable (not method or property)- inline body
+ GenExpr cenv cgbuf eenv sp body Continue
+ | _ ->
+ let isLocalTypeFunc = IsNamedLocalTypeFuncVal cenv.g vspec e
+ let selfv = if isLocalTypeFunc then None else Some (mkLocalValRef vspec)
+ GenLambda cenv cgbuf eenv isLocalTypeFunc selfv e Continue
| _ ->
GenExpr cenv cgbuf eenv sp e Continue;
@@ -5704,14 +5718,14 @@ and GenAttribArg amap g eenv x (ilArgTy:ILType) =
let ilElemTy = GenType amap m g eenv.tyenv elemTy
ILAttribElem.Array (ilElemTy, List.map (fun arg -> GenAttribArg amap g eenv arg ilElemTy) args)
- // Detect 'typeof<ty>' calls
+ // Detect 'typeof<ty>' calls
| TypeOfExpr g ty, _ ->
ILAttribElem.Type (Some (GenType amap x.Range g eenv.tyenv ty))
// Detect 'typedefof<ty>' calls
| TypeDefOfExpr g ty, _ ->
ILAttribElem.TypeRef (Some (GenType amap x.Range g eenv.tyenv ty).TypeRef)
-
+
// Ignore upcasts
| Expr.Op(TOp.Coerce,_,[arg2],_),_ ->
GenAttribArg amap g eenv arg2 ilArgTy
@@ -6240,7 +6254,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
| Some memberInfo ->
match name, memberInfo.MemberFlags.MemberKind with
| ("Item" | "op_IndexedLookup"), (MemberKind.PropertyGet | MemberKind.PropertySet) when nonNil (ArgInfosOfPropertyVal cenv.g vref.Deref) ->
- Some( mkILCustomAttribute cenv.g.ilg (mkILTyRef (cenv.g.ilg.mscorlibScopeRef,"System.Reflection.DefaultMemberAttribute"),[cenv.g.ilg.typ_String],[ILAttribElem.String(Some(name))],[]) )
+ Some( mkILCustomAttribute cenv.g.ilg (mkILTyRef (cenv.g.ilg.traits.ScopeRef,"System.Reflection.DefaultMemberAttribute"),[cenv.g.ilg.typ_String],[ILAttribElem.String(Some(name))],[]) )
| _ -> None)
|> Option.toList
@@ -6259,7 +6273,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
let ilDebugDisplayAttributes =
[ yield! GenAttrs cenv eenv debugDisplayAttrs
if generateDebugDisplayAttribute then
- yield mkDebuggerDisplayAttribute cenv.g.ilg ("{" + debugDisplayMethodName + "(),nq}") ]
+ yield cenv.g.ilg.mkDebuggerDisplayAttribute ("{" + debugDisplayMethodName + "(),nq}") ]
let CustomAttrs =
@@ -6336,14 +6350,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
yield! fspec.FieldAttribs ]
- let ilNotSerialized = HasFSharpAttribute cenv.g cenv.g.attrib_NonSerializedAttribute attribs
+ let ilNotSerialized = HasFSharpAttributeOpt cenv.g cenv.g.attrib_NonSerializedAttribute attribs
let fattribs =
attribs
// Do not generate FieldOffset as a true CLI custom attribute, since it is implied by other corresponding CLI metadata
|> List.filter (IsMatchingFSharpAttribute cenv.g cenv.g.attrib_FieldOffsetAttribute >> not)
// Do not generate NonSerialized as a true CLI custom attribute, since it is implied by other corresponding CLI metadata
- |> List.filter (IsMatchingFSharpAttribute cenv.g cenv.g.attrib_NonSerializedAttribute >> not)
+ |> List.filter (IsMatchingFSharpAttributeOpt cenv.g cenv.g.attrib_NonSerializedAttribute >> not)
let ilFieldMarshal, fattribs = GenMarshal cenv fattribs
@@ -6353,7 +6367,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
let extraAttribs =
match tyconRepr with
- | TRecdRepr _ when not useGenuineField -> [ mkDebuggerBrowsableNeverAttribute cenv.g.ilg ] // hide fields in records in debug display
+ | TRecdRepr _ when not useGenuineField -> [ cenv.g.ilg.mkDebuggerBrowsableNeverAttribute() ] // hide fields in records in debug display
| _ -> [] // don't hide fields in classes in debug display
yield
@@ -6744,43 +6758,52 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) =
else
[]
-
- let ilCtorDefForSerialziation =
- mkILCtor(ILMemberAccess.Family,
- [mkILParamNamed("info",cenv.g.ilg.typ_SerializationInfo);mkILParamNamed("context",cenv.g.ilg.typ_StreamingContext)],
- mkMethodBody
- (false,emptyILLocals,8,
- nonBranchingInstrsToCode
- [ mkLdarg0;
- mkLdarg 1us;
- mkLdarg 2us;
- mkNormalCall (mkILCtorMethSpecForTy (cenv.g.ilg.typ_Exception,[cenv.g.ilg.typ_SerializationInfo;cenv.g.ilg.typ_StreamingContext])) ]
- ,None))
+
+ let serializationRelatedMembers =
+ // do not emit serialization related members if target framework lacks SerializableAttribute or SerializationInfo
+ if not (cenv.opts.netFxHasSerializableAttribute && cenv.g.ilg.typ_SerializationInfo.IsSome) then []
+ else
+ let serializationInfoType = cenv.g.ilg.typ_SerializationInfo.Value
+ let ilCtorDefForSerialziation =
+ mkILCtor(ILMemberAccess.Family,
+ [mkILParamNamed("info", serializationInfoType);mkILParamNamed("context",cenv.g.ilg.typ_StreamingContext)],
+ mkMethodBody
+ (false,emptyILLocals,8,
+ nonBranchingInstrsToCode
+ [ mkLdarg0;
+ mkLdarg 1us;
+ mkLdarg 2us;
+ mkNormalCall (mkILCtorMethSpecForTy (cenv.g.ilg.typ_Exception,[serializationInfoType; cenv.g.ilg.typ_StreamingContext])) ]
+ ,None))
-
- let getObjectDataMethodForSerialization =
+#if BE_SECURITY_TRANSPARENT
+ [ilCtorDefForSerialziation]
+#else
+ let getObjectDataMethodForSerialization =
- let ilMethodDef =
- mkILNonGenericVirtualMethod
- ("GetObjectData",ILMemberAccess.Public,
- [mkILParamNamed ("info",cenv.g.ilg.typ_SerializationInfo);mkILParamNamed("context",cenv.g.ilg.typ_StreamingContext)],
- mkILReturn ILType.Void,
- (let code =
- nonBranchingInstrsToCode
- [ mkLdarg0;
- mkLdarg 1us;
- mkLdarg 2us;
- mkNormalCall (mkILNonGenericInstanceMethSpecInTy (cenv.g.ilg.typ_Exception, "GetObjectData", [cenv.g.ilg.typ_SerializationInfo;cenv.g.ilg.typ_StreamingContext], ILType.Void))
- ]
- mkMethodBody(true,emptyILLocals,8,code,None)))
- // Here we must encode: [SecurityPermission(SecurityAction.Demand, SerializationFormatter = true)]
- // In ILDASM this is: .permissionset demand = {[mscorlib]System.Security.Permissions.SecurityPermissionAttribute = {property bool 'SerializationFormatter' = bool(true)}}
- { ilMethodDef with
- SecurityDecls=mkILSecurityDecls [ IL.mkPermissionSet cenv.g.ilg (ILSecurityAction.Demand,[(cenv.g.ilg.tref_SecurityPermissionAttribute,[("SerializationFormatter",cenv.g.ilg.typ_Bool, ILAttribElem.Bool(true))])])];
- HasSecurity=true }
-
-
-
+ let ilMethodDef =
+ mkILNonGenericVirtualMethod
+ ("GetObjectData",ILMemberAccess.Public,
+ [mkILParamNamed ("info", serializationInfoType);mkILParamNamed("context",cenv.g.ilg.typ_StreamingContext)],
+ mkILReturn ILType.Void,
+ (let code =
+ nonBranchingInstrsToCode
+ [ mkLdarg0;
+ mkLdarg 1us;
+ mkLdarg 2us;
+ mkNormalCall (mkILNonGenericInstanceMethSpecInTy (cenv.g.ilg.typ_Exception, "GetObjectData", [serializationInfoType; cenv.g.ilg.typ_StreamingContext], ILType.Void))
+ ]
+ mkMethodBody(true,emptyILLocals,8,code,None)))
+ // Here we must encode: [SecurityPermission(SecurityAction.Demand, SerializationFormatter = true)]
+ // In ILDASM this is: .permissionset demand = {[mscorlib]System.Security.Permissions.SecurityPermissionAttribute = {property bool 'SerializationFormatter' = bool(true)}}
+ match cenv.g.ilg.tref_SecurityPermissionAttribute with
+ | None -> ilMethodDef
+ | Some securityPermissionAttributeType ->
+ { ilMethodDef with
+ SecurityDecls=mkILSecurityDecls [ IL.mkPermissionSet cenv.g.ilg (ILSecurityAction.Demand,[(securityPermissionAttributeType, [("SerializationFormatter",cenv.g.ilg.typ_Bool, ILAttribElem.Bool(true))])])];
+ HasSecurity=true }
+ [ilCtorDefForSerialziation; getObjectDataMethodForSerialization]
+#endif
let ilTypeName = tref.Name
let ilMethodDefsForComparison =
@@ -6791,20 +6814,10 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) =
let interfaces = exnc.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv.amap m cenv.g eenv.tyenv)
let tdef =
- let serCtors =
- if cenv.opts.netFxHasSerializableAttribute then
-#if BE_SECURITY_TRANSPARENT
- ignore(getObjectDataMethodForSerialization)
- [ ilCtorDefForSerialziation ]
-#else
- [ getObjectDataMethodForSerialization; ilCtorDefForSerialziation ]
-#endif
- else
- []
mkILGenericClass
(ilTypeName,access,[],cenv.g.ilg.typ_Exception,
interfaces,
- mkILMethods ([ilCtorDef] @ ilMethodDefsForComparison @ ilCtorDefNoArgs @ serCtors @ ilMethodDefsForProperties),
+ mkILMethods ([ilCtorDef] @ ilMethodDefsForComparison @ ilCtorDefNoArgs @ serializationRelatedMembers @ ilMethodDefsForProperties),
mkILFields ilFieldDefs,
emptyILTypeDefs,
mkILProperties ilPropertyDefs,
@@ -6827,12 +6840,12 @@ let CodegenAssembly cenv eenv mgbuf fileImpls =
// structures representing the contents of the module.
//-------------------------------------------------------------------------
-let GetEmptyIlxGenEnv ccu =
+let GetEmptyIlxGenEnv (ilg : ILGlobals) ccu =
let thisCompLoc = CompLocForCcu ccu
{ tyenv=TypeReprEnv.Empty;
cloc = thisCompLoc;
valsInScope=ValMap<_>.Empty;
- someTypeInThisAssembly=ecmaILGlobals.typ_Object; (* dummy value *)
+ someTypeInThisAssembly=ilg.typ_Object; (* dummy value *)
isFinalFile = false;
letBoundVars=[];
liveLocals=IntMap.empty();
@@ -7027,7 +7040,7 @@ let LookupGeneratedInfo (ctxt: ExecutionContext) (g:TcGlobals) eenv (v:Val) =
type IlxAssemblyGenerator(amap: Import.ImportMap, tcGlobals: Env.TcGlobals, tcVal : ConstraintSolver.TcValF, ccu: Tast.CcuThunk) =
// The incremental state held by the ILX code generator
- let mutable ilxGenEnv = GetEmptyIlxGenEnv ccu
+ let mutable ilxGenEnv = GetEmptyIlxGenEnv tcGlobals.ilg ccu
let intraAssemblyInfo = { StaticFieldInfo = new Dictionary<_,_>(HashIdentity.Structural) }
let casApplied = new Dictionary<Stamp,bool>()
diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs
index f3c3deb..331bb6a 100755
--- a/src/fsharp/import.fs
+++ b/src/fsharp/import.fs
@@ -464,22 +464,21 @@ let ImportILAssemblyTypeDefs (amap, m, auxModLoader, aref, mainmod:ILModuleDef)
let ImportILAssemblyTypeForwarders (amap, m, exportedTypes:ILExportedTypesAndForwarders) =
// Note 'td' may be in another module or another assembly!
// Note: it is very important that we call auxModLoader lazily
- lazy
- ([ //printfn "reading forwarders..."
- for exportedType in exportedTypes.AsList do
- let ns,n = splitILTypeName exportedType.Name
- //printfn "found forwarder for %s..." n
- let tcref = ImportILTypeRefUncached (amap()) m (ILTypeRef.Create(exportedType.ScopeRef,[],exportedType.Name))
- yield (Array.ofList ns,n),tcref
- let rec nested (nets:ILNestedExportedTypes) enc =
- [ for net in nets.AsList do
+ [ //printfn "reading forwarders..."
+ for exportedType in exportedTypes.AsList do
+ let ns,n = splitILTypeName exportedType.Name
+ //printfn "found forwarder for %s..." n
+ let tcref = lazy ImportILTypeRefUncached (amap()) m (ILTypeRef.Create(exportedType.ScopeRef,[],exportedType.Name))
+ yield (Array.ofList ns,n),tcref
+ let rec nested (nets:ILNestedExportedTypes) enc =
+ [ for net in nets.AsList do
- //printfn "found nested forwarder for %s..." net.Name
- let tcref = ImportILTypeRefUncached (amap()) m (ILTypeRef.Create (exportedType.ScopeRef,enc,net.Name))
- yield (Array.ofList enc,exportedType.Name),tcref
- yield! nested net.Nested (enc @ [ net.Name ]) ]
- yield! nested exportedType.Nested (ns@[n]) ]
- |> Map.ofList)
+ //printfn "found nested forwarder for %s..." net.Name
+ let tcref = lazy ImportILTypeRefUncached (amap()) m (ILTypeRef.Create (exportedType.ScopeRef,enc,net.Name))
+ yield (Array.ofList enc,exportedType.Name),tcref
+ yield! nested net.Nested (enc @ [ net.Name ]) ]
+ yield! nested exportedType.Nested (ns@[n])
+ ] |> Map.ofList
let ImportILAssembly(amap:(unit -> ImportMap),m,auxModuleLoader,sref,sourceDir,filename,ilModule:ILModuleDef,invalidateCcu:IEvent<string>) =
@@ -507,7 +506,7 @@ let ImportILAssembly(amap:(unit -> ImportMap),m,auxModuleLoader,sref,sourceDir,f
MemberSignatureEquality= (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (amap()).g ty1 ty2)
TypeForwarders =
(match ilModule.Manifest with
- | None -> lazy Map.empty
+ | None -> Map.empty
| Some manifest -> ImportILAssemblyTypeForwarders(amap,m,manifest.ExportedTypes)) }
CcuThunk.Create(nm,ccuData)
diff --git a/src/fsharp/import.fsi b/src/fsharp/import.fsi
index 40d4c41..204eaf7 100755
--- a/src/fsharp/import.fsi
+++ b/src/fsharp/import.fsi
@@ -56,4 +56,4 @@ val internal ImportProvidedMethodBaseAsILMethodRef : ImportMap -> range -> Taint
#endif
val internal ImportILGenericParameters : (unit -> ImportMap) -> range -> ILScopeRef -> TType list -> ILGenericParameterDef list -> Typar list
val internal ImportILAssembly : (unit -> ImportMap) * range * (ILScopeRef -> ILModuleDef) * ILScopeRef * sourceDir:string * filename: string option * ILModuleDef * IEvent<string> -> CcuThunk
-val internal ImportILAssemblyTypeForwarders : (unit -> ImportMap) * range * ILExportedTypesAndForwarders -> Lazy<Map<(string array * string), EntityRef>>
+val internal ImportILAssemblyTypeForwarders : (unit -> ImportMap) * range * ILExportedTypesAndForwarders -> Map<(string array * string), Lazy<EntityRef>>
diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs
index 3e58111..b8465ac 100755
--- a/src/fsharp/infos.fs
+++ b/src/fsharp/infos.fs
@@ -63,7 +63,7 @@ let GetSuperTypeOfType g amap m typ =
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
let superOpt = st.PApplyOption((fun st -> match st.BaseType with null -> None | t -> Some t),m)
match superOpt with
@@ -108,12 +108,12 @@ let rec GetImmediateInterfacesOfType g amap m typ =
not (tyconRefEq g itcref g.system_GenericIEquatable_tcref) then
yield ity
| _ -> ()
- yield mkAppTy g.system_GenericIComparable_tcref [typ];
+ yield mkAppTy g.system_GenericIComparable_tcref [typ]
yield mkAppTy g.system_GenericIEquatable_tcref [typ]]
else
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
[ for ity in info.ProvidedType.PApplyArray((fun st -> st.GetInterfaces()), "GetInterfaces", m) do
yield Import.ImportProvidedType amap m ity ]
#endif
@@ -314,90 +314,125 @@ let FixupNewTypars m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig
let n1 = tinst.Length
let n2 = tpsorig.Length
let n3 = tps.Length
- if n0 <> n1 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n0,n1)),m));
- if n2 <> n3 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n2,n3)),m));
+ if n0 <> n1 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n0,n1)),m))
+ if n2 <> n3 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n2,n3)),m))
// The real code..
let renaming,tptys = mkTyparToTyparRenaming tpsorig tps
let tprefInst = mkTyparInst formalEnclosingTypars tinst @ renaming
- (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints m tprefInst tporig)) ;
+ (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints m tprefInst tporig))
renaming,tptys
//-------------------------------------------------------------------------
// Predicates and properties on values and members
-/// Check if an F#-declared member value is a virtual method
-let MemberRefIsVirtual (vref:ValRef) =
- let flags = vref.MemberInfo.Value.MemberFlags
- flags.IsDispatchSlot || flags.IsOverrideOrExplicitImpl
-
-/// Check if an F#-declared member value is an 'override' or explicit member implementation
-// REVIEW: We should not need the notion of "DefiniteFSharpOverride" at all
-// REVIEW: MemberRefIsVirtual (vref:ValRef) = IsDispatchSlot || IsOverrideOrExplicitImpl.
-// So not IsDispatchSlot implies IsOverrideOrExplicitImpl
-// Q: why is this not "flags.IsOverrideOrExplicitImpl"?
-// Q: could an override (with nonNil membInfo.ImplementedSlotSigs) ever have flags.IsOverrideOrExplicitImpl = false?
-let private MemberRefIsDefiniteFSharpOverride (vref:ValRef) =
- let membInfo = vref.MemberInfo.Value
- let flags = membInfo.MemberFlags
- not flags.IsDispatchSlot && (flags.IsOverrideOrExplicitImpl || nonNil membInfo.ImplementedSlotSigs)
-
-/// Check if an F#-declared member value is a dispatch slot
-let MemberRefIsDispatchSlot (vref:ValRef) =
- let membInfo = vref.MemberInfo.Value
- membInfo.MemberFlags.IsDispatchSlot
type ValRef with
/// Indicates if an F#-declared function or member value is a CLIEvent property compiled as a .NET event
member x.IsFSharpEventProperty g =
x.IsMember && CompileAsEvent g x.Attribs && not x.IsExtensionMember
+ /// Check if an F#-declared member value is a virtual method
+ member vref.IsVirtualMember =
+ let flags = vref.MemberInfo.Value.MemberFlags
+ flags.IsDispatchSlot || flags.IsOverrideOrExplicitImpl
+
+ /// Check if an F#-declared member value is a dispatch slot
+ member vref.IsDispatchSlotMember =
+ let membInfo = vref.MemberInfo.Value
+ membInfo.MemberFlags.IsDispatchSlot
+
+ /// Check if an F#-declared member value is an 'override' or explicit member implementation
+ member vref.IsDefiniteFSharpOverrideMember =
+ let membInfo = vref.MemberInfo.Value
+ let flags = membInfo.MemberFlags
+ not flags.IsDispatchSlot && (flags.IsOverrideOrExplicitImpl || nonNil membInfo.ImplementedSlotSigs)
+
//-------------------------------------------------------------------------
-// ILTypeInfo
+// Helper methods associated with using TAST metadata (F# members, values etc.)
+// as backing data for MethInfo, PropInfo etc.
-/// Describes an F# use of an IL type, including the type instantiation associated with the type at a particular usage point.
-[<NoComparison; NoEquality>]
-type ILTypeInfo =
- /// ILTypeInfo (tyconRef, ilTypeRef, typeArgs, ilTypeDef).
- | ILTypeInfo of TyconRef * ILTypeRef * TypeInst * ILTypeDef
- member x.TyconRef = let (ILTypeInfo(tcref,_,_,_)) = x in tcref
- member x.ILTypeRef = let (ILTypeInfo(_,tref,_,_)) = x in tref
- member x.TypeInst = let (ILTypeInfo(_,_,tinst,_)) = x in tinst
- member x.RawMetadata = let (ILTypeInfo(_,_,_,tdef)) = x in tdef
- member x.ToType = TType_app(x.TyconRef,x.TypeInst)
- member x.ILScopeRef = x.ILTypeRef.Scope
- member x.Name = x.ILTypeRef.Name
- member x.IsValueType = x.RawMetadata.IsStructOrEnum
- member x.Instantiate inst =
- let (ILTypeInfo(tcref,tref,tinst,tdef)) = x
- ILTypeInfo(tcref,tref,instTypes inst tinst,tdef)
+#if EXTENSIONTYPING
+/// Get the return type of a provided method, where 'void' is returned as 'None'
+let GetCompiledReturnTyOfProvidedMethodInfo amap m (mi:Tainted<ProvidedMethodBase>) =
+ let returnType =
+ if mi.PUntaint((fun mi -> mi.IsConstructor),m) then
+ mi.PApply((fun mi -> mi.DeclaringType),m)
+ else mi.Coerce<ProvidedMethodInfo>(m).PApply((fun mi -> mi.ReturnType),m)
+ let typ = Import.ImportProvidedType amap m returnType
+ if isVoidTy amap.g typ then None else Some typ
+#endif
- member x.FormalTypars m = x.TyconRef.Typars m
+/// The slotsig returned by methInfo.GetSlotSig is in terms of the type parameters on the parent type of the overriding method.
+/// Reverse-map the slotsig so it is in terms of the type parameters for the overriding method
+let ReparentSlotSigToUseMethodTypars g m ovByMethValRef slotsig =
+ match PartitionValRefTypars g ovByMethValRef with
+ | Some(_,enclosingTypars,_,_,_) ->
+ let parentToMemberInst,_ = mkTyparToTyparRenaming (ovByMethValRef.MemberApparentParent.Typars(m)) enclosingTypars
+ let res = instSlotSig parentToMemberInst slotsig
+ res
+ | None ->
+ // Note: it appears PartitionValRefTypars should never return 'None'
+ slotsig
- static member FromType g ty =
- if isILAppTy g ty then
- let tcref,tinst = destAppTy g ty
- let scoref,enc,tdef = tcref.ILTyconInfo
- let tref = mkRefForNestedILTypeDef scoref (enc,tdef)
- ILTypeInfo(tcref,tref,tinst,tdef)
- else
- failwith "ILTypeInfo.FromType"
-//-------------------------------------------------------------------------
-// ParamNameAndType, ParamData
+/// Construct the data representing a parameter in the signature of an abstract method slot
+let MakeSlotParam (ty,argInfo:ArgReprInfo) = TSlotParam(Option.map textOfId argInfo.Name, ty, false,false,false,argInfo.Attribs)
-[<NoComparison; NoEquality>]
-type ParamNameAndType = ParamNameAndType of string option * TType
+/// Construct the data representing the signature of an abstract method slot
+let MakeSlotSig (nm,typ,ctps,mtps,paraml,retTy) = copySlotSig (TSlotSig(nm,typ,ctps,mtps,paraml,retTy))
+
+
+/// Split the type of an F# member value into
+/// - the type parameters associated with method but matching those of the enclosing type
+/// - the type parameters associated with a generic method
+/// - the return type of the method
+/// - the actual type arguments of the enclosing type.
+let private AnalyzeTypeOfMemberVal isCSharpExt g (typ,vref:ValRef) =
+ let memberAllTypars,_,retTy,_ = GetTypeOfMemberInMemberForm g vref
+ if isCSharpExt || vref.IsExtensionMember then
+ [],memberAllTypars,retTy,[]
+ else
+ let parentTyArgs = argsOfAppTy g typ
+ let memberParentTypars,memberMethodTypars = List.chop parentTyArgs.Length memberAllTypars
+ memberParentTypars,memberMethodTypars,retTy,parentTyArgs
+
+/// Get the object type for a member value which is an extension method (C#-style or F#-style)
+let private GetObjTypeOfInstanceExtensionMethod g (vref:ValRef) =
+ let _,curriedArgInfos,_,_ = GetTopValTypeInCompiledForm g vref.ValReprInfo.Value vref.Type vref.Range
+ curriedArgInfos.Head.Head |> fst
+
+/// Get the object type for a member value which is a C#-style extension method
+let private GetArgInfosOfMember isCSharpExt g (vref:ValRef) =
+ if isCSharpExt then
+ let _,curriedArgInfos,_,_ = GetTopValTypeInCompiledForm g vref.ValReprInfo.Value vref.Type vref.Range
+ [ curriedArgInfos.Head.Tail ]
+ else
+ ArgInfosOfMember g vref
+
+/// Combine the type instantiation and generic method instantiation
+let private CombineMethInsts ttps mtps tinst minst = (mkTyparInst ttps tinst @ mkTyparInst mtps minst)
-let ParamNameAndTypeOfArgInfo (ty,argInfo : ArgReprInfo) = ParamNameAndType(Option.map textOfId argInfo.Name, ty)
+/// Work out the instantiation relevant to interpret the backing metadata for a member.
+///
+/// The 'minst' is the instantiation of any generic method type parameters (this instantiation is
+/// not included in the MethInfo objects, but carreid separately).
+let private GetInstantiationForMemberVal g isCSharpExt (typ,vref,minst) =
+ let memberParentTypars,memberMethodTypars,_retTy,parentTyArgs = AnalyzeTypeOfMemberVal isCSharpExt g (typ,vref)
+ CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs minst
-let ParamNameAndTypesOfMember g vref = ArgInfosOfMember g vref |> List.mapSquared ParamNameAndTypeOfArgInfo
+let private GetInstantiationForPropertyVal g (typ,vref) =
+ let memberParentTypars,memberMethodTypars,_retTy,parentTyArgs = AnalyzeTypeOfMemberVal false g (typ,vref)
+ CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs (generalizeTypars memberMethodTypars)
-let InstParamNameAndType inst (ParamNameAndType(nm,ty)) = ParamNameAndType(nm, instType inst ty)
+/// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced
+/// later through 'open' get priority in overload resolution.
+type ExtensionMethodPriority = uint64
-let InstParamNameAndTypes inst paramTypes = paramTypes |> List.mapSquared (InstParamNameAndType inst)
+//-------------------------------------------------------------------------
+// OptionalArgCallerSideValue, OptionalArgInfo
/// The caller-side value for the optional arg, is any
type OptionalArgCallerSideValue =
@@ -408,6 +443,7 @@ type OptionalArgCallerSideValue =
| WrapperForIUnknown
| PassByRef of TType * OptionalArgCallerSideValue
+/// Represents information about a parameter indicating if it is optional.
type OptionalArgInfo =
/// The argument is not optional
| NotOptional
@@ -417,68 +453,89 @@ type OptionalArgInfo =
| CallerSide of OptionalArgCallerSideValue
member x.IsOptional = match x with CalleeSide | CallerSide _ -> true | NotOptional -> false
+ /// Compute the OptionalArgInfo for an IL parameter
+ ///
+ /// This includes the Visual Basic rules for IDispatchConstant and IUnknownConstant and optinal arguments.
+ static member FromILParameter g amap m ilScope ilTypeInst (ilParam: ILParameter) =
+ if ilParam.IsOptional then
+ match ilParam.Default with
+ | None ->
+ // Do a type-directed analysis of the IL type to determine the default value to pass.
+ // The same rules as Visual Basic are applied here.
+ let rec analyze ty =
+ if isByrefTy g ty then
+ let ty = destByrefTy g ty
+ PassByRef (ty, analyze ty)
+ elif isObjTy g ty then
+ if TryFindILAttributeOpt g.attrib_IDispatchConstantAttribute ilParam.CustomAttrs then WrapperForIDispatch
+ elif TryFindILAttributeOpt g.attrib_IUnknownConstantAttribute ilParam.CustomAttrs then WrapperForIUnknown
+ else MissingValue
+ else
+ DefaultValue
+ CallerSide (analyze (ImportTypeFromMetadata amap m ilScope ilTypeInst [] ilParam.Type))
+ | Some v ->
+ CallerSide (Constant v)
+ else
+ NotOptional
+
+//-------------------------------------------------------------------------
+// ParamNameAndType, ParamData
+
+[<NoComparison; NoEquality>]
+/// Partial information about a parameter returned for use by the Language Service
+type ParamNameAndType =
+ | ParamNameAndType of string option * TType
+
+ static member FromArgInfo (ty,argInfo : ArgReprInfo) = ParamNameAndType(Option.map textOfId argInfo.Name, ty)
+ static member FromMember isCSharpExtMem g vref = GetArgInfosOfMember isCSharpExtMem g vref |> List.mapSquared ParamNameAndType.FromArgInfo
+ static member Instantiate inst p = let (ParamNameAndType(nm,ty)) = p in ParamNameAndType(nm, instType inst ty)
+ static member InstantiateCurried inst paramTypes = paramTypes |> List.mapSquared (ParamNameAndType.Instantiate inst)
+
[<NoComparison; NoEquality>]
+/// Full information about a parameter returned for use by the type checker and language service.
type ParamData =
/// ParamData(isParamArray, isOut, optArgInfo, nameOpt, ttype)
ParamData of bool * bool * OptionalArgInfo * string option * TType
-// Compute the OptionalArgInfo for an IL parameter
-let OptionalArgInfoOfILParameter g amap m ilScope ilTypeInst (ilParam: ILParameter) =
- if ilParam.IsOptional then
- match ilParam.Default with
- | None ->
- // Do a type-directed analysis of the IL type to determine the default value to pass.
- // The same rules as Visual Basic are applied here.
- let rec analyze ty =
- if isByrefTy g ty then
- let ty = destByrefTy g ty
- PassByRef (ty, analyze ty)
- elif isObjTy g ty then
- if TryFindILAttribute g.attrib_IDispatchConstantAttribute ilParam.CustomAttrs then WrapperForIDispatch
- elif TryFindILAttribute g.attrib_IUnknownConstantAttribute ilParam.CustomAttrs then WrapperForIUnknown
- else MissingValue
- else
- DefaultValue
- CallerSide (analyze (ImportTypeFromMetadata amap m ilScope ilTypeInst [] ilParam.Type))
- | Some v ->
- CallerSide (Constant v)
- else
- NotOptional
-let ConstantObjToILFieldInit m (v:obj) =
- if v = null then ILFieldInit.Null
- else
- let objTy = v.GetType()
- let v =
- if objTy.IsEnum then
- let fi = objTy.GetField("value__")
- fi.GetValue(v)
- else v
- match v with
- | :? single as i -> ILFieldInit.Single i
- | :? double as i -> ILFieldInit.Double i
- | :? bool as i -> ILFieldInit.Bool i
- | :? char as i -> ILFieldInit.Char (uint16 i)
- | :? string as i -> ILFieldInit.String i
- | :? sbyte as i -> ILFieldInit.Int8 i
- | :? byte as i -> ILFieldInit.UInt8 i
- | :? int16 as i -> ILFieldInit.Int16 i
- | :? uint16 as i -> ILFieldInit.UInt16 i
- | :? int as i -> ILFieldInit.Int32 i
- | :? uint32 as i -> ILFieldInit.UInt32 i
- | :? int64 as i -> ILFieldInit.Int64 i
- | :? uint64 as i -> ILFieldInit.UInt64 i
- | _ -> error(Error(FSComp.SR.infosInvalidProvidedLiteralValue(try v.ToString() with _ -> "?"),m))
-
-
-#if EXTENSIONTYPING
-// Compute the OptionalArgInfo for a provided parameter. Same logic as OptionalArgInfoOfILParameter
-// except we do not aply the Visual Basic rules for IDispatchConstant and IUnknownConstant to optional
-// provided parameters.
-let OptionalArgInfoOfProvidedParameter g amap m (provParam : Tainted<ProvidedParameterInfo>) =
+//-------------------------------------------------------------------------
+// Helper methods associated with type providers
+
+#if EXTENSIONTYPING
+
+type ILFieldInit with
+ /// Compute the ILFieldInit for the given provided constant value for a provided enum type.
+ static member FromProvidedObj m (v:obj) =
+ if v = null then ILFieldInit.Null else
+ let objTy = v.GetType()
+ let v = if objTy.IsEnum then objTy.GetField("value__").GetValue(v) else v
+ match v with
+ | :? single as i -> ILFieldInit.Single i
+ | :? double as i -> ILFieldInit.Double i
+ | :? bool as i -> ILFieldInit.Bool i
+ | :? char as i -> ILFieldInit.Char (uint16 i)
+ | :? string as i -> ILFieldInit.String i
+ | :? sbyte as i -> ILFieldInit.Int8 i
+ | :? byte as i -> ILFieldInit.UInt8 i
+ | :? int16 as i -> ILFieldInit.Int16 i
+ | :? uint16 as i -> ILFieldInit.UInt16 i
+ | :? int as i -> ILFieldInit.Int32 i
+ | :? uint32 as i -> ILFieldInit.UInt32 i
+ | :? int64 as i -> ILFieldInit.Int64 i
+ | :? uint64 as i -> ILFieldInit.UInt64 i
+ | _ -> error(Error(FSComp.SR.infosInvalidProvidedLiteralValue(try v.ToString() with _ -> "?"),m))
+
+
+/// Compute the OptionalArgInfo for a provided parameter.
+///
+/// This is the same logic as OptionalArgInfoOfILParameter except we do not apply the
+/// Visual Basic rules for IDispatchConstant and IUnknownConstant to optional
+/// provided parameters.
+let OptionalArgInfoOfProvidedParameter (amap:Import.ImportMap) m (provParam : Tainted<ProvidedParameterInfo>) =
+ let g = amap.g
if provParam.PUntaint((fun p -> p.IsOptional),m) then
- match provParam.PUntaint((fun p -> p.RawDefaultValue),m) with
- | null ->
+ match provParam.PUntaint((fun p -> p.HasDefaultValue),m) with
+ | false ->
// Do a type-directed analysis of the IL type to determine the default value to pass.
let rec analyze ty =
if isByrefTy g ty then
@@ -489,21 +546,20 @@ let OptionalArgInfoOfProvidedParameter g amap m (provParam : Tainted<ProvidedPar
let pty = Import.ImportProvidedType amap m (provParam.PApply((fun p -> p.ParameterType),m))
CallerSide (analyze pty)
- | v ->
- CallerSide (Constant (ConstantObjToILFieldInit m v))
+ | _ ->
+ let v = provParam.PUntaint((fun p -> p.RawDefaultValue),m)
+ CallerSide (Constant (ILFieldInit.FromProvidedObj m v))
else
NotOptional
-//-------------------------------------------------------------------------
-// Some helper functions
-
+/// Compute the ILFieldInit for the given provided constant value for a provided enum type.
let GetAndSanityCheckProviderMethod m (mi: Tainted<'T :> ProvidedMemberInfo>) (get : 'T -> ProvidedMethodInfo) err =
match mi.PApply((fun mi -> (get mi :> ProvidedMethodBase)),m) with
| Tainted.Null -> error(Error(err(mi.PUntaint((fun mi -> mi.Name),m),mi.PUntaint((fun mi -> mi.DeclaringType.Name),m)),m))
| meth -> meth
-
-let RepresentativeMethodInfoOfPropertyInfo (pi:Tainted<ProvidedPropertyInfo>) m =
+/// Try to get an arbitrary ProvidedMethodInfo associated with a property.
+let ArbitraryMethodInfoOfPropertyInfo (pi:Tainted<ProvidedPropertyInfo>) m =
if pi.PUntaint((fun pi -> pi.CanRead), m) then
GetAndSanityCheckProviderMethod m pi (fun pi -> pi.GetGetMethod()) FSComp.SR.etPropertyCanReadButHasNoGetter
elif pi.PUntaint((fun pi -> pi.CanWrite), m) then
@@ -513,19 +569,40 @@ let RepresentativeMethodInfoOfPropertyInfo (pi:Tainted<ProvidedPropertyInfo>) m
#endif
-/// Split the type of an F# member value into
-/// - the type parameters associated with method but matching those of the enclosing type
-/// - the type parameters associated with a generic method
-/// - the return type of the method
-/// - the actual type arguments of the enclosing type.
-let AnalyzeTypeOfMemberVal g (typ,vref) =
- let mamberAllTypars,_,retTy,_ = GetTypeOfMemberInMemberForm g vref
-
- let parentTyArgs = argsOfAppTy g typ
- let memberParentTypars,memberMethodTypars = List.chop parentTyArgs.Length mamberAllTypars
- memberParentTypars,memberMethodTypars,retTy,parentTyArgs
+//-------------------------------------------------------------------------
+// ILTypeInfo
+/// Describes an F# use of an IL type, including the type instantiation associated with the type at a particular usage point.
+///
+/// This is really just 1:1 with the subset ot TType which result from building types using IL type definitions.
+[<NoComparison; NoEquality>]
+type ILTypeInfo =
+ /// ILTypeInfo (tyconRef, ilTypeRef, typeArgs, ilTypeDef).
+ | ILTypeInfo of TyconRef * ILTypeRef * TypeInst * ILTypeDef
+
+ member x.TyconRef = let (ILTypeInfo(tcref,_,_,_)) = x in tcref
+ member x.ILTypeRef = let (ILTypeInfo(_,tref,_,_)) = x in tref
+ member x.TypeInst = let (ILTypeInfo(_,_,tinst,_)) = x in tinst
+ member x.RawMetadata = let (ILTypeInfo(_,_,_,tdef)) = x in tdef
+ member x.ToType = TType_app(x.TyconRef,x.TypeInst)
+ member x.ILScopeRef = x.ILTypeRef.Scope
+ member x.Name = x.ILTypeRef.Name
+ member x.IsValueType = x.RawMetadata.IsStructOrEnum
+ member x.Instantiate inst =
+ let (ILTypeInfo(tcref,tref,tinst,tdef)) = x
+ ILTypeInfo(tcref,tref,instTypes inst tinst,tdef)
+
+ member x.FormalTypars m = x.TyconRef.Typars m
+
+ static member FromType g ty =
+ if isILAppTy g ty then
+ let tcref,tinst = destAppTy g ty
+ let scoref,enc,tdef = tcref.ILTyconInfo
+ let tref = mkRefForNestedILTypeDef scoref (enc,tdef)
+ ILTypeInfo(tcref,tref,tinst,tdef)
+ else
+ failwith "ILTypeInfo.FromType"
//-------------------------------------------------------------------------
// ILMethInfo
@@ -534,65 +611,61 @@ let AnalyzeTypeOfMemberVal g (typ,vref) =
/// Describes an F# use of an IL method.
[<NoComparison; NoEquality>]
type ILMethInfo =
- /// ILMethInfo(ilDeclaringTypeInfo, extensionMethodInfo, ilMethodDef, ilGenericMethodTyArgs)
+ /// ILMethInfo(g, ilApparentType, ilDeclaringTyconRefOpt, ilMethodDef, ilGenericMethodTyArgs)
+ ///
+ /// Describes an F# use of an IL method.
///
- /// Describes an F# use of an IL method.
- | ILMethInfo of ILTypeInfo * ILTypeRef option * ILMethodDef * Typars
+ /// If ilDeclaringTyconRefOpt is 'Some' then this is an F# use of an C#-style extension method.
+ /// If ilDeclaringTyconRefOpt is 'None' then ilApparentType is an IL type definition.
+ | ILMethInfo of TcGlobals * TType * TyconRef option * ILMethodDef * Typars
- /// ILFSMethInfo(DeclaringType, FSharpObjKind, extensionMethodInfo, ilMethodDef)
- /// - DeclaringType refers apparent parent type
- /// - FSharpObjKind Indicates whether the type declaration is a class, interface, enum, delegate or struct
- /// Describes an F# use of an IL extension method on F# object.
- | ILFSMethInfo of TyconRef * TyconObjModelKind * ILTypeRef option * ILMethodDef
+ member x.TcGlobals = match x with ILMethInfo(g,_,_,_,_) -> g
- /// Get the declaring type of the method as an ILTypeInfo. If this is an extension method, this is apparent type, i.e. the
- /// logical type being extended. If this is an extension method on a F# type, nothing returns.
- member x.ILTypeInfo = match x with ILMethInfo(tinfo,_,_,_) -> Some tinfo | ILFSMethInfo _ -> None
+ /// Get the apparent declaring type of the method as an F# type.
+ /// If this is an C#-style extension method then this is the type which the method
+ /// appears to extend. This may be a variable type.
+ member x.ApparentEnclosingType = match x with ILMethInfo(_,ty,_,_,_) -> ty
- /// Get the Abstract IL metadata associated with the method.
- member x.RawMetadata = match x with ILMethInfo(_,_,md,_) -> md | ILFSMethInfo(_,_,_,md) -> md
+ /// Get the declaring type associated with an extension member, if any.
+ member x.DeclaringTyconRefOption = match x with ILMethInfo(_,_,tcrefOpt,_,_) -> tcrefOpt
- /// Get the actual IL parent of a C#-style extension member with IL backing metadata
- member x.ExtensionMethodInfo = match x with ILMethInfo(_,extInfo,_,_) -> extInfo | ILFSMethInfo(_,_,extInfo,_) -> extInfo
+ /// Get the Abstract IL metadata associated with the method.
+ member x.RawMetadata = match x with ILMethInfo(_,_,_,md,_) -> md
- /// Get a reference to the named declaring type associated with the method, as an ILTypeRef
- member x.ILTypeRef = match x with ILMethInfo(tinfo,_,_,_) -> tinfo.ILTypeRef | ILFSMethInfo _ -> failwith "cannot happen"
+ /// Get the formal method type parameters associated with a method.
+ member x.FormalMethodTypars = match x with ILMethInfo(_,_,_,_,fmtps) -> fmtps
/// Get the IL name of the method
member x.ILName = x.RawMetadata.Name
/// Indicates if the method is an extension method
- member x.IsCSharpExtensionMethod = x.ExtensionMethodInfo.IsSome
+ member x.IsILExtensionMethod = x.DeclaringTyconRefOption.IsSome
- /// Get the declaring type of the method. If this is a C# extension method then this is the C# type
+ /// Get the declaring type of the method. If this is an C#-style extension method then this is the IL type
/// holding the static member that is the extension method.
- member x.ActualILTypeRef =
- match x.ExtensionMethodInfo with
- | None -> x.ILTypeRef
- | Some info -> info
-
- /// Get the instantiation of the declaring type of the method. If this is a C# extension method then this is empty.
- member x.ActualTypeInst =
- match x.ExtensionMethodInfo with
- | None -> match x.ILTypeInfo with Some(tinfo) -> tinfo.TypeInst | None -> []
- | Some _info -> []
+ member x.DeclaringTyconRef =
+ match x.DeclaringTyconRefOption with
+ | Some tcref -> tcref
+ | None -> tcrefOfAppTy x.TcGlobals x.ApparentEnclosingType
+ /// Get the instantiation of the declaring type of the method.
+ /// If this is an C#-style extension method then this is empty because extension members
+ /// are never in generic classes.
+ member x.DeclaringTypeInst =
+ if x.IsILExtensionMethod then [] else argsOfAppTy x.TcGlobals x.ApparentEnclosingType
/// Get the Abstract IL scope information associated with interpreting the Abstract IL metadata that backs this method.
- member x.MetadataScope = x.ActualILTypeRef.Scope
+ member x.MetadataScope = x.DeclaringTyconRef.CompiledRepresentationForNamedType.Scope
- /// Get the Abstract IL metadata corresponding to the parameters of the method. If this is a C# extension
- /// method then drop the object argument.
+ /// Get the Abstract IL metadata corresponding to the parameters of the method.
+ /// If this is an C#-style extension method then drop the object argument.
member x.ParamMetadata =
let ps = x.RawMetadata.Parameters |> ILList.toList
- if x.IsCSharpExtensionMethod then List.tail ps else ps
+ if x.IsILExtensionMethod then List.tail ps else ps
/// Get the number of parameters of the method
member x.NumParams = x.ParamMetadata.Length
- /// Get the number of generic parameters of the method. This includes all type parameters even if this is a C# extension method extending a generic type.
- member x.GenericArity = x.RawMetadata.GenericParams.Length
-
/// Indicates if the method is a constructor
member x.IsConstructor = x.RawMetadata.IsConstructor
@@ -620,7 +693,7 @@ type ILMethInfo =
/// Does it appear to the user as a static method?
member x.IsStatic =
- not x.IsCSharpExtensionMethod && // all C# extension methods are instance
+ not x.IsILExtensionMethod && // all C#-declared extension methods are instance
x.RawMetadata.CallingConv.IsStatic
/// Does it have the .NET IL 'newslot' flag set, and is also a virtual?
@@ -632,65 +705,55 @@ type ILMethInfo =
/// Does it appear to the user as an instance method?
member x.IsInstance = not x.IsConstructor && not x.IsStatic
- /// Get the argument types of the the IL method. If this is a C# extension method then drop the object argument.
+ /// Get the argument types of the the IL method. If this is an C#-style extension method
+ /// then drop the object argument.
member x.GetParamTypes(amap,m,minst) =
- x.ParamMetadata |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.ActualTypeInst minst p.Type)
+ x.ParamMetadata |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type)
- /// Get all the argument types of the IL method. Include the object argument even if this is a C# extension method.
+ /// Get all the argument types of the IL method. Include the object argument even if this is
+ /// an C#-style extension method.
member x.GetRawArgTypes(amap,m,minst) =
- // This includes, for example, C# extension methods.
- x.RawMetadata.Parameters |> ILList.toList |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.ActualTypeInst minst p.Type)
+ x.RawMetadata.Parameters |> ILList.toList |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type)
- /// Get info about the arguments of the IL method. If this is a C# extension method then drop the object argument.
+ /// Get info about the arguments of the IL method. If this is an C#-style extension method then
+ /// drop the object argument.
member x.GetParamNamesAndTypes(amap,m,minst) =
- x.ParamMetadata |> List.map (fun p -> ParamNameAndType(p.Name, ImportTypeFromMetadata amap m x.MetadataScope x.ActualTypeInst minst p.Type) )
-
- /// Get the declaring type of the method as an F# type.
- member x.EnclosingType = match x with ILMethInfo(tinfo,_,_,_) -> tinfo.ToType | ILFSMethInfo(t,_,_,_) -> TType_app(t,[])
+ x.ParamMetadata |> List.map (fun p -> ParamNameAndType(p.Name, ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) )
/// Get a reference to the method (dropping all generic instantiations), as an Abstract IL ILMethodRef.
- member minfo.ILMethodRef =
- let mref = mkRefToILMethod (minfo.ActualILTypeRef,minfo.RawMetadata)
- rescopeILMethodRef minfo.MetadataScope mref
+ member x.ILMethodRef =
+ let mref = mkRefToILMethod (x.DeclaringTyconRef.CompiledRepresentationForNamedType,x.RawMetadata)
+ rescopeILMethodRef x.MetadataScope mref
/// Indicates if the method is marked as a DllImport (a PInvoke). This is done by looking at the IL custom attributes on
/// the method.
- member minfo.IsDllImport g =
+ member x.IsDllImport g =
let (AttribInfo(tref,_)) = g.attrib_DllImportAttribute
- minfo.RawMetadata.CustomAttrs |> TryDecodeILAttribute g tref (Some(tref.Scope)) |> isSome
+ x.RawMetadata.CustomAttrs |> TryDecodeILAttribute g tref (Some tref.Scope) |> isSome
- /// Get the (zero or one) 'self'/'this'/'object' arguments associated with an IL method. An instance extension method returns
- /// one object argument.
+ /// Get the (zero or one) 'self'/'this'/'object' arguments associated with an IL method.
+ /// An instance extension method returns one object argument.
member x.GetObjArgTypes(amap, m, minst) =
- // all C# extension methods are instance
- if x.IsCSharpExtensionMethod then
- x.RawMetadata.Parameters |> ILList.toList |> List.head |> (fun p -> [ImportTypeFromMetadata amap m x.MetadataScope x.ActualTypeInst minst p.Type])
- elif x.IsInstance then
- [x.EnclosingType]
+ // All C#-style extension methods are instance. We have to re-read the 'obj' type w.r.t. the
+ // method instantiation.
+ if x.IsILExtensionMethod then
+ [ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst x.RawMetadata.Parameters.Head.Type]
+ else if x.IsInstance then
+ [ x.ApparentEnclosingType ]
else
[]
- /// Get the compiled return type of an ILMethInfo, where 'void' is None.
- member minfo.GetCompiledReturnTy (amap, m, minst) =
- ImportReturnTypeFromMetaData amap m minfo.RawMetadata.Return.Type minfo.MetadataScope minfo.ActualTypeInst minst
+ /// Get the compiled return type of the method, where 'void' is None.
+ member x.GetCompiledReturnTy (amap, m, minst) =
+ ImportReturnTypeFromMetaData amap m x.RawMetadata.Return.Type x.MetadataScope x.DeclaringTypeInst minst
- /// Get the F# view of the return type of an ILMethInfo, where 'void' is 'unit'.
- member minfo.GetFSharpReturnTy (amap, m, minst) =
- minfo.GetCompiledReturnTy(amap, m, minst)
+ /// Get the F# view of the return type of the method, where 'void' is 'unit'.
+ member x.GetFSharpReturnTy (amap, m, minst) =
+ x.GetCompiledReturnTy(amap, m, minst)
|> GetFSharpViewOfReturnType amap.g
//-------------------------------------------------------------------------
-// ExtensionMethodPriority
-
-
-/// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced
-/// later through 'open' get priority in overload resolution.
-type ExtensionMethodPriority = uint64
-
-
-
-//-------------------------------------------------------------------------
// MethInfo
@@ -715,27 +778,46 @@ type MethInfo =
#if EXTENSIONTYPING
/// Describes a use of a method backed by provided metadata
- | ProvidedMeth of TcGlobals * Tainted<ProvidedMethodBase> * Import.ImportMap * range
+ | ProvidedMeth of Import.ImportMap * Tainted<ProvidedMethodBase> * ExtensionMethodPriority option * range
#endif
- /// Get the enclosing ("parent"/"declaring") type of the method info. If this is an extension member,
- /// then this is the apparent parent.
+ /// Get the enclosing type of the method info.
+ ///
+ /// If this is an extension member, then this is the apparent parent, i.e. the type the method appears to extend.
+ /// This may be a variable type.
member x.EnclosingType =
match x with
- | ILMeth(_g,x,_) -> x.EnclosingType
+ | ILMeth(_g,ilminfo,_) -> ilminfo.ApparentEnclosingType
| FSMeth(_g,typ,_,_) -> typ
| DefaultStructCtor(_g,typ) -> typ
#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,amap,m) ->
+ | ProvidedMeth(amap,mi,_,m) ->
Import.ImportProvidedType amap m (mi.PApply((fun mi -> mi.DeclaringType),m))
#endif
- /// Get the extension method priority of the method, if it has one.
- member x.Priority =
+ /// Get the declaring type or module holding the method. If this is an C#-style extension method then this is the type
+ /// holding the static member that is the extension method. If this is an F#-style extension method it is the logical module
+ /// holding the value for the extension method.
+ member x.DeclaringEntityRef =
+ match x with
+ | ILMeth(_,ilminfo,_) when x.IsExtensionMember -> ilminfo.DeclaringTyconRef
+ | FSMeth(_,_,vref,_) when x.IsExtensionMember -> vref.TopValActualParent
+ | _ -> tcrefOfAppTy x.TcGlobals x.EnclosingType
+
+ /// Get the extension method priority of the method, if it has one.
+ member x.ExtensionMemberPriorityOption =
match x with
- | ILMeth(_,_,Some pri) -> pri
- | FSMeth(_,_,_,Some pri) -> pri
- | _ -> System.UInt64.MaxValue // all others take prioity over extension members
+ | ILMeth(_,_,pri) -> pri
+ | FSMeth(_,_,_,pri) -> pri
+#if EXTENSIONTYPING
+ | ProvidedMeth(_,_,pri,_) -> pri
+#endif
+ | DefaultStructCtor _ -> None
+
+ /// Get the extension method priority of the method. If it is not an extension method
+ /// then use the highest possible value since non-extension methods always take priority
+ /// over extension members.
+ member x.ExtensionMemberPriority = defaultArg x.ExtensionMemberPriorityOption System.UInt64.MaxValue
#if DEBUG
/// Get the method name in DebuggerDisplayForm
@@ -776,37 +858,31 @@ type MethInfo =
override x.ToString() = x.EnclosingType.ToString() + x.LogicalName
- /// Get the actual type instantiation of the declaring type associated with this use of the method.
- /// If this is an extension member, then this is the actual instantiation of the apparent parent
- /// of the member.
- member x.ActualTypeInst =
- match x with
- | ILMeth(_g,y,_) -> y.ActualTypeInst
- | FSMeth(g,_,_,_) | DefaultStructCtor(g,_) -> argsOfAppTy g x.EnclosingType
-#if EXTENSIONTYPING
- | ProvidedMeth(g,_,_,_) -> argsOfAppTy g x.EnclosingType
-#endif
+ /// Get the actual type instantiation of the declaring type associated with this use of the method.
+ ///
+ /// For extension members this is empty (the instantiation of the declaring type).
+ member x.DeclaringTypeInst =
+ if x.IsExtensionMember then [] else argsOfAppTy x.TcGlobals x.EnclosingType
- /// Get the TcGlobals value that governs the method declaration
+ /// Get the TcGlobals value that governs the method declaration
member x.TcGlobals =
match x with
| ILMeth(g,_,_) -> g
| FSMeth(g,_,_,_) -> g
| DefaultStructCtor (g,_) -> g
#if EXTENSIONTYPING
- | ProvidedMeth(g,_,_,_) -> g
+ | ProvidedMeth(amap,_,_,_) -> amap.g
#endif
-
- /// Get the formal generic method parameters for the method as a list of type variables.
+ /// Get the formal generic method parameters for the method as a list of type variables.
+ ///
+ /// For an extension method this includes all type parameters, even if it is extending a generic type.
member x.FormalMethodTypars =
match x with
- | ILMeth(_,tinfo,_) -> match tinfo with ILMethInfo(_,_,_,mtps) -> mtps | _ -> []
+ | ILMeth(_,ilmeth,_) -> ilmeth.FormalMethodTypars
| FSMeth(g,typ,vref,_) ->
- let allTypars,_ = destTopForallTy g vref.ValReprInfo.Value vref.Type
- let parentTyArgs = argsOfAppTy g typ
- let methodTypars = List.drop parentTyArgs.Length allTypars
- methodTypars
+ let _,memberMethodTypars,_,_ = AnalyzeTypeOfMemberVal x.IsCSharpStyleExtensionMember g (typ,vref)
+ memberMethodTypars
| DefaultStructCtor _ -> []
#if EXTENSIONTYPING
| ProvidedMeth _ -> [] // There will already have been an error if there are generic parameters here.
@@ -826,16 +902,19 @@ type MethInfo =
XmlDoc (mi.PUntaint((fun mix -> (mix :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(mi.TypeProvider.PUntaintNoFailure(id))),m))
#endif
- /// Try to get an F# ValRef for the method
+ /// Try to get an arbitrary F# ValRef associated with the member. This is to determine if the member is virtual, amongst other things.
member x.ArbitraryValRef =
match x with
| FSMeth(_g,_,vref,_) -> Some vref
| _ -> None
+ /// Get a list of argument-number counts, one count for each set of curried arguments.
+ ///
+ /// For an extension member, drop the 'this' argument.
member x.NumArgs =
match x with
- | ILMeth(_g,x,_) -> [x.NumParams]
- | FSMeth(g,_,vref,_) -> ArgInfosOfMember g vref |> List.map List.length
+ | ILMeth(_,ilminfo,_) -> [ilminfo.NumParams]
+ | FSMeth(g,_,vref,_) -> GetArgInfosOfMember x.IsCSharpStyleExtensionMember g vref |> List.map List.length
| DefaultStructCtor _ -> [0]
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> [mi.PUntaint((fun mi -> mi.GetParameters().Length),m)] // Why is this a list? Answer: because the method might be curried
@@ -846,29 +925,21 @@ type MethInfo =
/// Does the method appear to the user as an instance method?
member x.IsInstance =
match x with
- | ILMeth(_,x,_) -> x.IsInstance
- | FSMeth(_,_,vref,_) -> vref.IsInstanceMember
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsInstance
+ | FSMeth(_,_,vref,_) -> vref.IsInstanceMember || x.IsCSharpStyleExtensionMember
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> not mi.IsConstructor && not mi.IsStatic),m)
#endif
- member x.GenericArity =
- match x with
- | ILMeth(_g,x,_) -> x.GenericArity
- | FSMeth(g,typ,vref,_) ->
- let _,memberMethodTypars,_,_ = AnalyzeTypeOfMemberVal g (typ,vref)
- memberMethodTypars.Length
- | DefaultStructCtor _ -> 0
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,_,m) ->
- mi.PUntaint((fun mi -> if mi.IsGenericMethod then mi.GetGenericArguments().Length else 0),m)
-#endif
+ /// Get the number of generic method parameters for a method.
+ /// For an extension method this includes all type parameters, even if it is extending a generic type.
+ member x.GenericArity = x.FormalMethodTypars.Length
member x.IsProtectedAccessiblity =
match x with
- | ILMeth(_g,x,_) -> x.IsProtectedAccessibility
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsProtectedAccessibility
| FSMeth _ -> false
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
@@ -877,8 +948,8 @@ type MethInfo =
member x.IsVirtual =
match x with
- | ILMeth(_,x,_) -> x.IsVirtual
- | FSMeth(_,_,vref,_) -> MemberRefIsVirtual vref
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsVirtual
+ | FSMeth(_,_,vref,_) -> vref.IsVirtualMember
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> mi.IsVirtual), m)
@@ -886,10 +957,8 @@ type MethInfo =
member x.IsConstructor =
match x with
- | ILMeth(_g,x,_) -> x.IsConstructor
- | FSMeth(_g,_,vref,_) ->
- let flags = (Option.get vref.MemberInfo).MemberFlags
- (flags.MemberKind = MemberKind.Constructor)
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsConstructor
+ | FSMeth(_g,_,vref,_) -> (vref.MemberInfo.Value.MemberFlags.MemberKind = MemberKind.Constructor)
| DefaultStructCtor _ -> true
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> mi.IsConstructor), m)
@@ -897,30 +966,29 @@ type MethInfo =
member x.IsClassConstructor =
match x with
- | ILMeth(_g,x,_) -> x.IsClassConstructor
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsClassConstructor
| FSMeth _ -> false
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> mi.IsConstructor && mi.IsStatic), m) // Note: these are never public anyway
#endif
- member meth.IsDispatchSlot =
- match meth with
- | ILMeth(_g,x,_) ->
- x.IsVirtual
+ member x.IsDispatchSlot =
+ match x with
+ | ILMeth(_g,ilmeth,_) -> ilmeth.IsVirtual
| FSMeth(g,_,vref,_) as x ->
isInterfaceTy g x.EnclosingType ||
vref.MemberInfo.Value.MemberFlags.IsDispatchSlot
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
- | ProvidedMeth _ -> meth.IsVirtual // Note: follow same implementation as ILMeth
+ | ProvidedMeth _ -> x.IsVirtual // Note: follow same implementation as ILMeth
#endif
member x.IsFinal =
not x.IsVirtual ||
match x with
- | ILMeth(_g,x,_) -> x.IsFinal
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsFinal
| FSMeth(_g,_,_vref,_) -> false
| DefaultStructCtor _ -> true
#if EXTENSIONTYPING
@@ -935,10 +1003,8 @@ type MethInfo =
// For IL methods, this is 'true' for abstract methods, and 'false' for virtual methods
member minfo.IsAbstract =
match minfo with
- | ILMeth(_g,x,_) -> x.IsAbstract
- | FSMeth(g,_,vref,_) ->
- isInterfaceTy g minfo.EnclosingType ||
- MemberRefIsDispatchSlot vref
+ | ILMeth(_,ilmeth,_) -> ilmeth.IsAbstract
+ | FSMeth(g,_,vref,_) -> isInterfaceTy g minfo.EnclosingType || vref.IsDispatchSlotMember
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> mi.IsAbstract), m)
@@ -949,32 +1015,51 @@ type MethInfo =
(x.IsVirtual &&
(match x with
| ILMeth(_,x,_) -> x.IsNewSlot
- | FSMeth(_,_,vref,_) -> MemberRefIsDispatchSlot vref
+ | FSMeth(_,_,vref,_) -> vref.IsDispatchSlotMember
#if EXTENSIONTYPING
| ProvidedMeth(_,mi,_,m) -> mi.PUntaint((fun mi -> mi.IsHideBySig), m) // REVIEW: Check this is correct
#endif
| DefaultStructCtor _ -> false))
+ /// Check if this method is marked 'override' and thus definitely overrides another method.
member x.IsDefiniteFSharpOverride =
match x with
- | ILMeth(_,_,_) -> false
- | FSMeth(_,_,vref,_) -> MemberRefIsDefiniteFSharpOverride vref
+ | ILMeth _ -> false
+ | FSMeth(_,_,vref,_) -> vref.IsDefiniteFSharpOverrideMember
| DefaultStructCtor _ -> false
#if EXTENSIONTYPING
| ProvidedMeth _ -> false
#endif
- member x.IsExtensionMember =
- match x with
- | ILMeth(_,x,_) -> x.ExtensionMethodInfo.IsSome
- | FSMeth(_,_,vref,_) -> vref.IsExtensionMember
- | DefaultStructCtor _ -> false
-#if EXTENSIONTYPING
- | ProvidedMeth _ -> false // We don't support provided extension members.
-#endif
+ /// Determine if this is an extension member.
+ member x.IsExtensionMember = x.IsCSharpStyleExtensionMember || x.IsFSharpStyleExtensionMember
- member x.IsFSharpEventProperty =
+ /// Determine if this is an F# extension member.
+ member x.IsFSharpStyleExtensionMember =
+ match x with FSMeth (_,_,vref,_) -> vref.IsExtensionMember | _ -> false
+
+ /// Determine if this is an C#-style extension member.
+ member x.IsCSharpStyleExtensionMember =
+ x.ExtensionMemberPriorityOption.IsSome &&
+ (match x with ILMeth _ -> true | FSMeth (_,_,vref,_) -> not vref.IsExtensionMember | _ -> false)
+
+ /// Add the actual type instantiation of the apparent type of an F# extension method.
+ //
+ // When an explicit type instantiation is given for an F# extension members the type
+ // arguments implied by the object type are not given in source code. This means we must
+ // add them explicitly. For example
+ // type List<'T> with
+ // member xs.Map<'U>(f : 'T -> 'U) = ....
+ // is called as
+ // xs.Map<int>
+ // but is compiled as a generic methods with two type arguments
+ // Map<'T,'U>(this: List<'T>, f : 'T -> 'U)
+ member x.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs) =
+ (if x.IsFSharpStyleExtensionMember then argsOfAppTy x.TcGlobals x.EnclosingType else []) @ tyargs
+
+ /// Indicates if this method is a generated method associated with an F# CLIEvent property compiled as a .NET event
+ member x.IsFSharpEventPropertyMethod =
match x with
| FSMeth(g,_,vref,_) -> vref.IsFSharpEventProperty(g)
#if EXTENSIONTYPING
@@ -982,13 +1067,279 @@ type MethInfo =
#endif
| _ -> false
+ /// Indicates if this method takes no arguments
member x.IsNullary = (x.NumArgs = [0])
+ /// Indicates if the enclosing type for the method is a value type.
+ ///
+ /// For an extension method, this indicates if the method extends a struct type.
member x.IsStruct =
isStructTy x.TcGlobals x.EnclosingType
+ /// Build IL method infos.
+ static member CreateILMeth (amap:Import.ImportMap, m, typ:TType, md: ILMethodDef) =
+ let tinfo = ILTypeInfo.FromType amap.g typ
+ let mtps = Import.ImportILGenericParameters (fun () -> amap) m tinfo.ILScopeRef tinfo.TypeInst md.GenericParams
+ ILMeth (amap.g,ILMethInfo(amap.g,tinfo.ToType,None,md,mtps),None)
+
+ /// Build IL method infos for a C#-style extension method
+ static member CreateILExtensionMeth (amap, m, apparentTy:TType, declaringTyconRef:TyconRef, extMethPri, md: ILMethodDef) =
+ let scoref = declaringTyconRef.CompiledRepresentationForNamedType.Scope
+ let mtps = Import.ImportILGenericParameters (fun () -> amap) m scoref [] md.GenericParams
+ ILMeth (amap.g,ILMethInfo(amap.g,apparentTy,Some declaringTyconRef,md,mtps),extMethPri)
+
+ /// Tests whether two method infos have the same underlying definition.
+ /// Used to merge operator overloads collected from left and right of an operator constraint.
+ static member MethInfosUseIdenticalDefinitions x1 x2 =
+ match x1,x2 with
+ | ILMeth(_,x1,_), ILMeth(_,x2,_) -> (x1.RawMetadata === x2.RawMetadata)
+ | FSMeth(g,_,vref1,_), FSMeth(_,_,vref2,_) -> valRefEq g vref1 vref2
+ | DefaultStructCtor(g,ty1), DefaultStructCtor(_,ty2) -> tyconRefEq g (tcrefOfAppTy g ty1) (tcrefOfAppTy g ty2)
+#if EXTENSIONTYPING
+ | ProvidedMeth(_,mi1,_,_),ProvidedMeth(_,mi2,_,_) -> ProvidedMethodBase.TaintedEquals (mi1, mi2)
+#endif
+ | _ -> false
+
+ /// Calculates a hash code of method info. Note: this is a very imperfect implementation,
+ /// but it works decently for comparing methods in the language service...
+ member x.ComputeHashCode() =
+ match x with
+ | ILMeth(_,x1,_) -> hash x1.RawMetadata.Name
+ | FSMeth(_,_,vref,_) -> hash vref.LogicalName
+ | DefaultStructCtor(_,_ty) -> 34892 // "ty" doesn't support hashing. We could use "hash (tcrefOfAppTy g ty).CompiledName" or
+ // something but we don't have a "g" parameter here yet. But this hash need only be very approximate anyway
+#if EXTENSIONTYPING
+ | ProvidedMeth(_,mi,_,_) -> ProvidedMethodInfo.TaintedGetHashCode(mi)
+#endif
+
+ /// Apply a type instantiation to a method info, i.e. apply the instantiation to the enclosing type.
+ member x.Instantiate(amap, m, inst) =
+ match x with
+ | ILMeth(_g,ilminfo,pri) ->
+ match ilminfo with
+ | ILMethInfo(_,typ,None,md,_) -> MethInfo.CreateILMeth(amap, m, instType inst typ, md)
+ | ILMethInfo(_,typ,Some declaringTyconRef,md,_) -> MethInfo.CreateILExtensionMeth(amap, m, instType inst typ, declaringTyconRef, pri, md)
+ | FSMeth(g,typ,vref,pri) -> FSMeth(g,instType inst typ,vref,pri)
+ | DefaultStructCtor(g,typ) -> DefaultStructCtor(g,instType inst typ)
+#if EXTENSIONTYPING
+ | ProvidedMeth _ ->
+ match inst with
+ | [] -> x
+ | _ -> assert false; failwith "Not supported"
+#endif
+
+ /// Get the return type of a method info, where 'void' is returned as 'None'
+ member x.GetCompiledReturnTy (amap, m, minst) =
+ match x with
+ | ILMeth(_g,ilminfo,_) ->
+ ilminfo.GetCompiledReturnTy(amap, m, minst)
+ | FSMeth(g,typ,vref,_) ->
+ let inst = GetInstantiationForMemberVal g x.IsCSharpStyleExtensionMember (typ,vref,minst)
+ let _,_,retTy,_ = AnalyzeTypeOfMemberVal x.IsCSharpStyleExtensionMember g (typ,vref)
+ retTy |> Option.map (instType inst)
+ | DefaultStructCtor _ -> None
+#if EXTENSIONTYPING
+ | ProvidedMeth(amap,mi,_,m) ->
+ GetCompiledReturnTyOfProvidedMethodInfo amap m mi
+#endif
+
+ /// Get the return type of a method info, where 'void' is returned as 'unit'
+ member x.GetFSharpReturnTy(amap, m, minst) =
+ x.GetCompiledReturnTy(amap, m, minst) |> GetFSharpViewOfReturnType amap.g
+
+ /// Get the parameter types of a method info
+ member x.GetParamTypes(amap, m, minst) =
+ match x with
+ | ILMeth(_g,ilminfo,_) ->
+ // A single group of tupled arguments
+ [ ilminfo.GetParamTypes(amap,m,minst) ]
+ | FSMeth(g,typ,vref,_) ->
+ let paramTypes = ParamNameAndType.FromMember x.IsCSharpStyleExtensionMember g vref
+ let inst = GetInstantiationForMemberVal g x.IsCSharpStyleExtensionMember (typ,vref,minst)
+ paramTypes |> List.mapSquared (fun (ParamNameAndType(_,ty)) -> instType inst ty)
+ | DefaultStructCtor _ -> []
+#if EXTENSIONTYPING
+ | ProvidedMeth(amap,mi,_,m) ->
+ // A single group of tupled arguments
+ [ [ for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters",m) do
+ yield Import.ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType),m)) ] ]
+#endif
+
+ /// Get the (zero or one) 'self'/'this'/'object' arguments associated with a method.
+ /// An instance method returns one object argument.
+ member x.GetObjArgTypes (amap, m, minst) =
+ match x with
+ | ILMeth(_,ilminfo,_) -> ilminfo.GetObjArgTypes(amap, m, minst)
+ | FSMeth(g,typ,vref,_) ->
+ if x.IsInstance then
+ // The 'this' pointer of an extension member can depend on the minst
+ if x.IsExtensionMember then
+ let inst = GetInstantiationForMemberVal g x.IsCSharpStyleExtensionMember (typ,vref,minst)
+ let rawObjTy = GetObjTypeOfInstanceExtensionMethod g vref
+ [ rawObjTy |> instType inst ]
+ else
+ [ typ ]
+ else []
+ | DefaultStructCtor _ -> []
+#if EXTENSIONTYPING
+ | ProvidedMeth(amap,mi,_,m) ->
+ if x.IsInstance then [ Import.ImportProvidedType amap m (mi.PApply((fun mi -> mi.DeclaringType),m)) ] // find the type of the 'this' argument
+ else []
+#endif
+
+ /// Get the parameter attributes of a method info, which get combined with the parameter names and types
+ member x.GetParamAttribs(amap, m) =
+ match x with
+ | ILMeth(g,ilMethInfo,_) ->
+ [ [ for p in ilMethInfo.ParamMetadata do
+ let isParamArrayArg = TryFindILAttribute g.attrib_ParamArrayAttribute p.CustomAttrs
+ let isOutArg = (p.IsOut && not p.IsIn)
+ // Note: we get default argument values from VB and other .NET language metadata
+ let optArgInfo = OptionalArgInfo.FromILParameter g amap m ilMethInfo.MetadataScope ilMethInfo.DeclaringTypeInst p
+ yield (isParamArrayArg, isOutArg, optArgInfo) ] ]
+
+ | FSMeth(g,_,vref,_) ->
+ GetArgInfosOfMember x.IsCSharpStyleExtensionMember g vref
+ |> List.mapSquared (fun (ty,argInfo) ->
+ let isParamArrayArg = HasFSharpAttribute g g.attrib_ParamArrayAttribute argInfo.Attribs
+ let isOutArg = HasFSharpAttribute g g.attrib_OutAttribute argInfo.Attribs && isByrefTy g ty
+ let isOptArg = HasFSharpAttribute g g.attrib_OptionalArgumentAttribute argInfo.Attribs
+ // Note: can't specify caller-side default arguments in F#, by design (default is specified on the callee-side)
+ let optArgInfo = if isOptArg then CalleeSide else NotOptional
+ (isParamArrayArg,isOutArg,optArgInfo))
+
+ | DefaultStructCtor _ ->
+ [[]]
+
+#if EXTENSIONTYPING
+ | ProvidedMeth(amap,mi,_,_) ->
+ // A single group of tupled arguments
+ [ [for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
+ let isParamArrayArg = p.PUntaint((fun px -> (px :> IProvidedCustomAttributeProvider).GetAttributeConstructorArgs(p.TypeProvider.PUntaintNoFailure(id), typeof<System.ParamArrayAttribute>.FullName).IsSome),m)
+ let optArgInfo = OptionalArgInfoOfProvidedParameter amap m p
+ yield (isParamArrayArg, p.PUntaint((fun p -> p.IsOut), m), optArgInfo)] ]
+#endif
+
+ /// Get the signature of an abstract method slot.
+ //
+ // This code has grown organically over time. We've managed to unify the ILMeth+ProvidedMeth paths.
+ // The FSMeth, ILMeth+ProvidedMeth paths can probably be unified too.
+ member x.GetSlotSig(amap, m) =
+ match x with
+ | FSMeth(g,typ,vref,_) ->
+ match vref.RecursiveValInfo with
+ | ValInRecScope(false) -> error(Error((FSComp.SR.InvalidRecursiveReferenceToAbstractSlot()),m))
+ | _ -> ()
+
+ let allTyparsFromMethod,_,retTy,_ = GetTypeOfMemberInMemberForm g vref
+ // A slot signature is w.r.t. the type variables of the type it is associated with.
+ // So we have to rename from the member type variables to the type variables of the type.
+ let formalEnclosingTypars = (tcrefOfAppTy g typ).Typars(m)
+ let formalEnclosingTyparsFromMethod,formalMethTypars = List.chop formalEnclosingTypars.Length allTyparsFromMethod
+ let methodToParentRenaming,_ = mkTyparToTyparRenaming formalEnclosingTyparsFromMethod formalEnclosingTypars
+ let formalParams =
+ GetArgInfosOfMember x.IsCSharpStyleExtensionMember g vref
+ |> List.mapSquared (map1Of2 (instType methodToParentRenaming) >> MakeSlotParam )
+ let formalRetTy = Option.map (instType methodToParentRenaming) retTy
+ MakeSlotSig(x.LogicalName, x.EnclosingType, formalEnclosingTypars, formalMethTypars, formalParams, formalRetTy)
+ | DefaultStructCtor _ -> error(InternalError("no slotsig for DefaultStructCtor",m))
+ | _ ->
+ let g = x.TcGlobals
+ // slotsigs must contain the formal types for the arguments and return type
+ // a _formal_ 'void' return type is represented as a 'unit' type.
+ // slotsigs are independent of instantiation: if an instantiation
+ // happens to make the return type 'unit' (i.e. it was originally a variable type
+ // then that does not correspond to a slotsig compiled as a 'void' return type.
+ // REVIEW: should we copy down attributes to slot params?
+ let tcref = tcrefOfAppTy g x.EnclosingType
+ let formalEnclosingTyparsOrig = tcref.Typars(m)
+ let formalEnclosingTypars = copyTypars formalEnclosingTyparsOrig
+ let _,formalEnclosingTyparTys = FixupNewTypars m [] [] formalEnclosingTyparsOrig formalEnclosingTypars
+ let formalMethTypars = copyTypars x.FormalMethodTypars
+ let _,formalMethTyparTys = FixupNewTypars m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars
+ let formalRetTy, formalParams =
+ match x with
+ | ILMeth(_,ilminfo,_) ->
+ let ftinfo = ILTypeInfo.FromType g (TType_app(tcref,formalEnclosingTyparTys))
+ let formalRetTy = ImportReturnTypeFromMetaData amap m ilminfo.RawMetadata.Return.Type ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys
+ let formalParams =
+ [ [ for p in ilminfo.RawMetadata.Parameters do
+ let paramType = ImportTypeFromMetadata amap m ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys p.Type
+ yield TSlotParam(p.Name, paramType, p.IsIn, p.IsOut, p.IsOptional, []) ] ]
+ formalRetTy, formalParams
+#if EXTENSIONTYPING
+ | ProvidedMeth (_,mi,_,_) ->
+ // GENERIC TYPE PROVIDERS: for generics, formal types should be generated here, not the actual types
+ // For non-generic type providers there is no difference
+ let formalRetTy = x.GetCompiledReturnTy(amap, m, formalMethTyparTys)
+ // GENERIC TYPE PROVIDERS: formal types should be generated here, not the actual types
+ // For non-generic type providers there is no difference
+ let formalParams =
+ [ [ for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
+ let paramName = p.PUntaint((fun p -> match p.Name with null -> None | s -> Some s),m)
+ let paramType = Import.ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType),m))
+ let isIn, isOut,isOptional = p.PUntaint((fun p -> p.IsIn, p.IsOut, p.IsOptional),m)
+ yield TSlotParam(paramName, paramType, isIn, isOut, isOptional, []) ] ]
+ formalRetTy, formalParams
+#endif
+ | _ -> failwith "unreachable"
+ MakeSlotSig(x.LogicalName, x.EnclosingType, formalEnclosingTypars, formalMethTypars,formalParams, formalRetTy)
+
+ /// Get the ParamData objects for the parameters of a MethInfo
+ member x.GetParamDatas(amap, m, minst) =
+ let paramNamesAndTypes =
+ match x with
+ | ILMeth(_g,ilminfo,_) ->
+ [ ilminfo.GetParamNamesAndTypes(amap,m,minst) ]
+ | FSMeth(g,typ,vref,_) ->
+ let items = ParamNameAndType.FromMember x.IsCSharpStyleExtensionMember g vref
+ let inst = GetInstantiationForMemberVal g x.IsCSharpStyleExtensionMember (typ,vref,minst)
+ items |> ParamNameAndType.InstantiateCurried inst
+ | DefaultStructCtor _ ->
+ [[]]
+#if EXTENSIONTYPING
+ | ProvidedMeth(amap,mi,_,_) ->
+ // A single set of tupled parameters
+ [ [for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
+ let pname =
+ match p.PUntaint((fun p -> p.Name), m) with
+ | null -> None
+ | name -> Some name
+ let ptyp =
+ match p.PApply((fun p -> p.ParameterType), m) with
+ | Tainted.Null -> amap.g.unit_ty
+ | parameterType -> Import.ImportProvidedType amap m parameterType
+ yield ParamNameAndType(pname,ptyp) ] ]
+
+#endif
+
+ let paramAttribs = x.GetParamAttribs(amap, m)
+ (paramAttribs,paramNamesAndTypes) ||> List.map2 (List.map2 (fun (isParamArrayArg,isOutArg,optArgInfo) (ParamNameAndType(nmOpt,pty)) ->
+ ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,pty)))
+
+
+ /// Select all the type parameters of the declaring type of a method.
+ ///
+ /// For extension methods, no type parameters are returned, because all the
+ /// type parameters are part of the apparent type, rather the
+ /// declaring type, even for extension methods extending generic types.
+ member x.GetFormalTyparsOfDeclaringType m =
+ if x.IsExtensionMember then []
+ else
+ match x with
+ | ILMeth(_,ilminfo,_) -> ilminfo.DeclaringTyconRef.Typars m
+ | FSMeth(g,typ,vref,_) ->
+ let memberParentTypars,_,_,_ = AnalyzeTypeOfMemberVal false g (typ,vref)
+ memberParentTypars
+ | DefaultStructCtor(g,typ) ->
+ (tcrefOfAppTy g typ).Typars(m)
+#if EXTENSIONTYPING
+ | ProvidedMeth (amap,_,_,_) ->
+ (tcrefOfAppTy amap.g x.EnclosingType).Typars(m)
+#endif
+
//-------------------------------------------------------------------------
// ILFieldInfo
@@ -1000,7 +1351,7 @@ type ILFieldInfo =
| ILFieldInfo of ILTypeInfo * ILFieldDef // .NET IL fields
#if EXTENSIONTYPING
/// Represents a single use of a field backed by provided metadata
- | ProvidedField of TcGlobals * Tainted<ProvidedFieldInfo> * Import.ImportMap * range
+ | ProvidedField of Import.ImportMap * Tainted<ProvidedFieldInfo> * range
#endif
/// Get the enclosing ("parent"/"declaring") type of the field.
@@ -1008,7 +1359,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo(tinfo,_) -> tinfo.ToType
#if EXTENSIONTYPING
- | ProvidedField(_,fi,amap,m) -> (Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.DeclaringType),m)))
+ | ProvidedField(amap,fi,m) -> (Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.DeclaringType),m)))
#endif
/// Get a reference to the declaring type of the field as an ILTypeRef
@@ -1016,7 +1367,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo(tinfo,_) -> tinfo.ILTypeRef
#if EXTENSIONTYPING
- | ProvidedField(_,fi,amap,m) -> (Import.ImportProvidedTypeAsILType amap m (fi.PApply((fun fi -> fi.DeclaringType),m))).TypeRef
+ | ProvidedField(amap,fi,m) -> (Import.ImportProvidedTypeAsILType amap m (fi.PApply((fun fi -> fi.DeclaringType),m))).TypeRef
#endif
/// Get the scope used to interpret IL metadata
@@ -1035,7 +1386,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo(_,pd) -> pd.Name
#if EXTENSIONTYPING
- | ProvidedField(_,fi,_,m) -> fi.PUntaint((fun fi -> fi.Name),m)
+ | ProvidedField(_,fi,m) -> fi.PUntaint((fun fi -> fi.Name),m)
#endif
/// Indicates if the field is readonly (in the .NET/C# sense of readonly)
@@ -1043,17 +1394,15 @@ type ILFieldInfo =
match x with
| ILFieldInfo(_,pd) -> pd.IsInitOnly
#if EXTENSIONTYPING
- | ProvidedField(_,fi,_,m) -> fi.PUntaint((fun fi -> fi.IsInitOnly),m)
+ | ProvidedField(_,fi,m) -> fi.PUntaint((fun fi -> fi.IsInitOnly),m)
#endif
-
-
- /// Indicates if the field is a member of a struct or enum type
+ /// Indicates if the field is a member of a struct or enum type
member x.IsValueType =
match x with
| ILFieldInfo(tinfo,_) -> tinfo.IsValueType
#if EXTENSIONTYPING
- | ProvidedField(g,_,_,_) -> isStructTy g x.EnclosingType
+ | ProvidedField(amap,_,_) -> isStructTy amap.g x.EnclosingType
#endif
/// Indicates if the field is static
@@ -1061,7 +1410,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo(_,pd) -> pd.IsStatic
#if EXTENSIONTYPING
- | ProvidedField(_,fi,_,m) -> fi.PUntaint((fun fi -> fi.IsStatic),m)
+ | ProvidedField(_,fi,m) -> fi.PUntaint((fun fi -> fi.IsStatic),m)
#endif
/// Indicates if the field has the 'specialname' property in the .NET IL
@@ -1069,7 +1418,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo(_,pd) -> pd.IsSpecialName
#if EXTENSIONTYPING
- | ProvidedField(_,fi,_,m) -> fi.PUntaint((fun fi -> fi.IsSpecialName),m)
+ | ProvidedField(_,fi,m) -> fi.PUntaint((fun fi -> fi.IsSpecialName),m)
#endif
/// Indicates if the field is a literal field with an associated literal value
@@ -1077,9 +1426,9 @@ type ILFieldInfo =
match x with
| ILFieldInfo(_,pd) -> if pd.IsLiteral then pd.LiteralValue else None
#if EXTENSIONTYPING
- | ProvidedField(_,fi,_,m) ->
+ | ProvidedField(_,fi,m) ->
if fi.PUntaint((fun fi -> fi.IsLiteral),m) then
- Some (ConstantObjToILFieldInit m (fi.PUntaint((fun fi -> fi.GetRawConstantValue()),m)))
+ Some (ILFieldInit.FromProvidedObj m (fi.PUntaint((fun fi -> fi.GetRawConstantValue()),m)))
else
None
#endif
@@ -1089,7 +1438,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo (_,fdef) -> fdef.Type
#if EXTENSIONTYPING
- | ProvidedField(_,fi,amap,m) -> Import.ImportProvidedTypeAsILType amap m (fi.PApply((fun fi -> fi.FieldType),m))
+ | ProvidedField(amap,fi,m) -> Import.ImportProvidedTypeAsILType amap m (fi.PApply((fun fi -> fi.FieldType),m))
#endif
/// Get the type of the field as an F# type
@@ -1097,7 +1446,7 @@ type ILFieldInfo =
match x with
| ILFieldInfo (tinfo,fdef) -> ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] fdef.Type
#if EXTENSIONTYPING
- | ProvidedField(_,fi,amap,m) -> Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.FieldType),m))
+ | ProvidedField(amap,fi,m) -> Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.FieldType),m))
#endif
/// Get an (uninstantiated) reference to the field as an Abstract IL ILFieldRef
@@ -1184,52 +1533,57 @@ type UnionCaseInfo =
type ILPropInfo =
| ILPropInfo of ILTypeInfo * ILPropertyDef
- /// Get the declaring IL type of the property, including any generic instantiation
+ /// Get the declaring IL type of the IL property, including any generic instantiation
member x.ILTypeInfo = match x with (ILPropInfo(tinfo,_)) -> tinfo
- /// Get the raw Abstract IL metadata for the property
+ /// Get the raw Abstract IL metadata for the IL property
member x.RawMetadata = match x with (ILPropInfo(_,pd)) -> pd
- /// Get the name of the property
+ /// Get the name of the IL property
member x.PropertyName = x.RawMetadata.Name
- /// Gets the ILMethInfo of the 'get' method for the property
- member x.GetterMethod =
+ /// Gets the ILMethInfo of the 'get' method for the IL property
+ member x.GetterMethod(g) =
assert x.HasGetter
- let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata (Option.get x.RawMetadata.GetMethod)
- ILMethInfo(x.ILTypeInfo,None,mdef,[])
+ let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata x.RawMetadata.GetMethod.Value
+ ILMethInfo(g,x.ILTypeInfo.ToType,None,mdef,[])
- /// Gets the ILMethInfo of the 'set' method for the property
- member x.SetterMethod =
+ /// Gets the ILMethInfo of the 'set' method for the IL property
+ member x.SetterMethod(g) =
assert x.HasSetter
- let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata (Option.get x.RawMetadata.SetMethod)
- ILMethInfo(x.ILTypeInfo,None,mdef,[])
+ let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata x.RawMetadata.SetMethod.Value
+ ILMethInfo(g,x.ILTypeInfo.ToType,None,mdef,[])
- /// Indicates if the property has a 'get' method
+ /// Indicates if the IL property has a 'get' method
member x.HasGetter = isSome x.RawMetadata.GetMethod
- /// Indicates if the property has a 'set' method
+ /// Indicates if the IL property has a 'set' method
member x.HasSetter = isSome x.RawMetadata.SetMethod
- /// Indicates if the property is static
+ /// Indicates if the IL property is static
member x.IsStatic = (x.RawMetadata.CallingConv = ILThisConvention.Static)
- member x.IsVirtual =
- (x.HasGetter && x.GetterMethod.IsVirtual) ||
- (x.HasSetter && x.SetterMethod.IsVirtual)
+ /// Indicates if the IL property is virtual
+ member x.IsVirtual(g) =
+ (x.HasGetter && x.GetterMethod(g).IsVirtual) ||
+ (x.HasSetter && x.SetterMethod(g).IsVirtual)
- member x.IsNewSlot =
- (x.HasGetter && x.GetterMethod.IsNewSlot) ||
- (x.HasSetter && x.SetterMethod.IsNewSlot)
+ /// Indicates if the IL property is logically a 'newslot', i.e. hides any previous slots of the same name.
+ member x.IsNewSlot(g) =
+ (x.HasGetter && x.GetterMethod(g).IsNewSlot) ||
+ (x.HasSetter && x.SetterMethod(g).IsNewSlot)
+ /// Get the names and types of the indexer arguments associated wih the IL property.
member x.GetParamNamesAndTypes(amap,m) =
let (ILPropInfo (tinfo,pdef)) = x
pdef.Args |> ILList.toList |> List.map (fun ty -> ParamNameAndType(None, ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty) )
+ /// Get the types of the indexer arguments associated wih the IL property.
member x.GetParamTypes(amap,m) =
let (ILPropInfo (tinfo,pdef)) = x
pdef.Args |> ILList.toList |> List.map (fun ty -> ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty)
+ /// Get the return type of the IL property.
member x.GetPropertyType (amap,m) =
let (ILPropInfo (tinfo,pdef)) = x
ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] pdef.Type
@@ -1248,101 +1602,116 @@ type PropInfo =
| ILProp of TcGlobals * ILPropInfo
#if EXTENSIONTYPING
/// An F# use of a property backed by provided metadata
- | ProvidedProp of TcGlobals * Tainted<ProvidedPropertyInfo> * Import.ImportMap * range
+ | ProvidedProp of Import.ImportMap * Tainted<ProvidedPropertyInfo> * range
#endif
+ /// Try to get an arbitrary F# ValRef associated with the member. This is to determine if the member is virtual, amongst other things.
+ member x.ArbitraryValRef =
+ match x with
+ | FSProp(_,_,Some vref,_)
+ | FSProp(_,_,_, Some vref) -> Some vref
+ | FSProp(_,_,None,None) -> failwith "unreachable"
+ | _ -> None
+
+ /// Indicates if this property has an associated XML comment authored in this assembly.
member x.HasDirectXmlComment =
match x with
- | FSProp(g,_,Some(vref),_)
- | FSProp(g,_,_,Some(vref)) -> valRefInThisAssembly g.compilingFslib vref
+ | FSProp(g,_,Some vref,_)
+ | FSProp(g,_,_,Some vref) -> valRefInThisAssembly g.compilingFslib vref
#if EXTENSIONTYPING
| ProvidedProp _ -> true
#endif
| _ -> false
+ /// Get the logical name of the property.
member x.PropertyName =
match x with
| ILProp(_,x) -> x.PropertyName
| FSProp(_,_,Some vref,_)
| FSProp(_,_,_, Some vref) -> vref.PropertyName
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) -> pi.PUntaint((fun pi -> pi.Name),m)
+ | ProvidedProp(_,pi,m) -> pi.PUntaint((fun pi -> pi.Name),m)
#endif
| FSProp _ -> failwith "unreachable"
+ /// Indicates if this property has an associated getter method.
member x.HasGetter =
match x with
| ILProp(_,x) -> x.HasGetter
| FSProp(_,_,x,_) -> isSome x
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) -> pi.PUntaint((fun pi -> pi.CanRead),m)
+ | ProvidedProp(_,pi,m) -> pi.PUntaint((fun pi -> pi.CanRead),m)
#endif
+ /// Indicates if this property has an associated setter method.
member x.HasSetter =
match x with
| ILProp(_,x) -> x.HasSetter
| FSProp(_,_,_,x) -> isSome x
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) -> pi.PUntaint((fun pi -> pi.CanWrite),m)
+ | ProvidedProp(_,pi,m) -> pi.PUntaint((fun pi -> pi.CanWrite),m)
#endif
+ /// Get the enclosing type of the proeprty.
+ ///
+ /// If this is an extension member, then this is the apparent parent, i.e. the type the property appears to extend.
member x.EnclosingType =
match x with
| ILProp(_,x) -> x.ILTypeInfo.ToType
| FSProp(_,typ,_,_) -> typ
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,amap,m) ->
+ | ProvidedProp(amap,pi,m) ->
Import.ImportProvidedType amap m (pi.PApply((fun pi -> pi.DeclaringType),m))
#endif
+ /// Determine if this is an extension member.
+ member x.IsExtensionMember =
+ match x.ArbitraryValRef with Some vref -> vref.IsExtensionMember | _ -> false
/// True if the getter (or, if absent, the setter) is a virtual method
// REVIEW: for IL properties this is getter OR setter. For F# properties it is getter ELSE setter
member x.IsVirtualProperty =
match x with
- | ILProp(_,x) -> x.IsVirtual
+ | ILProp(g,x) -> x.IsVirtual(g)
| FSProp(_,_,Some vref,_)
- | FSProp(_,_,_, Some vref) -> MemberRefIsVirtual vref
+ | FSProp(_,_,_, Some vref) -> vref.IsVirtualMember
| FSProp _-> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
- let mi = RepresentativeMethodInfoOfPropertyInfo pi m
+ | ProvidedProp(_,pi,m) ->
+ let mi = ArbitraryMethodInfoOfPropertyInfo pi m
mi.PUntaint((fun mi -> mi.IsVirtual), m)
#endif
-
- // REVIEW: this doesn't accord precisely with the IsNewSlot definition for members
+ /// Indicates if the property is logically a 'newslot', i.e. hides any previous slots of the same name.
member x.IsNewSlot =
match x with
- | ILProp(_,x) -> x.IsNewSlot
+ | ILProp(g,x) -> x.IsNewSlot(g)
| FSProp(_,_,Some vref,_)
- | FSProp(_,_,_, Some vref) -> MemberRefIsDispatchSlot vref
+ | FSProp(_,_,_, Some vref) -> vref.IsDispatchSlotMember
| FSProp(_,_,None,None) -> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
- let mi = RepresentativeMethodInfoOfPropertyInfo pi m
+ | ProvidedProp(_,pi,m) ->
+ let mi = ArbitraryMethodInfoOfPropertyInfo pi m
mi.PUntaint((fun mi -> mi.IsHideBySig), m)
#endif
- /// True if the getter (or, if absent, the setter) for the property is a dispatch slot
+ /// Indicates if the getter (or, if absent, the setter) for the property is a dispatch slot.
// REVIEW: for IL properties this is getter OR setter. For F# properties it is getter ELSE setter
member x.IsDispatchSlot =
match x with
- | ILProp(_,x) -> x.IsVirtual
-
+ | ILProp(g,x) -> x.IsVirtual(g)
| FSProp(g,typ,Some vref,_)
| FSProp(g,typ,_, Some vref) ->
- isInterfaceTy g typ ||
- (let membInfo = (Option.get vref.MemberInfo)
- membInfo.MemberFlags.IsDispatchSlot)
+ isInterfaceTy g typ || (vref.MemberInfo.Value.MemberFlags.IsDispatchSlot)
| FSProp _ -> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
- let mi = RepresentativeMethodInfoOfPropertyInfo pi m
+ | ProvidedProp(_,pi,m) ->
+ let mi = ArbitraryMethodInfoOfPropertyInfo pi m
mi.PUntaint((fun mi -> mi.IsVirtual), m)
#endif
+ /// Indicates if this property is static.
member x.IsStatic =
match x with
| ILProp(_,x) -> x.IsStatic
@@ -1350,20 +1719,17 @@ type PropInfo =
| FSProp(_,_,_, Some vref) -> not vref.IsInstanceMember
| FSProp(_,_,None,None) -> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
- (RepresentativeMethodInfoOfPropertyInfo pi m).PUntaint((fun mi -> mi.IsStatic), m)
+ | ProvidedProp(_,pi,m) ->
+ (ArbitraryMethodInfoOfPropertyInfo pi m).PUntaint((fun mi -> mi.IsStatic), m)
#endif
+ /// Indicates if this property is marked 'override' and thus definitely overrides another property.
member x.IsDefiniteFSharpOverride =
- match x with
- | ILProp _ -> false
- | FSProp(_,_,Some vref,_)
- | FSProp(_,_,_,Some vref) -> MemberRefIsDefiniteFSharpOverride vref
- | FSProp(_,_,None,None) -> failwith "unreachable"
-#if EXTENSIONTYPING
- | ProvidedProp _ -> false
-#endif
+ match x.ArbitraryValRef with
+ | Some vref -> vref.IsDefiniteFSharpOverrideMember
+ | None -> false
+ /// Indicates if this property is an indexer property, i.e. a property with arguments.
member x.IsIndexer =
match x with
| ILProp(_,ILPropInfo(_,pdef)) -> pdef.Args.Length <> 0
@@ -1380,10 +1746,11 @@ type PropInfo =
| FSProp(_,_,None,None) ->
failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
+ | ProvidedProp(_,pi,m) ->
pi.PUntaint((fun pi -> pi.GetIndexParameters().Length), m)>0
#endif
+ /// Indicates if this is an F# property compiled as a CLI event, e.g. a [<CLIEvent>] property.
member x.IsFSharpEventProperty =
match x with
| FSProp(g,_,Some vref,None) -> vref.IsFSharpEventProperty(g)
@@ -1392,19 +1759,23 @@ type PropInfo =
#endif
| _ -> false
- // Property infos can combine getters and setters, assuming they are consistent w.r.t. 'virtual', indexer argument types etc.
- // When checking consistency we split these apart
+ /// Return a new property info where there is no associated setter, only an associated getter.
+ ///
+ /// Property infos can combine getters and setters, assuming they are consistent w.r.t. 'virtual', indexer argument types etc.
+ /// When checking consistency we split these apart
member x.DropSetter =
match x with
| FSProp(g,typ,Some vref,_) -> FSProp(g,typ,Some vref,None)
| _ -> x
+ /// Return a new property info where there is no associated getter, only an associated setter.
member x.DropGetter =
match x with
| FSProp(g,typ,_,Some vref) -> FSProp(g,typ,None,Some vref)
| _ -> x
+ /// Get the intra-assembly XML documentation for the property.
member x.XmlDoc =
match x with
| ILProp _ -> XmlDoc.Empty
@@ -1412,91 +1783,120 @@ type PropInfo =
| FSProp(_,_,_, Some vref) -> vref.XmlDoc
| FSProp(_,_,None,None) -> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
+ | ProvidedProp(_,pi,m) ->
XmlDoc (pi.PUntaint((fun pix -> (pix :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(pi.TypeProvider.PUntaintNoFailure(id))), m))
#endif
+ /// Get the TcGlobals associated with the object
member x.TcGlobals =
match x with
| ILProp(g,_) -> g
| FSProp(g,_,_,_) -> g
#if EXTENSIONTYPING
- | ProvidedProp(g,_,_,_) -> g
+ | ProvidedProp(amap,_,_) -> amap.g
+#endif
+
+ /// Indicates if the enclosing type for the property is a value type.
+ ///
+ /// For an extension property, this indicates if the property extends a struct type.
+ member x.IsValueType = isStructTy x.TcGlobals x.EnclosingType
+
+
+ /// Get the result type of the property
+ member x.GetPropertyType (amap,m) =
+ match x with
+ | ILProp (_,ilpinfo) -> ilpinfo.GetPropertyType (amap,m)
+ | FSProp (g,typ,Some vref,_)
+ | FSProp (g,typ,_,Some vref) ->
+ let inst = GetInstantiationForPropertyVal g (typ,vref)
+ ReturnTypeOfPropertyVal g vref.Deref |> instType inst
+
+ | FSProp _ -> failwith "unreachable"
+#if EXTENSIONTYPING
+ | ProvidedProp(_,pi,m) ->
+ Import.ImportProvidedType amap m (pi.PApply((fun pi -> pi.PropertyType),m))
#endif
- member x.IsValueType = isStructTy x.TcGlobals x.EnclosingType
-
- member x.ArbitraryValRef =
- match x with
- | FSProp(_,_,Some vref,_)
- | FSProp(_,_,_, Some vref) -> Some vref
- | FSProp(_,_,None,None) -> failwith "unreachable"
- | _ -> None
+ /// Get the names and types of the indexer parameters associated with the property
member x.GetParamNamesAndTypes(amap,m) =
match x with
| ILProp (_,ilpinfo) -> ilpinfo.GetParamNamesAndTypes(amap,m)
| FSProp (g,typ,Some vref,_)
| FSProp (g,typ,_,Some vref) ->
- let memberParentTypars,_mtps,_retTy,parentTyArgs = AnalyzeTypeOfMemberVal amap.g (typ,vref)
- let inst = mkTyparInst memberParentTypars parentTyArgs
- ArgInfosOfPropertyVal g vref.Deref |> List.map (ParamNameAndTypeOfArgInfo >> InstParamNameAndType inst)
+ let inst = GetInstantiationForPropertyVal g (typ,vref)
+ ArgInfosOfPropertyVal g vref.Deref |> List.map (ParamNameAndType.FromArgInfo >> ParamNameAndType.Instantiate inst)
| FSProp _ -> failwith "unreachable"
#if EXTENSIONTYPING
- | ProvidedProp (_,pi,_,m) ->
+ | ProvidedProp (_,pi,m) ->
[ for p in pi.PApplyArray((fun pi -> pi.GetIndexParameters()), "GetIndexParameters", m) do
let paramName = p.PUntaint((fun p -> match p.Name with null -> None | s -> Some s), m)
let paramType = Import.ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType), m))
yield ParamNameAndType(paramName, paramType) ]
#endif
- member x.GetPropertyType (amap,m) =
- match x with
- | ILProp (_,ilpinfo) -> ilpinfo.GetPropertyType (amap,m)
- | FSProp (g,typ,Some vref,_)
- | FSProp (g,typ,_,Some vref) ->
- let memberParentTypars,_,_,parentTyArgs = AnalyzeTypeOfMemberVal amap.g (typ,vref)
- let inst = mkTyparInst memberParentTypars parentTyArgs
- ReturnTypeOfPropertyVal g vref.Deref
- |> instType inst
-
- | FSProp _ -> failwith "unreachable"
-#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) ->
- Import.ImportProvidedType amap m (pi.PApply((fun pi -> pi.PropertyType),m))
-#endif
-
-
+ /// Get the details of the indexer parameters associated with the property
member x.GetParamDatas(amap,m) =
x.GetParamNamesAndTypes(amap,m)
|> List.map (fun (ParamNameAndType(nm,pty)) -> ParamData(false,false,NotOptional,nm, pty))
+ /// Get the types of the indexer parameters associated with the property
member x.GetParamTypes(amap,m) =
x.GetParamNamesAndTypes(amap,m) |> List.map (fun (ParamNameAndType(_,ty)) -> ty)
+ /// Get a MethInfo for the 'getter' method associated with the property
member x.GetterMethod =
match x with
- | ILProp(g,x) -> ILMeth(g,x.GetterMethod,None)
+ | ILProp(g,x) -> ILMeth(g,x.GetterMethod(g),None)
| FSProp(g,typ,Some vref,_) -> FSMeth(g,typ,vref,None)
#if EXTENSIONTYPING
- | ProvidedProp(g,pi,amap,m) ->
+ | ProvidedProp(amap,pi,m) ->
let meth = GetAndSanityCheckProviderMethod m pi (fun pi -> pi.GetGetMethod()) FSComp.SR.etPropertyCanReadButHasNoGetter
- ProvidedMeth(g, meth, amap, m)
+ ProvidedMeth(amap, meth, None, m)
#endif
| FSProp _ -> failwith "no getter method"
+ /// Get a MethInfo for the 'setter' method associated with the property
member x.SetterMethod =
match x with
- | ILProp(g,x) -> ILMeth(g,x.SetterMethod,None)
+ | ILProp(g,x) -> ILMeth(g,x.SetterMethod(g),None)
| FSProp(g,typ,_,Some vref) -> FSMeth(g,typ,vref,None)
#if EXTENSIONTYPING
- | ProvidedProp(g,pi,amap,m) ->
+ | ProvidedProp(amap,pi,m) ->
let meth = GetAndSanityCheckProviderMethod m pi (fun pi -> pi.GetSetMethod()) FSComp.SR.etPropertyCanWriteButHasNoSetter
- ProvidedMeth(g, meth, amap, m)
+ ProvidedMeth(amap, meth, None, m)
#endif
| FSProp _ -> failwith "no setter method"
+ /// Test whether two property infos have the same underlying definition.
+ ///
+ /// Uses the same techniques as 'MethInfosUseIdenticalDefinitions'.
+ static member PropInfosUseIdenticalDefinitions x1 x2 =
+ let optVrefEq g = function
+ | Some(v1), Some(v2) -> valRefEq g v1 v2
+ | None, None -> true
+ | _ -> false
+ match x1,x2 with
+ | ILProp(_, x1), ILProp(_, x2) -> (x1.RawMetadata === x2.RawMetadata)
+ | FSProp(g, _, vrefa1, vrefb1), FSProp(_, _, vrefa2, vrefb2) ->
+ (optVrefEq g (vrefa1, vrefa2)) && (optVrefEq g (vrefb1, vrefb2))
+#if EXTENSIONTYPING
+ | ProvidedProp(_,pi1,_), ProvidedProp(_,pi2,_) -> ProvidedPropertyInfo.TaintedEquals (pi1, pi2)
+#endif
+ | _ -> false
+
+ /// Calculates a hash code of property info (similar as previous)
+ member pi.ComputeHashCode() =
+ match pi with
+ | ILProp(_, x1) -> hash x1.RawMetadata.Name
+ | FSProp(_,_,vrefOpt1, vrefOpt2) ->
+ // Hash on option<string>*option<string>
+ let vth = (vrefOpt1 |> Option.map (fun vr -> vr.LogicalName), (vrefOpt2 |> Option.map (fun vr -> vr.LogicalName)))
+ hash vth
+#if EXTENSIONTYPING
+ | ProvidedProp(_,pi,_) -> ProvidedPropertyInfo.TaintedGetHashCode(pi)
+#endif
//-------------------------------------------------------------------------
// ILEventInfo
@@ -1514,14 +1914,14 @@ type ILEventInfo =
member x.ILTypeInfo = match x with (ILEventInfo(tinfo,_)) -> tinfo
/// Get the ILMethInfo describing the 'add' method associated with the event
- member x.AddMethod =
+ member x.AddMethod(g) =
let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata x.RawMetadata.AddMethod
- ILMethInfo(x.ILTypeInfo,None,mdef,[])
+ ILMethInfo(g,x.ILTypeInfo.ToType,None,mdef,[])
/// Get the ILMethInfo describing the 'remove' method associated with the event
- member x.RemoveMethod =
+ member x.RemoveMethod(g) =
let mdef = resolveILMethodRef x.ILTypeInfo.RawMetadata x.RawMetadata.RemoveMethod
- ILMethInfo(x.ILTypeInfo,None,mdef,[])
+ ILMethInfo(g,x.ILTypeInfo.ToType,None,mdef,[])
/// Get the declaring type of the event as an ILTypeRef
member x.TypeRef = x.ILTypeInfo.ILTypeRef
@@ -1530,12 +1930,15 @@ type ILEventInfo =
member x.Name = x.RawMetadata.Name
/// Indicates if the property is static
- member x.IsStatic = x.AddMethod.IsStatic
+ member x.IsStatic(g) = x.AddMethod(g).IsStatic
override x.ToString() = x.ILTypeInfo.ToString() + "::" + x.Name
//-------------------------------------------------------------------------
// Helpers for EventInfo
+/// An exception type used to raise an error using the old error system.
+///
+/// Error text: "A definition to be compiled as a .NET event does not have the expected form. Only property members can be compiled as .NET events."
exception BadEventTransformation of range
/// Properties compatible with type IDelegateEvent and atributed with CLIEvent are special: we generate metadata and add/remove methods
@@ -1571,17 +1974,21 @@ type EventInfo =
| ILEvent of TcGlobals * ILEventInfo
#if EXTENSIONTYPING
/// An F# use of an event backed by provided metadata
- | ProvidedEvent of TcGlobals * Import.ImportMap * Tainted<ProvidedEventInfo> * range
+ | ProvidedEvent of Import.ImportMap * Tainted<ProvidedEventInfo> * range
#endif
+ /// Get the enclosing type of the event.
+ ///
+ /// If this is an extension member, then this is the apparent parent, i.e. the type the event appears to extend.
member x.EnclosingType =
match x with
| ILEvent(_,e) -> e.ILTypeInfo.ToType
| FSEvent (_,p,_,_) -> p.EnclosingType
#if EXTENSIONTYPING
- | ProvidedEvent (_,amap,ei,m) -> Import.ImportProvidedType amap m (ei.PApply((fun ei -> ei.DeclaringType),m))
+ | ProvidedEvent (amap,ei,m) -> Import.ImportProvidedType amap m (ei.PApply((fun ei -> ei.DeclaringType),m))
#endif
+ /// Indicates if this event has an associated XML comment authored in this assembly.
member x.HasDirectXmlComment =
match x with
| FSEvent (_,p,_,_) -> p.HasDirectXmlComment
@@ -1590,436 +1997,117 @@ type EventInfo =
#endif
| _ -> false
+ /// Get the intra-assembly XML documentation for the property.
member x.XmlDoc =
match x with
| ILEvent _ -> XmlDoc.Empty
| FSEvent (_,p,_,_) -> p.XmlDoc
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,m) ->
+ | ProvidedEvent (_,ei,m) ->
XmlDoc (ei.PUntaint((fun eix -> (eix :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(ei.TypeProvider.PUntaintNoFailure(id))), m))
#endif
+ /// Get the logical name of the event.
member x.EventName =
match x with
| ILEvent(_,e) -> e.Name
| FSEvent (_,p,_,_) -> p.PropertyName
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,m) -> ei.PUntaint((fun ei -> ei.Name), m)
+ | ProvidedEvent (_,ei,m) -> ei.PUntaint((fun ei -> ei.Name), m)
#endif
+ /// Indicates if this property is static.
member x.IsStatic =
match x with
- | ILEvent(_,e) -> e.IsStatic
+ | ILEvent(g,e) -> e.IsStatic(g)
| FSEvent (_,p,_,_) -> p.IsStatic
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,m) ->
+ | ProvidedEvent (_,ei,m) ->
let meth = GetAndSanityCheckProviderMethod m ei (fun ei -> ei.GetAddMethod()) FSComp.SR.etEventNoAdd
meth.PUntaint((fun mi -> mi.IsStatic), m)
#endif
+ /// Get the TcGlobals associated with the object
member x.TcGlobals =
match x with
| ILEvent(g,_) -> g
| FSEvent(g,_,_,_) -> g
#if EXTENSIONTYPING
- | ProvidedEvent (g,_,_,_) -> g
+ | ProvidedEvent (amap,_,_) -> amap.g
#endif
+ /// Indicates if the enclosing type for the event is a value type.
+ ///
+ /// For an extension event, this indicates if the event extends a struct type.
member x.IsValueType = isStructTy x.TcGlobals x.EnclosingType
+ /// Get the 'add' method associated with an event
member x.GetAddMethod() =
match x with
- | ILEvent(g,e) -> ILMeth(g,e.AddMethod,None)
+ | ILEvent(g,e) -> ILMeth(g,e.AddMethod(g),None)
| FSEvent(g,p,addValRef,_) -> FSMeth(g,p.EnclosingType,addValRef,None)
#if EXTENSIONTYPING
- | ProvidedEvent (g,amap,ei,m) ->
+ | ProvidedEvent (amap,ei,m) ->
let meth = GetAndSanityCheckProviderMethod m ei (fun ei -> ei.GetAddMethod()) FSComp.SR.etEventNoAdd
- ProvidedMeth(g, meth, amap, m)
+ ProvidedMeth(amap, meth, None, m)
#endif
+ /// Get the 'remove' method associated with an event
member x.GetRemoveMethod() =
match x with
- | ILEvent(g,e) -> ILMeth(g,e.RemoveMethod,None)
+ | ILEvent(g,e) -> ILMeth(g,e.RemoveMethod(g),None)
| FSEvent(g,p,_,removeValRef) -> FSMeth(g,p.EnclosingType,removeValRef,None)
#if EXTENSIONTYPING
- | ProvidedEvent (g,amap,ei,m) ->
+ | ProvidedEvent (amap,ei,m) ->
let meth = GetAndSanityCheckProviderMethod m ei (fun ei -> ei.GetRemoveMethod()) FSComp.SR.etEventNoRemove
- ProvidedMeth(g, meth, amap, m)
+ ProvidedMeth(amap, meth, None, m)
#endif
-
+ /// Try to get an arbitrary F# ValRef associated with the member. This is to determine if the member is virtual, amongst other things.
member x.ArbitraryValRef =
match x with
| FSEvent(_,_,addValRef,_) -> Some addValRef
| _ -> None
+ /// Get the delegate type associated with the event.
member x.GetDelegateType(amap,m) =
match x with
| ILEvent(_,ILEventInfo(tinfo,edef)) ->
// Get the delegate type associated with an IL event, taking into account the instantiation of the
// declaring type.
- if isNone edef.Type then error (nonStandardEventError x.EventName m);
+ if isNone edef.Type then error (nonStandardEventError x.EventName m)
ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] edef.Type.Value
| FSEvent(g,p,_,_) ->
FindDelegateTypeOfPropertyEvent g amap x.EventName m (p.GetPropertyType(amap,m))
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,_) ->
+ | ProvidedEvent (_,ei,_) ->
Import.ImportProvidedType amap m (ei.PApply((fun ei -> ei.EventHandlerType), m))
#endif
-type ILMethInfo with
- /// Build IL method infos.
- static member Create (amap, m, tinfo:ILTypeInfo, extInfo:ILTypeRef option, extMethPri, md: ILMethodDef) =
- let tinst,scoref =
- match extInfo with
- | None ->
- tinfo.TypeInst,tinfo.ILScopeRef
- | Some tref ->
- // C# extension methods have no type typars
- [], tref.Scope
- let mtps = Import.ImportILGenericParameters (fun () -> amap) m scoref tinst md.GenericParams
- ILMeth (amap.g,ILMethInfo(tinfo,extInfo, md,mtps),extMethPri)
-
-
-
-/// Tests whether two method infos have the same underlying definition.
-/// Used to merge operator overloads collected from left and right of an operator constraint.
-let MethInfosUseIdenticalDefinitions _g x1 x2 =
- match x1,x2 with
- | ILMeth(_,x1,_), ILMeth(_,x2,_) -> (x1.RawMetadata === x2.RawMetadata)
- | FSMeth(g,_,vref1,_), FSMeth(_,_,vref2,_) -> valRefEq g vref1 vref2
- | DefaultStructCtor(g,ty1), DefaultStructCtor(_,ty2) -> tyconRefEq g (tcrefOfAppTy g ty1) (tcrefOfAppTy g ty2)
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi1,_,_),ProvidedMeth(_,mi2,_,_) -> ProvidedMethodBase.TaintedEquals (mi1, mi2)
-#endif
- | _ -> false
-
-/// Tests whether two property infos have the same underlying definition.
-/// Uses the same techniques as pervious 'MethInfosUseIdenticalDefinitions'.
-let PropInfosUseIdenticalDefinitions x1 x2 =
- let optVrefEq g = function
- | Some(v1), Some(v2) -> valRefEq g v1 v2
- | None, None -> true
- | _ -> false
- match x1,x2 with
- | ILProp(_, x1), ILProp(_, x2) -> (x1.RawMetadata === x2.RawMetadata)
- | FSProp(g, _, vrefa1, vrefb1), FSProp(_, _, vrefa2, vrefb2) ->
- (optVrefEq g (vrefa1, vrefa2)) && (optVrefEq g (vrefb1, vrefb2))
-#if EXTENSIONTYPING
- | ProvidedProp(_,pi1,_,_), ProvidedProp(_,pi2,_,_) -> ProvidedPropertyInfo.TaintedEquals (pi1, pi2)
-#endif
- | _ -> false
-
-/// Test whether two event infos have the same underlying definition.
-let EventInfosUseIdenticalDefintions x1 x2 =
- match x1, x2 with
- | FSEvent(g, pi1, vrefa1, vrefb1), FSEvent(_, pi2, vrefa2, vrefb2) ->
- PropInfosUseIdenticalDefinitions pi1 pi2 && valRefEq g vrefa1 vrefa2 && valRefEq g vrefb1 vrefb2
- | ILEvent(_, x1), ILEvent(_, x2) -> (x1.RawMetadata === x2.RawMetadata)
+ /// Test whether two event infos have the same underlying definition.
+ static member EventInfosUseIdenticalDefintions x1 x2 =
+ match x1, x2 with
+ | FSEvent(g, pi1, vrefa1, vrefb1), FSEvent(_, pi2, vrefa2, vrefb2) ->
+ PropInfo.PropInfosUseIdenticalDefinitions pi1 pi2 && valRefEq g vrefa1 vrefa2 && valRefEq g vrefb1 vrefb2
+ | ILEvent(_, x1), ILEvent(_, x2) -> (x1.RawMetadata === x2.RawMetadata)
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei1,_), ProvidedEvent (_,_,ei2,_) -> ProvidedEventInfo.TaintedEquals (ei1, ei2)
+ | ProvidedEvent (_,ei1,_), ProvidedEvent (_,ei2,_) -> ProvidedEventInfo.TaintedEquals (ei1, ei2)
#endif
- | _ -> false
+ | _ -> false
-/// Calculates a hash code of method info. Note: this is a very imperfect implementation,
-/// but it works decently for comparing methods in the language service...
-let GetMethInfoHashCode mi =
- match mi with
- | ILMeth(_,x1,_) -> hash x1.RawMetadata.Name
- | FSMeth(_,_,vref,_) -> hash vref.LogicalName
- | DefaultStructCtor(_,_ty) -> 34892 // "ty" doesn't support hashing. We could use "hash (tcrefOfAppTy g ty).CompiledName" or
- // something but we don't have a "g" parameter here yet. But this hash need only be very approximate anyway
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,_,_) -> ProvidedMethodInfo.TaintedGetHashCode(mi)
-#endif
-
-/// Calculates a hash code of property info (similar as previous)
-let GetPropInfoHashCode mi =
- match mi with
- | ILProp(_, x1) -> hash x1.RawMetadata.Name
- | FSProp(_,_,vrefOpt1, vrefOpt2) ->
- // Value to hash is option<string>*option<string>, which can be hashed efficiently
- let vth = (vrefOpt1 |> Option.map (fun vr -> vr.LogicalName), vrefOpt2 |> Option.map (fun vr -> vr.LogicalName))
- hash vth
-#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,_) -> ProvidedPropertyInfo.TaintedGetHashCode(pi)
-#endif
-
-/// Calculates a hash code of event info (similar as previous)
-let GetEventInfoHashCode mi =
- match mi with
- | ILEvent(_, x1) -> hash x1.RawMetadata.Name
- | FSEvent(_, pi, vref1, vref2) -> hash (GetPropInfoHashCode pi, vref1.LogicalName, vref2.LogicalName)
-#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,_) -> ProvidedEventInfo.TaintedGetHashCode(ei)
-#endif
-
-/// Apply a type instantiation to a method info, i.e. apply the instantiation to the enclosing type.
-let InstMethInfo amap m inst meth =
- match meth with
- | ILMeth(_g,x,pri) ->
- match x with
- | ILMethInfo(tinfo,_,_,_) -> ILMethInfo.Create(amap, m, tinfo.Instantiate inst, x.ExtensionMethodInfo, pri, x.RawMetadata)
- | _ -> failwith "not supported"
- | FSMeth(g,typ,vref,pri) -> FSMeth(g,instType inst typ,vref,pri)
- | DefaultStructCtor(g,typ) -> DefaultStructCtor(g,instType inst typ)
-#if EXTENSIONTYPING
- | ProvidedMeth _ ->
- match inst with
- | [] -> meth
- | _ -> assert false; failwith "Not supported"
-#endif
-
-
-/// Combine the type instantiation and generic method instantiation
-let CombineMethInsts ttps mtps tinst minst = (mkTyparInst ttps tinst @ mkTyparInst mtps minst)
-
-#if EXTENSIONTYPING
-/// Get the return type of a provided method, where 'void' is returned as 'None'
-let GetCompiledReturnTyOfProvidedMethodInfo amap m (mi:Tainted<ProvidedMethodBase>) =
- let returnType =
- if mi.PUntaint((fun mi -> mi.IsConstructor),m) then
- mi.PApply((fun mi -> mi.DeclaringType),m)
- else mi.Coerce<ProvidedMethodInfo>(m).PApply((fun mi -> mi.ReturnType),m)
- let typ = Import.ImportProvidedType amap m returnType
- if isVoidTy amap.g typ then None else Some typ
-#endif
-
-/// The slotsig returned by methInfo.GetSlotSig is in terms of the type parameters on the parent type of the overriding method.
-/// Reverse-map the slotsig so it is in terms of the type parameters for the overriding method
-let ReparentSlotSigToUseMethodTypars g m ovByMethValRef slotsig =
- match PartitionValRefTypars g ovByMethValRef with
- | Some(_,enclosingTypars,_,_,_) ->
- let parentToMemberInst,_ = mkTyparToTyparRenaming (ovByMethValRef.MemberApparentParent.Typars(m)) enclosingTypars
- let res = instSlotSig parentToMemberInst slotsig
- res
- | None ->
- // Note: it appears PartitionValRefTypars should never return 'None'
- slotsig
-
-
-/// Construct the data representing a parameter in the signature of an abstract method slot
-let mkSlotParam (ty,argInfo:ArgReprInfo) = TSlotParam(Option.map textOfId argInfo.Name, ty, false,false,false,argInfo.Attribs)
-
-/// Construct the data representing the signature of an abstract method slot
-let mkSlotSig (nm,typ,ctps,mtps,paraml,retTy) = copySlotSig (TSlotSig(nm,typ,ctps,mtps,paraml,retTy))
-
-
-type MethInfo with
- /// Get the return type of a method info, where 'void' is returned as 'None'
- member minfo.GetCompiledReturnTy (amap, m, minst) =
- match minfo with
- | ILMeth(_g,ilminfo,_) ->
- ilminfo.GetCompiledReturnTy(amap, m, minst)
- | FSMeth(g,typ,vref,_) ->
- let memberParentTypars,memberMethodTypars,retTy,parentTyArgs = AnalyzeTypeOfMemberVal g (typ,vref)
- retTy |> Option.map (instType (CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs minst))
- | DefaultStructCtor _ -> None
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,amap,m) ->
- GetCompiledReturnTyOfProvidedMethodInfo amap m mi
-#endif
-
- /// Get the return type of a method info, where 'void' is returned as 'unit'
- member minfo.GetFSharpReturnTy(amap, m, minst) =
- minfo.GetCompiledReturnTy(amap, m, minst) |> GetFSharpViewOfReturnType amap.g
-
- /// Get the parameter types of a method info
- member minfo.GetParamTypes(amap, m, minst) =
- match minfo with
- | ILMeth(_g,ilminfo,_) ->
- // A single group of tupled arguments
- [ ilminfo.GetParamTypes(amap,m,minst) ]
- | FSMeth(g,typ,vref,_) ->
- let memberParentTypars,memberMethodTypars,_,parentTyArgs = AnalyzeTypeOfMemberVal g (typ,vref)
- let paramTypes = ParamNameAndTypesOfMember g vref
- let inst = CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs minst
- paramTypes |> List.mapSquared (fun (ParamNameAndType(_,ty)) -> instType inst ty)
- | DefaultStructCtor _ -> []
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,amap,m) ->
- // A single group of tupled arguments
- [ [ for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters",m) do
- yield Import.ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType),m)) ] ]
-#endif
-
- /// Get the (zero or one) 'self'/'this'/'object' arguments associated with a method. An instance extension method returns
- /// one object argument.
- member minfo.GetObjArgTypes (amap, m, minst) =
- match minfo with
- | ILMeth(_g,ilminfo,_) -> ilminfo.GetObjArgTypes(amap, m, minst)
- | FSMeth(_g,typ,vref,_) -> if vref.IsInstanceMember then [typ] else []
- | DefaultStructCtor _ -> []
-#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,amap,m) ->
- if mi.PUntaint((fun mi -> mi.IsStatic || mi.IsConstructor),m) then
- [] // no 'this' argument
- else
- [ Import.ImportProvidedType amap m (mi.PApply((fun mi -> mi.DeclaringType),m)) ] // find the type of the 'this' argument
-#endif
-
- /// Get the parameter attributes of a method info, which get combined with the parameter names and types
- member minfo.GetParamAttribs(amap, m) =
- match minfo with
- | ILMeth(g,ilMethInfo,_) ->
- [ [ for p in ilMethInfo.ParamMetadata do
- let isParamArrayArg = TryFindILAttribute g.attrib_ParamArrayAttribute p.CustomAttrs
- let isOutArg = (p.IsOut && not p.IsIn)
- // Note: we get default argument values from VB and other .NET language metadata
- let optArgInfo = OptionalArgInfoOfILParameter g amap m ilMethInfo.MetadataScope ilMethInfo.ActualTypeInst p
- yield (isParamArrayArg, isOutArg, optArgInfo) ] ]
-
- | FSMeth(g,_,vref,_) ->
- vref
- |> ArgInfosOfMember g
- |> List.mapSquared (fun (ty,argInfo) ->
- let isParamArrayArg = HasFSharpAttribute g g.attrib_ParamArrayAttribute argInfo.Attribs
- let isOutArg = HasFSharpAttribute g g.attrib_OutAttribute argInfo.Attribs && isByrefTy g ty
- let isOptArg = HasFSharpAttribute g g.attrib_OptionalArgumentAttribute argInfo.Attribs
- // Note: can't specify caller-side default arguments in F#, by design (default is specified on the callee-side)
- let optArgInfo = if isOptArg then CalleeSide else NotOptional
- (isParamArrayArg,isOutArg,optArgInfo))
-
- | DefaultStructCtor _ ->
- [[]]
-
-#if EXTENSIONTYPING
- | ProvidedMeth(g,mi,_,_) ->
- // A single group of tupled arguments
- [ [for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
- let isParamArrayArg = p.PUntaint((fun px -> (px :> IProvidedCustomAttributeProvider).GetAttributeConstructorArgs(p.TypeProvider.PUntaintNoFailure(id), typeof<System.ParamArrayAttribute>.FullName).IsSome),m)
- let optArgInfo = OptionalArgInfoOfProvidedParameter g amap m p
- yield (isParamArrayArg, p.PUntaint((fun p -> p.IsOut), m), optArgInfo)] ]
-#endif
-
-
-
- /// Get the signature of an abstract method slot.
- //
- // This code has grown organically over time. We've managed to unify the ILMeth+ProvidedMeth paths.
- // The FSMeth, ILMeth+ProvidedMeth paths can probably be unified too.
- member minfo.GetSlotSig(amap, m) =
- match minfo with
- | FSMeth(g,typ,vref,_) ->
- match vref.RecursiveValInfo with
- | ValInRecScope(false) -> error(Error((FSComp.SR.InvalidRecursiveReferenceToAbstractSlot()),m));
- | _ -> ()
-
- let allTyparsFromMethod,_,retTy,_ = GetTypeOfMemberInMemberForm g vref
- // A slot signature is w.r.t. the type variables of the type it is associated with.
- // So we have to rename from the member type variables to the type variables of the type.
- let formalEnclosingTypars = (tcrefOfAppTy g typ).Typars(m)
- let formalEnclosingTyparsFromMethod,formalMethTypars = List.chop formalEnclosingTypars.Length allTyparsFromMethod
- let methodToParentRenaming,_ = mkTyparToTyparRenaming formalEnclosingTyparsFromMethod formalEnclosingTypars
- let formalParams =
- vref
- |> ArgInfosOfMember g
- |> List.mapSquared (map1Of2 (instType methodToParentRenaming) >> mkSlotParam )
- let formalRetTy = Option.map (instType methodToParentRenaming) retTy
- mkSlotSig(minfo.LogicalName, minfo.EnclosingType, formalEnclosingTypars, formalMethTypars, formalParams, formalRetTy)
- | DefaultStructCtor _ -> error(InternalError("no slotsig for DefaultStructCtor",m))
- | _ ->
- let g = minfo.TcGlobals
- // slotsigs must contain the formal types for the arguments and return type
- // a _formal_ 'void' return type is represented as a 'unit' type.
- // slotsigs are independent of instantiation: if an instantiation
- // happens to make the return type 'unit' (i.e. it was originally a variable type
- // then that does not correspond to a slotsig compiled as a 'void' return type.
- // REVIEW: should we copy down attributes to slot params?
- let tcref = tcrefOfAppTy g minfo.EnclosingType
- let formalEnclosingTyparsOrig = tcref.Typars(m)
- let formalEnclosingTypars = copyTypars formalEnclosingTyparsOrig
- let _,formalEnclosingTyparTys = FixupNewTypars m [] [] formalEnclosingTyparsOrig formalEnclosingTypars
- let formalMethTypars = copyTypars minfo.FormalMethodTypars
- let _,formalMethTyparTys = FixupNewTypars m formalEnclosingTypars formalEnclosingTyparTys minfo.FormalMethodTypars formalMethTypars
- let formalRetTy, formalParams =
- match minfo with
- | ILMeth(_,ilminfo,_) ->
- let ftinfo = ILTypeInfo.FromType g (TType_app(tcref,formalEnclosingTyparTys))
- let formalRetTy = ImportReturnTypeFromMetaData amap m ilminfo.RawMetadata.Return.Type ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys
- let formalParams =
- [ [ for p in ilminfo.RawMetadata.Parameters do
- let paramType = ImportTypeFromMetadata amap m ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys p.Type
- yield TSlotParam(p.Name, paramType, p.IsIn, p.IsOut, p.IsOptional, []) ] ]
- formalRetTy, formalParams
-#if EXTENSIONTYPING
- | ProvidedMeth (_,mi,_,_) ->
- // GENERIC TYPE PROVIDERS: for generics, formal types should be generated here, not the actual types
- // For non-generic type providers there is no difference
- let formalRetTy = minfo.GetCompiledReturnTy(amap, m, formalMethTyparTys)
- // GENERIC TYPE PROVIDERS: formal types should be generated here, not the actual types
- // For non-generic type providers there is no difference
- let formalParams =
- [ [ for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
- let paramName = p.PUntaint((fun p -> match p.Name with null -> None | s -> Some s),m)
- let paramType = Import.ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType),m))
- let isIn, isOut,isOptional = p.PUntaint((fun p -> p.IsIn, p.IsOut, p.IsOptional),m)
- yield TSlotParam(paramName, paramType, isIn, isOut, isOptional, []) ] ]
- formalRetTy, formalParams
-#endif
- | _ -> failwith "unreachable"
- mkSlotSig(minfo.LogicalName, minfo.EnclosingType, formalEnclosingTypars, formalMethTypars,formalParams, formalRetTy)
-
- /// Get the ParamData objects for the parameters of a MethInfo
- member minfo.GetParamDatas(amap, m, minst) =
- let paramNamesAndTypes =
- match minfo with
- | ILMeth(_g,ilminfo,_) ->
- [ ilminfo.GetParamNamesAndTypes(amap,m,minst) ]
- | FSMeth(g,typ,vref,_) ->
- let memberParentTypars,memberMethodTypars,_,parentTyArgs = AnalyzeTypeOfMemberVal g (typ,vref)
- let items = ParamNameAndTypesOfMember g vref
- let inst = CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs minst
- items |> InstParamNameAndTypes inst
- | DefaultStructCtor _ ->
- [[]]
-#if EXTENSIONTYPING
- | ProvidedMeth(_g,mi,amap,_) ->
- // A single set of tupled parameters
- [ [for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
- let pname =
- match p.PUntaint((fun p -> p.Name), m) with
- | null -> None
- | name -> Some name
- let ptyp =
- match p.PApply((fun p -> p.ParameterType), m) with
- | Tainted.Null -> amap.g.unit_ty
- | parameterType -> Import.ImportProvidedType amap m parameterType
- yield ParamNameAndType(pname,ptyp) ] ]
-
-#endif
-
- let paramAttribs = minfo.GetParamAttribs(amap, m)
- (paramAttribs,paramNamesAndTypes) ||> List.map2 (List.map2 (fun (isParamArrayArg,isOutArg,optArgInfo) (ParamNameAndType(nmOpt,pty)) ->
- ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,pty)))
-
-
- /// Select all the type parameters of the declaring type of a method.
- ///
- /// For extension methods, no type parameters are returned,
- /// because all the type parameters are considered to be associated with the method, rather than the declaring type, even for extension
- /// methods extending generic types.
- member minfo.GetFormalTyparsOfEnclosingType m =
- match minfo with
- | ILMeth(_,ilminfo,_) ->
- match ilminfo with
- | ILMethInfo(tinfo,_,_,_) when not ilminfo.IsCSharpExtensionMethod -> tinfo.FormalTypars m
- | _ -> [] // For extension methods all type variables are on the method
- | FSMeth(g,typ,vref,_) ->
- let memberParentTypars,_,_,_ = AnalyzeTypeOfMemberVal g (typ,vref)
- memberParentTypars
- | DefaultStructCtor(g,typ) ->
- (tcrefOfAppTy g typ).Typars(m)
+ /// Calculates a hash code of event info (similar as previous)
+ member ei.ComputeHashCode() =
+ match ei with
+ | ILEvent(_, x1) -> hash x1.RawMetadata.Name
+ | FSEvent(_, pi, vref1, vref2) -> hash ( pi.ComputeHashCode(), vref1.LogicalName, vref2.LogicalName)
#if EXTENSIONTYPING
- | ProvidedMeth (g,_,_,_) ->
- (tcrefOfAppTy g minfo.EnclosingType).Typars(m)
+ | ProvidedEvent (_,ei,_) -> ProvidedEventInfo.TaintedGetHashCode(ei)
#endif
//-------------------------------------------------------------------------
-// Method signatures
-//-------------------------------------------------------------------------
+// Helpers associated with getting and comparing method signatures
/// Represents the information about the compiled form of a method signature. Used when analyzing implementation
@@ -2039,7 +2127,7 @@ let CompiledSigOfMeth g amap m (minfo:MethInfo) =
// of the enclosing type. This instaniations can be used to interpret those type parameters
let fmtpinst =
let parentTyArgs = argsOfAppTy g minfo.EnclosingType
- let memberParentTypars = minfo.GetFormalTyparsOfEnclosingType m
+ let memberParentTypars = minfo.GetFormalTyparsOfDeclaringType m
mkTyparInst memberParentTypars parentTyArgs
CompiledSig(vargtys,vrty,formalMethTypars,fmtpinst)
@@ -2096,7 +2184,7 @@ type AccessorDomain =
| AccessibleFrom of CompilationPath list * TyconRef option
| AccessibleFromEverywhere
- /// An AccessorDomain which returns everything but .NET private/internal items
+ /// An AccessorDomain which returns everything but .NET private/internal items.
/// This is used
/// - when solving member trait constraints, which are solved independently of accessibility
/// - for failure paths in error reporting, e.g. to produce an error that an F# item is not accessible
@@ -2153,13 +2241,21 @@ module AccessibilityLogic =
(access = ILMemberAccess.Public) || accessibleByFamily || accessibleByInternalsVisibleTo
| AccessibleFromSomewhere ->
true
-
- let private isILTypeDefAccessible ad (tdef: ILTypeDef) =
- match ad with
- | AccessibleFromSomewhere -> true
- | AccessibleFromEverywhere
- | AccessibleFromSomeFSharpCode
- | AccessibleFrom _ -> tdef.Access = ILTypeDefAccess.Public || tdef.Access = ILTypeDefAccess.Nested ILMemberAccess.Public
+
+ /// Determine if tdef is accessible. If tdef.Access = ILTypeDefAccess.Nested then encTyconRefOpt s TyconRef of enclosing type
+ /// and visibility of tdef is obtained using member access rules
+ let private isILTypeDefAccessible (amap : Import.ImportMap) m ad encTyconRefOpt (tdef: ILTypeDef) =
+ match tdef.Access with
+ | ILTypeDefAccess.Nested nestedAccess ->
+ match encTyconRefOpt with
+ | None -> assert false; true
+ | Some encTyconRef -> CheckILMemberAccess amap.g amap m encTyconRef ad nestedAccess
+ | _ ->
+ match ad with
+ | AccessibleFromSomewhere -> true
+ | AccessibleFromEverywhere
+ | AccessibleFromSomeFSharpCode
+ | AccessibleFrom _ -> tdef.Access = ILTypeDefAccess.Public
// is tcref visible through the AccessibleFrom(cpaths,_)? note: InternalsVisibleTo extends those cpaths.
let private isTyconAccessibleViaVisibleTo ad (tcrefOfViewedItem:TyconRef) =
@@ -2169,56 +2265,87 @@ module AccessibilityLogic =
| AccessibleFromSomeFSharpCode -> false
| AccessibleFrom (cpaths,_tcrefViewedFromOption) ->
canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath
-
- let private isILTypeInfoAccessible ad (ILTypeInfo(tcrefOfViewedItem,_,_tinst,tdef)) =
- isILTypeDefAccessible ad tdef || isTyconAccessibleViaVisibleTo ad tcrefOfViewedItem
+
+ /// Determine if given IL based TyconRef is accessible. If TyconRef is nested then we'll walk though the list of enclosing types
+ /// and test if all of them are accessible
+ let private isILTypeInfoAccessible amap m ad (tcrefOfViewedItem : TyconRef) =
+ let scoref, enc, tdef = tcrefOfViewedItem.ILTyconInfo
+ let rec check parentTycon path =
+ let ilTypeDefAccessible =
+ match parentTycon with
+ | None ->
+ match path with
+ | [] -> assert false; true // in this case path should have at least one element
+ | [x] -> isILTypeDefAccessible amap m ad None x // shortcut for non-nested types
+ | x::xs ->
+ // check if enclosing type x is accessible.
+ // if yes - create parent tycon for type 'x' and continue with the rest of the path
+ isILTypeDefAccessible amap m ad None x &&
+ (
+ let parentILTyRef = mkRefForNestedILTypeDef scoref ([], x)
+ let parentTycon = Import.ImportILTypeRef amap m parentILTyRef
+ check (Some (parentTycon, [x])) xs
+ )
+ | (Some (parentTycon, parentPath)) ->
+ match path with
+ | [] -> true // end of path is reached - success
+ | x::xs ->
+ // check if x is accessible from the parent tycon
+ // if yes - create parent tycon for type 'x' and continue with the rest of the path
+ isILTypeDefAccessible amap m ad (Some parentTycon) x &&
+ (
+ let parentILTyRef = mkRefForNestedILTypeDef scoref (parentPath, x)
+ let parentTycon = Import.ImportILTypeRef amap m parentILTyRef
+ check (Some (parentTycon, parentPath @ [x])) xs
+ )
+ ilTypeDefAccessible || isTyconAccessibleViaVisibleTo ad tcrefOfViewedItem
+
+ check None (enc @ [tdef])
- let private isILMemberAccessible g amap m ad tinfo access =
- isILTypeInfoAccessible ad tinfo && CheckILMemberAccess g amap m tinfo.TyconRef ad access
+ let private isILMemberAccessible g amap m adType ad (ILTypeInfo(tcrefOfViewedItem, _, _, _)) access =
+ isILTypeInfoAccessible amap m adType tcrefOfViewedItem && CheckILMemberAccess g amap m tcrefOfViewedItem ad access
- let IsEntityAccessible ad (tcref:TyconRef) =
+ let IsEntityAccessible amap m ad (tcref:TyconRef) =
if tcref.IsILTycon then
- (isTyconAccessibleViaVisibleTo ad tcref) || // either: visibleTo (e.g. InternalsVisibleTo)
- (let _scoref,enc,tdef = tcref.ILTyconInfo // or: accessible, along with all enclosing types
- List.forall (isILTypeDefAccessible ad) enc &&
- isILTypeDefAccessible ad tdef)
+ isILTypeInfoAccessible amap m ad tcref
else
tcref.Accessibility |> IsAccessible ad
- let CheckTyconAccessible m ad tcref =
- let res = IsEntityAccessible ad tcref
+ let CheckTyconAccessible amap m ad tcref =
+ let res = IsEntityAccessible amap m ad tcref
if not res then
errorR(Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName,m))
res
- let IsTyconReprAccessible ad tcref =
- IsEntityAccessible ad tcref &&
+ let IsTyconReprAccessible amap m ad tcref =
+ IsEntityAccessible amap m ad tcref &&
IsAccessible ad tcref.TypeReprAccessibility
- let CheckTyconReprAccessible m ad tcref =
- CheckTyconAccessible m ad tcref &&
+ let CheckTyconReprAccessible amap m ad tcref =
+ CheckTyconAccessible amap m ad tcref &&
(let res = IsAccessible ad tcref.TypeReprAccessibility
if not res then
- errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName,m));
+ errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName,m))
res)
- let rec IsTypeAccessible g ad ty =
+ let rec IsTypeAccessible g amap m ad ty =
not (isAppTy g ty) ||
let tcref,tinst = destAppTy g ty
- IsEntityAccessible ad tcref && IsTypeInstAccessible g ad tinst
+ IsEntityAccessible amap m ad tcref && IsTypeInstAccessible g amap m ad tinst
- and IsProvidedMemberAccessible g amap m ad ty access =
- let isTyAccessible = IsTypeAccessible g ad ty
+ and IsProvidedMemberAccessible (amap:Import.ImportMap) m ad ty access =
+ let g = amap.g
+ let isTyAccessible = IsTypeAccessible g amap m ad ty
if not isTyAccessible then false
else
not (isAppTy g ty) ||
let tcrefOfViewedItem,_ = destAppTy g ty
CheckILMemberAccess g amap m tcrefOfViewedItem ad access
- and IsTypeInstAccessible g ad tinst =
+ and IsTypeInstAccessible g amap m ad tinst =
match tinst with
| [] -> true
- | _ -> List.forall (IsTypeAccessible g ad) tinst
+ | _ -> List.forall (IsTypeAccessible g amap m ad) tinst
let getILAccess isPublic isFamily isFamilyOrAssembly isFamilyAndAssembly =
if isPublic then ILMemberAccess.Public
@@ -2229,21 +2356,21 @@ module AccessibilityLogic =
let IsILFieldInfoAccessible g amap m ad x =
match x with
- | ILFieldInfo (tinfo,fd) -> isILMemberAccessible g amap m ad tinfo fd.Access
+ | ILFieldInfo (tinfo,fd) -> isILMemberAccessible g amap m ad ad tinfo fd.Access
#if EXTENSIONTYPING
- | ProvidedField (g, tpfi, amap, m) as pfi ->
+ | ProvidedField (amap, tpfi, m) as pfi ->
let access = tpfi.PUntaint((fun fi -> getILAccess fi.IsPublic fi.IsFamily fi.IsFamilyOrAssembly fi.IsFamilyAndAssembly), m)
- IsProvidedMemberAccessible g amap m ad pfi.EnclosingType access
+ IsProvidedMemberAccessible amap m ad pfi.EnclosingType access
#endif
let IsILEventInfoAccessible g amap m ad (ILEventInfo (tinfo,edef)) =
let access = (resolveILMethodRef tinfo.RawMetadata edef.AddMethod).Access
- isILMemberAccessible g amap m ad tinfo access
-
- let IsILMethInfoAccessible g amap m ad = function
- | ILMethInfo (tinfo,_,mdef,_) -> isILMemberAccessible g amap m ad tinfo mdef.Access
- | ILFSMethInfo (tcref,_,_,mdef) -> CheckILMemberAccess g amap m tcref ad mdef.Access
+ isILMemberAccessible g amap m ad ad tinfo access
+ let private IsILMethInfoAccessible g amap m adType ad ilminfo =
+ match ilminfo with
+ | ILMethInfo (_,typ,None,mdef,_) -> isILMemberAccessible g amap m adType ad (ILTypeInfo.FromType g typ) mdef.Access
+ | ILMethInfo (_,_,Some declaringTyconRef,mdef,_) -> CheckILMemberAccess g amap m declaringTyconRef ad mdef.Access
let IsILPropInfoAccessible g amap m ad (ILPropInfo(tinfo,pdef)) =
let tdef = tinfo.RawMetadata
@@ -2255,7 +2382,7 @@ module AccessibilityLogic =
| None -> ILMemberAccess.Public
| Some mref -> (resolveILMethodRef tdef mref).Access
- isILMemberAccessible g amap m ad tinfo ilAccess
+ isILMemberAccessible g amap m ad ad tinfo ilAccess
let IsValAccessible ad (vref:ValRef) =
vref.Accessibility |> IsAccessible ad
@@ -2264,52 +2391,65 @@ module AccessibilityLogic =
if not (IsValAccessible ad vref) then
errorR (Error (FSComp.SR.valueIsNotAccessible vref.DisplayName,m))
- let IsUnionCaseAccessible ad (ucref:UnionCaseRef) =
- IsTyconReprAccessible ad ucref.TyconRef &&
+ let IsUnionCaseAccessible amap m ad (ucref:UnionCaseRef) =
+ IsTyconReprAccessible amap m ad ucref.TyconRef &&
IsAccessible ad ucref.UnionCase.Accessibility
- let CheckUnionCaseAccessible m ad (ucref:UnionCaseRef) =
- CheckTyconReprAccessible m ad ucref.TyconRef &&
+ let CheckUnionCaseAccessible amap m ad (ucref:UnionCaseRef) =
+ CheckTyconReprAccessible amap m ad ucref.TyconRef &&
(let res = IsAccessible ad ucref.UnionCase.Accessibility
if not res then
errorR (Error (FSComp.SR.unionCaseIsNotAccessible ucref.CaseName,m))
res)
- let IsRecdFieldAccessible ad (rfref:RecdFieldRef) =
- IsTyconReprAccessible ad rfref.TyconRef &&
+ let IsRecdFieldAccessible amap m ad (rfref:RecdFieldRef) =
+ IsTyconReprAccessible amap m ad rfref.TyconRef &&
IsAccessible ad rfref.RecdField.Accessibility
- let CheckRecdFieldAccessible m ad (rfref:RecdFieldRef) =
- CheckTyconReprAccessible m ad rfref.TyconRef &&
+ let CheckRecdFieldAccessible amap m ad (rfref:RecdFieldRef) =
+ CheckTyconReprAccessible amap m ad rfref.TyconRef &&
(let res = IsAccessible ad rfref.RecdField.Accessibility
if not res then
errorR (Error (FSComp.SR.fieldIsNotAccessible rfref.FieldName,m))
res)
- let CheckRecdFieldInfoAccessible m ad (rfinfo:RecdFieldInfo) =
- CheckRecdFieldAccessible m ad rfinfo.RecdFieldRef |> ignore
+ let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) =
+ CheckRecdFieldAccessible amap m ad rfinfo.RecdFieldRef |> ignore
let CheckILFieldInfoAccessible g amap m ad finfo =
if not (IsILFieldInfoAccessible g amap m ad finfo) then
errorR (Error (FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName,m))
-
- let IsMethInfoAccessible amap m ad = function
- | ILMeth (g,x,_) -> IsILMethInfoAccessible g amap m ad x
+
+ /// Uses a separate accessibility domains for containing type and method itself
+ /// This makes sense cases like
+ /// type A() =
+ /// type protected B() =
+ /// member this.Public() = ()
+ /// member protected this.Protected() = ()
+ /// type C() =
+ /// inherit A()
+ /// let x = A.B()
+ /// do x.Public()
+ /// when calling x.SomeMethod() we need to use 'adTyp' do verify that type of x is accessible from C
+ /// and 'ad' to determine accessibility of SomeMethod.
+ /// I.e when calling x.Public() and x.Protected() -in both cases first check should succeed and second - should fail in the latter one.
+ let IsTypeAndMethInfoAccessible amap m adTyp ad = function
+ | ILMeth (g,x,_) -> IsILMethInfoAccessible g amap m adTyp ad x
| FSMeth (_,_,vref,_) -> IsValAccessible ad vref
- | DefaultStructCtor(g,typ) -> IsTypeAccessible g ad typ
+ | DefaultStructCtor(g,typ) -> IsTypeAccessible g amap m ad typ
#if EXTENSIONTYPING
- | ProvidedMeth(g,tpmb,_amap,m) as etmi ->
+ | ProvidedMeth(amap,tpmb,_,m) as etmi ->
let access = tpmb.PUntaint((fun mi -> getILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly), m)
- IsProvidedMemberAccessible g amap m ad etmi.EnclosingType access
+ IsProvidedMemberAccessible amap m ad etmi.EnclosingType access
#endif
-
+ let IsMethInfoAccessible amap m ad minfo = IsTypeAndMethInfoAccessible amap m ad ad minfo
let IsPropInfoAccessible g amap m ad = function
| ILProp (_,x) -> IsILPropInfoAccessible g amap m ad x
| FSProp (_,_,Some vref,_)
| FSProp (_,_,_,Some vref) -> IsValAccessible ad vref
#if EXTENSIONTYPING
- | ProvidedProp (g, tppi, amap, m) as pp->
+ | ProvidedProp (amap, tppi, m) as pp->
let access =
let a = tppi.PUntaint((fun ppi ->
let tryGetILAccessForProvidedMethodBase (mi : ProvidedMethodBase) =
@@ -2320,7 +2460,7 @@ module AccessibilityLogic =
| None -> tryGetILAccessForProvidedMethodBase(ppi.GetSetMethod())
| x -> x), m)
defaultArg a ILMemberAccess.Public
- IsProvidedMemberAccessible g amap m ad pp.EnclosingType access
+ IsProvidedMemberAccessible amap m ad pp.EnclosingType access
#endif
| _ -> false
@@ -2347,7 +2487,7 @@ module AttributeChecking =
ignore m; ignore f3
match metadataOfTycon tcref.Deref with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let provAttribs = info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)),m)
match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with
| Some args -> f3 args
@@ -2373,7 +2513,6 @@ module AttributeChecking =
#endif
let TryBindMethInfoAttribute g m (AttribInfo(atref,_) as attribSpec) minfo f1 f2 f3 =
- ignore f3
BindMethInfoAttributes m minfo
(fun ilAttribs -> TryDecodeILAttribute g atref (Some(atref.Scope)) ilAttribs |> Option.bind f1)
(fun fsAttribs -> TryFindFSharpAttribute g attribSpec fsAttribs |> Option.bind f2)
@@ -2393,6 +2532,13 @@ module AttributeChecking =
(function (Attrib(_,_,[ AttribStringArg msg ],_,_,_,_)) -> Some msg | _ -> None)
(function [ Some ((:? string as msg) : obj) ] -> Some msg | _ -> None)
+ let MethInfoHasAttribute g m attribSpec minfo =
+ TryBindMethInfoAttribute g m attribSpec minfo
+ (fun _ -> Some ())
+ (fun _ -> Some ())
+ (fun _ -> Some ())
+ |> Option.isSome
+
/// This is used to detect the 'DefaultMemberAttribute' and 'ConditionalAttribute' attributes (on type definitions)
let TryFindTyconRefStringAttribute g m attribSpec tcref =
TryBindTyconRefAttribute g m attribSpec tcref
@@ -2400,6 +2546,13 @@ module AttributeChecking =
(function (Attrib(_,_,[ AttribStringArg(msg) ],_,_,_,_)) -> Some msg | _ -> None)
(function [ Some ((:? string as msg) : obj) ] -> Some msg | _ -> None)
+ let TyconRefHasAttribute g m attribSpec tcref =
+ TryBindTyconRefAttribute g m attribSpec tcref
+ (fun _ -> Some ())
+ (fun _ -> Some ())
+ (fun _ -> Some ())
+ |> Option.isSome
+
/// Check IL attributes for 'ObsoleteAttribute'
let private CheckILAttributes g cattrs m =
@@ -2519,8 +2672,8 @@ module AttributeChecking =
| FSProp(g,_,_,Some vref) -> CheckFSharpAttributes g vref.Attribs m
| FSProp _ -> failwith "CheckPropInfoAttributes: unreachable"
#if EXTENSIONTYPING
- | ProvidedProp (g,pi,_amap,m) ->
- CheckProvidedAttributes g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m))
+ | ProvidedProp (amap,pi,m) ->
+ CheckProvidedAttributes amap.g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m))
#endif
@@ -2530,25 +2683,26 @@ module AttributeChecking =
| ILFieldInfo(_,pd) ->
CheckILAttributes g pd.CustomAttrs m |> CommitOperationResult
#if EXTENSIONTYPING
- | ProvidedField (g,fi,_amap,m) ->
- CheckProvidedAttributes g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) |> CommitOperationResult
+ | ProvidedField (amap,fi,m) ->
+ CheckProvidedAttributes amap.g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) |> CommitOperationResult
#endif
let CheckMethInfoAttributes g m tyargsOpt minfo =
- let search = BindMethInfoAttributes m minfo
- (fun ilAttribs -> Some(CheckILAttributes g ilAttribs m))
- (fun fsAttribs ->
- let res =
- CheckFSharpAttributes g fsAttribs m ++ (fun () ->
- if isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then
- ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName),m));
- else
- CompleteD)
- Some res)
-#if EXTENSIONTYPING
- (fun provAttribs -> Some (CheckProvidedAttributes g m provAttribs))
+ let search =
+ BindMethInfoAttributes m minfo
+ (fun ilAttribs -> Some(CheckILAttributes g ilAttribs m))
+ (fun fsAttribs ->
+ let res =
+ CheckFSharpAttributes g fsAttribs m ++ (fun () ->
+ if isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then
+ ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName),m))
+ else
+ CompleteD)
+ Some res)
+#if EXTENSIONTYPING
+ (fun provAttribs -> Some (CheckProvidedAttributes g m provAttribs))
#else
- (fun _provAttribs -> None)
+ (fun _provAttribs -> None)
#endif
match search with
| Some res -> res
@@ -2601,7 +2755,7 @@ module AttributeChecking =
| FSProp (g,_,_,Some vref) -> CheckFSharpAttributesForUnseen g vref.Attribs m
| FSProp _ -> failwith "CheckPropInfoAttributes: unreachable"
#if EXTENSIONTYPING
- | ProvidedProp (_g,pi,_amap,m) ->
+ | ProvidedProp (_amap,pi,m) ->
CheckProvidedAttributesForUnseen (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) m
#endif
@@ -2635,27 +2789,20 @@ open AttributeChecking
/// Build an expression node that is a call to a .NET method.
let BuildILMethInfoCall g amap m isProp (minfo:ILMethInfo) valUseFlags minst direct args =
- let valu =
- match minfo with
- | ILMethInfo(tinfo,_,_,_) -> tinfo.IsValueType
- | ILFSMethInfo(_,kind,_,_) when kind.IsValueType -> true
- | ILFSMethInfo _ -> false
+ let valu = isStructTy g minfo.ApparentEnclosingType
let ctor = minfo.IsConstructor
if minfo.IsClassConstructor then
- error (InternalError (minfo.ILName+": cannot call a class constructor",m));
+ error (InternalError (minfo.ILName+": cannot call a class constructor",m))
let useCallvirt =
not valu && not direct && minfo.IsVirtual
let isProtected = minfo.IsProtectedAccessibility
let ilMethRef = minfo.ILMethodRef
let newobj = ctor && (match valUseFlags with NormalValUse -> true | _ -> false)
- let exprty = if ctor then minfo.EnclosingType else minfo.GetFSharpReturnTy(amap, m, minst)
- // The thing might be an extension method, in which case adjust the instantiations
- let actualTypeInst = minfo.ActualTypeInst
- let actualMethInst = minst
- let retTy = (if not ctor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprty])
+ let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst)
+ let retTy = (if not ctor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy])
let isDllImport = minfo.IsDllImport g
- Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,newobj,valUseFlags,isProp,isDllImport,ilMethRef,actualTypeInst,actualMethInst, retTy),[],args,m),
- exprty
+ Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,newobj,valUseFlags,isProp,isDllImport,ilMethRef,minfo.DeclaringTypeInst,minst,retTy),[],args,m),
+ exprTy
/// Build a call to the System.Object constructor taking no arguments,
let BuildObjCtorCall g m =
@@ -2688,7 +2835,7 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) =
let tuptys = tupargs |> List.map (tyOfExpr g)
(mkTupled g m tupargs tuptys),
(argst, rangeOfFunTy g fty) )
- if not leftover.IsEmpty then error(InternalError("Unexpected "+string(leftover.Length)+" remaining arguments in method application",m));
+ if not leftover.IsEmpty then error(InternalError("Unexpected "+string(leftover.Length)+" remaining arguments in method application",m))
mkApps g ((vexp,vexprty),[],args3,m),
retTy
@@ -2698,7 +2845,7 @@ let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args =
let vexpty = vref.Type
let tpsorig,tau = vref.TypeScheme
let vtinst = argsOfAppTy g typ @ minst
- if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m));
+ if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m))
let expr = mkTyAppExpr m (vexp,vexpty) vtinst
let exprty = instType (mkTyparInst tpsorig vtinst) tau
BuildFSharpMethodApp g m vref expr exprty args
@@ -2718,7 +2865,7 @@ let MakeMethInfoCall amap m minfo minst args =
| DefaultStructCtor(_,typ) ->
mkDefault (m,typ)
#if EXTENSIONTYPING
- | ProvidedMeth(_,mi,amap,m) ->
+ | ProvidedMeth(amap,mi,_,m) ->
let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant
let ilMethodRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m mi
let isConstructor = mi.PUntaint((fun c -> c.IsConstructor), m)
@@ -2737,8 +2884,6 @@ let MakeMethInfoCall amap m minfo minst args =
/// Use the given function to select some of the member values from the members of an F# type
let SelectImmediateMemberVals g optFilter f (tcref:TyconRef) =
- let _aug = tcref.TypeContents
-
let chooser (vref:ValRef) =
match vref.MemberInfo with
// The 'when' condition is a workaround for the fact that values providing
@@ -2772,19 +2917,18 @@ let GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ =
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
let meths =
match optFilter with
| Some name -> st.PApplyArray ((fun st -> st.GetMethods() |> Array.filter (fun mi -> mi.Name = name) ), "GetMethods", m)
| None -> st.PApplyArray ((fun st -> st.GetMethods()), "GetMethods", m)
- [ for mi in meths -> ProvidedMeth(g,mi.Coerce(m),amap,m) ]
+ [ for mi in meths -> ProvidedMeth(amap,mi.Coerce(m),None,m) ]
#endif
| ILTypeMetadata (_,tdef) ->
- let tinfo = ILTypeInfo.FromType g typ
let mdefs = tdef.Methods
let mdefs = (match optFilter with None -> mdefs.AsList | Some nm -> mdefs.FindByName nm)
- mdefs |> List.map (fun mdef -> ILMethInfo.Create(amap, m, tinfo, None, None, mdef))
+ mdefs |> List.map (fun mdef -> MethInfo.CreateILMeth(amap, m, typ, mdef))
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
if not (isAppTy g typ) then []
else SelectImmediateMemberVals g optFilter (TrySelectMemberVal g optFilter typ None) (tcrefOfAppTy g typ)
@@ -2840,7 +2984,7 @@ let GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ =
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
let matchingProps =
match optFilter with
@@ -2851,7 +2995,7 @@ let GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ =
| None ->
st.PApplyArray((fun st -> st.GetProperties()), "GetProperties", m)
matchingProps
- |> Seq.map(fun pi -> ProvidedProp(g,pi,amap,m))
+ |> Seq.map(fun pi -> ProvidedProp(amap,pi,m))
|> List.ofSeq
#endif
| ILTypeMetadata (_,tdef) ->
@@ -2897,15 +3041,15 @@ type InfoReader(g:TcGlobals, amap:Import.ImportMap) =
let infos =
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
match optFilter with
| None ->
- [ for fi in st.PApplyArray((fun st -> st.GetFields()), "GetFields" , m) -> ProvidedField(g,fi,amap,m) ]
+ [ for fi in st.PApplyArray((fun st -> st.GetFields()), "GetFields" , m) -> ProvidedField(amap,fi,m) ]
| Some name ->
match st.PApply ((fun st -> st.GetField name), m) with
| Tainted.Null -> []
- | fi -> [ ProvidedField(g,fi,amap,m) ]
+ | fi -> [ ProvidedField(amap,fi,m) ]
#endif
| ILTypeMetadata (_,tdef) ->
let tinfo = ILTypeInfo.FromType g typ
@@ -2921,15 +3065,15 @@ type InfoReader(g:TcGlobals, amap:Import.ImportMap) =
let infos =
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
match optFilter with
| None ->
- [ for ei in st.PApplyArray((fun st -> st.GetEvents()), "GetEvents" , m) -> ProvidedEvent(g,amap,ei,m) ]
+ [ for ei in st.PApplyArray((fun st -> st.GetEvents()), "GetEvents" , m) -> ProvidedEvent(amap,ei,m) ]
| Some name ->
match st.PApply ((fun st -> st.GetEvent name), m) with
| Tainted.Null -> []
- | ei -> [ ProvidedEvent(g,amap,ei,m) ]
+ | ei -> [ ProvidedEvent(amap,ei,m) ]
#endif
| ILTypeMetadata (_,tdef) ->
let tinfo = ILTypeInfo.FromType g typ
@@ -3008,7 +3152,7 @@ type InfoReader(g:TcGlobals, amap:Import.ImportMap) =
| _ when nonNil rfinfos ->
match rfinfos with
| [single] -> Some(RecdFieldItem(single))
- | _ -> failwith "Unexpected multiple fields with the same name" // Because an explicit name was supplied.
+ | _ -> failwith "Unexpected multiple fields with the same name" // Because an explicit name (i.e., nm) was supplied, there will be only one element at most.
| _ -> acc)
g amap m
AllowMultiIntfInstantiations.No
@@ -3093,7 +3237,16 @@ type InfoReader(g:TcGlobals, amap:Import.ImportMap) =
match recdOrClassFieldInfoCache.Apply((Some nm,AccessibleFromSomewhere),m,typ) with
| [] -> None
| [single] -> Some single
- | _ -> failwith "unexpected multiple fields with same name"
+ | flds ->
+ // multiple fields with the same name can come from different classes,
+ // so filter them by the given type name
+ match tryDestAppTy g typ with
+ | None -> None
+ | Some tcref ->
+ match flds |> List.filter (fun rfinfo -> tyconRefEq g tcref rfinfo.TyconRef) with
+ | [] -> None
+ | [single] -> Some single
+ | _ -> failwith "unexpected multiple fields with same name" // Because it should have been already reported as duplicate fields
member x.TryFindNamedItemOfType (nm,ad,m,typ) =
namedItemsCache.Apply(((nm,ad),m,typ))
@@ -3115,7 +3268,7 @@ let private ConstructorInfosOfILType g amap m typ =
let tinfo = ILTypeInfo.FromType g typ
tinfo.RawMetadata.Methods.FindByName ".ctor"
|> List.filter (fun md -> match md.mdKind with MethodKind.Ctor -> true | _ -> false)
- |> List.map (fun mdef -> ILMethInfo.Create (amap, m, tinfo, None, None, mdef))
+ |> List.map (fun mdef -> MethInfo.CreateILMeth (amap, m, typ, mdef))
/// Get the constructors of any F# type
let GetIntrinsicConstructorInfosOfType (infoReader:InfoReader) m ty =
@@ -3124,10 +3277,10 @@ let GetIntrinsicConstructorInfosOfType (infoReader:InfoReader) m ty =
if isAppTy g ty then
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info ->
+ | ProvidedTypeMetadata info ->
let st = info.ProvidedType
[ for ci in st.PApplyArray((fun st -> st.GetConstructors()), "GetConstructors", m) do
- yield ProvidedMeth(g,ci.Coerce(m),amap,m) ]
+ yield ProvidedMeth(amap,ci.Coerce(m),None,m) ]
#endif
| ILTypeMetadata _ ->
ConstructorInfosOfILType g amap m ty
@@ -3357,7 +3510,7 @@ let GetSigOfFunctionForDelegate (infoReader:InfoReader) delty m ad =
| [] -> [g.unit_ty]
| _ -> compiledViewOfDelArgTys
let delRetTy = invokeMethInfo.GetFSharpReturnTy(amap, m, minst)
- CheckMethInfoAttributes g m None invokeMethInfo |> CommitOperationResult;
+ CheckMethInfoAttributes g m None invokeMethInfo |> CommitOperationResult
let fty = mkIteratedFunTy fsharpViewOfDelArgTys delRetTy
SigOfFunctionForDelegate(invokeMethInfo,compiledViewOfDelArgTys,delRetTy,fty)
diff --git a/src/fsharp/lexhelp.fs b/src/fsharp/lexhelp.fs
index 6b59e97..2d27596 100755
--- a/src/fsharp/lexhelp.fs
+++ b/src/fsharp/lexhelp.fs
@@ -10,8 +10,6 @@
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-// Helper functions for the F# lexer lex.mll
-
module internal Microsoft.FSharp.Compiler.Lexhelp
@@ -328,7 +326,7 @@ module Keywords =
| "__SOURCE_DIRECTORY__" ->
let filename = fileOfFileIndex lexbuf.StartPos.FileIndex
let dirname = if filename = stdinMockFilename then
- System.IO.Directory.GetCurrentDirectory() // TODO: is this right for Silverlight?
+ System.IO.Directory.GetCurrentDirectory()
else
filename |> FileSystem.SafeGetFullPath (* asserts that path is already absolute *)
|> System.IO.Path.GetDirectoryName
diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi
index 0b02fb8..77643e6 100755
--- a/src/fsharp/lexhelp.fsi
+++ b/src/fsharp/lexhelp.fsi
@@ -9,8 +9,6 @@
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-// Helper functions for the F# lexer lex.mll
-
module internal Microsoft.FSharp.Compiler.Lexhelp
diff --git a/src/fsharp/lowertop.fs b/src/fsharp/lowertop.fs
index f3969e8..7b50aef 100755
--- a/src/fsharp/lowertop.fs
+++ b/src/fsharp/lowertop.fs
@@ -82,13 +82,13 @@ let mkUnitDelayLambda g m e =
let callNonOverloadedMethod g amap m methName ty args =
match TryFindIntrinsicMethInfo (InfoReader(g,amap)) m AccessibleFromSomeFSharpCode methName ty with
- | [] -> error(InternalError("No method called '"^methName^"' was found",m));
+ | [] -> error(InternalError("No method called '"+methName+"' was found",m));
| ILMeth(g,ilMethInfo,_) :: _ ->
// REVIEW: consider if this should ever be a constrained call. At the moment typecheck limitations in the F# typechecker
// ensure the enumerator type used within computation expressions is not a struct type
BuildILMethInfoCall g amap m false ilMethInfo NormalValUse [] false args |> fst
| _ ->
- error(InternalError("The method called '"^methName^"' resolved to a non-IL type",m))
+ error(InternalError("The method called '"+methName+"' resolved to a non-IL type",m))
type LoweredSeqFirstPhaseResult =
diff --git a/src/fsharp/nameres.fs b/src/fsharp/nameres.fs
index 0ee42cc..fcc86d6 100755
--- a/src/fsharp/nameres.fs
+++ b/src/fsharp/nameres.fs
@@ -68,52 +68,61 @@ type NameResolver(g:TcGlobals,
// Helpers for unionconstrs and recdfields
//-------------------------------------------------------------------------
+/// Get references to all the union cases in the type definition
let UnionCaseRefsInTycon (modref: ModuleOrNamespaceRef) (tycon:Tycon) =
tycon.UnionCasesAsList |> List.map (mkModuleUnionCaseRef modref tycon)
+/// Get references to all the union cases defined in the module
let UnionCaseRefsInModuleOrNamespace (modref:ModuleOrNamespaceRef) =
[ for x in modref.ModuleOrNamespaceType.AllEntities do yield! UnionCaseRefsInTycon modref x ]
+/// Try to find a type with a union case of the given name
let TryFindTypeWithUnionCase (modref:ModuleOrNamespaceRef) (id: Ident) =
modref.ModuleOrNamespaceType.AllEntities
|> QueueList.tryFind (fun tycon -> tycon.GetUnionCaseByName id.idText |> isSome)
+/// Try to find a type with a record field of the given name
let TryFindTypeWithRecdField (modref:ModuleOrNamespaceRef) (id: Ident) =
modref.ModuleOrNamespaceType.AllEntities
|> QueueList.tryFind (fun tycon -> tycon.GetFieldByName id.idText |> isSome)
+/// Get the active pattern elements defined by a given value, if any
let ActivePatternElemsOfValRef vref =
match TryGetActivePatternInfo vref with
| Some (APInfo(_,nms) as apinfo) -> List.mapi (fun i _ -> APElemRef(apinfo,vref, i)) nms
| None -> []
+/// Try to make a reference to a value in a module.
+//
// mkNestedValRef may fail if the assembly load set is
// incomplete and the value is an extension member of a type that is not
// available. In some cases we can reasonably recover from this, e.g. by simply not adding
// an entry to a table. Callsites have to cope with the error (None) condition
// sensibly, e.g. in a way that won't change the way things are compiled as the
// assembly set is completed.
-let tryMkValRefInModRef modref vspec =
+let TryMkValRefInModRef modref vspec =
protectAssemblyExploration
None
(fun () -> Some (mkNestedValRef modref vspec))
+/// Get the active pattern elements defined by a given value, if any
let ActivePatternElemsOfVal modref vspec =
// If the assembly load set is incomplete then dont add anything to the table
- match tryMkValRefInModRef modref vspec with
+ match TryMkValRefInModRef modref vspec with
| None -> []
| Some vref -> ActivePatternElemsOfValRef vref
-let ActivePatternElemsOfModuleOrNamespace (modref:ModuleOrNamespaceRef) : ActivePatternElemRef NameMap =
+/// Get the active pattern elements defined in a module, if any. Cache in the slot in the module type.
+let ActivePatternElemsOfModuleOrNamespace (modref:ModuleOrNamespaceRef) : NameMap<ActivePatternElemRef> =
let mtyp = modref.ModuleOrNamespaceType
cacheOptRef mtyp.ActivePatternElemRefLookupTable (fun () ->
let aprefs = [ for x in mtyp.AllValsAndMembers do yield! ActivePatternElemsOfVal modref x ]
(Map.empty,aprefs) ||> List.fold (fun acc apref -> NameMap.add apref.Name apref acc) )
//---------------------------------------------------------------------------
-//
+// Name Resolution Items
//-------------------------------------------------------------------------
// Note: Active patterns are encoded like this:
@@ -121,72 +130,128 @@ let ActivePatternElemsOfModuleOrNamespace (modref:ModuleOrNamespaceRef) : Active
// match () with | A | B -> () // A and B are reported using 'Item.ActivePatternCase'
[<NoEquality; NoComparison>]
+/// Represents an item that results from name resolution
type Item =
- // These exist in the "eUnqualifiedItems" map in the type environment.
- | Value of ValRef
- | UnionCase of UnionCaseInfo
- | ActivePatternResult of ActivePatternInfo * TType * int * range
- | ActivePatternCase of ActivePatternElemRef
- | ExnCase of TyconRef
- | RecdField of RecdFieldInfo
-
- // The following are never in the items table but are valid results of binding
- // an identitifer in different circumstances.
- | NewDef of Ident
- | ILField of ILFieldInfo
- | Event of EventInfo
- | Property of string * PropInfo list
- | MethodGroup of string * MethInfo list
- | CtorGroup of string * MethInfo list
- | FakeInterfaceCtor of TType
- | DelegateCtor of TType
- | Types of string * TType list
- /// CustomOperation(nm, helpText, methInfo)
- ///
- /// Used to indicate the availability or resolution of a custom query operation such as 'sortBy' or 'where' in computation expression syntax
- | CustomOperation of string * (unit -> string option) * MethInfo option
- | CustomBuilder of string * ValRef
- | TypeVar of string
- | ModuleOrNamespaces of Tast.ModuleOrNamespaceRef list
- | ImplicitOp of Ident
- | ArgName of Ident * TType
- | SetterArg of Ident * Item
- | UnqualifiedType of TyconRef list
-
-let MakeMethGroup (nm,minfos:MethInfo list) =
- let minfos = minfos |> List.sortBy (fun minfo -> minfo.NumArgs |> List.sum)
- Item.MethodGroup (nm,minfos)
-
-let MakeCtorGroup (nm,minfos:MethInfo list) =
- let minfos = minfos |> List.sortBy (fun minfo -> minfo.NumArgs |> List.sum)
- Item.CtorGroup (nm,minfos)
-
-
-//---------------------------------------------------------------------------
-//
-//-------------------------------------------------------------------------
-
+ /// Represents the resolution of a name to an F# value or function.
+ | Value of ValRef
+ /// Represents the resolution of a name to an F# union case.
+ | UnionCase of UnionCaseInfo
+ /// Represents the resolution of a name to an F# active pattern result.
+ | ActivePatternResult of ActivePatternInfo * TType * int * range
+ /// Represents the resolution of a name to an F# active pattern case within the body of an active pattern.
+ | ActivePatternCase of ActivePatternElemRef
+ /// Represents the resolution of a name to an F# exception definition.
+ | ExnCase of TyconRef
+ /// Represents the resolution of a name to an F# record field.
+ | RecdField of RecdFieldInfo
+
+ // The following are never in the items table but are valid results of binding
+ // an identitifer in different circumstances.
+
+ /// Represents the resolution of a name at the point of its own definition.
+ | NewDef of Ident
+ /// Represents the resolution of a name to a .NET field
+ | ILField of ILFieldInfo
+ /// Represents the resolution of a name to an event
+ | Event of EventInfo
+ /// Represents the resolution of a name to a property
+ | Property of string * PropInfo list
+ /// Represents the resolution of a name to a group of methods
+ | MethodGroup of string * MethInfo list
+ /// Represents the resolution of a name to a constructor
+ | CtorGroup of string * MethInfo list
+ /// Represents the resolution of a name to the fake constructor simulated for an interface type.
+ | FakeInterfaceCtor of TType
+ /// Represents the resolution of a name to a delegate
+ | DelegateCtor of TType
+ /// Represents the resolution of a name to a group of types
+ | Types of string * TType list
+ /// CustomOperation(nm, helpText, methInfo)
+ ///
+ /// Used to indicate the availability or resolution of a custom query operation such as 'sortBy' or 'where' in computation expression syntax
+ | CustomOperation of string * (unit -> string option) * MethInfo option
+ /// Represents the resolution of a name to a custom builder in the F# computation expression syntax
+ | CustomBuilder of string * ValRef
+ /// Represents the resolution of a name to a type variable
+ | TypeVar of string
+ /// Represents the resolution of a name to a module or namespace
+ | ModuleOrNamespaces of Tast.ModuleOrNamespaceRef list
+ /// Represents the resolution of a name to an operator
+ | ImplicitOp of Ident * TraitConstraintSln option ref
+ /// Represents the resolution of a name to a named argument
+ | ArgName of Ident * TType
+ /// Represents the resolution of a name to a named property setter
+ | SetterArg of Ident * Item
+ /// Represents the potential resolution of an unqualified name to a type.
+ | UnqualifiedType of TyconRef list
+
+ static member MakeMethGroup (nm,minfos:MethInfo list) =
+ let minfos = minfos |> List.sortBy (fun minfo -> minfo.NumArgs |> List.sum)
+ Item.MethodGroup (nm,minfos)
+
+ static member MakeCtorGroup (nm,minfos:MethInfo list) =
+ let minfos = minfos |> List.sortBy (fun minfo -> minfo.NumArgs |> List.sum)
+ Item.CtorGroup (nm,minfos)
+
+ member d.DisplayName g =
+ match d with
+ | Item.Value v -> v.DisplayName
+ | Item.ActivePatternCase apref -> apref.Name
+ | Item.UnionCase uinfo -> DecompileOpName uinfo.UnionCase.DisplayName
+ | Item.ExnCase tcref -> tcref.LogicalName
+ | Item.RecdField rfinfo -> DecompileOpName rfinfo.RecdField.Name
+ | Item.NewDef id -> id.idText
+ | Item.ILField finfo -> finfo.FieldName
+ | Item.Event einfo -> einfo.EventName
+ | Item.Property(nm,_) -> nm
+ | Item.MethodGroup(nm,_) -> nm
+ | Item.CtorGroup(nm,_) -> DemangleGenericTypeName nm
+ | Item.FakeInterfaceCtor typ
+ | Item.DelegateCtor typ -> DemangleGenericTypeName (tcrefOfAppTy g typ).LogicalName
+ | Item.Types(nm,_) -> DemangleGenericTypeName nm
+ | Item.TypeVar nm -> nm
+ | Item.ModuleOrNamespaces(modref :: _) -> modref.DemangledModuleOrNamespaceName
+ | Item.ArgName (id,_) -> id.idText
+ | Item.SetterArg (id, _) -> id.idText
+ | Item.CustomOperation (customOpName,_,_) -> customOpName
+ | Item.CustomBuilder (nm,_) -> nm
+ | _ -> ""
+
+/// Information about an extension member held in the name resolution environment
type ExtensionMember =
+
+ /// F#-style Extrinsic extension member, defined in F# code
| FSExtMem of ValRef * ExtensionMethodPriority
- | ILExtMem of ILTypeRef * ILMethodDef * ExtensionMethodPriority
+
+ /// ILExtMem(declaringTyconRef, ilMetadata, pri)
+ ///
+ /// IL-style extension member, backed by some kind of method with an [<Extension>] attribute
+ | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority
+
+ /// Check if two extension members refer to the same definition
static member Equality g e1 e2 =
match e1, e2 with
| FSExtMem (vref1,_), FSExtMem (vref2,_) -> valRefEq g vref1 vref2
- | ILExtMem (_,md1,_), ILExtMem (_,md2,_) -> md1 === md2
+ | ILExtMem (_,md1,_), ILExtMem (_,md2,_) -> MethInfo.MethInfosUseIdenticalDefinitions md1 md2
| _ -> false
+
+ /// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced
+ /// later through 'open' get priority in overload resolution.
member x.Priority =
match x with
| FSExtMem (_,pri) -> pri
| ILExtMem (_,_,pri) -> pri
type FullyQualifiedFlag =
- // Only resolve full paths.
+ /// Only resolve full paths
| FullyQualified
+ /// Resolve any paths accessible via 'open'
| OpenQualified
[<NoEquality; NoComparison>]
+/// The environment of information used to resolve names
type NameResolutionEnv =
{ /// Display environment information for output
eDisplayEnv: DisplayEnv
@@ -234,7 +299,10 @@ type NameResolutionEnv =
eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap<NameArityPair,TyconRef>
/// Extension members by type and name
- eExtensionMembers: TyconRefMultiMap<ExtensionMember>
+ eIndexedExtensionMembers: TyconRefMultiMap<ExtensionMember>
+
+ /// Other extension members unindexed by type
+ eUnindexedExtensionMembers: ExtensionMember list
/// Typars (always available by unqualified names). Further typars can be
/// in the tpenv, a structure folded through each top-level definition.
@@ -242,6 +310,7 @@ type NameResolutionEnv =
}
+ /// The initial, empty name resolution environment. The mother of all things.
static member Empty(g) =
{ eDisplayEnv=DisplayEnv.Empty g
eModulesAndNamespaces=Map.empty
@@ -253,60 +322,95 @@ type NameResolutionEnv =
eTyconsByDemangledNameAndArity=LayeredMap.Empty
eFullyQualifiedTyconsByAccessNames=LayeredMultiMap.Empty
eFullyQualifiedTyconsByDemangledNameAndArity=LayeredMap.Empty
- eExtensionMembers=TyconRefMultiMap<_>.Empty
+ eIndexedExtensionMembers=TyconRefMultiMap<_>.Empty
+ eUnindexedExtensionMembers=[]
eTypars=Map.empty }
member nenv.DisplayEnv = nenv.eDisplayEnv
member nenv.FindUnqualifiedItem nm = nenv.eUnqualifiedItems.[nm]
+ /// Get the table of types, indexed by name and arity
member nenv.TyconsByDemangledNameAndArity fq =
match fq with
| FullyQualified -> nenv.eFullyQualifiedTyconsByDemangledNameAndArity
| OpenQualified -> nenv.eTyconsByDemangledNameAndArity
+ /// Get the table of types, indexed by name
member nenv.TyconsByAccessNames fq =
match fq with
| FullyQualified -> nenv.eFullyQualifiedTyconsByAccessNames
| OpenQualified -> nenv.eTyconsByAccessNames
+ /// Get the table of modules and namespaces
member nenv.ModulesAndNamespaces fq =
match fq with
| FullyQualified -> nenv.eFullyQualifiedModulesAndNamespaces
| OpenQualified -> nenv.eModulesAndNamespaces
-// Note: incrementing sequence of integers during type checking
-let nextExtensionMethodPriority() = uint64 (newStamp())
+//-------------------------------------------------------------------------
+// Helpers to do with extension members
+//-------------------------------------------------------------------------
+
+/// Allocate the next extension method priority. This is an incrementing sequence of integers
+/// during type checking.
+let NextExtensionMethodPriority() = uint64 (newStamp())
+
+/// Get the info for all the .NET-style extension members listed as static members in the type.
+let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap:Import.ImportMap) m (tcrefOfStaticClass:TyconRef) =
+ let g = amap.g
+ // Type must be non-generic and have 'Extension' attribute
+ if tcrefOfStaticClass.Typars(m).Length = 0 && TyconRefHasAttribute g m g.attrib_ExtensionAttribute tcrefOfStaticClass then
+ let pri = NextExtensionMethodPriority()
+ let typ = generalizedTyconRef tcrefOfStaticClass
+
+ // Get the 'plain' methods, not interpreted as extension methods
+ let minfos = GetImmediateIntrinsicMethInfosOfType (None, AccessorDomain.AccessibleFromSomeFSharpCode) g amap m typ
+ [ for minfo in minfos do
+ // Method must be static, have 'Extension' attribute, must not be curried, must have at least one argument
+ if not minfo.IsInstance && not minfo.IsExtensionMember && MethInfoHasAttribute g m g.attrib_ExtensionAttribute minfo && minfo.NumArgs.Length = 1 && minfo.NumArgs.Head >= 1 then
+ let ilExtMem = ILExtMem (tcrefOfStaticClass, minfo, pri)
+
+ // The results are indexed by the TyconRef of the first 'this' argument, if any.
+ // So we need to go and crack the type of the 'this' argument.
+ //
+ // This is convoluted because we only need the ILTypeRef of the first argument, and we don't
+ // want to read any other metadata as it can trigger missing-assembly errors. It turns out ImportILTypeRef
+ // is less eager in reading metadata than GetParamTypes.
+ //
+ // We don't use the index for the IL extension method for tuple of F# function types (e.g. if extension
+ // methods for tuple occur in C# code)
+ let thisTyconRef =
+ match metadataOfTycon tcrefOfStaticClass.Deref, minfo with
+ | ILTypeMetadata (scoref,_), ILMeth(_,ILMethInfo(_,_,_,ilMethod,_),_) ->
+ match ilMethod.ParameterTypes with
+ | firstTy :: _ ->
+ match firstTy with
+ | ILType.Boxed tspec | ILType.Value tspec ->
+ let tcref = (tspec |> rescopeILTypeSpec scoref).TypeRef |> Import.ImportILTypeRef amap m
+ if isCompiledTupleTyconRef g tcref || tyconRefEq g tcref g.fastFunc_tcr then None
+ else Some tcref
+ | _ -> None
+ | _ -> None
+ | _ ->
+ // The results are indexed by the TyconRef of the first 'this' argument, if any.
+ // So we need to go and crack the type of the 'this' argument.
+ let thisTy = minfo.GetParamTypes(amap,m,generalizeTypars minfo.FormalMethodTypars).Head.Head
+ match thisTy with
+ | AppTy amap.g (tcrefOfTypeExtended, _) -> Some tcrefOfTypeExtended
+ | _ -> None
+
+ match thisTyconRef with
+ | Some tcref -> yield Choice1Of2(tcref, ilExtMem)
+ | _ -> yield Choice2Of2 ilExtMem ]
+ else
+ []
//-------------------------------------------------------------------------
-// Item functions
+// Helpers to do with building environments
//-------------------------------------------------------------------------
-let DisplayNameOfItem g d =
- match d with
- | Item.Value v -> v.DisplayName
- | Item.ActivePatternCase apref -> apref.Name
- | Item.UnionCase uinfo -> DecompileOpName uinfo.UnionCase.DisplayName
- | Item.ExnCase tcref -> tcref.LogicalName
- | Item.RecdField rfinfo -> DecompileOpName rfinfo.RecdField.Name
- | Item.NewDef id -> id.idText
- | Item.ILField finfo -> finfo.FieldName
- | Item.Event einfo -> einfo.EventName
- | Item.Property(nm,_) -> nm
- | Item.MethodGroup(nm,_) -> nm
- | Item.CtorGroup(nm,_) -> DemangleGenericTypeName nm
- | Item.FakeInterfaceCtor typ
- | Item.DelegateCtor typ -> DemangleGenericTypeName (tcrefOfAppTy g typ).LogicalName
- | Item.Types(nm,_) -> DemangleGenericTypeName nm
- | Item.TypeVar nm -> nm
- | Item.ModuleOrNamespaces(modref :: _) -> modref.DemangledModuleOrNamespaceName
- | Item.ArgName (id,_) -> id.idText
- | Item.SetterArg (id, _) -> id.idText
- | Item.CustomOperation (customOpName,_,_) -> customOpName
- | Item.CustomBuilder (nm,_) -> nm
- | _ -> ""
-
/// For the operations that build the overall name resolution
/// tables, BulkAdd.Yes is set to true when "opening" a
/// namespace. If BulkAdd is true then add-and-collapse
@@ -333,11 +437,12 @@ let AddValRefsToItems (bulkAddMode: BulkAdd) (eUnqualifiedItems: LayeredMap<_,_>
let vref = vrefs.[0]
eUnqualifiedItems.Add (vref.LogicalName, Item.Value vref)
-let AddValRefToExtensionMembers pri (eExtensionMembers: TyconRefMultiMap<_>) (vref:ValRef) =
+/// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member
+let AddValRefToExtensionMembers pri (eIndexedExtensionMembers: TyconRefMultiMap<_>) (vref:ValRef) =
if vref.IsMember && vref.IsExtensionMember then
- eExtensionMembers.Add (vref.MemberApparentParent, FSExtMem (vref,pri))
+ eIndexedExtensionMembers.Add (vref.MemberApparentParent, FSExtMem (vref,pri))
else
- eExtensionMembers
+ eIndexedExtensionMembers
/// This entrypoint is used to add some extra items to the environment for Visual Studio, e.g. static members
@@ -348,9 +453,10 @@ let AddFakeNamedValRefToNameEnv nm nenv vref =
let AddFakeNameToNameEnv nm nenv item =
{nenv with eUnqualifiedItems= nenv.eUnqualifiedItems.Add (nm, item) }
+/// Add a set of F# values to the environment.
let AddValRefsToNameEnvWithPriority bulkAddMode pri nenv vrefs =
{nenv with eUnqualifiedItems= AddValRefsToItems bulkAddMode nenv.eUnqualifiedItems vrefs;
- eExtensionMembers = (nenv.eExtensionMembers,vrefs) ||> Array.fold (AddValRefToExtensionMembers pri);
+ eIndexedExtensionMembers = (nenv.eIndexedExtensionMembers,vrefs) ||> Array.fold (AddValRefToExtensionMembers pri);
ePatItems =
(nenv.ePatItems,vrefs) ||> Array.fold (fun acc vref ->
let ePatItems =
@@ -365,142 +471,125 @@ let AddValRefsToNameEnvWithPriority bulkAddMode pri nenv vrefs =
ePatItems) }
+/// Add a single F# value to the environment.
let AddValRefToNameEnv nenv vref =
- AddValRefsToNameEnvWithPriority BulkAdd.No (nextExtensionMethodPriority()) nenv [| vref |]
+ AddValRefsToNameEnvWithPriority BulkAdd.No (NextExtensionMethodPriority()) nenv [| vref |]
+/// Add a set of active pattern result tags to the environment.
let AddActivePatternResultTagsToNameEnv (apinfo: PrettyNaming.ActivePatternInfo) nenv ty m =
let nms = apinfo.Names
let apresl = nms |> List.mapi (fun j nm -> nm, j)
{ nenv with eUnqualifiedItems= (apresl,nenv.eUnqualifiedItems) ||> List.foldBack (fun (nm,j) acc -> acc.Add(nm, Item.ActivePatternResult(apinfo,ty,j, m))); }
+/// Generalize a union case, from Cons --> List<T>.Cons
let GeneralizeUnionCaseRef (ucref:UnionCaseRef) =
UnionCaseInfo (fst (generalizeTyconRef ucref.TyconRef), ucref)
+/// Add type definitions to the sub-table of the environment indexed by name and arity
let AddTyconsByDemangledNameAndArity (bulkAddMode: BulkAdd) (tcrefs: TyconRef[]) (tab: LayeredMap<NameArityPair,TyconRef>) =
let entries = tcrefs |> Array.map (fun tcref -> KeyTyconByDemangledNameAndArity tcref.LogicalName tcref.TyparsNoRange tcref)
match bulkAddMode with
| BulkAdd.Yes -> tab.AddAndMarkAsCollapsible entries
| BulkAdd.No -> (tab,entries) ||> Array.fold (fun tab (KeyValue(k,v)) -> tab.Add(k,v))
+/// Add type definitions to the sub-table of the environment indexed by access name
let AddTyconByAccessNames bulkAddMode (tcrefs:TyconRef[]) (tab: LayeredMultiMap<string,_>) =
let entries = tcrefs |> Array.collect (fun tcref -> KeyTyconByAccessNames tcref.LogicalName tcref)
match bulkAddMode with
| BulkAdd.Yes -> tab.AddAndMarkAsCollapsible entries
| BulkAdd.No -> (tab,entries) ||> Array.fold (fun tab (KeyValue(k,v)) -> tab.Add (k,v))
-// Get the info for all the .NET-style extension members listed as static members in the type
-let private CSharpExtensionMemberInfosForTyconRef amap m (tcref:TyconRef) =
- let scoref,enc,tdef = tcref.ILTyconInfo
- if ILThingHasExtensionAttribute tdef.CustomAttrs then
- let pri = nextExtensionMethodPriority()
- let tref = ILTypeInfo(tcref,mkRefForNestedILTypeDef scoref (enc,tdef),[],tdef)
-
- // found extension attribute on type 'tcref.LogicalName'
-
- tdef.Methods.AsList |> List.collect (fun md ->
- if ILThingHasExtensionAttribute md.CustomAttrs && md.Parameters.Length > 0 then
- let thisParam = ILList.nth md.Parameters 0
- let ilty = thisParam.Type
- match ilty with
- | ILType.Boxed tspec
- | ILType.Value tspec ->
- let tcref = (tspec |> rescopeILTypeSpec scoref).TypeRef |> Import.ImportILTypeRef amap m
- // found extension method 'md.Name' on type 'tcref.LogicalName'
-
- [(tcref, ILExtMem (tref.ILTypeRef, md, pri))]
- // Do not import extension members whose 'this' is only a type parameter
- | _ ->
- []
- else
- [])
- else
- []
-
-let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) amap m nenv (tcref:TyconRef) =
- let AddRecdField (rfref:RecdFieldRef) tab = NameMultiMap.add rfref.FieldName rfref tab
+/// Add a record field to the corresponding sub-table of the name resolution environment
+let AddRecdField (rfref:RecdFieldRef) tab = NameMultiMap.add rfref.FieldName rfref tab
- let AddUnionCases1 (tab:Map<_,_>) (ucrefs:UnionCaseRef list)=
- (tab, ucrefs) ||> List.fold (fun acc ucref ->
- let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
- acc.Add (ucref.CaseName, item))
+/// Add a set of union cases to the corresponding sub-table of the environment
+let AddUnionCases1 (tab:Map<_,_>) (ucrefs:UnionCaseRef list)=
+ (tab, ucrefs) ||> List.fold (fun acc ucref ->
+ let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
+ acc.Add (ucref.CaseName, item))
- let AddUnionCases2 (eUnqualifiedItems: LayeredMap<_,_>) (ucrefs :UnionCaseRef list) =
- match bulkAddMode with
- | BulkAdd.Yes ->
- let items =
- ucrefs |> Array.ofList |> Array.map (fun ucref ->
- let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
- KeyValuePair(ucref.CaseName,item))
- eUnqualifiedItems.AddAndMarkAsCollapsible items
+/// Add a set of union cases to the corresponding sub-table of the environment
+let AddUnionCases2 bulkAddMode (eUnqualifiedItems: LayeredMap<_,_>) (ucrefs :UnionCaseRef list) =
+ match bulkAddMode with
+ | BulkAdd.Yes ->
+ let items =
+ ucrefs |> Array.ofList |> Array.map (fun ucref ->
+ let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
+ KeyValuePair(ucref.CaseName,item))
+ eUnqualifiedItems.AddAndMarkAsCollapsible items
- | BulkAdd.No ->
- (eUnqualifiedItems,ucrefs) ||> List.fold (fun acc ucref ->
- let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
- acc.Add (ucref.CaseName, item))
+ | BulkAdd.No ->
+ (eUnqualifiedItems,ucrefs) ||> List.fold (fun acc ucref ->
+ let item = Item.UnionCase (GeneralizeUnionCaseRef ucref)
+ acc.Add (ucref.CaseName, item))
+/// Add any implied contents of a type definition to the environment.
+let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) amap m nenv (tcref:TyconRef) =
let isIL = tcref.IsILTycon
let ucrefs = if isIL then [] else tcref.UnionCasesAsList |> List.map (mkNestedUnionCaseRef tcref)
let flds = if isIL then [| |] else tcref.AllFieldsArray
- let eExtensionMembers =
- if isIL then
- let csharpExtensionMeths = CSharpExtensionMemberInfosForTyconRef amap m tcref
- (nenv.eExtensionMembers,csharpExtensionMeths) ||> List.fold (fun tab (tcref,extMemInfo) -> tab.Add (tcref, extMemInfo))
+ let eIndexedExtensionMembers, eUnindexedExtensionMembers =
+ let ilStyleExtensionMeths = GetCSharpStyleIndexedExtensionMembersForTyconRef amap m tcref
+ ((nenv.eIndexedExtensionMembers,nenv.eUnindexedExtensionMembers),ilStyleExtensionMeths) ||> List.fold (fun (tab1,tab2) extMemInfo ->
+ match extMemInfo with
+ | Choice1Of2 (tcref,extMemInfo) -> tab1.Add (tcref, extMemInfo), tab2
+ | Choice2Of2 extMemInfo -> tab1, extMemInfo :: tab2)
+
+ let eFieldLabels =
+ if not tcref.IsRecordTycon || isIL || flds.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
+ nenv.eFieldLabels
else
- nenv.eExtensionMembers
+ (nenv.eFieldLabels,flds) ||> Array.fold (fun acc f ->
+ if f.IsStatic || f.IsCompilerGenerated then acc
+ else AddRecdField (mkNestedRecdFieldRef tcref f) acc)
+ let eUnqualifiedItems =
+ let tab = nenv.eUnqualifiedItems
+ // add the type name for potential use as a constructor
+ // The rules are
+ // - The unqualified lookup table in the environment can contain map names to a set of type names (the set of type names is a new kind of "item").
+ // - When the contents of a type definition is added to the environment, an entry is added in this table for all class and struct types.
+ // - When opening a module, types are added first to the environment, then values, then auto-opened sub-modules.
+ // - When a value is added by an "open" previously available type names will become inaccessible by this table.
+ let tab =
+
+ // This may explore into an unreferenced assembly if the name
+ // is a type abbreviation. If it does, assume the name does not
+ // have a constructor.
+ let mayHaveConstruction =
+ protectAssemblyExploration
+ false
+ (fun () ->
+ let typ = generalizedTyconRef tcref
+ isClassTy g typ || isStructTy g typ)
+
+ if mayHaveConstruction then
+ tab.LinearTryModifyThenLaterFlatten (tcref.DisplayName, (fun prev ->
+ match prev with
+ | Some (Item.UnqualifiedType tcrefs) -> Item.UnqualifiedType (tcref::tcrefs)
+ | _ -> Item.UnqualifiedType [tcref]))
+ else
+ tab
+ if isIL || ucrefs.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
+ tab
+ else
+ AddUnionCases2 bulkAddMode tab ucrefs
+ let ePatItems =
+ if isIL || ucrefs.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
+ nenv.ePatItems
+ else
+ AddUnionCases1 nenv.ePatItems ucrefs
{ nenv with
- eFieldLabels=
- (if not tcref.IsRecordTycon || isIL || flds.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
- nenv.eFieldLabels
- else (nenv.eFieldLabels,flds) ||> Array.fold (fun acc f ->
- if f.IsStatic || f.IsCompilerGenerated then acc
- else AddRecdField (mkNestedRecdFieldRef tcref f) acc)) ;
- eUnqualifiedItems =
- (let tab = nenv.eUnqualifiedItems
- // add the type name for potential use as a constructor
- // The rules are
- // - The unqualified lookup table in the environment can contain map names to a set of type names (the set of type names is a new kind of "item").
- // - When the contents of a type definition is added to the environment, an entry is added in this table for all class and struct types.
- // - When opening a module, types are added first to the environment, then values, then auto-opened sub-modules.
- // - When a value is added by an "open" previously available type names will become inaccessible by this table.
- let tab =
-
- // This may explore into an unreferenced assembly if the name
- // is a type abbreviation. If it does, assume the name does not
- // have a constructor.
- let mayHaveConstruction =
- protectAssemblyExploration
- false
- (fun () ->
- let typ = generalizedTyconRef tcref
- isClassTy g typ || isStructTy g typ)
-
- if mayHaveConstruction then
- tab.LinearTryModifyThenLaterFlatten (tcref.DisplayName, (fun prev ->
- match prev with
- | Some (Item.UnqualifiedType tcrefs) -> Item.UnqualifiedType (tcref::tcrefs)
- | _ -> Item.UnqualifiedType [tcref]))
-
- //match nenv.eUnqualifiedItems.TryFind tcref.DisplayName with
- //| Some (Item.UnqualifiedType tcrefs) -> tab.Add(tcref.DisplayName, Item.UnqualifiedType (tcref::tcrefs))
- //| _ -> tab.Add(tcref.DisplayName, Item.UnqualifiedType [tcref])
- else
- tab
- if isIL || ucrefs.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
- tab
- else
- AddUnionCases2 tab ucrefs);
- ePatItems =
- (if isIL || ucrefs.Length = 0 || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) then
- nenv.ePatItems
- else
- AddUnionCases1 nenv.ePatItems ucrefs);
- eExtensionMembers =
- eExtensionMembers; }
+ eFieldLabels= eFieldLabels
+ eUnqualifiedItems = eUnqualifiedItems
+ ePatItems = ePatItems
+ eIndexedExtensionMembers = eIndexedExtensionMembers
+ eUnindexedExtensionMembers = eUnindexedExtensionMembers }
+/// Add a set of type definitions to the name resolution environment
let AddTyconRefsToNameEnv bulkAddMode ownDefinition g amap m root nenv tcrefs =
let env = List.fold (AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition g amap m) nenv tcrefs
// Add most of the contents of the tycons en-masse, then flatten the tables if we're opening a module or namespace
@@ -515,6 +604,7 @@ let AddTyconRefsToNameEnv bulkAddMode ownDefinition g amap m root nenv tcrefs =
eTyconsByAccessNames=
AddTyconByAccessNames bulkAddMode tcrefs nenv.eTyconsByAccessNames }
+/// Add a set of F# exception definitions to the name resolution environment
let AddExceptionDeclsToNameEnv bulkAddMode nenv (ecref:TyconRef) =
assert ecref.IsExceptionDecl
let item = Item.ExnCase ecref
@@ -528,6 +618,7 @@ let AddExceptionDeclsToNameEnv bulkAddMode nenv (ecref:TyconRef) =
ePatItems = nenv.ePatItems.Add (ecref.LogicalName, item) }
+/// Add a module abbreviation to the name resolution environment
let AddModuleAbbrevToNameEnv (id:Ident) nenv modrefs =
{nenv with
eModulesAndNamespaces=
@@ -539,17 +630,18 @@ let AddModuleAbbrevToNameEnv (id:Ident) nenv modrefs =
// Open a structure or an IL namespace
//-------------------------------------------------------------------------
-let nestedModuleRefs (modref: ModuleOrNamespaceRef) =
+let MakeNestedModuleRefs (modref: ModuleOrNamespaceRef) =
modref.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions
|> List.map modref.MkNestedTyconRef
+/// Add a set of module or namespace to the name resolution environment, including any sub-modules marked 'AutoOpen'
+//
// Recursive because of "AutoOpen", i.e. adding a module reference may automatically open further modules
-
let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: ModuleOrNamespaceRef list) =
let modrefsMap = modrefs |> NameMap.ofKeyedList (fun modref -> modref.DemangledModuleOrNamespaceName)
let addModrefs tab =
let add old nw =
- if IsEntityAccessible ad nw then
+ if IsEntityAccessible amap m ad nw then
nw :: old
else
old
@@ -569,27 +661,30 @@ let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: Module
nenv)
nenv
+/// Add the contents of a module or namespace to the name resolution environment
and AddModuleOrNamespaceContentsToNameEnv (g:TcGlobals) amap (ad:AccessorDomain) m nenv (modref:ModuleOrNamespaceRef) =
- let pri = nextExtensionMethodPriority()
+ let pri = NextExtensionMethodPriority()
let mty = modref.ModuleOrNamespaceType
let tycons = mty.TypeAndExceptionDefinitions
let exncs = mty.ExceptionDefinitions
let nenv = { nenv with eDisplayEnv= nenv.eDisplayEnv.AddOpenModuleOrNamespace modref }
- let tcrefs = tycons |> List.map modref.MkNestedTyconRef |> List.filter (IsEntityAccessible ad)
- let exrefs = exncs |> List.map modref.MkNestedTyconRef |> List.filter (IsEntityAccessible ad)
+ let tcrefs = tycons |> List.map modref.MkNestedTyconRef |> List.filter (IsEntityAccessible amap m ad)
+ let exrefs = exncs |> List.map modref.MkNestedTyconRef |> List.filter (IsEntityAccessible amap m ad)
let nenv = (nenv,exrefs) ||> List.fold (AddExceptionDeclsToNameEnv BulkAdd.Yes)
let nenv = (nenv,tcrefs) ||> AddTyconRefsToNameEnv BulkAdd.Yes false g amap m false
let vrefs =
mty.AllValsAndMembers.ToFlatList()
|> FlatList.choose (fun x ->
- if IsAccessible ad x.Accessibility then tryMkValRefInModRef modref x
+ if IsAccessible ad x.Accessibility then TryMkValRefInModRef modref x
else None)
|> FlatList.toArray
let nenv = AddValRefsToNameEnvWithPriority BulkAdd.Yes pri nenv vrefs
- let nenv = (nenv,nestedModuleRefs modref) ||> AddModuleOrNamespaceRefsToNameEnv g amap m false ad
+ let nenv = (nenv,MakeNestedModuleRefs modref) ||> AddModuleOrNamespaceRefsToNameEnv g amap m false ad
nenv
+/// Add a set of modules or namespaces to the name resolution environment
+//
// Note this is a 'foldBack' - the most recently added modules come first in the list, e.g.
// module M1 = ... // M1a
// module M1 = ... // M1b
@@ -599,15 +694,18 @@ and AddModuleOrNamespaceContentsToNameEnv (g:TcGlobals) amap (ad:AccessorDomain)
and AddModulesAndNamespacesContentsToNameEnv g amap ad m nenv modrefs =
(modrefs, nenv) ||> List.foldBack (fun modref acc -> AddModuleOrNamespaceContentsToNameEnv g amap ad m acc modref)
-
-let AddModrefToNameEnv g amap m root ad nenv (modref:EntityRef) =
+/// Add a single modules or namespace to the name resolution environment
+let AddModuleOrNamespaceRefToNameEnv g amap m root ad nenv (modref:EntityRef) =
AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv [modref]
+/// A flag which indicates if it is an error to have two declared type parameters with identical names
+/// in the name resolution environment.
type CheckForDuplicateTyparFlag =
| CheckForDuplicateTypars
| NoCheckForDuplicateTypars
+/// Add some declared type parameters to the name resolution environment
let AddDeclaredTyparsToNameEnv check nenv typars =
let typarmap =
List.foldBack
@@ -623,7 +721,7 @@ let AddDeclaredTyparsToNameEnv check nenv typars =
//-------------------------------------------------------------------------
-// FreshenTycon and instantiationGenerator.
+// Generating fresh instantiations for type inference.
//-------------------------------------------------------------------------
/// Convert a reference to a named type into a type that includes
@@ -683,13 +781,11 @@ let AddResults res1 res2 =
let (+++) x y = AddResults x y
let NoResultsOrUsefulErrors = Result []
-// REVIEW: make this tail recursive
let rec CollectResults f = function
| [] -> NoResultsOrUsefulErrors
| [h] -> OneResult (f h)
| h :: t -> AddResults (OneResult (f h)) (CollectResults f t)
-// REVIEW: make this tail recursive
let MapResults f = function
| Result xs -> Result (List.map f xs)
| Exception err -> Exception err
@@ -705,21 +801,30 @@ let AtMostOneResult m res =
// TypeNameResolutionInfo
//-------------------------------------------------------------------------
+/// Indicates whether we are resolving type names to type definitions or to constructor methods.
type TypeNameResolutionFlag =
- | ResolveTypeNamesToCtors
- | ResolveTypeNamesToTypeRefs
+ | ResolveTypeNamesToCtors
+ | ResolveTypeNamesToTypeRefs
[<RequireQualifiedAccess>]
[<NoEquality; NoComparison>]
+/// Represents information about the generic argument count of a type name when resolving it.
+///
+/// In some situations we resolve "List" to any type definition with that name regardless of the number
+/// of generic arguments. In others, we know precisely how many generic arguments are needed.
type TypeNameResolutionStaticArgsInfo =
/// Indicates indefinite knowledge of type arguments
| Indefinite
/// Indicates definite knowledge of type arguments
| Definite of int
+
/// Indicates definite knowledge of empty type arguments
static member DefiniteEmpty = TypeNameResolutionStaticArgsInfo.Definite 0
- static member FromTyArgs (tyargs: SynType list) = TypeNameResolutionStaticArgsInfo.Definite tyargs.Length
+
+ static member FromTyArgs (numTyArgs: int) = TypeNameResolutionStaticArgsInfo.Definite numTyArgs
+
member x.HasNoStaticArgsInfo = match x with TypeNameResolutionStaticArgsInfo.Indefinite -> true | _-> false
+
member x.NumStaticArgs = match x with TypeNameResolutionStaticArgsInfo.Indefinite -> 0 | TypeNameResolutionStaticArgsInfo.Definite n -> n
// Get the first possible mangled name of the type, assuming the args are generic args
@@ -730,6 +835,7 @@ type TypeNameResolutionStaticArgsInfo =
[<NoEquality; NoComparison>]
+/// Represents information which guides name resolution of types.
type TypeNameResolutionInfo =
| TypeNameResolutionInfo of TypeNameResolutionFlag * TypeNameResolutionStaticArgsInfo
@@ -744,7 +850,7 @@ type TypeNameResolutionInfo =
// Resolve (possibly mangled) type names
//-------------------------------------------------------------------------
-/// Qualified lookups where the number of generic arguments is known
+/// Qualified lookups of type names where the number of generic arguments is known
/// from context, e.g. Module.Type<args>. The full names suh as ``List`1`` can
/// be used to qualify access if needed
let LookupTypeNameInEntityHaveArity nm (staticResInfo: TypeNameResolutionStaticArgsInfo) (mty:ModuleOrNamespaceType) =
@@ -753,7 +859,7 @@ let LookupTypeNameInEntityHaveArity nm (staticResInfo: TypeNameResolutionStaticA
| Some _ as r -> r
| None -> mty.TypesByMangledName.TryFind nm
-/// Unqualified lookups where the number of generic arguments is known
+/// Unqualified lookups of type names where the number of generic arguments is known
/// from context, e.g. List<arg>. Rebindings due to 'open' may have rebound identifiers.
let LookupTypeNameInEnvHaveArity fq nm numTyArgs (nenv:NameResolutionEnv) =
let key = if IsMangledGenericName nm then DecodeGenericTypeName nm else NameArityPair(nm,numTyArgs)
@@ -761,20 +867,22 @@ let LookupTypeNameInEnvHaveArity fq nm numTyArgs (nenv:NameResolutionEnv) =
| Some res -> Some res
| None -> nenv.TyconsByAccessNames(fq).TryFind nm |> Option.map List.head
-/// Unqualified lookups where the number of generic arguments is NOT known
-/// from context. This is used in five places:
-/// - static member lookups, e.g. MyType.StaticMember(3)
-/// - e.g. MyModule.MyType.StaticMember(3)
-/// - type-qualified field names, e.g. { RecordType.field = 3 }
-/// - type-qualified constructor names, e.g. match x with UnionType.A -> 3
-/// - identifiers to constructors for better error messages, e.g. 'String(3)' after 'open System'
-/// - the special single-constructor rule in TcTyconCores
-///
-/// Because of the potential ambiguity multiple results can be returned.
-/// Explicit type annotations can be added where needed to specify the generic arity.
-///
-/// In theory the full names such as ``RecordType`1`` can
-/// also be used to qualify access if needed, though this is almost never needed.
+/// Implements unqualified lookups of type names where the number of generic arguments is NOT known
+/// from context.
+//
+// This is used in five places:
+// - static member lookups, e.g. MyType.StaticMember(3)
+// - e.g. MyModule.MyType.StaticMember(3)
+// - type-qualified field names, e.g. { RecordType.field = 3 }
+// - type-qualified constructor names, e.g. match x with UnionType.A -> 3
+// - identifiers to constructors for better error messages, e.g. 'String(3)' after 'open System'
+// - the special single-constructor rule in TcTyconCores
+//
+// Because of the potential ambiguity multiple results can be returned.
+// Explicit type annotations can be added where needed to specify the generic arity.
+//
+// In theory the full names such as ``RecordType`1`` can
+// also be used to qualify access if needed, though this is almost never needed.
let LookupTypeNameNoArity nm (byDemangledNameAndArity: LayeredMap<NameArityPair,_>) (byAccessNames: LayeredMultiMap<string,_>) =
if IsMangledGenericName nm then
@@ -787,19 +895,23 @@ let LookupTypeNameNoArity nm (byDemangledNameAndArity: LayeredMap<NameArityPair,
else
byAccessNames.[nm]
+/// Qualified lookup of type names in the environment
let LookupTypeNameInEnvNoArity fq nm (nenv: NameResolutionEnv) =
LookupTypeNameNoArity nm (nenv.TyconsByDemangledNameAndArity(fq)) (nenv.TyconsByAccessNames(fq))
+/// Qualified lookup of type names in an entity
let LookupTypeNameInEntityNoArity m nm (mtyp:ModuleOrNamespaceType) =
LookupTypeNameNoArity nm (mtyp.TypesByDemangledNameAndArity(m)) mtyp.TypesByAccessNames
+/// Qualified lookup of type names in an entity where we may know a generic argument count
let LookupTypeNameInEnvMaybeHaveArity fq nm (typeNameResInfo: TypeNameResolutionInfo) nenv =
if typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo then
LookupTypeNameInEnvNoArity fq nm nenv
else
LookupTypeNameInEnvHaveArity fq nm typeNameResInfo.StaticArgsInfo.NumStaticArgs nenv |> Option.toList
-
+/// A flag which indicates if direct references to generated provided types are allowed. Normally these
+/// are disallowed.
[<RequireQualifiedAccess>]
type PermitDirectReferenceToGeneratedType =
| Yes
@@ -808,8 +920,7 @@ type PermitDirectReferenceToGeneratedType =
#if EXTENSIONTYPING
-
-/// Generated types may not be returned from name resolution.
+/// Check for direct references to generated provided types.
let CheckForDirectReferenceToGeneratedType (tcref: TyconRef, genOk, m) =
match genOk with
| PermitDirectReferenceToGeneratedType.Yes -> ()
@@ -833,6 +944,8 @@ let AddEntityForProvidedType (amap: Import.ImportMap, modref: ModuleOrNamespaceR
tcref
+/// Given a provided type or provided namespace, resolve the type name using the type provider API.
+/// If necessary, incorporate the provided type or namespace into the entity.
let ResolveProvidedTypeNameInEntity (amap, m, typeName, staticResInfo: TypeNameResolutionStaticArgsInfo, modref: ModuleOrNamespaceRef) =
match modref.TypeReprInfo with
| TProvidedNamespaceExtensionPoint(resolutionEnvironment,resolvers) ->
@@ -856,7 +969,7 @@ let ResolveProvidedTypeNameInEntity (amap, m, typeName, staticResInfo: TypeNameR
error(Error(FSComp.SR.etNestedProvidedTypesDoNotTakeStaticArgumentsOrGenericParameters(),m))
if resolutionEnvironment.showResolutionMessages then
- dprintfn "resolving name '%s' in SingleTypeExtensionPoint '%s'" typeName (sty.PUntaint((fun sty -> sty.FullName), m))
+ dprintfn "resolving name '%s' in TProvidedTypeExtensionPoint '%s'" typeName (sty.PUntaint((fun sty -> sty.FullName), m))
match sty.PApply((fun sty -> sty.GetNestedType(typeName)), m) with
| Tainted.Null -> []
@@ -865,6 +978,7 @@ let ResolveProvidedTypeNameInEntity (amap, m, typeName, staticResInfo: TypeNameR
| _ -> []
#endif
+/// Lookup a type name in an entity.
let LookupTypeNameInEntityMaybeHaveArity (amap, m, nm, staticResInfo:TypeNameResolutionStaticArgsInfo, modref: ModuleOrNamespaceRef) =
let mtyp = modref.ModuleOrNamespaceType
let tcrefs =
@@ -885,10 +999,19 @@ let LookupTypeNameInEntityMaybeHaveArity (amap, m, nm, staticResInfo:TypeNameRes
#else
amap |> ignore
#endif
- //let tcrefs = tcrefs |> List.filter (IsEntityAccessible ad)
tcrefs
+/// Make a type that refers to a nested type.
+///
+/// Handle the .NET/C# business where nested generic types implictly accumulate the type parameters
+/// from their enclosing types.
+let MakeNestedType (ncenv:NameResolver) (tinst:TType list) m (tcrefNested:TyconRef) =
+ let tps = List.drop tinst.Length (tcrefNested.Typars m)
+ let tinstNested = ncenv.InstantiationGenerator m tps
+ mkAppTy tcrefNested (tinst @ tinstNested)
+
+/// Get all the accessible nested types of an existing type.
let GetNestedTypesOfType (ad, ncenv:NameResolver, optFilter, staticResInfo, checkForGenerated, m) typ =
let g = ncenv.g
ncenv.InfoReader.ReadPrimaryTypeHierachy(AllowMultiIntfInstantiations.No,m,typ) |> List.collect (fun typ ->
@@ -903,17 +1026,11 @@ let GetNestedTypesOfType (ad, ncenv:NameResolver, optFilter, staticResInfo, chec
#else
checkForGenerated |> ignore
#endif
- let MakeNestedType (tcrefNested:TyconRef) =
- // Handle the .NET/C# business where nested generic types implictly accumulate the type parameters
- // from their enclosing types.
- let tps = List.drop tinst.Length (tcrefNested.Typars m)
- let tinstNested = ncenv.InstantiationGenerator m tps
- mkAppTy tcrefNested (tinst @ tinstNested)
match optFilter with
| Some nm ->
LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, m, nm, staticResInfo, tcref)
- |> List.map MakeNestedType
+ |> List.map (MakeNestedType ncenv tinst m)
| None ->
#if EXTENSIONTYPING
match tycon.TypeReprInfo with
@@ -921,34 +1038,33 @@ let GetNestedTypesOfType (ad, ncenv:NameResolver, optFilter, staticResInfo, chec
[ for nestedType in info.ProvidedType.PApplyArray((fun sty -> sty.GetNestedTypes()), "GetNestedTypes", m) do
let nestedTypeName = nestedType.PUntaint((fun t -> t.Name), m)
for nestedTcref in LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, m, nestedTypeName, staticResInfo, tcref) do
- yield MakeNestedType nestedTcref ]
+ yield MakeNestedType ncenv tinst m nestedTcref ]
| _ ->
#endif
mty.TypesByAccessNames.Values
|> Seq.toList
- |> List.map (tcref.MkNestedTyconRef >> MakeNestedType)
- |> List.filter (IsTypeAccessible g ad)
+ |> List.map (tcref.MkNestedTyconRef >> MakeNestedType ncenv tinst m)
+ |> List.filter (IsTypeAccessible g ncenv.amap m ad)
else [])
//-------------------------------------------------------------------------
// Report environments to visual studio. We stuff intermediary results
// into a global variable. A little unpleasant.
-// REVIEW: We could at least put the global in cenv!!!
//-------------------------------------------------------------------------
-// Represents a type of the occurence when reporting name in name resolution
+/// Represents a type of the occurence when reporting name in name resolution
[<RequireQualifiedAccess>]
type ItemOccurence =
- // This is a binding / declaration of the item
+ /// This is a binding / declaration of the item
| Binding = 0
- // This is a usage of the item
+ /// This is a usage of the item
| Use = 1
- // This is a usage of a type name in a type
+ /// This is a usage of a type name in a type
| UseInType = 2
- // This is a usage of a type name in an attribute
+ /// This is a usage of a type name in an attribute
| UseInAttribute = 3
- // Inside pattern matching
+ /// Inside pattern matching
| Pattern = 4
type ITypecheckResultsSink =
@@ -987,31 +1103,37 @@ let CallExprHasTypeSink (sink:TcResultsSink) (m:range,nenv,typ,denv,ad) =
| None -> ()
| Some sink -> sink.NotifyExprHasType(m.End,typ,denv,nenv,ad,m)
+//-------------------------------------------------------------------------
+// Check inferrability of type parameters in resolved items.
+//-------------------------------------------------------------------------
+
/// Checks if the type variables associated with the result of a resolution are inferrable,
/// i.e. occur in the arguments or return type of the resolution. If not give a warning
/// about a type instantiation being needed.
-type ResultTyparChecker = unit -> bool
+type ResultTyparChecker = ResultTyparChecker of (unit -> bool)
let CheckAllTyparsInferrable amap m item =
match item with
| Item.Property(_,pinfos) ->
pinfos |> List.forall (fun pinfo ->
- let freeInEnclosingType = freeInType CollectTyparsNoCaching pinfo.EnclosingType
+ pinfo.IsExtensionMember ||
+ let freeInDeclaringType = freeInType CollectTyparsNoCaching pinfo.EnclosingType
let freeInArgsAndRetType =
accFreeInTypes CollectTyparsNoCaching (pinfo.GetParamTypes(amap,m))
(freeInType CollectTyparsNoCaching (pinfo.GetPropertyType(amap,m)))
- let free = Zset.diff freeInEnclosingType.FreeTypars freeInArgsAndRetType.FreeTypars
+ let free = Zset.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars
free.IsEmpty)
| Item.MethodGroup(_,minfos) ->
minfos |> List.forall (fun minfo ->
+ minfo.IsExtensionMember ||
let fminst = minfo.FormalMethodInst
- let freeInEnclosingType = freeInType CollectTyparsNoCaching minfo.EnclosingType
+ let freeInDeclaringType = freeInType CollectTyparsNoCaching minfo.EnclosingType
let freeInArgsAndRetType =
List.foldBack (accFreeInTypes CollectTyparsNoCaching) (minfo.GetParamTypes(amap, m, fminst))
(accFreeInTypes CollectTyparsNoCaching (minfo.GetObjArgTypes(amap, m, fminst))
(freeInType CollectTyparsNoCaching (minfo.GetFSharpReturnTy(amap, m, fminst))))
- let free = Zset.diff freeInEnclosingType.FreeTypars freeInArgsAndRetType.FreeTypars
+ let free = Zset.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars
free.IsEmpty)
| Item.CtorGroup _
@@ -1036,6 +1158,10 @@ let CheckAllTyparsInferrable amap m item =
| Item.UnqualifiedType _
| Item.SetterArg _ -> true
+//-------------------------------------------------------------------------
+// Check inferrability of type parameters in resolved items.
+//-------------------------------------------------------------------------
+
/// Keeps track of information relevant to the chosen resolution of a long identifier
///
/// When we resolve an item such as System.Console.In we
@@ -1052,7 +1178,7 @@ type ResolutionInfo =
static member SendToSink(sink, ncenv: NameResolver, nenv, occ, ad, ResolutionInfo(entityPath,warnings), typarChecker) =
entityPath |> List.iter (fun (m,eref:EntityRef) ->
CheckEntityAttributes ncenv.g eref m |> CommitOperationResult;
- CheckTyconAccessible m ad eref |> ignore;
+ CheckTyconAccessible ncenv.amap m ad eref |> ignore;
let item =
if eref.IsModuleOrNamespace then
Item.ModuleOrNamespaces [eref]
@@ -1085,10 +1211,11 @@ type ResolutionInfo =
// Given ambiguous C<_>, C<_,_> we resolve the ambiguous 'C()' to C<_> with an ambiguity error
// Given C<_> we resolve the ambiguous 'C()' to C<_> with a warning if the argument or return types can't be inferred
-let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs:(ResolutionInfo * TyconRef) list,
- typeNameResInfo:TypeNameResolutionInfo,
- genOk:PermitDirectReferenceToGeneratedType,
- m) =
+let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities
+ (tcrefs:(ResolutionInfo * TyconRef) list,
+ typeNameResInfo:TypeNameResolutionInfo,
+ genOk:PermitDirectReferenceToGeneratedType,
+ m) =
let tcrefs =
tcrefs
@@ -1115,7 +1242,7 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs:(ResolutionI
| [(resInfo,tcref)] when typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo && tcref.Typars(m).Length > 0 && typeNameResInfo.ResolutionFlag = ResolveTypeNamesToTypeRefs ->
let resInfo =
- resInfo.AddWarning (fun typarChecker ->
+ resInfo.AddWarning (fun (ResultTyparChecker typarChecker) ->
if not (typarChecker()) then
warning(Error(FSComp.SR.nrTypeInstantiationIsMissingAndCouldNotBeInferred(tcref.DisplayName, tcref.DisplayNameWithStaticParametersAndUnderscoreTypars),m)))
[(resInfo,tcref)]
@@ -1138,7 +1265,7 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs:(ResolutionI
// Consume ids that refer to a namespace
//-------------------------------------------------------------------------
-let rec ResolveLongIndentAsModuleOrNamespace fullyQualified (nenv:NameResolutionEnv) ad (lid:Ident list) =
+let rec ResolveLongIndentAsModuleOrNamespace amap m fullyQualified (nenv:NameResolutionEnv) ad (lid:Ident list) =
match lid with
| [] -> NoResultsOrUsefulErrors
@@ -1147,7 +1274,7 @@ let rec ResolveLongIndentAsModuleOrNamespace fullyQualified (nenv:NameResolution
| id :: lid when id.idText = MangledGlobalName ->
- ResolveLongIndentAsModuleOrNamespace FullyQualified nenv ad lid
+ ResolveLongIndentAsModuleOrNamespace amap m FullyQualified nenv ad lid
| id:: rest ->
match nenv.ModulesAndNamespaces(fullyQualified).TryFind(id.idText) with
@@ -1159,13 +1286,13 @@ let rec ResolveLongIndentAsModuleOrNamespace fullyQualified (nenv:NameResolution
| [] -> success (depth,modref,mty)
| id:: rest ->
match mty.ModulesAndNamespacesByDemangledName.TryFind id.idText with
- | Some mspec when IsEntityAccessible ad (modref.MkNestedTyconRef mspec) ->
+ | Some mspec when IsEntityAccessible amap m ad (modref.MkNestedTyconRef mspec) ->
let subref = modref.MkNestedTyconRef mspec
look (depth+1) subref mspec.ModuleOrNamespaceType rest
| _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameNamespace,id,[]))
modrefs |> CollectResults (fun modref ->
- if IsEntityAccessible ad modref then
+ if IsEntityAccessible amap m ad modref then
look 1 modref modref.ModuleOrNamespaceType rest
else
raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,[])))
@@ -1173,11 +1300,11 @@ let rec ResolveLongIndentAsModuleOrNamespace fullyQualified (nenv:NameResolution
raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,[]))
-let ResolveLongIndentAsModuleOrNamespaceThen fullyQualified (nenv:NameResolutionEnv) ad lid f =
+let ResolveLongIndentAsModuleOrNamespaceThen amap m fullyQualified (nenv:NameResolutionEnv) ad lid f =
match lid with
| [] -> NoResultsOrUsefulErrors
| id :: rest ->
- match ResolveLongIndentAsModuleOrNamespace fullyQualified nenv ad [id] with
+ match ResolveLongIndentAsModuleOrNamespace amap m fullyQualified nenv ad [id] with
| Result modrefs ->
modrefs |> CollectResults (fun (depth,modref,mty) ->
let resInfo = ResolutionInfo.Empty.AddEntity(id.idRange,modref)
@@ -1206,15 +1333,16 @@ let private ResolveObjectConstructorPrim (ncenv:NameResolver) edenv resInfo m ad
raze (Error(FSComp.SR.nrNoConstructorsAvailableForType(NicePrint.minimalStringOfType edenv typ),m))
else
let ctorInfos = ctorInfos |> List.filter (IsMethInfoAccessible amap m ad)
- success (resInfo,MakeCtorGroup ((tcrefOfAppTy g typ).LogicalName, (defaultStructCtorInfo at ctorInfos)))
+ success (resInfo,Item.MakeCtorGroup ((tcrefOfAppTy g typ).LogicalName, (defaultStructCtorInfo at ctorInfos)))
let ResolveObjectConstructor (ncenv:NameResolver) edenv m ad typ =
ResolveObjectConstructorPrim (ncenv:NameResolver) edenv [] m ad typ |?> (fun (_resInfo,item) -> item)
//-------------------------------------------------------------------------
-// Bind IL "." notation (member lookup or lookup in a type)
+// Bind the "." notation (member lookup or lookup in a type)
//-------------------------------------------------------------------------
+/// Query the declared properties of a type (including inherited properties)
let IntrinsicPropInfosOfTypeInScope (infoReader:InfoReader) (optFilter, ad) findFlag m typ =
let g = infoReader.g
let amap = infoReader.amap
@@ -1222,35 +1350,47 @@ let IntrinsicPropInfosOfTypeInScope (infoReader:InfoReader) (optFilter, ad) find
let pinfos = pinfos |> ExcludeHiddenOfPropInfos g amap m
pinfos
-let ExtensionPropInfosOfTypeInScope (infoReader:InfoReader) (eExtensionMembers: TyconRefMultiMap<_>) (optFilter, ad) _findFlag m typ =
+/// Select from a list of extension properties
+let SelectPropInfosFromExtMembers (infoReader:InfoReader,ad,optFilter) declaringTy m extMemInfos =
let g = infoReader.g
let amap = infoReader.amap
- infoReader.ReadEntireTypeHierachy(AllowMultiIntfInstantiations.No,m,typ) |> List.collect (fun typ ->
- if (isAppTy g typ) then
- let tcref = tcrefOfAppTy g typ
- // NOTE: multiple "open"'s push multiple duplicate values into eExtensionMembers
- // REVIEW: this looks a little slow: ListSet.setify is quadratic.
- let extValRefs =
- tcref
- |> eExtensionMembers.Find
- |> ListSet.setify (ExtensionMember.Equality g)
- let propCollector = new PropertyCollector(g,amap,m,typ,optFilter,ad)
- extValRefs |> List.iter (fun emem ->
- match emem with
- | FSExtMem (vref,_pri) ->
- match vref.MemberInfo with
- | None -> ()
- | Some membInfo -> propCollector.Collect(membInfo,vref)
- | ILExtMem _ ->
- // No extension properties coming from .NET
- ())
- propCollector.Close()
- else [])
-
-let AllPropInfosOfTypeInScope infoReader eExtensionMembers (optFilter, ad) findFlag m typ =
+ // NOTE: multiple "open"'s push multiple duplicate values into eIndexedExtensionMembers, hence setify.
+ // REVIEW: this looks a little slow: ListSet.setify is quadratic.
+ let extMemInfos = extMemInfos |> ListSet.setify (ExtensionMember.Equality g)
+ let propCollector = new PropertyCollector(g,amap,m,declaringTy,optFilter,ad)
+ extMemInfos |> List.iter (fun emem ->
+ match emem with
+ | FSExtMem (vref,_pri) ->
+ match vref.MemberInfo with
+ | None -> ()
+ | Some membInfo -> propCollector.Collect(membInfo,vref)
+ | ILExtMem _ ->
+ // No extension properties coming from .NET
+ ())
+ propCollector.Close()
+
+/// Query the available extension properties of a type (including extension properties for inherited types)
+let ExtensionPropInfosOfTypeInScope (infoReader:InfoReader) (nenv: NameResolutionEnv) (optFilter, ad) m typ =
+ let g = infoReader.g
+
+ let extMemsFromHierarchy =
+ infoReader.ReadEntireTypeHierachy(AllowMultiIntfInstantiations.No,m,typ) |> List.collect (fun typ ->
+ if (isAppTy g typ) then
+ let tcref = tcrefOfAppTy g typ
+ let extMemInfos = nenv.eIndexedExtensionMembers.Find tcref
+ SelectPropInfosFromExtMembers (infoReader,ad,optFilter) typ m extMemInfos
+ else [])
+
+ let extMemsDangling = SelectPropInfosFromExtMembers (infoReader,ad,optFilter) typ m nenv.eUnindexedExtensionMembers
+ extMemsDangling @ extMemsFromHierarchy
+
+
+/// Get all the available properties of a type (both intrinsic and extension)
+let AllPropInfosOfTypeInScope infoReader nenv (optFilter, ad) findFlag m typ =
IntrinsicPropInfosOfTypeInScope infoReader (optFilter, ad) findFlag m typ
- @ ExtensionPropInfosOfTypeInScope infoReader eExtensionMembers (optFilter, ad) findFlag m typ
+ @ ExtensionPropInfosOfTypeInScope infoReader nenv (optFilter, ad) m typ
+/// Get the available methods of a type (both declared and inherited)
let IntrinsicMethInfosOfType (infoReader:InfoReader) (optFilter,ad,allowMultiIntfInst) findFlag m typ =
let g = infoReader.g
let amap = infoReader.amap
@@ -1258,48 +1398,54 @@ let IntrinsicMethInfosOfType (infoReader:InfoReader) (optFilter,ad,allowMultiInt
let minfos = minfos |> ExcludeHiddenOfMethInfos g amap m
minfos
-let ImmediateExtensionMethInfosOfTypeInScope (infoReader:InfoReader) (eExtensionMembers: TyconRefMultiMap<_>) (optFilter,_ad) _findFlag m typ =
+/// Select from a list of extension methods
+let SelectMethInfosFromExtMembers (infoReader:InfoReader) optFilter apparentTy m extMemInfos =
let g = infoReader.g
- if (isAppTy g typ) then
- let tcref = tcrefOfAppTy g typ
- // NOTE: multiple "open"'s push multiple duplicate values into eExtensionMembers
- // REVIEW: this looks a little slow: ListSet.setify is quadratic.
- let extValRefs =
- tcref
- |> eExtensionMembers.Find
- |> ListSet.setify (ExtensionMember.Equality g)
- // Mark the extension members up with a number indicating priority (in open order, 0 = most recent)
- extValRefs |> List.choose (fun emem ->
- match emem with
- | FSExtMem (vref,pri) ->
- match vref.MemberInfo with
- | None -> None
- | Some membInfo -> TrySelectMemberVal g optFilter typ (Some pri) membInfo vref
- | ILExtMem (actualParent,md,pri) when (match optFilter with None -> true | Some nm -> nm = md.Name) ->
- if Tastops.isILAppTy g typ then
- // 'typ' is the logical parent
- let tinfo = ILTypeInfo.FromType g typ
- Some(ILMethInfo.Create (infoReader.amap, m, tinfo, Some actualParent, Some pri, md))
- else
- /// then, this is not a type definition backed by Abstract IL metadata.
- let tcref,_ = destAppTy g typ
- if tcref.IsFSharpObjectModelTycon then
- // case for C# extension method on an F# type
- let fsObjKind = tcref.FSharpObjectModelTypeInfo.fsobjmodel_kind
- Some(ILMeth(infoReader.amap.g,ILFSMethInfo(tcref,fsObjKind,Some actualParent,md),Some pri))
- else
- failwith "cannot happen: ILExtMem"
- | _ ->
- None)
- else []
-
-let ExtensionMethInfosOfTypeInScope (infoReader:InfoReader) eExtensionMembers (optFilter,ad) findFlag m typ =
- infoReader.ReadEntireTypeHierachy(AllowMultiIntfInstantiations.No,m,typ) |> List.collect (fun typ ->
- ImmediateExtensionMethInfosOfTypeInScope infoReader eExtensionMembers (optFilter,ad) findFlag m typ)
-
-let AllMethInfosOfTypeInScope infoReader eExtensionMembers (optFilter,ad) findFlag m typ =
+ // NOTE: multiple "open"'s push multiple duplicate values into eIndexedExtensionMembers
+ // REVIEW: this looks a little slow: ListSet.setify is quadratic.
+ let extMemInfos = extMemInfos |> ListSet.setify (ExtensionMember.Equality g)
+ extMemInfos |> List.choose (fun emem ->
+ match emem with
+ | FSExtMem (vref,pri) ->
+ match vref.MemberInfo with
+ | None -> None
+ | Some membInfo -> TrySelectMemberVal g optFilter apparentTy (Some pri) membInfo vref
+ | ILExtMem (actualParent,minfo,pri) when (match optFilter with None -> true | Some nm -> nm = minfo.LogicalName) ->
+ // Make a reference to the type containing the extension members
+ match minfo with
+ | ILMeth(_,ilminfo,_) ->
+ Some(MethInfo.CreateILExtensionMeth (infoReader.amap, m, apparentTy, actualParent, Some pri, ilminfo.RawMetadata))
+ // F#-defined IL-style extension methods are not seen as extension methods in F# code
+ | FSMeth(g,_,vref,_) ->
+ Some(FSMeth(g, apparentTy, vref, Some pri))
+#if EXTENSIONTYPING
+ // // Provided extension methods are not yet supported
+ | ProvidedMeth(amap,providedMeth,_,m) ->
+ Some(ProvidedMeth(amap, providedMeth, Some pri,m))
+#endif
+ | DefaultStructCtor _ ->
+ //| _ ->
+ None
+ | _ ->
+ None)
+
+/// Query the available extension properties of a methods (including extension methods for inherited types)
+let ExtensionMethInfosOfTypeInScope (infoReader:InfoReader) (nenv: NameResolutionEnv) optFilter m typ =
+ let extMemsDangling = SelectMethInfosFromExtMembers infoReader optFilter typ m nenv.eUnindexedExtensionMembers
+ let extMemsFromHierarchy =
+ infoReader.ReadEntireTypeHierachy(AllowMultiIntfInstantiations.No,m,typ) |> List.collect (fun typ ->
+ let g = infoReader.g
+ if (isAppTy g typ) then
+ let tcref = tcrefOfAppTy g typ
+ let extValRefs = nenv.eIndexedExtensionMembers.Find tcref
+ SelectMethInfosFromExtMembers infoReader optFilter typ m extValRefs
+ else [])
+ extMemsDangling @ extMemsFromHierarchy
+
+/// Get all the available methods of a type (both intrinsic and extension)
+let AllMethInfosOfTypeInScope infoReader nenv (optFilter,ad) findFlag m typ =
IntrinsicMethInfosOfType infoReader (optFilter,ad,AllowMultiIntfInstantiations.No) findFlag m typ
- @ ExtensionMethInfosOfTypeInScope infoReader eExtensionMembers (optFilter,ad) findFlag m typ
+ @ ExtensionMethInfosOfTypeInScope infoReader nenv optFilter m typ
exception IndeterminateType of range
@@ -1312,6 +1458,7 @@ type LookupKind =
| Ctor
+/// Try to find a union case of a type, with the given name
let TryFindUnionCaseOfType g typ nm =
if isAppTy g typ then
let tcref,tinst = destAppTy g typ
@@ -1328,7 +1475,7 @@ let CoreDisplayName(pinfo:PropInfo) =
| FSProp _ -> failwith "unexpected (property must have either getter or setter)"
| ILProp(_,ILPropInfo(_,def)) -> def.Name
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,m) -> pi.PUntaint((fun pi -> pi.Name), m)
+ | ProvidedProp(_,pi,m) -> pi.PUntaint((fun pi -> pi.Name), m)
#endif
let DecodeFSharpEvent (pinfos:PropInfo list) ad g (ncenv:NameResolver) m =
@@ -1375,21 +1522,22 @@ let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo
match TryFindIntrinsicNamedItemOfType ncenv.InfoReader (nm,ad) findFlag m typ with
| Some (PropertyItem psets) when (match lookupKind with Expr -> true | _ -> false) ->
let pinfos = psets |> ExcludeHiddenOfPropInfos g ncenv.amap m
- match DecodeFSharpEvent pinfos ad g ncenv m with
+
+ // fold the available extension members into the overload resolution
+ let extensionPropInfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter,ad) m typ
+
+ // make sure to keep the intrinsic pinfos before the extension pinfos in the list,
+ // since later on this logic is used when giving preference to intrinsic definitions
+ match DecodeFSharpEvent (pinfos at extensionPropInfos) ad g ncenv m with
| Some x -> success (resInfo, x, rest)
| None-> raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,[]))
| Some(MethodItem msets) when (match lookupKind with Expr -> true | _ -> false) ->
let minfos = msets |> ExcludeHiddenOfMethInfos g ncenv.amap m
+
// fold the available extension members into the overload resolution
- let extensionMethInfos =
- match lookupKind with
- | Expr -> ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (optFilter,ad) findFlag m typ
- | _ -> []
- //if nonNil(extensionMethInfos) && (match lookupKind with Expr -> true | _ -> false) then
- success (resInfo,MakeMethGroup (nm,minfos at extensionMethInfos),rest)
-
- //success (resInfo,MakeMethGroup (nm,minfos),rest)
+ let extensionMethInfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ
+ success (resInfo,Item.MakeMethGroup (nm,minfos at extensionMethInfos),rest)
| Some (ILFieldItem (finfo:: _)) when (match lookupKind with Expr | Pattern -> true | _ -> false) ->
success (resInfo,Item.ILField finfo,rest)
@@ -1398,15 +1546,15 @@ let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo
| Some (RecdFieldItem (rfinfo)) when (match lookupKind with Expr | RecdField | Pattern -> true | _ -> false) ->
success(resInfo,Item.RecdField(rfinfo),rest)
| _ ->
- let pinfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (optFilter, ad) findFlag m typ
+ let pinfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter, ad) m typ
if nonNil pinfos && (match lookupKind with Expr -> true | _ -> false) then
success (resInfo,Item.Property (nm,pinfos),rest) else
- let minfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (optFilter,ad) findFlag m typ
+ let minfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ
if nonNil minfos && (match lookupKind with Expr -> true | _ -> false) then
- success (resInfo,MakeMethGroup (nm,minfos),rest) else
+ success (resInfo,Item.MakeMethGroup (nm,minfos),rest)
- if isTyparTy g typ then raze (IndeterminateType(unionRanges m id.idRange))
+ elif isTyparTy g typ then raze (IndeterminateType(unionRanges m id.idRange))
else raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,[]))
let nestedSearchAccessible =
@@ -1434,7 +1582,7 @@ let ResolveLongIdentInType sink ncenv nenv lookupKind m ad lid findFlag typeName
ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind ResolutionInfo.Empty 0 m ad lid findFlag typeNameResInfo typ
|> AtMostOneResult m
|> ForceRaise
- ResolutionInfo.SendToSink (sink,ncenv,nenv,ItemOccurence.UseInType,ad,resInfo,(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
+ ResolutionInfo.SendToSink (sink,ncenv,nenv,ItemOccurence.UseInType,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
item,rest
let private ResolveLongIdentInTyconRef (ncenv:NameResolver) nenv lookupKind resInfo depth m ad lid typeNameResInfo tcref =
@@ -1454,9 +1602,9 @@ let private ResolveLongIdentInTyconRefs (ncenv:NameResolver) nenv lookupKind dep
// ResolveExprLongIdentInModuleOrNamespace
//-------------------------------------------------------------------------
-let (|AccessibleEntityRef|_|) ad (modref: ModuleOrNamespaceRef) mspec =
+let (|AccessibleEntityRef|_|) amap m ad (modref: ModuleOrNamespaceRef) mspec =
let eref = modref.MkNestedTyconRef mspec
- if IsEntityAccessible ad eref then Some eref else None
+ if IsEntityAccessible amap m ad eref then Some eref else None
let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeNameResInfo: TypeNameResolutionInfo) ad resInfo depth m modref (mty:ModuleOrNamespaceType) (lid :Ident list) =
// resInfo records the modules or namespaces actually relevant to a resolution
@@ -1469,13 +1617,13 @@ let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeN
success(resInfo,Item.Value (mkNestedValRef modref vspec),rest)
| _->
match TryFindTypeWithUnionCase modref id with
- | Some tycon when IsTyconReprAccessible ad (modref.MkNestedTyconRef tycon) ->
+ | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.MkNestedTyconRef tycon) ->
let ucref = mkUnionCaseRef (modref.MkNestedTyconRef tycon) id.idText
let ucinfo = FreshenUnionCaseRef ncenv m ucref
success (resInfo,Item.UnionCase ucinfo,rest)
| _ ->
match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with
- | Some excon when IsTyconReprAccessible ad (modref.MkNestedTyconRef excon) ->
+ | Some excon when IsTyconReprAccessible ncenv.amap m ad (modref.MkNestedTyconRef excon) ->
success (resInfo,Item.ExnCase (modref.MkNestedTyconRef excon),rest)
| _ ->
@@ -1505,7 +1653,7 @@ let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeN
let moduleSearch =
if (nonNil rest) then
match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with
- | Some(AccessibleEntityRef ad modref submodref) ->
+ | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) ->
let resInfo = resInfo.AddEntity(id.idRange,submodref)
OneResult (ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest)
@@ -1573,7 +1721,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n
match AtMostOneResult m search with
| Result _ as res ->
let resInfo,item,rest = ForceRaise res
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
Some(item,rest)
| _ ->
None
@@ -1592,13 +1740,13 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n
let implicitOpSearch =
if IsMangledOpName id.idText then
- success [(resInfo,Item.ImplicitOp id,[])]
+ success [(resInfo,Item.ImplicitOp(id, ref None),[])]
else NoResultsOrUsefulErrors
let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueOfConstructor,id,[]))
let search = ctorSearch +++ implicitOpSearch +++ failingCase
let resInfo,item,rest = ForceRaise (AtMostOneResult m search)
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
item,rest
@@ -1624,7 +1772,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n
// Otherwise modules are searched first. REVIEW: modules and types should be searched together.
// For each module referenced by 'id', search the module as if it were an F# module and/or a .NET namespace.
let moduleSearch ad =
- ResolveLongIndentAsModuleOrNamespaceThen fullyQualified nenv ad lid
+ ResolveLongIndentAsModuleOrNamespaceThen ncenv.amap m fullyQualified nenv ad lid
(ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad)
// REVIEW: somewhat surprisingly, this shows up on performance traces, with tcrefs non-nil.
@@ -1654,7 +1802,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n
| _ ->
let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,[]))
ForceRaise (AtMostOneResult m (search +++ moduleSearch AccessibleFromSomeFSharpCode +++ tyconSearch AccessibleFromSomeFSharpCode +++ failingCase))
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item));
item,rest
let ResolveExprLongIdent sink (ncenv:NameResolver) m ad nenv typeNameResInfo lid =
@@ -1670,14 +1818,14 @@ let rec ResolvePatternLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv num
| id :: rest ->
let m = unionRanges m id.idRange
match TryFindTypeWithUnionCase modref id with
- | Some tycon when IsTyconReprAccessible ad (modref.MkNestedTyconRef tycon) ->
+ | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.MkNestedTyconRef tycon) ->
let tcref = modref.MkNestedTyconRef tycon
let ucref = mkUnionCaseRef tcref id.idText
let ucinfo = FreshenUnionCaseRef ncenv m ucref
success (resInfo,Item.UnionCase ucinfo,rest)
| _ ->
match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with
- | Some exnc when IsEntityAccessible ad (modref.MkNestedTyconRef exnc) ->
+ | Some exnc when IsEntityAccessible ncenv.amap m ad (modref.MkNestedTyconRef exnc) ->
success (resInfo,Item.ExnCase (modref.MkNestedTyconRef exnc),rest)
| _ ->
// An active pattern constructor in a module
@@ -1712,7 +1860,7 @@ let rec ResolvePatternLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv num
let moduleSearch =
if nonNil rest then
match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with
- | Some(AccessibleEntityRef ad modref submodref) ->
+ | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) ->
let resInfo = resInfo.AddEntity(id.idRange,submodref)
OneResult (ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest)
| _ ->
@@ -1753,7 +1901,7 @@ let rec ResolvePatternLongIdentPrim sink (ncenv:NameResolver) fullyQualified war
// Long identifiers in patterns
| _ ->
let moduleSearch ad =
- ResolveLongIndentAsModuleOrNamespaceThen fullyQualified nenv ad lid
+ ResolveLongIndentAsModuleOrNamespaceThen ncenv.amap m fullyQualified nenv ad lid
(ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad)
let tyconSearch ad =
match lid with
@@ -1768,7 +1916,7 @@ let rec ResolvePatternLongIdentPrim sink (ncenv:NameResolver) fullyQualified war
| Result _ as res -> ForceRaise res
| _ ->
ForceRaise (AtMostOneResult m (tyconSearch AccessibleFromSomeFSharpCode +++ moduleSearch AccessibleFromSomeFSharpCode))
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> true));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> true));
if nonNil rest then error(Error(FSComp.SR.nrIsNotConstructorOrLiteral(),(List.head rest).idRange));
res
@@ -1781,20 +1929,22 @@ let ResolvePatternLongIdent sink (ncenv:NameResolver) warnOnUpper newDef m ad ne
// Resolve F#/IL "." syntax in types
//-------------------------------------------------------------------------
-let DerefAbbrevTyconRef_WORKAROUND (ncenv:NameResolver) (tcref: TyconRef) m =
- // HANDLE NON-GENERIC CASE OF BUG REPORTED TO FSBUGS: Nested types are not found when you abbreviate a .NET type
- //
- // Handling the generic case is harder, e.g. for
- // type X = List<int>
- //
- // X.ListEnumerator // should resolve
+/// Resolve nested types referenced through a .NET abbreviation.
+//
+// Note the generic case is not supported by F#, so
+// type X = List<int>
+//
+// X.ListEnumerator // does not resolve
+//
+let ResolveNestedTypeThroughAbbreviation (ncenv:NameResolver) (tcref: TyconRef) m =
if tcref.IsTypeAbbrev && tcref.Typars(m).IsEmpty && isAppTy ncenv.g tcref.TypeAbbrev.Value && isNil (argsOfAppTy ncenv.g tcref.TypeAbbrev.Value) then
tcrefOfAppTy ncenv.g tcref.TypeAbbrev.Value
else
tcref
+/// Resolve a long identifier representing a type name
let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo:TypeNameResolutionInfo) ad resInfo genOk depth m (tcref: TyconRef) (lid: Ident list) =
- let tcref = DerefAbbrevTyconRef_WORKAROUND ncenv tcref m
+ let tcref = ResolveNestedTypeThroughAbbreviation ncenv tcref m
match lid with
| [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m))
| [id] ->
@@ -1826,12 +1976,14 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo
AtMostOneResult m tyconSearch
+/// Resolve a long identifier representing a type name and report the result
let ResolveTypeLongIdentInTyconRef sink (ncenv:NameResolver) nenv typeNameResInfo ad m tcref (lid: Ident list) =
let resInfo,tcref = ForceRaise (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty PermitDirectReferenceToGeneratedType.No 0 m tcref lid)
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> true));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> true));
tcref
+/// Resolve a long identifier representing a type in a module or namespace
let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (typeNameResInfo: TypeNameResolutionInfo) ad genOk (resInfo:ResolutionInfo) depth m modref _mty (lid: Ident list) =
match lid with
| [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m))
@@ -1845,7 +1997,7 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (ty
let m = unionRanges m id.idRange
let modulSearch =
match modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with
- | Some(AccessibleEntityRef ad modref submodref) ->
+ | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) ->
let resInfo = resInfo.AddEntity(id.idRange,submodref)
ResolveTypeLongIdentInModuleOrNamespace ncenv typeNameResInfo ad genOk resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest
| _ ->
@@ -1857,6 +2009,7 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (ty
| [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,[]))
tyconSearch +++ modulSearch
+/// Resolve a long identifier representing a type
let rec ResolveTypeLongIdentPrim (ncenv:NameResolver) fullyQualified m nenv ad (lid: Ident list) (staticResInfo: TypeNameResolutionStaticArgsInfo) genOk =
let typeNameResInfo = TypeNameResolutionInfo.ResolveToTypeRefs staticResInfo
match lid with
@@ -1893,17 +2046,17 @@ let rec ResolveTypeLongIdentPrim (ncenv:NameResolver) fullyQualified m nenv ad (
NoResultsOrUsefulErrors
| OpenQualified ->
match LookupTypeNameInEnvHaveArity fullyQualified id.idText staticResInfo.NumStaticArgs nenv with
- | Some tcref when IsEntityAccessible ad tcref ->
+ | Some tcref when IsEntityAccessible ncenv.amap m ad tcref ->
OneResult (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty genOk 1 m tcref rest)
| _ ->
NoResultsOrUsefulErrors
let modulSearch =
- ResolveLongIndentAsModuleOrNamespaceThen fullyQualified nenv ad lid
+ ResolveLongIndentAsModuleOrNamespaceThen ncenv.amap m fullyQualified nenv ad lid
(ResolveTypeLongIdentInModuleOrNamespace ncenv typeNameResInfo ad genOk)
|?> List.concat
let modulSearchFailed() =
- ResolveLongIndentAsModuleOrNamespaceThen fullyQualified nenv AccessibleFromSomeFSharpCode lid
+ ResolveLongIndentAsModuleOrNamespaceThen ncenv.amap m fullyQualified nenv AccessibleFromSomeFSharpCode lid
(ResolveTypeLongIdentInModuleOrNamespace ncenv typeNameResInfo.DropStaticArgsInfo ad genOk)
|?> List.concat
match tyconSearch +++ modulSearch with
@@ -1924,13 +2077,14 @@ let rec ResolveTypeLongIdentPrim (ncenv:NameResolver) fullyQualified m nenv ad (
AtMostOneResult m ((tyconSearch +++ modulSearch +++ modulSearchFailed()) |?> (fun tcrefs -> CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, rangeOfLid lid)))
+/// Resolve a long identifier representing a type and report it
let ResolveTypeLongIdent sink (ncenv:NameResolver) occurence fullyQualified nenv ad (lid: Ident list) staticResInfo genOk =
let m = rangeOfLid lid
let res = ResolveTypeLongIdentPrim ncenv fullyQualified m nenv ad lid staticResInfo genOk
// Register the result as a name resolution
match res with
| Result (resInfo,tcref) ->
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.UseInType, ad,resInfo,(fun () -> true));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.UseInType, ad,resInfo,ResultTyparChecker(fun () -> true));
let item = Item.Types(tcref.DisplayName,[FreshenTycon ncenv m tcref])
CallNameResolutionSink sink (m,nenv,item,item,occurence,nenv.eDisplayEnv,ad)
| _ -> ()
@@ -1940,6 +2094,7 @@ let ResolveTypeLongIdent sink (ncenv:NameResolver) occurence fullyQualified nenv
// Resolve F#/IL "." syntax in records etc.
//-------------------------------------------------------------------------
+/// Resolve a long identifier representing a record field in a module or namespace
let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:ResolutionInfo) depth m (modref: ModuleOrNamespaceRef) _mty (lid: Ident list) =
let typeNameResInfo = TypeNameResolutionInfo.Default
match lid with
@@ -1949,7 +2104,7 @@ let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:Re
// search for module-qualified names, e.g. { Microsoft.FSharp.Core.contents = 1 }
let modulScopedFieldNames =
match TryFindTypeWithRecdField modref id with
- | Some tycon when IsEntityAccessible ad (modref.MkNestedTyconRef tycon) ->
+ | Some tycon when IsEntityAccessible ncenv.amap m ad (modref.MkNestedTyconRef tycon) ->
success(modref.MkNestedRecdFieldRef tycon id, rest)
| _ -> error
// search for type-qualified names, e.g. { Microsoft.FSharp.Core.Ref.contents = 1 }
@@ -1968,7 +2123,7 @@ let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:Re
let modulSearch =
if nonNil rest then
match modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with
- | Some(AccessibleEntityRef ad modref submodref) ->
+ | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) ->
let resInfo = resInfo.AddEntity(id.idRange,submodref)
ResolveFieldInModuleOrNamespace ncenv nenv ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest
| _ ->
@@ -1978,6 +2133,7 @@ let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:Re
| [] ->
error(InternalError("ResolveFieldInModuleOrNamespace",m))
+/// Resolve a long identifier representing a record field
let ResolveField (ncenv:NameResolver) nenv ad typ (mp,id:Ident) =
let typeNameResInfo = TypeNameResolutionInfo.Default
let g = ncenv.g
@@ -2010,7 +2166,7 @@ let ResolveField (ncenv:NameResolver) nenv ad typ (mp,id:Ident) =
tyconSearch
| _ -> NoResultsOrUsefulErrors
let modulSearch ad =
- ResolveLongIndentAsModuleOrNamespaceThen OpenQualified nenv ad lid
+ ResolveLongIndentAsModuleOrNamespaceThen ncenv.amap m OpenQualified nenv ad lid
(ResolveFieldInModuleOrNamespace ncenv nenv ad)
let item,rest = ForceRaise (AtMostOneResult m (modulSearch ad +++ tyconSearch ad +++ modulSearch AccessibleFromSomeFSharpCode +++ tyconSearch AccessibleFromSomeFSharpCode))
if nonNil rest then errorR(Error(FSComp.SR.nrInvalidFieldLabel(),(List.head rest).idRange));
@@ -2023,6 +2179,7 @@ let FreshenRecdFieldRef (ncenv:NameResolver) m (rfref:RecdFieldRef) =
/// Resolve F#/IL "." syntax in expressions (2).
+///
/// We have an expr. on the left, and we do an access, e.g.
/// (f obj).field or (f obj).meth. The basic rule is that if l-r type
/// inference has determined the outer type then we can proceed in a simple fashion. The exception
@@ -2072,7 +2229,7 @@ let ComputeItemRange wholem (lid: Ident list) rest =
/// Filters method groups that will be sent to Visual Studio IntelliSense
/// to include only static/instance members
-let filterMethodGroups (ncenv:NameResolver) itemRange item staticOnly =
+let FilterMethodGroups (ncenv:NameResolver) itemRange item staticOnly =
match item with
| Item.MethodGroup(nm, minfos) ->
let minfos = minfos |> List.filter (fun minfo ->
@@ -2080,7 +2237,7 @@ let filterMethodGroups (ncenv:NameResolver) itemRange item staticOnly =
Item.MethodGroup(nm, minfos)
| item -> item
-let needsOverloadResolution namedItem =
+let NeedsOverloadResolution namedItem =
match namedItem with
| Item.MethodGroup(_,_::_::_)
| Item.CtorGroup(_,_::_::_)
@@ -2088,32 +2245,34 @@ let needsOverloadResolution namedItem =
| _ -> false
type IfOverloadResolutionFails = IfOverloadResolutionFails of (unit -> unit)
-// Specifies if overload resolution needs to notify Language Service of overload resolution
+
+/// Specifies if overload resolution needs to notify Language Service of overload resolution
[<RequireQualifiedAccess>]
type AfterOverloadResolution =
- // Notfication is not needed
+ /// Notfication is not needed
| DoNothing
- // Notfy the sink
+ /// Notfy the sink
| SendToSink of (Item -> unit) * IfOverloadResolutionFails // Overload resolution failure fallback
- // Find override among given overrides and notify the sink
- // 'Item' contains the candidate overrides.
+ /// Find override among given overrides and notify the sink. The 'Item' contains the candidate overrides.
| ReplaceWithOverrideAndSendToSink of Item * (Item -> unit) * IfOverloadResolutionFails // Overload resolution failure fallback
+/// Resolve a long identifier occurring in an expression position.
+///
/// Called for 'TypeName.Bar' - for VS IntelliSense, we can filter out instance members from method groups
let ResolveLongIdentAsExprAndComputeRange (sink:TcResultsSink) (ncenv:NameResolver) wholem ad nenv typeNameResInfo lid =
let item,rest = ResolveExprLongIdent sink ncenv wholem ad nenv typeNameResInfo lid
let itemRange = ComputeItemRange wholem lid rest
// Record the precise resolution of the field for intellisense
- let item = filterMethodGroups ncenv itemRange item true
+ let item = FilterMethodGroups ncenv itemRange item true
let callSink refinedItem =
CallNameResolutionSink sink (itemRange, nenv, refinedItem, item, ItemOccurence.Use, nenv.DisplayEnv, ad);
let afterOverloadResolution =
match sink.CurrentSink with
| None -> AfterOverloadResolution.DoNothing
| Some _ ->
- if needsOverloadResolution item then
+ if NeedsOverloadResolution item then
AfterOverloadResolution.SendToSink(callSink, (fun () -> callSink item) |> IfOverloadResolutionFails)
else
callSink item
@@ -2137,7 +2296,7 @@ let ResolveExprDotLongIdentAndComputeRange (sink:TcResultsSink) (ncenv:NameResol
resInfo,item,rest,itemRange
// "true" resolution
let resInfo,item,rest,itemRange = resolveExpr findFlag
- ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,(fun () -> CheckAllTyparsInferrable ncenv.amap itemRange item));
+ ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap itemRange item));
// Record the precise resolution of the field for intellisense/goto definition
let afterOverloadResolution =
@@ -2154,10 +2313,10 @@ let ResolveExprDotLongIdentAndComputeRange (sink:TcResultsSink) (ncenv:NameResol
item, itemRange,true
let sendToSink refinedItem =
let staticOnly = thisIsActuallyATyAppNotAnExpr
- let refinedItem = filterMethodGroups ncenv itemRange refinedItem staticOnly
- let unrefinedItem = filterMethodGroups ncenv itemRange unrefinedItem staticOnly
+ let refinedItem = FilterMethodGroups ncenv itemRange refinedItem staticOnly
+ let unrefinedItem = FilterMethodGroups ncenv itemRange unrefinedItem staticOnly
CallNameResolutionSink sink (itemRange, nenv, refinedItem, unrefinedItem, ItemOccurence.Use, nenv.DisplayEnv, ad)
- match overrides,needsOverloadResolution unrefinedItem with
+ match overrides,NeedsOverloadResolution unrefinedItem with
| false, true ->
AfterOverloadResolution.SendToSink(sendToSink, IfOverloadResolutionFails(fun () -> sendToSink unrefinedItem))
| true, true ->
@@ -2183,20 +2342,19 @@ let ResolveExprDotLongIdentAndComputeRange (sink:TcResultsSink) (ncenv:NameResol
let FakeInstantiationGenerator (_m:range) gps = List.map mkTyparTy gps
-// note: making local refs is ok since it is only used by VS
+// note: using local refs is ok since it is only used by VS
let ItemForModuleOrNamespaceRef v = Item.ModuleOrNamespaces [v]
let ItemForPropInfo (pinfo:PropInfo) = Item.Property (pinfo.PropertyName, [pinfo])
-let ItemForMethInfos (nm,minfos) = MakeMethGroup(nm, minfos)
-let IsTyconUnseenObsoleteSpec ad g m (x:TyconRef) allowObsolete =
- not (IsEntityAccessible ad x) ||
+let IsTyconUnseenObsoleteSpec ad g amap m (x:TyconRef) allowObsolete =
+ not (IsEntityAccessible amap m ad x) ||
((not allowObsolete) &&
(if x.IsILTycon then
CheckILAttributesForUnseen g x.ILTyconRawMetadata.CustomAttrs m
else
CheckFSharpAttributesForUnseen g x.Attribs m))
-let IsTyconUnseen ad g m (x:TyconRef) = IsTyconUnseenObsoleteSpec ad g m x false
+let IsTyconUnseen ad g amap m (x:TyconRef) = IsTyconUnseenObsoleteSpec ad g amap m x false
let IsValUnseen ad g m (v:ValRef) =
not (IsValAccessible ad v) ||
@@ -2204,16 +2362,16 @@ let IsValUnseen ad g m (v:ValRef) =
v.Deref.IsClassConstructor ||
CheckFSharpAttributesForUnseen g v.Attribs m
-let IsUnionCaseUnseen ad g m (ucref:UnionCaseRef) =
- not (IsUnionCaseAccessible ad ucref) ||
- IsTyconUnseen ad g m ucref.TyconRef ||
+let IsUnionCaseUnseen ad g amap m (ucref:UnionCaseRef) =
+ not (IsUnionCaseAccessible amap m ad ucref) ||
+ IsTyconUnseen ad g amap m ucref.TyconRef ||
CheckFSharpAttributesForUnseen g ucref.Attribs m
-let ItemIsUnseen ad g m item =
+let ItemIsUnseen ad g amap m item =
match item with
| Item.Value x -> IsValUnseen ad g m x
- | Item.UnionCase x -> IsUnionCaseUnseen ad g m x.UnionCaseRef
- | Item.ExnCase x -> IsTyconUnseen ad g m x
+ | Item.UnionCase x -> IsUnionCaseUnseen ad g amap m x.UnionCaseRef
+ | Item.ExnCase x -> IsTyconUnseen ad g amap m x
| _ -> false
let ItemOfTyconRef ncenv m (x:TyconRef) =
@@ -2265,7 +2423,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv isApplicableMeth m ad st
if statics && isAppTy g typ then
let tc,tinst = destAppTy g typ
tc.UnionCasesAsRefList
- |> List.filter (IsUnionCaseUnseen ad g m >> not)
+ |> List.filter (IsUnionCaseUnseen ad g ncenv.amap m >> not)
|> List.map (fun ucref -> Item.UnionCase(UnionCaseInfo(tinst,ucref)))
else []
@@ -2289,7 +2447,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv isApplicableMeth m ad st
x.IsStatic = statics &&
IsILFieldInfoAccessible g amap m ad x)
let pinfosIncludingUnseen =
- AllPropInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (None,ad) PreferOverrides m typ
+ AllPropInfosOfTypeInScope ncenv.InfoReader nenv (None,ad) PreferOverrides m typ
|> List.filter (fun x ->
x.IsStatic = statics &&
IsPropInfoAccessible g amap m ad x)
@@ -2327,12 +2485,24 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv isApplicableMeth m ad st
// Don't show GetHashCode or Equals for F# types that admit equality as an abnormal operation
let isUnseenDueToBasicObjRules =
not (isObjTy g typ) &&
+ not minfo.IsExtensionMember &&
match minfo.LogicalName with
| "GetType" -> false
- | "GetHashCode" -> not (Augment.TypeDefinitelyHasEquality g typ)
+ | "GetHashCode" -> isObjTy g minfo.EnclosingType && not (Augment.TypeDefinitelyHasEquality g typ)
| "ToString" -> false
- | "Equals" -> not (minfo.IsInstance && Augment.TypeDefinitelyHasEquality g typ)
- | _ -> isObjTy g minfo.EnclosingType
+ | "Equals" ->
+ if not (isObjTy g minfo.EnclosingType) then
+ // declaring type is not System.Object - show it
+ false
+ elif minfo.IsInstance then
+ // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true
+ not (Augment.TypeDefinitelyHasEquality g typ)
+ else
+ // System.Object has only one static Equals method and we always want to suppress it
+ true
+ | _ ->
+ // filter out self methods of obj type
+ isObjTy g minfo.EnclosingType
let result =
not isUnseenDueToBasicObjRules &&
not minfo.IsInstance = statics &&
@@ -2359,7 +2529,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv isApplicableMeth m ad st
// REVIEW: add a name filter here in the common cases?
let minfos =
- AllMethInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (None,ad) PreferOverrides m typ
+ AllMethInfosOfTypeInScope ncenv.InfoReader nenv (None,ad) PreferOverrides m typ
|> List.filter minfoFilter
|> List.filter (fun minfo -> not(addersAndRemovers|>List.exists (fun ar-> ar = minfo.LogicalName)))
@@ -2380,7 +2550,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv isApplicableMeth m ad st
List.map Item.ILField finfos @
List.map Item.Event einfos @
List.map (ItemOfTy g) nestedTypes @
- List.map ItemForMethInfos (NameMap.toList (partitionl minfos Map.empty))
+ List.map Item.MakeMethGroup (NameMap.toList (partitionl minfos Map.empty))
let rec ResolvePartialLongIdentInType (ncenv: NameResolver) nenv isApplicableMeth m ad statics plid typ =
@@ -2392,7 +2562,7 @@ let rec ResolvePartialLongIdentInType (ncenv: NameResolver) nenv isApplicableMet
let rfinfos =
GetRecordOrClassFieldsOfType ncenv.InfoReader (None,ad) m typ
- |> List.filter (fun fref -> IsRecdFieldAccessible ad fref.RecdFieldRef)
+ |> List.filter (fun fref -> IsRecdFieldAccessible ncenv.amap m ad fref.RecdFieldRef)
|> List.filter (fun fref -> fref.RecdField.IsStatic = statics)
let nestedTypes =
@@ -2409,7 +2579,7 @@ let rec ResolvePartialLongIdentInType (ncenv: NameResolver) nenv isApplicableMet
let rty = if pinfo.IsIndexer then mkTupledTy g (pinfo.GetParamTypes(amap, m)) --> rty else rty
rty
(typ
- |> AllPropInfosOfTypeInScope ncenv.InfoReader nenv.eExtensionMembers (Some id,ad) IgnoreOverrides m
+ |> AllPropInfosOfTypeInScope ncenv.InfoReader nenv (Some id,ad) IgnoreOverrides m
|> List.filter (fun x -> x.IsStatic = statics)
|> List.filter (IsPropInfoAccessible g amap m ad)
|> List.collect (fun pinfo -> (FullTypeOfPinfo pinfo) |> ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad false rest)) @
@@ -2449,7 +2619,7 @@ let InfosForTyconConstructors (ncenv:NameResolver) m ad (tcref:TyconRef) =
|> List.filter (MethInfoIsUnseen g m typ >> not)
match ctors with
| [] -> []
- | _ -> [MakeCtorGroup(nm,ctors)]
+ | _ -> [Item.MakeCtorGroup(nm,ctors)]
| item ->
[item]
| Exception _ -> []
@@ -2486,7 +2656,7 @@ let rec private EntityRefContainsSomethingAccessible (ncenv: NameResolver) m ad
(mty.AllEntities
|> QueueList.exists (fun tc ->
not tc.IsModuleOrNamespace &&
- not (IsTyconUnseen ad g m (modref.MkNestedTyconRef tc)))) ||
+ not (IsTyconUnseen ad g ncenv.amap m (modref.MkNestedTyconRef tc)))) ||
// Search the sub-modules of the namespace/modulefor something accessible
(mty.ModulesAndNamespacesByDemangledName
@@ -2501,7 +2671,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
let tycons =
mty.TypeDefinitions
|> List.filter (fun tcref -> not (tcref.LogicalName.Contains(",")))
- |> List.filter (fun tycon -> not (IsTyconUnseen ad g m (modref.MkNestedTyconRef tycon)))
+ |> List.filter (fun tycon -> not (IsTyconUnseen ad g ncenv.amap m (modref.MkNestedTyconRef tycon)))
let ilTyconNames =
mty.TypesByAccessNames.Values
@@ -2515,14 +2685,14 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
// Collect up the accessible values in the module, excluding the members
(mty.AllValsAndMembers
|> Seq.toList
- |> List.choose (tryMkValRefInModRef modref) // if the assembly load set is incomplete and we get a None value here, then ignore the value
+ |> List.choose (TryMkValRefInModRef modref) // if the assembly load set is incomplete and we get a None value here, then ignore the value
|> List.filter (fun v -> v.MemberInfo.IsNone)
|> List.filter (IsValUnseen ad g m >> not)
|> List.map Item.Value)
// Collect up the accessible discriminated union cases in the module
@ (UnionCaseRefsInModuleOrNamespace modref
- |> List.filter (IsUnionCaseUnseen ad g m >> not)
+ |> List.filter (IsUnionCaseUnseen ad g ncenv.amap m >> not)
|> List.map GeneralizeUnionCaseRef
|> List.map Item.UnionCase)
@@ -2537,7 +2707,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
@ (mty.ExceptionDefinitionsByDemangledName
|> NameMap.range
|> List.map modref.MkNestedTyconRef
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.map Item.ExnCase)
// Collect up the accessible sub-modules
@@ -2546,7 +2716,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> notFakeContainerModule ilTyconNames)
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> IsInterestingModuleName)
|> List.map modref.MkNestedTyconRef
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.filter (EntityRefContainsSomethingAccessible ncenv m ad)
|> List.map ItemForModuleOrNamespaceRef)
@@ -2561,7 +2731,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
(match mty.ModulesAndNamespacesByDemangledName.TryFind(id) with
| Some mspec
- when not (IsTyconUnseenObsoleteSpec ad g m (modref.MkNestedTyconRef mspec) allowObsolete) ->
+ when not (IsTyconUnseenObsoleteSpec ad g ncenv.amap m (modref.MkNestedTyconRef mspec) allowObsolete) ->
let allowObsolete = rest <> [] && allowObsolete
ResolvePartialLongIdentInModuleOrNamespace ncenv nenv isApplicableMeth m ad (modref.MkNestedTyconRef mspec) rest allowObsolete
| _ -> [])
@@ -2569,7 +2739,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is
@ (LookupTypeNameInEntityNoArity m id modref.ModuleOrNamespaceType
|> List.collect (fun tycon ->
let tcref = modref.MkNestedTyconRef tycon
- if not (IsTyconUnseenObsoleteSpec ad g m tcref allowObsolete) then
+ if not (IsTyconUnseenObsoleteSpec ad g ncenv.amap m tcref allowObsolete) then
tcref |> generalizedTyconRef |> ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad true rest
else
[]))
@@ -2600,7 +2770,7 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE
nenv.eUnqualifiedItems.Values
|> Seq.toList
|> List.filter (function Item.UnqualifiedType _ -> false | _ -> true)
- |> List.filter (ItemIsUnseen ad g m >> not)
+ |> List.filter (ItemIsUnseen ad g ncenv.amap m >> not)
let activePatternItems =
match fullyQualified with
@@ -2616,7 +2786,7 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> IsInterestingModuleName )
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> notFakeContainerModule ilTyconNames)
|> List.filter (EntityRefContainsSomethingAccessible ncenv m ad)
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.map ItemForModuleOrNamespaceRef
let tycons =
@@ -2624,14 +2794,14 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE
|> Seq.toList
|> List.filter (fun tcref -> not (tcref.LogicalName.Contains(",")))
|> List.filter (fun tcref -> not tcref.IsExceptionDecl)
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.map (ItemOfTyconRef ncenv m)
// Get all the constructors accessible from here
let constructors =
nenv.TyconsByDemangledNameAndArity(fullyQualified).Values
|> Seq.toList
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.collect (InfosForTyconConstructors ncenv m ad)
unqualifiedItems @ activePatternItems @ moduleAndNamespaceItems @ tycons @ constructors
@@ -2662,7 +2832,7 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE
[ if not isItemVal then
// type.lookup : lookup a static something in a type
for tcref in LookupTypeNameInEnvNoArity OpenQualified id nenv do
- let tcref = DerefAbbrevTyconRef_WORKAROUND ncenv tcref m
+ let tcref = ResolveNestedTypeThroughAbbreviation ncenv tcref m
let typ = FreshenTycon ncenv m tcref
yield! ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad true rest typ ]
namespaces @ values @ staticSometingInType
@@ -2681,7 +2851,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForRecordFields (ncenv: NameRe
mty.TypeDefinitions
|> List.filter (fun tcref -> not (tcref.LogicalName.Contains(",")))
|> List.filter (fun tycon -> tycon.IsRecordTycon)
- |> List.filter (fun tycon -> not (IsTyconUnseen ad g m (modref.MkNestedTyconRef tycon)))
+ |> List.filter (fun tycon -> not (IsTyconUnseen ad g ncenv.amap m (modref.MkNestedTyconRef tycon)))
let ilTyconNames =
mty.TypesByAccessNames.Values
@@ -2697,7 +2867,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForRecordFields (ncenv: NameRe
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> notFakeContainerModule ilTyconNames)
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> IsInterestingModuleName)
|> List.map modref.MkNestedTyconRef
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.filter (EntityRefContainsSomethingAccessible ncenv m ad)
|> List.map ItemForModuleOrNamespaceRef)
@@ -2705,7 +2875,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForRecordFields (ncenv: NameRe
@ (tycons |> List.map (modref.MkNestedTyconRef >> ItemOfTyconRef ncenv m) )
@ [ // accessible record fields
for tycon in tycons do
- if IsEntityAccessible ad (modref.MkNestedTyconRef tycon) then
+ if IsEntityAccessible ncenv.amap m ad (modref.MkNestedTyconRef tycon) then
let ttype = FreshenTycon ncenv m (modref.MkNestedTyconRef tycon)
yield!
GetRecordOrClassFieldsOfType ncenv.InfoReader (None, ad) m ttype
@@ -2715,7 +2885,7 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForRecordFields (ncenv: NameRe
| id :: rest ->
(match mty.ModulesAndNamespacesByDemangledName.TryFind(id) with
| Some mspec
- when not (IsTyconUnseenObsoleteSpec ad g m (modref.MkNestedTyconRef mspec) allowObsolete) ->
+ when not (IsTyconUnseenObsoleteSpec ad g ncenv.amap m (modref.MkNestedTyconRef mspec) allowObsolete) ->
let allowObsolete = rest <> [] && allowObsolete
ResolvePartialLongIdentInModuleOrNamespaceForRecordFields ncenv nenv m ad (modref.MkNestedTyconRef mspec) rest allowObsolete
| _ -> [])
@@ -2762,7 +2932,7 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv:
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> IsInterestingModuleName )
|> List.filter (fun x -> x.DemangledModuleOrNamespaceName |> notFakeContainerModule iltyconNames)
|> List.filter (EntityRefContainsSomethingAccessible ncenv m ad)
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.map ItemForModuleOrNamespaceRef
let recdTyCons =
@@ -2770,7 +2940,7 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv:
|> Seq.toList
|> List.filter (fun tcref -> not (tcref.LogicalName.Contains(",")))
|> List.filter (fun tcref -> tcref.IsRecordTycon)
- |> List.filter (IsTyconUnseen ad g m >> not)
+ |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not)
|> List.map (ItemOfTyconRef ncenv m)
let recdFields =
@@ -2805,4 +2975,4 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv:
)
|> List.map Item.RecdField
| _-> []
- modsOrNs @ qualifiedFields
\ No newline at end of file
+ modsOrNs @ qualifiedFields
diff --git a/src/fsharp/nameres.fsi b/src/fsharp/nameres.fsi
index de2996e..bd57d56 100755
--- a/src/fsharp/nameres.fsi
+++ b/src/fsharp/nameres.fsi
@@ -51,9 +51,6 @@ type Item =
| ActivePatternCase of ActivePatternElemRef
| ExnCase of TyconRef
| RecdField of RecdFieldInfo
-
- // The following are never in the items table but are valid results of binding
- // an identitifer in different circumstances.
| NewDef of Ident
| ILField of ILFieldInfo
| Event of EventInfo
@@ -70,30 +67,35 @@ type Item =
| CustomBuilder of string * ValRef
| TypeVar of string
| ModuleOrNamespaces of Tast.ModuleOrNamespaceRef list
- /// Represents the resolution of a source identifier to an implicit use of an infix operator
- | ImplicitOp of Ident
+ /// Represents the resolution of a source identifier to an implicit use of an infix operator (+solution if such available)
+ | ImplicitOp of Ident * TraitConstraintSln option ref
/// Represents the resolution of a source identifier to a named argument
| ArgName of Ident * TType
| SetterArg of Ident * Item
| UnqualifiedType of TyconRef list
+ member DisplayName : TcGlobals -> string
+
[<Sealed>]
+/// Information about an extension member held in the name resolution environment
type ExtensionMember
[<NoEquality; NoComparison>]
+/// The environment of information used to resolve names
type NameResolutionEnv =
- {eDisplayEnv: DisplayEnv;
- eUnqualifiedItems: LayeredMap<string,Item>;
- ePatItems: NameMap<Item>;
- eModulesAndNamespaces: NameMultiMap<ModuleOrNamespaceRef>;
- eFullyQualifiedModulesAndNamespaces: NameMultiMap<ModuleOrNamespaceRef>;
- eFieldLabels: NameMultiMap<RecdFieldRef>;
- eTyconsByAccessNames: LayeredMultiMap<string,TyconRef>;
- eFullyQualifiedTyconsByAccessNames: LayeredMultiMap<string,TyconRef>;
- eTyconsByDemangledNameAndArity: LayeredMap<NameArityPair,TyconRef>;
- eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap<NameArityPair,TyconRef>;
- eExtensionMembers: TyconRefMultiMap<ExtensionMember>;
- eTypars: NameMap<Typar>;}
+ {eDisplayEnv: DisplayEnv
+ eUnqualifiedItems: LayeredMap<string,Item>
+ ePatItems: NameMap<Item>
+ eModulesAndNamespaces: NameMultiMap<ModuleOrNamespaceRef>
+ eFullyQualifiedModulesAndNamespaces: NameMultiMap<ModuleOrNamespaceRef>
+ eFieldLabels: NameMultiMap<RecdFieldRef>
+ eTyconsByAccessNames: LayeredMultiMap<string,TyconRef>
+ eFullyQualifiedTyconsByAccessNames: LayeredMultiMap<string,TyconRef>
+ eTyconsByDemangledNameAndArity: LayeredMap<NameArityPair,TyconRef>
+ eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap<NameArityPair,TyconRef>
+ eIndexedExtensionMembers: TyconRefMultiMap<ExtensionMember>
+ eUnindexedExtensionMembers: ExtensionMember list
+ eTypars: NameMap<Typar> }
static member Empty : g:TcGlobals -> NameResolutionEnv
member DisplayEnv : DisplayEnv
member FindUnqualifiedItem : string -> Item
@@ -105,8 +107,6 @@ type FullyQualifiedFlag =
[<RequireQualifiedAccess>]
type BulkAdd = Yes | No
-val public DisplayNameOfItem : TcGlobals -> Item -> string
-
val internal AddFakeNamedValRefToNameEnv : string -> NameResolutionEnv -> ValRef -> NameResolutionEnv
val internal AddFakeNameToNameEnv : string -> NameResolutionEnv -> Item -> NameResolutionEnv
@@ -116,7 +116,7 @@ val internal AddTyconRefsToNameEnv : BulkAdd -> bool -> TcGlobal
val internal AddExceptionDeclsToNameEnv : BulkAdd -> NameResolutionEnv -> TyconRef -> NameResolutionEnv
val internal AddModuleAbbrevToNameEnv : Ident -> NameResolutionEnv -> ModuleOrNamespaceRef list -> NameResolutionEnv
val internal AddModuleOrNamespaceRefsToNameEnv : TcGlobals -> ImportMap -> range -> bool -> AccessorDomain -> NameResolutionEnv -> ModuleOrNamespaceRef list -> NameResolutionEnv
-val internal AddModrefToNameEnv : TcGlobals -> ImportMap -> range -> bool -> AccessorDomain -> NameResolutionEnv -> ModuleOrNamespaceRef -> NameResolutionEnv
+val internal AddModuleOrNamespaceRefToNameEnv : TcGlobals -> ImportMap -> range -> bool -> AccessorDomain -> NameResolutionEnv -> ModuleOrNamespaceRef -> NameResolutionEnv
val internal AddModulesAndNamespacesContentsToNameEnv : TcGlobals -> ImportMap -> AccessorDomain -> range -> NameResolutionEnv -> ModuleOrNamespaceRef list -> NameResolutionEnv
type CheckForDuplicateTyparFlag =
@@ -136,7 +136,7 @@ type TypeNameResolutionStaticArgsInfo =
/// Indicates definite knowledge of empty type arguments, i.e. the logical equivalent of name< >
static member DefiniteEmpty : TypeNameResolutionStaticArgsInfo
/// Deduce definite knowledge of type arguments
- static member FromTyArgs : SynType list -> TypeNameResolutionStaticArgsInfo
+ static member FromTyArgs : numTyArgs:int -> TypeNameResolutionStaticArgsInfo
[<NoEquality; NoComparison>]
type TypeNameResolutionInfo =
@@ -168,8 +168,8 @@ val internal CallEnvSink : TcResultsSink -> range * NameResolutio
val internal CallNameResolutionSink : TcResultsSink -> range * NameResolutionEnv * Item * Item * ItemOccurence * DisplayEnv * AccessorDomain -> unit
val internal CallExprHasTypeSink : TcResultsSink -> range * NameResolutionEnv * TType * DisplayEnv * AccessorDomain -> unit
-val internal AllPropInfosOfTypeInScope : InfoReader -> TyconRefMultiMap<ExtensionMember> -> string option * AccessorDomain -> FindMemberFlag -> range -> TType -> PropInfo list
-val internal AllMethInfosOfTypeInScope : InfoReader -> TyconRefMultiMap<ExtensionMember> -> string option * AccessorDomain -> FindMemberFlag -> range -> TType -> MethInfo list
+val internal AllPropInfosOfTypeInScope : InfoReader -> NameResolutionEnv -> string option * AccessorDomain -> FindMemberFlag -> range -> TType -> PropInfo list
+val internal AllMethInfosOfTypeInScope : InfoReader -> NameResolutionEnv -> string option * AccessorDomain -> FindMemberFlag -> range -> TType -> MethInfo list
exception internal IndeterminateType of range
exception internal UpperCaseIdentifierInPattern of range
@@ -195,7 +195,7 @@ type PermitDirectReferenceToGeneratedType =
| Yes
| No
-val internal ResolveLongIndentAsModuleOrNamespace : FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident list -> ResultOrException<(int * ModuleOrNamespaceRef * ModuleOrNamespaceType) list >
+val internal ResolveLongIndentAsModuleOrNamespace : Import.ImportMap -> range -> FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident list -> ResultOrException<(int * ModuleOrNamespaceRef * ModuleOrNamespaceType) list >
val internal ResolveObjectConstructor : NameResolver -> DisplayEnv -> range -> AccessorDomain -> TType -> ResultOrException<Item>
val internal ResolveLongIdentInType : TcResultsSink -> NameResolver -> NameResolutionEnv -> LookupKind -> range -> AccessorDomain -> Ident list -> FindMemberFlag -> TypeNameResolutionInfo -> TType -> Item * Ident list
val internal ResolvePatternLongIdent : TcResultsSink -> NameResolver -> WarnOnUpperFlag -> bool -> range -> AccessorDomain -> NameResolutionEnv -> TypeNameResolutionInfo -> Ident list -> Item
diff --git a/src/fsharp/opt.fs b/src/fsharp/opt.fs
index d72585e..3f2b835 100755
--- a/src/fsharp/opt.fs
+++ b/src/fsharp/opt.fs
@@ -2965,10 +2965,16 @@ and OptimizeBinding cenv isRec env (TBind(v,e,spBind)) =
// MarshalByRef methods may not be inlined
(match v.ActualParent with
| Parent tcref ->
+ match cenv.g.system_MarshalByRefObject_tcref with
+ | None -> false
+ | Some mbrTyconRef ->
// Check we can deref system_MarshalByRefObject_tcref. When compiling against the Silverlight mscorlib we can't
- cenv.g.system_MarshalByRefObject_tcref.TryDeref.IsSome &&
- // Check if this is a subtype of MarshalByRefObject
- ExistsSameHeadTypeInHierarchy cenv.g cenv.amap v.Range (generalizedTyconRef tcref) cenv.g.system_MarshalByRefObject_typ
+ if mbrTyconRef.TryDeref.IsSome then
+ // Check if this is a subtype of MarshalByRefObject
+ assert (cenv.g.system_MarshalByRefObject_typ.IsSome)
+ ExistsSameHeadTypeInHierarchy cenv.g cenv.amap v.Range (generalizedTyconRef tcref) cenv.g.system_MarshalByRefObject_typ.Value
+ else
+ false
| ParentNone -> false) ||
// These values are given a special going-over by the optimizer and
diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy
index f2fa10e..fef2030 100755
--- a/src/fsharp/pars.fsy
+++ b/src/fsharp/pars.fsy
@@ -447,8 +447,9 @@ let rangeOfLongIdent(lid:LongIdent) =
%right COLON_EQUALS
%nonassoc pat_tuple expr_tuple
%left COMMA
-%nonassoc slice_comma /* for matrix.[1..2,3..4] the ".." has higher precedence than "2,3" */
-%nonassoc DOT_DOT /* for matrix.[1..2,3..4] the ".." has higher precedence than "2,3" */
+%nonassoc slice_expr /* matrix.[e COMMA e] has higher precedence than "e COMMA e" */
+%nonassoc DOT_DOT /* for matrix.[1..2,3..4] the ".." has higher precedence than expression "2 COMMA 3" */
+%nonassoc slice_comma /* for matrix.[1..2,3..4] the "," has higher precedence than ".." */
%nonassoc paren_pat_colon
%nonassoc paren_pat_attribs
%left OR BAR_BAR JOIN_IN
@@ -1494,7 +1495,7 @@ memberCore:
let lidOuter,lidVisOuter =
match bindingPatOuter with
- | SynPat.LongIdent (lid,None,None,[],lidVisOuter,m) -> lid,lidVisOuter
+ | SynPat.LongIdent (lid,None,None, SynConstructorArgs.Pats [],lidVisOuter,m) -> lid,lidVisOuter
| SynPat.Named (_,id,_,visOuter,m) -> LongIdentWithDots([id],[]),visOuter
| p -> raiseParseErrorAt mBindLhs (FSComp.SR.parsInvalidDeclarationSyntax())
@@ -1512,7 +1513,7 @@ memberCore:
// Replace the "get" or the "set" with the right name
let rec go p =
match p with
- | SynPat.LongIdent (LongIdentWithDots([id],_),_,tyargs,args,lidVisInner,m) ->
+ | SynPat.LongIdent (LongIdentWithDots([id],_),_,tyargs,SynConstructorArgs.Pats args,lidVisInner,m) ->
// Setters have all arguments tupled in their internal form, though they don't
// appear to be tupled from the syntax. Somewhat unfortunate
let args =
@@ -1529,8 +1530,8 @@ memberCore:
else
args
// let idTool : Ident list = lidOuter |> List.map (fun (li:Ident) -> ident(li.idText,id.idRange)) |> List.rev |> List.take 1
- SynPat.LongIdent (lidOuter,Some(id),tyargs,args,mergeLidVisOuter lidVisInner,m)
- | SynPat.Named (_,nm,_,lidVisInner,m) -> SynPat.LongIdent (lidOuter,None,None,[],mergeLidVisOuter lidVisInner,m)
+ SynPat.LongIdent (lidOuter,Some(id),tyargs, SynConstructorArgs.Pats args,mergeLidVisOuter lidVisInner,m)
+ | SynPat.Named (_,nm,_,lidVisInner,m) -> SynPat.LongIdent (lidOuter,None,None, SynConstructorArgs.Pats [], mergeLidVisOuter lidVisInner,m)
| SynPat.Typed (p,ty,m) -> SynPat.Typed(go p,ty,m)
| SynPat.Attrib (p,attribs,m) -> SynPat.Attrib(go p,attribs,m)
| SynPat.Wild(m) -> SynPat.Wild(m)
@@ -1605,7 +1606,7 @@ classDefnMember:
let expr = $7
let valSynData = SynValData (Some CtorMemberFlags, SynValInfo([SynInfo.InferSynArgInfoFromPat $4],SynInfo.unnamedRetVal), $5)
let vis = $2
- let declPat = SynPat.LongIdent (LongIdentWithDots([mkSynId (rhs parseState 3) "new"],[]),None,Some noInferredTypars,[$4],vis,rhs parseState 3)
+ let declPat = SynPat.LongIdent (LongIdentWithDots([mkSynId (rhs parseState 3) "new"],[]),None,Some noInferredTypars, SynConstructorArgs.Pats [$4],vis,rhs parseState 3)
// Check that 'SynPatForConstructorDecl' matches this correctly
assert (match declPat with SynPatForConstructorDecl _ -> true | _ -> false);
[ SynMemberDefn.Member(Binding (None,NormalBinding,false,false,$1,grabXmlDoc(parseState,3),valSynData, declPat,None,expr,m,NoSequencePointAtInvisibleBinding),m) ] }
@@ -1800,10 +1801,10 @@ tyconNameAndTyparDecls:
prefixTyparDecls:
| typar { [ TyparDecl([],$1) ] }
- | LPAREN prefixTyparDeclList rparen { List.rev $2 }
+ | LPAREN typarDeclList rparen { List.rev $2 }
-prefixTyparDeclList:
- | prefixTyparDeclList COMMA typarDecl { $3 :: $1 }
+typarDeclList:
+ | typarDeclList COMMA typarDecl { $3 :: $1 }
| typarDecl { [$1] }
typarDecl :
@@ -1813,16 +1814,16 @@ typarDecl :
/* Any tokens in this grammar must be added to the lex filter rule 'peekAdjacentTypars' */
/* See the F# specification "Lexical analysis of type applications and type parameter definitions" */
postfixTyparDecls:
- | opt_HIGH_PRECEDENCE_TYAPP LESS prefixTyparDeclList opt_typeConstraints GREATER
+ | opt_HIGH_PRECEDENCE_TYAPP LESS typarDeclList opt_typeConstraints GREATER
{ if not $2 then warning(Error(FSComp.SR.parsNonAdjacentTypars(),rhs2 parseState 2 5));
List.rev $3, $4 }
/* Any tokens in this grammar must be added to the lex filter rule 'peekAdjacentTypars' */
/* See the F# specification "Lexical analysis of type applications and type parameter definitions" */
explicitValTyparDeclsCore:
- | prefixTyparDeclList COMMA DOT_DOT
+ | typarDeclList COMMA DOT_DOT
{ (List.rev $1,true) }
- | prefixTyparDeclList
+ | typarDeclList
{ (List.rev $1,false) }
|
{ ([],false) }
@@ -1965,14 +1966,19 @@ firstUnionCaseDecl:
Choice1Of2 (EnumCase ([],$1,$3,PreXmlDoc.Empty,rhs2 parseState 1 3))
}
+unionCaseReprElements:
+ | unionCaseReprElement STAR unionCaseReprElements { $1::$3 }
+ | unionCaseReprElement %prec prec_toptuptyptail_prefix { [$1] }
+
+unionCaseReprElement:
+ | ident COLON appType { mkNamedField($1, $3) }
+ | appType { mkAnonField $1 }
+
unionCaseRepr:
| braceFieldDeclList
{ errorR(Deprecated(FSComp.SR.parsConsiderUsingSeparateRecordType(),lhs parseState));
$1 }
- | appType STAR tupleTypeElements
- { List.map mkAnonField ($1 :: $3) }
- | appType
- { [mkAnonField $1] }
+ | unionCaseReprElements { $1 }
recdFieldDeclList:
| recdFieldDecl seps recdFieldDeclList
@@ -2122,7 +2128,7 @@ cPrototype:
SynExpr.Const(SynConst.String("extern was not given a DllImport attribute",rhs parseState 8),rhs parseState 8),
mRhs)
(fun attrs vis ->
- let bindingId = SynPat.LongIdent (LongIdentWithDots([nm],[]), None, Some noInferredTypars, [SynPat.Tuple(args,argsm)], vis, nmm)
+ let bindingId = SynPat.LongIdent (LongIdentWithDots([nm],[]), None, Some noInferredTypars, SynConstructorArgs.Pats [SynPat.Tuple(args,argsm)], vis, nmm)
let binding = mkSynBinding
(xmlDoc, bindingId)
(vis, false, false, mBindLhs, NoSequencePointAtInvisibleBinding, Some rty ,rhsExpr, mRhs, [], attrs, None)
@@ -2348,7 +2354,7 @@ headBindingPattern:
| headBindingPattern BAR headBindingPattern
{ SynPat.Or($1,$3,rhs2 parseState 1 3) }
| headBindingPattern COLON_COLON headBindingPattern
- { SynPat.LongIdent (LongIdentWithDots(mkSynCaseName (rhs parseState 2) opNameCons,[]), None, None,[SynPat.Tuple ([$1;$3],rhs2 parseState 1 3)],None,lhs parseState) }
+ { SynPat.LongIdent (LongIdentWithDots(mkSynCaseName (rhs parseState 2) opNameCons,[]), None, None, SynConstructorArgs.Pats [SynPat.Tuple ([$1;$3],rhs2 parseState 1 3)],None,lhs parseState) }
| tuplePatternElements %prec pat_tuple
{ SynPat.Tuple(List.rev $1, lhs parseState) }
| conjPatternElements %prec pat_conj
@@ -2368,20 +2374,31 @@ conjPatternElements:
| headBindingPattern AMP headBindingPattern
{ $3 :: $1 :: [] }
+namePatPairs:
+ | namePatPair opt_seps { [$1], lhs parseState }
+ | namePatPair seps namePatPairs { let (rs, _) = $3 in ($1::rs), lhs parseState }
+
+namePatPair:
+ | ident EQUALS parenPattern { ($1, $3) }
+
constrPattern:
| atomicPatternLongIdent explicitValTyparDecls
- { let vis,lid = $1 in SynPat.LongIdent (lid,None,Some $2,[],vis,lhs parseState) }
- | atomicPatternLongIdent opt_explicitValTyparDecls2 atomicPatterns %prec pat_app
- { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2,$3,vis,lhs parseState) }
- | atomicPatternLongIdent opt_explicitValTyparDecls2 HIGH_PRECEDENCE_PAREN_APP atomicPatterns
- { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2,$4,vis,lhs parseState) }
- | atomicPatternLongIdent opt_explicitValTyparDecls2 HIGH_PRECEDENCE_BRACK_APP atomicPatterns
- { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2,$4,vis,lhs parseState) }
+ { let vis,lid = $1 in SynPat.LongIdent (lid,None,Some $2, SynConstructorArgs.Pats [],vis,lhs parseState) }
+ | atomicPatternLongIdent opt_explicitValTyparDecls2 atomicPatsOrNamePatPairs %prec pat_app
+ { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2, $3,vis,lhs parseState) }
+ | atomicPatternLongIdent opt_explicitValTyparDecls2 HIGH_PRECEDENCE_PAREN_APP atomicPatsOrNamePatPairs
+ { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2, $4,vis,lhs parseState) }
+ | atomicPatternLongIdent opt_explicitValTyparDecls2 HIGH_PRECEDENCE_BRACK_APP atomicPatsOrNamePatPairs
+ { let vis,lid = $1 in SynPat.LongIdent (lid,None,$2, $4,vis,lhs parseState) }
| COLON_QMARK atomType %prec pat_isinst
{ SynPat.IsInst($2,lhs parseState) }
| atomicPattern
{ $1 }
+atomicPatsOrNamePatPairs:
+ | LPAREN namePatPairs rparen { SynConstructorArgs.NamePatPairs $2 }
+ | atomicPatterns { SynConstructorArgs.Pats $1 }
+
atomicPatterns:
| atomicPattern atomicPatterns %prec pat_args
{ $1 :: $2 }
@@ -2482,7 +2499,7 @@ parenPattern:
{ let lhsm = lhs parseState
SynPat.Attrib($2,$1,lhsm) }
| parenPattern COLON_COLON parenPattern
- { SynPat.LongIdent (LongIdentWithDots(mkSynCaseName (rhs parseState 2) opNameCons,[]), None, None, [ SynPat.Tuple ([$1;$3],rhs2 parseState 1 3) ],None,lhs parseState) }
+ { SynPat.LongIdent (LongIdentWithDots(mkSynCaseName (rhs parseState 2) opNameCons,[]), None, None, SynConstructorArgs.Pats [ SynPat.Tuple ([$1;$3],rhs2 parseState 1 3) ],None,lhs parseState) }
| constrPattern { $1 }
tupleParenPatternElements:
@@ -3198,10 +3215,12 @@ atomicExprQualification:
{ (fun e lhsm dotm ->
libraryOnlyError(lhs parseState);
SynExpr.LibraryOnlyUnionCaseFieldGet (e,mkSynCaseName lhsm opNameCons,(fst $5),lhsm)) }
+
| LPAREN typedSeqExpr rparen
{ (fun e lhsm dotm ->
mlCompatWarning (FSComp.SR.parsParenFormIsForML()) (lhs parseState);
mkSynDotParenGet lhsm dotm e $2) }
+
| LBRACK typedSeqExpr RBRACK
{ (fun e lhsm dotm -> mkSynDotBrackGet lhsm dotm e $2) }
@@ -3209,31 +3228,36 @@ atomicExprQualification:
{ reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnmatchedBracket());
(fun e lhsm dotm -> exprFromParseError (mkSynDotBrackGet lhsm dotm e $2)) }
+ | LBRACK optRange RBRACK
+ { (fun e lhsm dotm -> mkSynDotBrackSliceGet lhsm dotm e $2) }
+ | LBRACK optRange COMMA optRange RBRACK %prec slice_comma
+ { (fun e lhsm dotm -> mkSynDotBrackSlice2Get lhsm dotm e $2 $4) }
+ | LBRACK optRange COMMA optRange COMMA optRange RBRACK %prec slice_comma
+ { (fun e lhsm dotm -> mkSynDotBrackSlice3Get lhsm dotm e $2 $4 $6) }
+ | LBRACK optRange COMMA optRange COMMA optRange COMMA optRange RBRACK %prec slice_comma
+ { (fun e lhsm dotm -> mkSynDotBrackSlice4Get lhsm dotm e $2 $4 $6 $8) }
+
| LBRACK error RBRACK
{ let mArg = rhs2 parseState 1 3
(fun e lhsm dotm -> mkSynDotBrackGet lhsm dotm e (arbExpr("indexerExpr1",mArg))) }
+
| LBRACK recover
{ reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnmatchedBracket())
let mArg = (rhs parseState 1).EndRange
(fun e lhsm dotm -> exprFromParseError (mkSynDotBrackGet lhsm dotm e (arbExpr("indexerExpr2",mArg)))) }
- | LBRACK optRange RBRACK
- { (fun e lhsm dotm -> mkSynDotBrackSliceGet lhsm dotm e $2) }
- | LBRACK optRange COMMA optRange RBRACK %prec slice_comma
- { (fun e lhsm dotm -> mkSynDotBrackSlice2Get lhsm dotm e $2 $4) }
- | LBRACK optRange COMMA optRange COMMA optRange RBRACK %prec slice_comma
- { (fun e lhsm dotm -> mkSynDotBrackSlice3Get lhsm dotm e $2 $4 $6) }
- | LBRACK optRange COMMA optRange COMMA optRange COMMA optRange RBRACK %prec slice_comma
- { (fun e lhsm dotm -> mkSynDotBrackSlice4Get lhsm dotm e $2 $4 $6 $8) }
+
optRange:
| declExpr DOT_DOT declExpr
- { mkSynOptionalExpr (rhs parseState 1) (Some $1), mkSynOptionalExpr (rhs parseState 3) (Some $3) }
+ { SynIndexerArg.Two(mkSynOptionalExpr (rhs parseState 1) (Some $1), mkSynOptionalExpr (rhs parseState 3) (Some $3)) }
| declExpr DOT_DOT
- { mkSynOptionalExpr (rhs parseState 1) (Some $1), mkSynOptionalExpr (rhs parseState 2) None }
+ { SynIndexerArg.Two(mkSynOptionalExpr (rhs parseState 1) (Some $1), mkSynOptionalExpr (rhs parseState 2) None) }
| DOT_DOT declExpr
- { mkSynOptionalExpr (rhs parseState 1) None, mkSynOptionalExpr (rhs parseState 2) (Some $2) }
+ { SynIndexerArg.Two(mkSynOptionalExpr (rhs parseState 1) None, mkSynOptionalExpr (rhs parseState 2) (Some $2)) }
| STAR
- { mkSynOptionalExpr (rhs parseState 1) None, mkSynOptionalExpr (rhs parseState 1) None }
+ { SynIndexerArg.Two(mkSynOptionalExpr (rhs parseState 1) None, mkSynOptionalExpr (rhs parseState 1) None) }
+ | declExpr %prec slice_expr
+ { SynIndexerArg.One($1) }
/* the start et of atomicExprAfterType must not overlap with the valid postfix tokens of the type syntax, e.g. new List<T>(...) */
diff --git a/src/fsharp/patcompile.fs b/src/fsharp/patcompile.fs
index 84ba328..a5cdeeb 100755
--- a/src/fsharp/patcompile.fs
+++ b/src/fsharp/patcompile.fs
@@ -405,7 +405,7 @@ let discrimsEq g d1 d2 =
| Test.IsInst (srcty1,tgty1), Test.IsInst (srcty2,tgty2) -> typeEquiv g srcty1 srcty2 && typeEquiv g tgty1 tgty2
| Test.ActivePatternCase (_,_,vrefOpt1,n1,_), Test.ActivePatternCase (_,_,vrefOpt2,n2,_) ->
match vrefOpt1, vrefOpt2 with
- | Some (vref1, tinst1), Some (vref2, tinst2) -> valRefEq g vref1 vref2 && n1 = n2 && List.lengthsEqAndForall2 (typeEquiv g) tinst1 tinst2
+ | Some (vref1, tinst1), Some (vref2, tinst2) -> valRefEq g vref1 vref2 && n1 = n2 && not (doesActivePatternHaveFreeTypars g vref1) && List.lengthsEqAndForall2 (typeEquiv g) tinst1 tinst2
| _ -> false (* for equality purposes these are considered unequal! This is because adhoc computed patterns have no identity. *)
| _ -> false
@@ -451,7 +451,7 @@ let discrimsHaveSameSimultaneousClass g d1 d2 =
| Test.IsInst _, Test.IsInst _ -> false
| Test.ActivePatternCase (_,_,apatVrefOpt1,_,_), Test.ActivePatternCase (_,_,apatVrefOpt2,_,_) ->
match apatVrefOpt1, apatVrefOpt2 with
- | Some (vref1, tinst1), Some (vref2, tinst2) -> valRefEq g vref1 vref2 && List.lengthsEqAndForall2 (typeEquiv g) tinst1 tinst2
+ | Some (vref1, tinst1), Some (vref2, tinst2) -> valRefEq g vref1 vref2 && not (doesActivePatternHaveFreeTypars g vref1) && List.lengthsEqAndForall2 (typeEquiv g) tinst1 tinst2
| _ -> false (* for equality purposes these are considered different classes of discriminators! This is because adhoc computed patterns have no identity! *)
| _ -> false
@@ -1058,8 +1058,8 @@ let CompilePatternBasic
| TPat_query ((_,resTys,apatVrefOpt,idx,apinfo),p,m) ->
if apinfo.IsTotal then
-
- if (isNone apatVrefOpt && i = i') || (discrimsEq g discrim (Option.get (getDiscrimOfPattern pat))) then
+ let hasParam = (match apatVrefOpt with None -> true | Some (vref,_) -> doesActivePatternHaveFreeTypars g vref)
+ if (hasParam && i = i') || (discrimsEq g discrim (Option.get (getDiscrimOfPattern pat))) then
let aparity = apinfo.Names.Length
let accessf' j tpinst _e' =
if aparity <= 1 then
@@ -1069,7 +1069,7 @@ let CompilePatternBasic
mkUnionCaseFieldGetUnproven(Option.get resPreBindOpt,ucref,instTypes tpinst resTys,j,exprm)
mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j))
- elif isNone apatVrefOpt then
+ elif hasParam then
// Successful active patterns don't refute other patterns
[frontier]
@@ -1206,7 +1206,10 @@ let CompilePatternBasic
!res
// Assign an identifier to each TPat_query based on our knowledge of the 'identity' of the active pattern, if any
| TPat_query ((_,_,apatVrefOpt,_,_),_,_) ->
- let uniqId = match apatVrefOpt with None -> genUniquePathId() | Some (vref,_) -> vref.Stamp
+ let uniqId =
+ match apatVrefOpt with
+ | Some (vref,_) when not (doesActivePatternHaveFreeTypars g vref) -> vref.Stamp
+ | _ -> genUniquePathId()
let inp = Active(PathQuery(path,uniqId),subExpr,p)
[(inp::accActive, accValMap)]
| _ ->
diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs
index b5c5bfe..34b0ef1 100755
--- a/src/fsharp/range.fs
+++ b/src/fsharp/range.fs
@@ -11,7 +11,7 @@
//----------------------------------------------------------------------------
/// Anything to do with special names of identifiers and other lexical rules
-module (* internal *) Microsoft.FSharp.Compiler.Range
+module internal Microsoft.FSharp.Compiler.Range
open System.IO
open System.Collections.Generic
diff --git a/src/fsharp/range.fsi b/src/fsharp/range.fsi
index a5881be..aa5676d 100755
--- a/src/fsharp/range.fsi
+++ b/src/fsharp/range.fsi
@@ -9,7 +9,7 @@
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-module (* internal *) Microsoft.FSharp.Compiler.Range
+module internal Microsoft.FSharp.Compiler.Range
open System.Text
open System.Collections.Generic
diff --git a/src/fsharp/sreflect.fs b/src/fsharp/sreflect.fs
index 2dad17d..18d424b 100755
--- a/src/fsharp/sreflect.fs
+++ b/src/fsharp/sreflect.fs
@@ -191,6 +191,7 @@ let mkFieldSet ((d1,d2),tyargs,args) = CombExpr(FieldSetOp(d1,d2),tyargs,args)
let mkCtorCall (d,tyargs,args) = CombExpr(CtorCallOp(d),tyargs,args)
let mkMethodCall (d,tyargs,args) = CombExpr(MethodCallOp(d),tyargs,args)
let mkAttributedExpression(e,attr) = AttrExpr(e,[attr])
+let isAttributedExpression e = match e with AttrExpr(_, _) -> true | _ -> false
//---------------------------------------------------------------------------
// Pickle/unpickle expression and type specifications in a stable format
diff --git a/src/fsharp/sreflect.fsi b/src/fsharp/sreflect.fsi
index d4dff8c..9c9b27f 100755
--- a/src/fsharp/sreflect.fsi
+++ b/src/fsharp/sreflect.fsi
@@ -115,7 +115,7 @@ val mkCtorCall : CtorData * TypeData list * ExprData list -> ExprData
val mkMethodCall : MethodData * TypeData list * ExprData list -> ExprData
val mkAttributedExpression : ExprData * ExprData -> ExprData
val pickle : (ExprData -> byte[])
-
+val isAttributedExpression : ExprData -> bool
val PickleDefns : ((MethodBaseData * ExprData) list -> byte[])
val pickledDefinitionsResourceNameBase : string
diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs
index 62221a4..490a80e 100755
--- a/src/fsharp/tast.fs
+++ b/src/fsharp/tast.fs
@@ -2975,7 +2975,7 @@ and
TypeForwarders : CcuTypeForwarderTable }
/// Represents a table of .NET CLI type forwarders for an assembly
-and CcuTypeForwarderTable = Lazy<Map<string[] * string, EntityRef>>
+and CcuTypeForwarderTable = Map<string[] * string, Lazy<EntityRef>>
and CcuReference = string // ILAssemblyRef
@@ -3054,7 +3054,7 @@ and CcuThunk =
member ccu.Contents = ccu.Deref.Contents
/// The table of type forwarders for this assembly
- member ccu.TypeForwarders : Map<string[] * string, EntityRef> = ccu.Deref.TypeForwarders.Force()
+ member ccu.TypeForwarders : Map<string[] * string, Lazy<EntityRef>> = ccu.Deref.TypeForwarders
/// The table of modules and namespaces at the "root" of the assembly
member ccu.RootModulesAndNamespaces = ccu.Contents.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions
@@ -3094,7 +3094,9 @@ and CcuThunk =
/// Try to resolve a path into the CCU by referencing the .NET/CLI type forwarder table of the CCU
member ccu.TryForward(nlpath:string[],item:string) : EntityRef option =
ccu.EnsureDerefable(nlpath)
- ccu.TypeForwarders.TryFind(nlpath,item)
+ match ccu.TypeForwarders.TryFind(nlpath,item) with
+ | Some entity -> Some(entity.Force())
+ | None -> None
//printfn "trying to forward %A::%s from ccu '%s', res = '%A'" p n ccu.AssemblyName res.IsSome
/// Used to make forward calls into the type/assembly loader when comparing member signatures during linking
diff --git a/src/fsharp/tastops.fs b/src/fsharp/tastops.fs
index 9c5fd78..2c4404c 100755
--- a/src/fsharp/tastops.fs
+++ b/src/fsharp/tastops.fs
@@ -533,7 +533,7 @@ let rec sizeMeasure g ms =
| MeasureOne -> 1
//---------------------------------------------------------------------------
-// SOme basic type builders
+// Some basic type builders
//---------------------------------------------------------------------------
let mkNativePtrType g ty = TType_app (g.nativeptr_tcr, [ty])
@@ -556,7 +556,7 @@ let mkArrayTy g n ty m =
let maxTuple = 8
let goodTupleFields = maxTuple-1
-let is_tuple_tcref g tcref =
+let isCompiledTupleTyconRef g tcref =
match tcref with
| x when
(tyconRefEq g g.tuple1_tcr x ||
@@ -709,6 +709,8 @@ let destAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,tinst) ->
let tcrefOfAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tcref | _ -> failwith "tcrefOfAppTy")
let tryDestAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> Some tcref | _ -> None)
let (|AppTy|_|) g ty = ty |> stripTyEqns g |> (function TType_app(tcref,tinst) -> Some (tcref,tinst) | _ -> None)
+let (|TupleTy|_|) g ty = ty |> stripTyEqns g |> (function TType_tuple(tys) -> Some tys | _ -> None)
+let (|FunTy|_|) g ty = ty |> stripTyEqns g |> (function TType_fun(dty, rty) -> Some (dty, rty) | _ -> None)
let argsOfAppTy g ty = ty |> stripTyEqns g |> (function TType_app(_,tinst) -> tinst | _ -> [])
let tyconOfAppTy g ty = (tcrefOfAppTy g ty).Deref
@@ -1425,11 +1427,17 @@ let destArrayTy (g:TcGlobals) ty =
| [ty] -> ty
| _ -> failwith "destArrayTy";
+
+let isTypeConstructorEqualToOptional g tcOpt tc =
+ match tcOpt with
+ | None -> false
+ | Some tc2 -> tyconRefEq g tc2 tc
+
let isByrefLikeTyconRef g tcref =
tyconRefEq g g.byref_tcr tcref ||
- tyconRefEq g g.system_TypedReference_tcref tcref ||
- tyconRefEq g g.system_ArgIterator_tcref tcref ||
- tyconRefEq g g.system_RuntimeArgumentHandle_tcref tcref
+ isTypeConstructorEqualToOptional g g.system_TypedReference_tcref tcref ||
+ isTypeConstructorEqualToOptional g g.system_ArgIterator_tcref tcref ||
+ isTypeConstructorEqualToOptional g g.system_RuntimeArgumentHandle_tcref tcref
let isArrayTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> isArrayTyconRef g tcref | _ -> false)
let isArray1DTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g tcref g.il_arr1_tcr | _ -> false)
@@ -1447,13 +1455,13 @@ type TypeDefMetadata =
| ILTypeMetadata of ILScopeRef * ILTypeDef
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
#if EXTENSIONTYPING
- | ExtensionTypeMetadata of TProvidedTypeInfo
+ | ProvidedTypeMetadata of TProvidedTypeInfo
#endif
let metadataOfTycon (tycon:Tycon) =
#if EXTENSIONTYPING
match tycon.TypeReprInfo with
- | TProvidedTypeExtensionPoint info -> ExtensionTypeMetadata info
+ | TProvidedTypeExtensionPoint info -> ProvidedTypeMetadata info
| _ ->
#endif
if tycon.IsILTycon then
@@ -1466,7 +1474,7 @@ let metadataOfTycon (tycon:Tycon) =
let metadataOfTy g ty =
#if EXTENSIONTYPING
match extensionInfoOfTy g ty with
- | TProvidedTypeExtensionPoint info -> ExtensionTypeMetadata info
+ | TProvidedTypeExtensionPoint info -> ProvidedTypeMetadata info
| _ ->
#endif
if isILAppTy g ty then
@@ -1480,7 +1488,7 @@ let metadataOfTy g ty =
let isILReferenceTy g ty =
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> not info.IsStructOrEnum
+ | ProvidedTypeMetadata info -> not info.IsStructOrEnum
#endif
| ILTypeMetadata (_,td) -> not td.IsStructOrEnum
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isArrayTy g ty
@@ -1488,7 +1496,7 @@ let isILReferenceTy g ty =
let isILInterfaceTycon (tycon:Tycon) =
match metadataOfTycon tycon with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> info.IsInterface
+ | ProvidedTypeMetadata info -> info.IsInterface
#endif
| ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Interface)
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> false
@@ -1509,7 +1517,7 @@ let isFSharpInterfaceTy g ty = isAppTy g ty && (tyconOfAppTy g ty).IsFSharpInter
let isDelegateTy g ty =
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> info.IsDelegate ()
+ | ProvidedTypeMetadata info -> info.IsDelegate ()
#endif
| ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Delegate)
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
@@ -1518,7 +1526,7 @@ let isDelegateTy g ty =
let isInterfaceTy g ty =
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> info.IsInterface
+ | ProvidedTypeMetadata info -> info.IsInterface
#endif
| ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Interface)
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpInterfaceTy g ty
@@ -1526,7 +1534,7 @@ let isInterfaceTy g ty =
let isClassTy g ty =
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> info.IsClass
+ | ProvidedTypeMetadata info -> info.IsClass
#endif
| ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Class)
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpClassTy g ty
@@ -2044,21 +2052,31 @@ let GetTypeOfMemberInFSharpForm g (vref:ValRef) =
let membInfo,topValInfo = checkMemberValRef vref
GetMemberTypeInFSharpForm g membInfo.MemberFlags topValInfo vref.Type vref.Range
+let PartitionValTyparsForApparentEnclosingType g (v:Val) =
+ match v.ValReprInfo with
+ | None -> error(InternalError("PartitionValTypars: not a top value", v.Range))
+ | Some arities ->
+ let fullTypars,_ = destTopForallTy g arities v.Type
+ let parent = v.MemberApparentParent
+ let parentTypars = parent.TyparsNoRange
+ let nparentTypars = parentTypars.Length
+ if nparentTypars <= fullTypars.Length then
+ let memberParentTypars,memberMethodTypars = List.chop nparentTypars fullTypars
+ let memberToParentInst,tinst = mkTyparToTyparRenaming memberParentTypars parentTypars
+ Some(parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
+ else None
+
/// Match up the type variables on an member value with the type
/// variables on the apparent enclosing type
let PartitionValTypars g (v:Val) =
match v.ValReprInfo with
| None -> error(InternalError("PartitionValTypars: not a top value", v.Range))
| Some arities ->
- let fullTypars,_ = destTopForallTy g arities v.Type
- let parent = v.MemberApparentParent
- let parentTypars = parent.TyparsNoRange
- let nparentTypars = parentTypars.Length
- if nparentTypars <= fullTypars.Length then
- let memberParentTypars,memberMethodTypars = List.chop nparentTypars fullTypars
- let memberToParentInst,tinst = mkTyparToTyparRenaming memberParentTypars parentTypars
- Some(parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
- else None
+ if v.IsExtensionMember then
+ let fullTypars,_ = destTopForallTy g arities v.Type
+ Some([],[],fullTypars,emptyTyparInst,[])
+ else
+ PartitionValTyparsForApparentEnclosingType g v
let PartitionValRefTypars g (vref: ValRef) = PartitionValTypars g vref.Deref
@@ -2508,6 +2526,9 @@ let HasFSharpAttribute g tref attrs = List.exists (IsMatchingFSharpAttribute g t
let findAttrib g tref attrs = List.find (IsMatchingFSharpAttribute g tref) attrs
let TryFindFSharpAttribute g tref attrs = List.tryFind (IsMatchingFSharpAttribute g tref) attrs
+let HasFSharpAttributeOpt g trefOpt attrs = match trefOpt with Some tref -> List.exists (IsMatchingFSharpAttribute g tref) attrs | _ -> false
+let IsMatchingFSharpAttributeOpt g attrOpt (Attrib(tcref2,_,_,_,_,_,_)) = match attrOpt with Some ((AttribInfo(_,tcref))) -> tyconRefEq g tcref tcref2 | _ -> false
+
let (|ExtractAttribNamedArg|_|) nm args =
args |> List.tryPick (function (AttribNamedArg(nm2,_,_,v)) when nm = nm2 -> Some v | _ -> None)
@@ -2535,7 +2556,11 @@ let TryFindFSharpStringAttribute g nm attrs =
let TryFindILAttribute (AttribInfo (atref,_)) attrs =
HasILAttribute atref attrs
-
+let TryFindILAttributeOpt attr attrs =
+ match attr with
+ | Some (AttribInfo (atref,_)) -> HasILAttribute atref attrs
+ | _ -> false
+
//-------------------------------------------------------------------------
// List and reference types...
//-------------------------------------------------------------------------
@@ -2594,23 +2619,6 @@ let destLinqExpressionTy g ty =
| Some ty -> ty
| None -> failwith "destLinqExpressionTy: not an expression type"
-(*
-let isQuoteExprTy g ty =
- match tryDestAppTy g ty with
- | None -> false
- | Some tcref -> tyconRefEq g g.expr_tcr tcref
-
-let tryDestQuoteExprTy g ty =
- match argsOfAppTy g ty with
- | [ty1] when isQuoteExprTy g ty -> Some ty1
- | _ -> None
-
-let destQuoteExprTy g ty =
- match tryDestQuoteExprTy g ty with
- | Some ty -> ty
- | None -> failwith "destQuoteExprTy: not an expression type"
-*)
-
let mkNoneCase g = mkUnionCaseRef g.option_tcr_canon "None"
let mkSomeCase g = mkUnionCaseRef g.option_tcr_canon "Some"
@@ -2640,7 +2648,11 @@ let (|SpecificBinopExpr|_|) g vrefReqd expr =
| BinopExpr g (vref, arg1, arg2) when valRefEq g vref vrefReqd -> Some (arg1, arg2)
| _ -> None
-let (|EnumExpr|_|) g expr = (|SpecificUnopExpr|_|) g g.enum_vref expr
+let (|EnumExpr|_|) g expr =
+ match (|SpecificUnopExpr|_|) g g.enum_vref expr with
+ | None -> (|SpecificUnopExpr|_|) g g.enumOfValue_vref expr
+ | x -> x
+
let (|BitwiseOrExpr|_|) g expr = (|SpecificBinopExpr|_|) g g.bitwise_or_vref expr
let (|AttribBitwiseOrExpr|_|) g expr =
@@ -4213,7 +4225,7 @@ let underlyingTypeOfEnumTy g typ =
let tycon = tyconOfAppTy g typ
match metadataOfTy g typ with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata info -> info.UnderlyingTypeOfEnum()
+ | ProvidedTypeMetadata info -> info.UnderlyingTypeOfEnum()
#endif
| ILTypeMetadata (_,tdef) ->
@@ -4250,36 +4262,59 @@ let setValHasNoArity (f:Val) =
let normalizeEnumTy g ty = (if isEnumTy g ty then underlyingTypeOfEnumTy g ty else ty)
-// -1 equals "no", 0 is "unknown", 1 is "yes"
+type StaticOptimizationAnswer =
+ | Yes = 1y
+ | No = -1y
+ | Unknown = 0y
+
let decideStaticOptimizationConstraint g c =
match c with
| TTyconEqualsTycon (a,b) ->
- let a = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g a)
- let b = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g b)
- // Both types must be nominal for a definite result
- match tryDestAppTy g a with
- | Some tcref1 ->
- match tryDestAppTy g b with
- | Some tcref2 -> if tyconRefEq g tcref1 tcref2 then 1 else -1
- | None -> 0
- | None -> 0
+ // Both types must be nominal for a definite result
+ let rec checkTypes a b =
+ let a = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g a)
+ let b = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g b)
+ match a, b with
+ | AppTy g (tcref1, _), AppTy g (tcref2, _) ->
+ if tyconRefEq g tcref1 tcref2 then StaticOptimizationAnswer.Yes else StaticOptimizationAnswer.No
+ | FunTy g (dty1, rty1), FunTy g (dty2, rty2) ->
+ let dtyCheck = checkTypes dty1 dty2
+ if dtyCheck = StaticOptimizationAnswer.Unknown then
+ StaticOptimizationAnswer.Unknown
+ else
+ let rtyCheck = checkTypes rty1 rty2
+ if dtyCheck = rtyCheck then rtyCheck else StaticOptimizationAnswer.Unknown
+ | TupleTy g (t1::ts1), TupleTy g (t2::ts2) ->
+ let rec iter l1 l2 prev =
+ match l1, l2 with
+ | [], [] -> prev
+ | t1::ts1, t2::ts2 ->
+ let r = checkTypes t1 t2
+ if r = StaticOptimizationAnswer.Unknown || r <> prev then StaticOptimizationAnswer.Unknown else iter ts1 ts2 r
+ | _ -> StaticOptimizationAnswer.Unknown
+ let r = checkTypes t1 t2
+ if r = StaticOptimizationAnswer.Unknown then StaticOptimizationAnswer.Unknown else iter ts1 ts2 r
+ | _ -> StaticOptimizationAnswer.Unknown
+ checkTypes a b
| TTyconIsStruct a ->
let a = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g a)
match tryDestAppTy g a with
- | Some tcref1 -> if tcref1.IsStructOrEnumTycon then 1 else -1
- | None -> 0
+ | Some tcref1 -> if tcref1.IsStructOrEnumTycon then StaticOptimizationAnswer.Yes else StaticOptimizationAnswer.No
+ | None -> StaticOptimizationAnswer.Unknown
let rec DecideStaticOptimizations g cs =
match cs with
- | [] -> 1
+ | [] -> StaticOptimizationAnswer.Yes
| h::t ->
let d = decideStaticOptimizationConstraint g h
- if d = -1 then -1 elif d = 1 then DecideStaticOptimizations g t else 0
+ if d = StaticOptimizationAnswer.No then StaticOptimizationAnswer.No
+ elif d = StaticOptimizationAnswer.Yes then DecideStaticOptimizations g t
+ else StaticOptimizationAnswer.Unknown
let mkStaticOptimizationExpr g (cs,e1,e2,m) =
let d = DecideStaticOptimizations g cs in
- if d = -1 then e2
- elif d = 1 then e1
+ if d = StaticOptimizationAnswer.No then e2
+ elif d = StaticOptimizationAnswer.Yes then e1
else Expr.StaticOptimization(cs,e1,e2,m)
//--------------------------------------------------------------------------
@@ -4292,6 +4327,9 @@ type ValCopyFlag =
| CloneAll
| CloneAllAndMarkExprValsAsCompilerGenerated
| OnlyCloneExprVals
+
+// for quotations we do no want to avoid marking values as compiler generated since this may affect the shape of quotation (compiler generated values can be inlined)
+let fixValCopyFlagForQuotations = function CloneAllAndMarkExprValsAsCompilerGenerated -> CloneAll | x -> x
let markAsCompGen compgen d =
let compgen =
@@ -4424,9 +4462,11 @@ and remapExpr g (compgen:ValCopyFlag) (tmenv:Remap) x =
if vr === vr' && vf === vf' then x
else Expr.Val (vr',vf',m)
| Expr.Quote (a,{contents=Some(argTypes,argExprs,data)},isFromQueryExpression,m,ty) ->
+ // fix value of compgen for both original expression and pickled AST
+ let compgen = fixValCopyFlagForQuotations compgen
Expr.Quote (remapExpr g compgen tmenv a,{contents=Some(remapTypesAux tmenv argTypes,remapExprs g compgen tmenv argExprs,data)},isFromQueryExpression,m,remapType tmenv ty)
| Expr.Quote (a,{contents=None},isFromQueryExpression,m,ty) ->
- Expr.Quote (remapExpr g compgen tmenv a,{contents=None},isFromQueryExpression,m,remapType tmenv ty)
+ Expr.Quote (remapExpr g (fixValCopyFlagForQuotations compgen) tmenv a,{contents=None},isFromQueryExpression,m,remapType tmenv ty)
| Expr.Obj (_,typ,basev,basecall,overrides,iimpls,m) ->
let basev',tmenvinner = Option.mapFold (copyAndRemapAndBindVal g compgen) tmenv basev
mkObjExpr(remapType tmenv typ,basev',
@@ -5789,7 +5829,7 @@ let mkIsInst ty e m = mkAsmExpr ([ isinst ], [ty],[e], [ ty ], m)
let mspec_Object_GetHashCode ilg = IL.mkILNonGenericInstanceMethSpecInTy(ilg.typ_Object,"GetHashCode",[],ilg.typ_int32)
let mspec_Type_GetTypeFromHandle ilg = IL.mkILNonGenericStaticMethSpecInTy(ilg.typ_Type,"GetTypeFromHandle",[ilg.typ_RuntimeTypeHandle],ilg.typ_Type)
-let fspec_Missing_Value ilg = IL.mkILFieldSpecInTy(ilg.typ_Missing,"Value",ilg.typ_Missing)
+let fspec_Missing_Value ilg = IL.mkILFieldSpecInTy(ilg.typ_Missing.Value, "Value", ilg.typ_Missing.Value)
let typedExprForIntrinsic _g m (IntrinsicValRef(_,_,_,ty,_) as i) =
@@ -5820,6 +5860,9 @@ let mkCallGenericEqualityEROuter g m ty e1 e2 = mkApps g (ty
let mkCallGenericEqualityWithComparerOuter g m ty comp e1 e2 = mkApps g (typedExprForIntrinsic g m g.generic_equality_withc_outer_info, [[ty]], [comp;e1;e2], m)
let mkCallGenericHashWithComparerOuter g m ty comp e1 = mkApps g (typedExprForIntrinsic g m g.generic_hash_withc_outer_info, [[ty]], [comp;e1], m)
+let mkCallSubtractionOperator g m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.unchecked_subtraction_info, [[ty; ty; ty]], [e1;e2], m)
+
+let mkCallArrayLength g m ty el = mkApps g (typedExprForIntrinsic g m g.array_length_info, [[ty]], [el], m)
let mkCallArrayGet g m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.array_get_info, [[ty]], [ e1 ; e2 ], m)
let mkCallArray2DGet g m ty e1 idx1 idx2 = mkApps g (typedExprForIntrinsic g m g.array2D_get_info, [[ty]], [ e1 ; idx1; idx2 ], m)
let mkCallArray3DGet g m ty e1 idx1 idx2 idx3 = mkApps g (typedExprForIntrinsic g m g.array3D_get_info, [[ty]], [ e1 ; idx1; idx2; idx3 ], m)
@@ -5993,10 +6036,10 @@ let mkCompilationSourceNameAttr g n =
let isTypeProviderAssemblyAttr (cattr:ILAttribute) =
cattr.Method.EnclosingType.BasicQualifiedName = typeof<Microsoft.FSharp.Core.CompilerServices.TypeProviderAssemblyAttribute>.FullName
-let TryDecodeTypeProviderAssemblyAttr (cattr:ILAttribute) =
+let TryDecodeTypeProviderAssemblyAttr ilg (cattr:ILAttribute) =
if isTypeProviderAssemblyAttr cattr then
// ok to use ecmaILGlobals here since we're querying metadata, not making it
- let parms, _args = decodeILAttribData IL.ecmaILGlobals cattr None
+ let parms, _args = decodeILAttribData ilg cattr None
match parms with // The first parameter to the attribute is the name of the assembly with the compiler extensions.
| (ILAttribElem.String (Some assemblyName))::_ -> Some assemblyName
| (ILAttribElem.String None)::_ -> Some null
@@ -6026,10 +6069,10 @@ let tname_AutoOpenAttr = FSharpLib.Core + ".AutoOpenAttribute"
let tref_AutoOpenAttr () = mkILTyRef(IlxSettings.ilxFsharpCoreLibScopeRef (), tname_AutoOpenAttr)
let IsSignatureDataVersionAttr cattr = isILAttrib (tref_SignatureDataVersionAttr ()) cattr
-let TryFindAutoOpenAttr cattr =
+let TryFindAutoOpenAttr (ilg : IL.ILGlobals) cattr =
if isILAttrib (tref_AutoOpenAttr ()) cattr then
// ok to use ecmaILGlobals here since we're querying metadata, not making it
- match decodeILAttribData IL.ecmaILGlobals cattr None with
+ match decodeILAttribData ilg cattr None with
| [ILAttribElem.String s],_ -> s
| [],_ -> None
| _ ->
@@ -6038,13 +6081,13 @@ let TryFindAutoOpenAttr cattr =
else
None
-let tref_InternalsVisibleToAttr () =
- mkILTyRef (ecmaMscorlibScopeRef,"System.Runtime.CompilerServices.InternalsVisibleToAttribute")
+let tref_InternalsVisibleToAttr (ilg : IL.ILGlobals) =
+ mkILTyRef (ilg.traits.ScopeRef,"System.Runtime.CompilerServices.InternalsVisibleToAttribute")
-let TryFindInternalsVisibleToAttr cattr =
- if isILAttrib (tref_InternalsVisibleToAttr ()) cattr then
+let TryFindInternalsVisibleToAttr ilg cattr =
+ if isILAttrib (tref_InternalsVisibleToAttr ilg) cattr then
// ok to use ecmaILGlobals here since we're querying metadata, not making it
- match decodeILAttribData IL.ecmaILGlobals cattr None with
+ match decodeILAttribData ilg cattr None with
| [ILAttribElem.String s],_ -> s
| [],_ -> None
| _ ->
@@ -6053,10 +6096,10 @@ let TryFindInternalsVisibleToAttr cattr =
else
None
-let IsMatchingSignatureDataVersionAttr ((v1,v2,v3,_) : ILVersionInfo) cattr =
+let IsMatchingSignatureDataVersionAttr ilg ((v1,v2,v3,_) : ILVersionInfo) cattr =
IsSignatureDataVersionAttr cattr &&
// ok to use ecmaILGlobals here since we're querying metadata, not making it
- match decodeILAttribData IL.ecmaILGlobals cattr None with
+ match decodeILAttribData ilg cattr None with
| [ILAttribElem.Int32 u1; ILAttribElem.Int32 u2;ILAttribElem.Int32 u3 ],_ ->
(v1 = uint16 u1) && (v2 = uint16 u2) && (v3 = uint16 u3)
| _ ->
@@ -6166,7 +6209,7 @@ let rec MakeApplicationAndBetaReduceAux g (f, fty, tyargsl : TType list list, ar
match tryStripLambdaN argsl.Length f with
| Some (argvsl, body) ->
assert (argvsl.Length = argsl.Length)
- let argvs,body = List.mapfoldBack MultiLambdaToTupledLambda argvsl body
+ let argvs,body = List.mapFoldBack MultiLambdaToTupledLambda argvsl body
mkLetsBind m (mkCompGenBinds argvs argsl) body
| _ ->
mkExprApplAux g f fty argsl m
@@ -6957,7 +7000,7 @@ let isSealedTy g ty =
match metadataOfTy g ty with
#if EXTENSIONTYPING
- | ExtensionTypeMetadata st -> st.IsSealed
+ | ProvidedTypeMetadata st -> st.IsSealed
#endif
| ILTypeMetadata (_,td) -> td.IsSealed
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
@@ -7061,7 +7104,23 @@ type PrettyNaming.ActivePatternInfo with
member apinfo.OverallType g m dty rtys =
mkFunTy dty (apinfo.ResultType g m rtys)
+
+//---------------------------------------------------------------------------
+// Active pattern validation
+//---------------------------------------------------------------------------
+// check if an active pattern takes type parameters only bound by the return types,
+// not by their argument types.
+let doesActivePatternHaveFreeTypars g (v:ValRef) =
+ let vty = v.TauType
+ let vtps = v.Typars |> Zset.ofList typarOrder
+ if not (isFunTy g v.TauType) then
+ errorR(Error(FSComp.SR.activePatternIdentIsNotFunctionTyped(v.LogicalName),v.Range))
+ let argtys,resty = stripFunTy g vty
+ let argtps,restps= (freeInTypes CollectTypars argtys).FreeTypars,(freeInType CollectTypars resty).FreeTypars
+ // Error if an active pattern is generic in type variables that only occur in the result Choice<_,...>.
+ // Note: The test restricts to v.Typars since typars from the closure are considered fixed.
+ not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps))
//---------------------------------------------------------------------------
// RewriteExpr: rewrite bottom up with interceptors
@@ -7413,9 +7472,22 @@ let IsSimpleSyntacticConstantExpr g inputExpr =
checkExpr vrefs e
checkExpr Set.empty inputExpr
- // REVIEW: unchecked conversions
- // REVIEW: add min, max
+let EvalArithBinOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64) (arg1:Expr) (arg2:Expr) =
+ // At compile-time we check arithmetic
+ let m = unionRanges arg1.Range arg2.Range
+ try
+ match arg1, arg2 with
+ | Expr.Const(Const.Int32 x1,_,ty), Expr.Const(Const.Int32 x2,_,_) -> Expr.Const(Const.Int32 (opInt32 x1 x2),m,ty)
+ | Expr.Const(Const.SByte x1,_,ty), Expr.Const(Const.SByte x2,_,_) -> Expr.Const(Const.SByte (opInt8 x1 x2),m,ty)
+ | Expr.Const(Const.Int16 x1,_,ty), Expr.Const(Const.Int16 x2,_,_) -> Expr.Const(Const.Int16 (opInt16 x1 x2),m,ty)
+ | Expr.Const(Const.Int64 x1,_,ty), Expr.Const(Const.Int64 x2,_,_) -> Expr.Const(Const.Int64 (opInt64 x1 x2),m,ty)
+ | Expr.Const(Const.Byte x1,_,ty), Expr.Const(Const.Byte x2,_,_) -> Expr.Const(Const.Byte (opUInt8 x1 x2),m,ty)
+ | Expr.Const(Const.UInt16 x1,_,ty), Expr.Const(Const.UInt16 x2,_,_) -> Expr.Const(Const.UInt16 (opUInt16 x1 x2),m,ty)
+ | Expr.Const(Const.UInt32 x1,_,ty), Expr.Const(Const.UInt32 x2,_,_) -> Expr.Const(Const.UInt32 (opUInt32 x1 x2),m,ty)
+ | Expr.Const(Const.UInt64 x1,_,ty), Expr.Const(Const.UInt64 x2,_,_) -> Expr.Const(Const.UInt64 (opUInt64 x1 x2),m,ty)
+ | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(),m))
+ with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(),m))
// See also PostTypecheckSemanticChecks.CheckAttribArgExpr, which must match this precisely
let rec EvalAttribArgExpr g x =
@@ -7438,9 +7510,10 @@ let rec EvalAttribArgExpr g x =
| Const.Single _
| Const.Char _
| Const.Zero _
- | Const.String _ -> x
- | _ ->
- errorR (Error ( FSComp.SR.tastConstantCannotBeCustomAttribute(),m));
+ | Const.String _ ->
+ x
+ | Const.Decimal _ | Const.IntPtr _ | Const.UIntPtr _ | Const.Unit _ ->
+ errorR (Error ( FSComp.SR.tastNotAConstantExpression(),m))
x
| TypeOfExpr g _ -> x
@@ -7450,45 +7523,26 @@ let rec EvalAttribArgExpr g x =
| EnumExpr g arg1 ->
EvalAttribArgExpr g arg1
// Detect bitwise or of attribute flags
- | AttribBitwiseOrExpr g (arg1, arg2) ->
- match EvalAttribArgExpr g arg1, EvalAttribArgExpr g arg2 with
- | Expr.Const(Const.Int32 x1,m,ty), Expr.Const(Const.Int32 x2,_,_) -> Expr.Const(Const.Int32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.SByte x1,m,ty), Expr.Const(Const.SByte x2,_,_) -> Expr.Const(Const.SByte (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int16 x1,m,ty), Expr.Const(Const.Int16 x2,_,_) -> Expr.Const(Const.Int16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int64 x1,m,ty), Expr.Const(Const.Int64 x2,_,_) -> Expr.Const(Const.Int64 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Byte x1,m,ty), Expr.Const(Const.Byte x2,_,_) -> Expr.Const(Const.Byte (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt16 x1,m,ty), Expr.Const(Const.UInt16 x2,_,_) -> Expr.Const(Const.UInt16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt32 x1,m,ty), Expr.Const(Const.UInt32 x2,_,_) -> Expr.Const(Const.UInt32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt64 x1,m,ty), Expr.Const(Const.UInt64 x2,_,_) -> Expr.Const(Const.UInt64 (x1 ||| x2),m,ty)
- | _ -> x
+ | AttribBitwiseOrExpr g (arg1, arg2) ->
+ EvalArithBinOp ((|||),(|||),(|||),(|||),(|||),(|||),(|||),(|||)) (EvalAttribArgExpr g arg1) (EvalAttribArgExpr g arg2)
| SpecificBinopExpr g g.unchecked_addition_vref (arg1, arg2) ->
- match EvalAttribArgExpr g arg1, EvalAttribArgExpr g arg2 with
-(*
- | Expr.Const(Const.Int32 x1,m,ty), Expr.Const(Const.Int32 x2,_,_) -> Expr.Const(Const.Int32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.SByte x1,m,ty), Expr.Const(Const.SByte x2,_,_) -> Expr.Const(Const.SByte (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int16 x1,m,ty), Expr.Const(Const.Int16 x2,_,_) -> Expr.Const(Const.Int16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int64 x1,m,ty), Expr.Const(Const.Int64 x2,_,_) -> Expr.Const(Const.Int64 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Byte x1,m,ty), Expr.Const(Const.Byte x2,_,_) -> Expr.Const(Const.Byte (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt16 x1,m,ty), Expr.Const(Const.UInt16 x2,_,_) -> Expr.Const(Const.UInt16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt32 x1,m,ty), Expr.Const(Const.UInt32 x2,_,_) -> Expr.Const(Const.UInt32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt64 x1,m,ty), Expr.Const(Const.UInt64 x2,_,_) -> Expr.Const(Const.UInt64 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt64 x1,m,ty), Expr.Const(Const.UInt64 x2,_,_) -> Expr.Const(Const.UInt64 (x1 ||| x2),m,ty)
-*)
- | Expr.Const(Const.String x1,m,ty), Expr.Const(Const.String x2,_,_) -> Expr.Const(Const.String (x1 + x2),m,ty)
- | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(),x.Range))
-
- // Detect bitwise or of attribute flags
- | AttribBitwiseOrExpr g (arg1, arg2) ->
- match EvalAttribArgExpr g arg1, EvalAttribArgExpr g arg2 with
- | Expr.Const(Const.Int32 x1,m,ty), Expr.Const(Const.Int32 x2,_,_) -> Expr.Const(Const.Int32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.SByte x1,m,ty), Expr.Const(Const.SByte x2,_,_) -> Expr.Const(Const.SByte (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int16 x1,m,ty), Expr.Const(Const.Int16 x2,_,_) -> Expr.Const(Const.Int16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Int64 x1,m,ty), Expr.Const(Const.Int64 x2,_,_) -> Expr.Const(Const.Int64 (x1 ||| x2),m,ty)
- | Expr.Const(Const.Byte x1,m,ty), Expr.Const(Const.Byte x2,_,_) -> Expr.Const(Const.Byte (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt16 x1,m,ty), Expr.Const(Const.UInt16 x2,_,_) -> Expr.Const(Const.UInt16 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt32 x1,m,ty), Expr.Const(Const.UInt32 x2,_,_) -> Expr.Const(Const.UInt32 (x1 ||| x2),m,ty)
- | Expr.Const(Const.UInt64 x1,m,ty), Expr.Const(Const.UInt64 x2,_,_) -> Expr.Const(Const.UInt64 (x1 ||| x2),m,ty)
- | _ -> x
+ // At compile-time we check arithmetic
+ let v1,v2 = EvalAttribArgExpr g arg1, EvalAttribArgExpr g arg2
+ match v1,v2 with
+ | Expr.Const(Const.String x1,m,ty), Expr.Const(Const.String x2,_,_) -> Expr.Const(Const.String (x1 + x2),m,ty)
+ | _ ->
+#if ALLOW_ARITHMETIC_OPS_IN_LITERAL_EXPRESSIONS_AND_ATTRIBUTE_ARGS
+ EvalArithBinOp (Checked.(+),Checked.(+),Checked.(+),Checked.(+),Checked.(+),Checked.(+),Checked.(+),Checked.(+)) g v1 v2
+#else
+ errorR (Error ( FSComp.SR.tastNotAConstantExpression(),x.Range));
+ x
+#endif
+#if ALLOW_ARITHMETIC_OPS_IN_LITERAL_EXPRESSIONS_AND_ATTRIBUTE_ARGS
+ | SpecificBinopExpr g g.unchecked_subtraction_vref (arg1, arg2) ->
+ EvalArithBinOp (Checked.(-),Checked.(-),Checked.(-),Checked.(-),Checked.(-),Checked.(-),Checked.(-),Checked.(-)) g (EvalAttribArgExpr g arg1) (EvalAttribArgExpr g arg2)
+ | SpecificBinopExpr g g.unchecked_multiply_vref (arg1, arg2) ->
+ EvalArithBinOp (Checked.(*),Checked.(*),Checked.(*),Checked.(*),Checked.(*),Checked.(*),Checked.(*),Checked.(*)) g (EvalAttribArgExpr g arg1) (EvalAttribArgExpr g arg2)
+#endif
| _ ->
errorR (Error ( FSComp.SR.tastNotAConstantExpression(),x.Range));
x
@@ -7502,7 +7556,7 @@ and EvaledAttribExprEquality g e1 e2 =
| _ -> false
-let EvalAttribArg g x =
+let EvalLiteralExprOrAttribArg g x =
match x with
| Expr.Op (TOp.Coerce,_,[Expr.Op (TOp.Array,[elemTy],args,m)],_)
| Expr.Op (TOp.Array,[elemTy],args,m) ->
@@ -7554,7 +7608,7 @@ let rec mkCompiledTuple g (argtys,args,m) =
| [ty8],[arg8] ->
match ty8 with
// if it's already been nested or ended, pass it through
- | TType_app(tn, _) when (is_tuple_tcref g tn) ->
+ | TType_app(tn, _) when (isCompiledTupleTyconRef g tn) ->
ty8,arg8
| _ ->
let ty8enc = TType_app(g.tuple1_tcr,[ty8])
diff --git a/src/fsharp/tastops.fsi b/src/fsharp/tastops.fsi
index 95130e8..a799bca 100755
--- a/src/fsharp/tastops.fsi
+++ b/src/fsharp/tastops.fsi
@@ -211,6 +211,7 @@ val mkExnCaseFieldSet : Expr * TyconRef * int * Expr
val maxTuple : int
val goodTupleFields : int
+val isCompiledTupleTyconRef : TcGlobals -> TyconRef -> bool
val mkCompiledTupleTyconRef : TcGlobals -> 'a list -> TyconRef
val mkCompiledTupleTy : TcGlobals -> TTypes -> TType
val mkCompiledTuple : TcGlobals -> TTypes * Exprs * range -> TyconRef * TTypes * Exprs * range
@@ -558,7 +559,11 @@ val GetTypeOfMemberInMemberForm : TcGlobals -> ValRef -> Typars * CurriedArgInfo
val GetTypeOfIntrinsicMemberInCompiledForm : TcGlobals -> ValRef -> Typars * CurriedArgInfos * TType option * ArgReprInfo
val GetMemberTypeInMemberForm : TcGlobals -> MemberFlags -> ValReprInfo -> TType -> range -> Typars * CurriedArgInfos * TType option * ArgReprInfo
+/// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
+val PartitionValTyparsForApparentEnclosingType : TcGlobals -> Val -> (Typars * Typars * Typars * TyparInst * TType list) option
+/// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
val PartitionValTypars : TcGlobals -> Val -> (Typars * Typars * Typars * TyparInst * TType list) option
+/// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
val PartitionValRefTypars : TcGlobals -> ValRef -> (Typars * Typars * Typars * TyparInst * TType list) option
val ReturnTypeOfPropertyVal : TcGlobals -> Val -> TType
@@ -943,7 +948,7 @@ type TypeDefMetadata =
| ILTypeMetadata of ILScopeRef * ILTypeDef
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
#if EXTENSIONTYPING
- | ExtensionTypeMetadata of TProvidedTypeInfo
+ | ProvidedTypeMetadata of TProvidedTypeInfo
#endif
val metadataOfTycon : Tycon -> TypeDefMetadata
@@ -1130,6 +1135,7 @@ val mkCallTypeDefOf : TcGlobals -> range -> TType -> Expr
val mkCallCreateInstance : TcGlobals -> range -> TType -> Expr
val mkCallCreateEvent : TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr -> Expr
+val mkCallArrayLength : TcGlobals -> range -> TType -> Expr -> Expr
val mkCallArrayGet : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
val mkCallArray2DGet : TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
val mkCallArray3DGet : TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr
@@ -1139,6 +1145,7 @@ val mkCallRaise : TcGlobals -> range -> TType -> Expr -> Expr
val mkCallGenericComparisonWithComparerOuter : TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
val mkCallGenericEqualityEROuter : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
val mkCallEqualsOperator : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+val mkCallSubtractionOperator : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
val mkCallGenericEqualityWithComparerOuter : TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
val mkCallGenericHashWithComparerOuter : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
@@ -1185,12 +1192,14 @@ val mkLdelem : TcGlobals -> range -> TType -> Expr -> Expr -> Expr
// Analyze attribute sets
//-------------------------------------------------------------------------
-val HasILAttribute : ILTypeRef -> ILAttributes -> bool
val TryDecodeILAttribute : TcGlobals -> ILTypeRef -> ILScopeRef option -> ILAttributes -> (ILAttribElem list * ILAttributeNamedArg list) option
val TryFindILAttribute : Env.BuiltinAttribInfo -> ILAttributes -> bool
+val TryFindILAttributeOpt : Env.BuiltinAttribInfo option -> ILAttributes -> bool
val IsMatchingFSharpAttribute : TcGlobals -> Env.BuiltinAttribInfo -> Attrib -> bool
+val IsMatchingFSharpAttributeOpt : TcGlobals -> Env.BuiltinAttribInfo option -> Attrib -> bool
val HasFSharpAttribute : TcGlobals -> Env.BuiltinAttribInfo -> Attribs -> bool
+val HasFSharpAttributeOpt : TcGlobals -> Env.BuiltinAttribInfo option -> Attribs -> bool
val TryFindFSharpAttribute : TcGlobals -> Env.BuiltinAttribInfo -> Attribs -> Attrib option
val TryFindFSharpBoolAttribute : TcGlobals -> Env.BuiltinAttribInfo -> Attribs -> bool option
val TryFindFSharpStringAttribute : TcGlobals -> Env.BuiltinAttribInfo -> Attribs -> string option
@@ -1198,13 +1207,13 @@ val TryFindFSharpInt32Attribute : TcGlobals -> Env.BuiltinAttribInfo -> Attri
#if EXTENSIONTYPING
/// returns Some(assemblyName) for success
-val TryDecodeTypeProviderAssemblyAttr : ILAttribute -> string option
+val TryDecodeTypeProviderAssemblyAttr : ILGlobals -> ILAttribute -> string option
#endif
val IsSignatureDataVersionAttr : ILAttribute -> bool
val ILThingHasExtensionAttribute : ILAttributes -> bool
-val TryFindAutoOpenAttr : ILAttribute -> string option
-val TryFindInternalsVisibleToAttr : ILAttribute -> string option
-val IsMatchingSignatureDataVersionAttr : ILVersionInfo -> ILAttribute -> bool
+val TryFindAutoOpenAttr : IL.ILGlobals -> ILAttribute -> string option
+val TryFindInternalsVisibleToAttr : IL.ILGlobals -> ILAttribute -> string option
+val IsMatchingSignatureDataVersionAttr : IL.ILGlobals -> ILVersionInfo -> ILAttribute -> bool
val mkCompilationMappingAttr : TcGlobals -> int -> ILAttribute
@@ -1266,8 +1275,11 @@ val XmlDocSigOfEntity : EntityRef -> string
//---------------------------------------------------------------------------
// Resolve static optimizations
//-------------------------------------------------------------------------
-
-val DecideStaticOptimizations : Env.TcGlobals -> StaticOptimization list -> int
+type StaticOptimizationAnswer =
+ | Yes = 1y
+ | No = -1y
+ | Unknown = 0y
+val DecideStaticOptimizations : Env.TcGlobals -> StaticOptimization list -> StaticOptimizationAnswer
val mkStaticOptimizationExpr : Env.TcGlobals -> StaticOptimization list * Expr * Expr * range -> Expr
//---------------------------------------------------------------------------
@@ -1293,6 +1305,8 @@ type PrettyNaming.ActivePatternInfo with
member ResultType : Env.TcGlobals -> range -> TType list -> TType
member OverallType : Env.TcGlobals -> range -> TType -> TType list -> TType
+val doesActivePatternHaveFreeTypars : Env.TcGlobals -> ValRef -> bool
+
//---------------------------------------------------------------------------
// Structural rewrites
//-------------------------------------------------------------------------
@@ -1321,7 +1335,7 @@ val (|EnumExpr|_|) : TcGlobals -> Expr -> Expr option
val (|TypeOfExpr|_|) : TcGlobals -> Expr -> TType option
val (|TypeDefOfExpr|_|) : TcGlobals -> Expr -> TType option
-val EvalAttribArg: TcGlobals -> Expr -> Expr
+val EvalLiteralExprOrAttribArg: TcGlobals -> Expr -> Expr
val EvaledAttribExprEquality : TcGlobals -> Expr -> Expr -> bool
val IsSimpleSyntacticConstantExpr: TcGlobals -> Expr -> bool
diff --git a/src/fsharp/tc.fs b/src/fsharp/tc.fs
index 389404e..8687f43 100755
--- a/src/fsharp/tc.fs
+++ b/src/fsharp/tc.fs
@@ -54,8 +54,8 @@ open Microsoft.FSharp.Compiler.ExtensionTyping
//-------------------------------------------------------------------------
let isThreadOrContextStatic g attrs =
- HasFSharpAttribute g g.attrib_ThreadStaticAttribute attrs ||
- HasFSharpAttribute g g.attrib_ContextStaticAttribute attrs
+ HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute attrs ||
+ HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute attrs
let mkNilListPat g m ty = TPat_unioncase(g.nil_ucref,[ty],[],m)
let mkConsListPat g ty ph pt = TPat_unioncase(g.cons_ucref,[ty],[ph;pt],unionRanges ph.Range pt.Range)
@@ -119,38 +119,43 @@ exception StandardOperatorRedefinitionWarning of string * range
// Identify any security attributes
let IsSecurityAttribute g 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.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 g.attrib_SecurityAttribute.TyconRef [])) g amap m AllowMultiIntfInstantiations.No (mkAppTy tcref [])
- casmap.[tcs] <- exists
- exists
- | _ -> false
+ 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.No (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 ad m (rfinfo:RecdFieldInfo) =
- if rfinfo.IsStatic then error (Error (FSComp.SR.tcStaticFieldUsedWhenInstanceFieldExpected(),m));
- CheckRecdFieldInfoAttributes g rfinfo m |> CommitOperationResult;
- CheckRecdFieldInfoAccessible m ad rfinfo
+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;
+ 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));
+ error (Error (FSComp.SR.csMethodIsNotAnInstanceMethod(minfo.LogicalName),m))
else
- error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName),m));
+ error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName),m))
- // Eliminate the 'protected' portion of the accessibility domain for instance accesses
+ // 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) ->
@@ -166,13 +171,13 @@ let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo:MethInfo) =
AccessibleFrom(paths, None)
| _ -> ad
- if not (IsMethInfoAccessible amap m ad minfo) then
- error (Error (FSComp.SR.tcMethodNotAccessible(minfo.LogicalName),m));
+ 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));
+ if not rfinfo.RecdField.IsMutable then error (FieldNotMutable(denv,rfinfo.RecdFieldRef,m))
//-------------------------------------------------------------------------
// Information about object constructors
@@ -184,18 +189,18 @@ type SafeInitData =
type CtorInfo =
{ // Object model constructors have a very specific form to satisfy .NET limitations.
- // For "new = \arg. { new C with ... }";
+ // 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;
+ 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;
+ safeThisValOpt: Val option
/// A handle to the boolean ref cell to hold success of initialized 'this' for 'type X() as x = ...' constructs
- safeInitInfo: SafeInitData;
+ safeInitInfo: SafeInitData
ctorIsImplicit: bool
}
@@ -223,7 +228,7 @@ type UngeneralizableItem(computeFreeTyvars : (unit -> FreeTyvars)) =
member item.GetFreeTyvars() =
let fvs = computeFreeTyvars()
if fvs.FreeTypars.IsEmpty then
- willNeverHaveFreeTypars <- true;
+ willNeverHaveFreeTypars <- true
cachedFreeLocalTycons <- fvs.FreeTycons
cachedFreeTraitSolutions <- fvs.FreeTraitSolutions
fvs
@@ -235,13 +240,13 @@ type UngeneralizableItem(computeFreeTyvars : (unit -> FreeTyvars)) =
[<NoEquality; NoComparison>]
type TcEnv =
{ /// Name resolution information
- eNameResEnv : NameResolutionEnv;
+ 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;
+ eUngeneralizableItems: UngeneralizableItem list
// Two (!) versions of the current module path
// These are used to:
@@ -255,17 +260,17 @@ type TcEnv =
//
// 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;
+ ePath: Ident list
+ eCompPath: CompilationPath
+ eAccessPath: CompilationPath
eAccessRights: AccessorDomain // this field is computed from other fields, but we amortize the cost of computing it.
- eInternalsVisibleCompPaths: CompilationPath list; // internals under these should be accessible
+ eInternalsVisibleCompPaths: CompilationPath list // internals under these should be accessible
/// Mutable accumulator for the current module type
- eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref;
+ eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref
/// Here Some tcref indicates we can access protected members in all super types
- eFamilyType: TyconRef option;
+ eFamilyType: TyconRef option
// Information to enforce special restrictions on valid expressions
// for .NET constructors.
@@ -279,17 +284,17 @@ let computeAccessRights eAccessPath eInternalsVisibleCompPaths eFamilyType =
AccessibleFrom (eAccessPath :: eInternalsVisibleCompPaths, eFamilyType) // env.eAccessRights
let emptyTcEnv g =
- let cpath = CompPath (IL.ecmaMscorlibScopeRef,[])
- { eNameResEnv = NameResolutionEnv.Empty(g);
- eUngeneralizableItems=[];
- ePath=[];
- eCompPath=cpath; (* dummy *)
- eAccessPath=cpath; (* dummy *)
+ let cpath = CompPath (g.ilg.traits.ScopeRef,[])
+ { eNameResEnv = NameResolutionEnv.Empty(g)
+ eUngeneralizableItems=[]
+ ePath=[]
+ eCompPath=cpath // dummy
+ eAccessPath=cpath // dummy
eAccessRights=computeAccessRights cpath [] None // compute this field
- eInternalsVisibleCompPaths=[];
- eModuleOrNamespaceTypeAccumulator= ref (NewEmptyModuleOrNamespaceType Namespace);
- eFamilyType=None;
- eCtorInfo=None; }
+ eInternalsVisibleCompPaths=[]
+ eModuleOrNamespaceTypeAccumulator= ref (NewEmptyModuleOrNamespaceType Namespace)
+ eFamilyType=None
+ eCtorInfo=None }
//-------------------------------------------------------------------------
// Helpers related to determining if we're in a constructor and/or a class
@@ -297,15 +302,15 @@ let emptyTcEnv g =
//-------------------------------------------------------------------------
let InitialExplicitCtorInfo (safeThisValOpt, safeInitInfo) =
- { ctorShapeCounter=3;
- safeThisValOpt = safeThisValOpt;
- safeInitInfo = safeInitInfo;
+ { ctorShapeCounter=3
+ safeThisValOpt = safeThisValOpt
+ safeInitInfo = safeInitInfo
ctorIsImplicit=false}
let InitialImplicitCtorInfo () =
- { ctorShapeCounter=0;
- safeThisValOpt = None;
- safeInitInfo = NoSafeInitInfo;
+ { ctorShapeCounter=0
+ safeThisValOpt = None
+ safeInitInfo = NoSafeInitInfo
ctorIsImplicit=true }
let EnterFamilyRegion tcref env =
@@ -372,43 +377,43 @@ 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; }
+ {env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems }
let AddLocalValMap tcSink scopem (vals:Val NameMap) env =
let env = ModifyNameResEnv (AddValMapToNameEnv vals) env
- let env = {env with eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems; }
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ let 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 = ModifyNameResEnv (AddValListToNameEnv vals) env
- let env = {env with eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems; }
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ let 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);
+ let env = {env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems }
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalExnDefn tcSink scopem (exnc:Tycon) env =
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);
+ CallEnvSink tcSink (exnc.Range,env.NameEnv,env.eAccessRights)
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalTyconRefs ownDefinition g amap m tcrefs env =
ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false nenv tcrefs) env
-let AddLocalTycons g amap m tycons env =
+let AddLocalTycons g amap m (tycons: Tycon list) env =
AddLocalTyconRefs false g amap m (List.map mkLocalTyconRef tycons) env
let AddLocalTyconsAndReport tcSink g amap scopem tycons env =
let env = AddLocalTycons g amap scopem tycons env
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
//-------------------------------------------------------------------------
@@ -417,7 +422,7 @@ let AddLocalTyconsAndReport tcSink g amap scopem tycons env =
let OpenModulesOrNamespaces tcSink g amap scopem env mvvs =
let env = ModifyNameResEnv (fun nenv -> AddModulesAndNamespacesContentsToNameEnv g amap env.eAccessRights scopem nenv mvvs) env
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddRootModuleOrNamespaceRefs g amap m env modrefs =
@@ -431,7 +436,7 @@ let AddNonLocalCcu g amap scopem env (ccu:CcuThunk,internalsVisible) =
let tcrefs = ccu.RootTypeAndExceptionDefinitions |> List.map (mkNonLocalCcuRootEntityRef ccu)
let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs
let env = ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.Yes false g amap scopem true nenv tcrefs) env
- //CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ //CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespaceType) =
@@ -442,20 +447,20 @@ let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespa
let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs
let env = 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);
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let AddModuleAbbreviation tcSink scopem id modrefs env =
let env = ModifyNameResEnv (fun nenv -> AddModuleAbbrevToNameEnv id nenv modrefs) env
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ 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 tcSink g amap m scopem env (modul:ModuleOrNamespace) =
- let env = ModifyNameResEnv (fun nenv -> AddModrefToNameEnv g amap m false env.eAccessRights nenv (mkLocalModRef modul)) env
+ 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}
- CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights);
+ CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights)
env
let RegisterDeclaredTypars typars env =
@@ -473,21 +478,21 @@ let AddDeclaredTypars check typars env =
/// - the set of active fixups for "letrec" type inference
[<NoEquality; NoComparison>]
type cenv =
- { g: Env.TcGlobals;
+ { g: Env.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)>;
+ mutable recUses: ValMultiMap<(Expr ref * range * bool)>
/// Checks to run after all inference is complete.
- mutable postInferenceChecks: ResizeArray<unit -> unit>;
+ 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;
+ isScript: bool
/// Environment needed to convert IL types to F# types in the importer.
- amap: Import.ImportMap;
+ amap: Import.ImportMap
/// Used to generate new syntactic argument names in post-parse syntactic processing
synArgNameGenerator: SynArgNameGenerator
@@ -496,21 +501,21 @@ type cenv =
/// Holds a reference to the component being compiled.
/// This field is very rarely used (mainly when fixing up forward references to fslib.
- topCcu: CcuThunk;
+ topCcu: CcuThunk
/// Holds the current inference constraints
- css: ConstraintSolverState;
+ css: ConstraintSolverState
/// Are we compiling the signature of a module from fslib?
- compilingCanonicalFslibModuleType: bool;
- isSig: bool;
- haveSig: bool;
+ compilingCanonicalFslibModuleType: bool
+ isSig: bool
+ haveSig: bool
- niceNameGen: NiceNameGenerator;
- infoReader: InfoReader;
- nameResolver: NameResolver;
+ niceNameGen: NiceNameGenerator
+ infoReader: InfoReader
+ nameResolver: NameResolver
- conditionalDefines: string list;
+ conditionalDefines: string list
}
@@ -518,22 +523,22 @@ type cenv =
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 }
+ { 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
@@ -558,11 +563,11 @@ let MakeInnerEnv env nm modKind =
(* Note: here we allocate a new module type accumulator *)
let mtypeAcc = ref (NewEmptyModuleOrNamespaceType modKind)
let cpath = mkNestedCPath env.eCompPath nm.idText modKind
- { env with ePath = path;
- eCompPath = cpath;
- eAccessPath = cpath;
+ { 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) };
+ eNameResEnv = { env.eNameResEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) }
eModuleOrNamespaceTypeAccumulator = mtypeAcc },mtypeAcc
@@ -614,7 +619,7 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env =
env
else
let ad = env.eAccessRights
- match ResolveLongIndentAsModuleOrNamespace OpenQualified env.eNameResEnv ad enclosingNamespacePath with
+ match ResolveLongIndentAsModuleOrNamespace amap scopem OpenQualified env.eNameResEnv ad enclosingNamespacePath with
| Result modrefs -> OpenModulesOrNamespaces tcSink g amap scopem env (List.map p23 modrefs)
| Exception _ -> env
@@ -633,7 +638,7 @@ let UnifyTupleType cenv denv m ty ps =
if (List.length ps) = (List.length ptys) then ptys
else NewInferenceTypes ps
else NewInferenceTypes ps
- AddCxTypeEqualsType denv cenv.css m ty (TType_tuple ptys);
+ AddCxTypeEqualsType denv cenv.css m ty (TType_tuple ptys)
ptys
/// Optimized unification routine that avoids creating new inference
@@ -668,9 +673,9 @@ let UnifyUnitType cenv denv m ty exprOpt =
let perhapsProp =
typeEquiv cenv.g cenv.g.bool_ty ty &&
match exprOpt with
- | Some(Expr.App(Expr.Val(vf,_,_),_,_,[_;_],_)) when vf.LogicalName = opNameEquals -> true
+ | Some(Expr.App(Expr.Val(vf,_,_),_,_,[__],_)) when vf.LogicalName = opNameEquals -> true
| _ -> false
- warning (UnitTypeExpected (denv,ty,perhapsProp,m));
+ warning (UnitTypeExpected (denv,ty,perhapsProp,m))
false
else
true
@@ -773,7 +778,7 @@ let TcConst cenv ty m env c =
| SynMeasure.Power(ms, exponent, _) -> MeasurePower (tcMeasure ms) exponent
| SynMeasure.Product(ms1,ms2,_) -> MeasureProd(tcMeasure ms1, tcMeasure ms2)
| SynMeasure.Divide(ms1, ((SynMeasure.Seq (_::(_::_), _)) as ms2), m) ->
- warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(),m));
+ warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(),m))
MeasureProd(tcMeasure ms1, MeasureInv (tcMeasure ms2))
| SynMeasure.Divide(ms1,ms2,_) ->
MeasureProd(tcMeasure ms1, MeasureInv (tcMeasure ms2))
@@ -863,19 +868,19 @@ let TranslateTopArgSynInfo isArg m tcAttribute (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;
+ [ ( { TypeName=LongIdentWithDots(pathToSynLid m ["Microsoft";"FSharp";"Core";"OptionalArgument"],[])
+ ArgExpr=mkSynUnit m
+ Target=None
+ AppliesToGetterAndSetter=false
Range=m} : SynAttribute) ]
else
[]
if isArg && nonNil attrs && isNone nm then
- errorR(Error(FSComp.SR.tcParameterRequiresName(),m));
+ errorR(Error(FSComp.SR.tcParameterRequiresName(),m))
if not isArg && isSome nm then
- errorR(Error(FSComp.SR.tcReturnValuesCannotHaveNames(),m));
+ errorR(Error(FSComp.SR.tcReturnValuesCannotHaveNames(),m))
// Call the attribute checking function
let attribs = tcAttribute (optAttrs at attrs)
@@ -922,9 +927,9 @@ let MakeMemberDataAndMangledNameForMemberVal(g,tcref,isExtrinsic,attrs,optImplSl
let logicalName = ComputeLogicalName id memberFlags
let optIntfSlotTys = if optImplSlotTys |> List.forall (isInterfaceTy g) then optImplSlotTys else []
let memberInfo =
- { ApparentParent=tcref;
- MemberFlags=memberFlags;
- IsImplemented=false;
+ { 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.
@@ -932,7 +937,7 @@ let MakeMemberDataAndMangledNameForMemberVal(g,tcref,isExtrinsic,attrs,optImplSl
let isInstance = MemberIsCompiledAsInstance g tcref isExtrinsic memberInfo attrs
if (memberFlags.IsDispatchSlot || nonNil optIntfSlotTys) then
if not isInstance then
- errorR(VirtualAugmentationOnNullValuedType(id.idRange));
+ errorR(VirtualAugmentationOnNullValuedType(id.idRange))
elif not memberFlags.IsOverrideOrExplicitImpl && memberFlags.IsInstance then
if not isExtrinsic && not isInstance then
warning(NonVirtualAugmentationOnNullValuedType(id.idRange))
@@ -1181,7 +1186,7 @@ let UpdateAccModuleOrNamespaceType cenv env f =
if cenv.compilingCanonicalFslibModuleType then
let nleref = mkNonLocalEntityRef cenv.topCcu (arrPathOfLid env.ePath)
let modul = nleref.Deref
- modul.Data.entity_modul_contents <- notlazy (f true modul.ModuleOrNamespaceType);
+ modul.Data.entity_modul_contents <- notlazy (f true modul.ModuleOrNamespaceType)
SetCurrAccumulatedModuleOrNamespaceType env (f false (GetCurrAccumulatedModuleOrNamespaceType env))
let PublishModuleDefn cenv env mspec =
@@ -1203,11 +1208,11 @@ let PublishValueDefn cenv env declKind (vspec:Val) =
if (declKind = ModuleOrMemberBinding) &&
((GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind = Namespace) &&
(isNone vspec.MemberInfo) then
- errorR(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),vspec.Range));
+ errorR(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),vspec.Range))
if (declKind = ExtrinsicExtensionBinding) &&
((GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind = Namespace) then
- errorR(Error(FSComp.SR.tcNamespaceCannotContainExtensionMembers(),vspec.Range));
+ errorR(Error(FSComp.SR.tcNamespaceCannotContainExtensionMembers(),vspec.Range))
// Publish the value to the module type being generated.
if (match declKind with
@@ -1233,7 +1238,7 @@ let PublishValueDefn cenv env declKind (vspec:Val) =
let CombineVisibilityAttribs vis1 vis2 m =
if isSome vis1 && isSome vis2 then
- errorR(Error(FSComp.SR.tcMultipleVisibilityAttributes(),m));
+ errorR(Error(FSComp.SR.tcMultipleVisibilityAttributes(),m))
if isSome vis1 then vis1 else vis2
let ComputeAccessAndCompPath env declKindOpt m vis actualParent =
@@ -1244,14 +1249,13 @@ let ComputeAccessAndCompPath env declKindOpt m vis actualParent =
| Some declKind -> DeclKind.IsAccessModifierPermitted declKind
if isSome vis && not accessModPermitted then
- errorR(Error(FSComp.SR.tcMultipleVisibilityAttributesWithLet(),m));
+ errorR(Error(FSComp.SR.tcMultipleVisibilityAttributesWithLet(),m))
let vis =
match vis with
| None -> taccessPublic (* a module or member binding defaults to "public" *)
| Some SynAccess.Public -> taccessPublic
| Some SynAccess.Private -> taccessPrivate accessPath
| Some SynAccess.Internal -> taccessInternal
- (* errorR(InternalError(FSComp.SR.tcUnrecognizedAccessibilitySpec(),m)); *)
let vis =
match actualParent with
@@ -1298,7 +1302,7 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i
match memberInfoOpt with
| Some (ValMemberInfoTransient(memberInfo,_,_)) when not isExtrinsic ->
if memberInfo.ApparentParent.IsModuleOrNamespace then
- errorR(InternalError(FSComp.SR.tcExpectModuleOrNamespaceParent(id.idText),m));
+ errorR(InternalError(FSComp.SR.tcExpectModuleOrNamespaceParent(id.idText),m))
Parent(memberInfo.ApparentParent)
| _ -> altActualParent
@@ -1308,7 +1312,7 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i
let inlineFlag =
if HasFSharpAttribute cenv.g cenv.g.attrib_DllImportAttribute attrs then
if inlineFlag = ValInline.PseudoVal || inlineFlag = ValInline.Always then
- errorR(Error(FSComp.SR.tcDllImportStubsCannotBeInlined(),m));
+ errorR(Error(FSComp.SR.tcDllImportStubsCannotBeInlined(),m))
ValInline.Never
else
let implflags =
@@ -1374,7 +1378,7 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i
CheckForAbnormalOperatorNames cenv id.idRange (DecompileOpName vspec.CoreDisplayName) (isSome memberInfoOpt)
- PublishValueDefn cenv env declKind vspec;
+ PublishValueDefn cenv env declKind vspec
begin
match cenv.tcSink.CurrentSink with
@@ -1384,8 +1388,8 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i
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);
- end;
+ CallNameResolutionSink cenv.tcSink (vspec.Range,nenv,item,item,ItemOccurence.Binding,env.DisplayEnv,env.eAccessRights)
+ end
vspec
@@ -1431,7 +1435,7 @@ let MakeAndPublishSafeThisVal cenv env (thisIdOpt: Ident option) thisTy =
| Some thisId ->
// for structs, thisTy is a byref
if not (isFSharpObjModelTy cenv.g thisTy) then
- errorR(Error(FSComp.SR.tcStructsCanOnlyBindThisAtMemberDeclaration(),thisId.idRange));
+ 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))
@@ -1463,7 +1467,7 @@ let AdjustAndForgetUsesOfRecValue cenv (vrefTgt: ValRef) (valScheme : ValScheme)
| Expr.App(Expr.Val (_,vrefFlags,_),_,tyargs0,[],_) -> vrefFlags,tyargs0
| Expr.Val(_,vrefFlags,_) -> vrefFlags,[]
| _ ->
- errorR(Error(FSComp.SR.tcUnexpectedExprAtRecInfPoint(),m));
+ errorR(Error(FSComp.SR.tcUnexpectedExprAtRecInfPoint(),m))
NormalValUse,[]
let ityargs = generalizeTypars (List.drop (List.length tyargs0) generalizedTypars)
@@ -1477,8 +1481,8 @@ let AdjustAndForgetUsesOfRecValue cenv (vrefTgt: ValRef) (valScheme : ValScheme)
/// 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.SetType fty
+ vspec.SetValReprInfo topValData
vspec.SetValRec (ValInRecScope true)
/// Record the generated value expression as a place where we will have to
@@ -1488,7 +1492,7 @@ 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)) ;
+ cenv.recUses <- cenv.recUses.Add (vrefTgt.Deref, (fixupPoint,m,isComplete))
Expr.Link (fixupPoint)
| ValNotInRecScope ->
vexp
@@ -1509,12 +1513,12 @@ 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)));
+ 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));
+ errorR(Error(FSComp.SR.tcConstrainedTypeVariableCannotBeGeneralized(),m))
declaredTypars
@@ -1566,7 +1570,7 @@ let GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTyparsForThisBind
let generalizedTyparsLookingThroughTypeAbbreviations = computeRelevantTypars true
if not (generalizedTypars.Length = generalizedTyparsLookingThroughTypeAbbreviations.Length &&
List.forall2 typarEq generalizedTypars generalizedTyparsLookingThroughTypeAbbreviations) then
- warning(Error(FSComp.SR.tcTypeParametersInferredAreNotStable(),m));
+ warning(Error(FSComp.SR.tcTypeParametersInferredAreNotStable(),m))
let hasDeclaredTypars = nonNil declaredTypars
// This is just about the only place we form a TypeScheme
@@ -1753,7 +1757,7 @@ 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);
+ 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))
@@ -1784,14 +1788,14 @@ let FreshenAbstractSlot g amap m synTyparDecls absMethInfo =
match synTyparDecls with
| SynValTyparDecls(synTypars,infer,_) ->
- if nonNil synTypars && infer then errorR(Error(FSComp.SR.tcOverridingMethodRequiresAllOrNoTypeParameters(),m));
+ if nonNil synTypars && infer 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.GetFormalTyparsOfEnclosingType m
+ 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
@@ -1808,7 +1812,7 @@ let FreshenAbstractSlot g amap m synTyparDecls absMethInfo =
let BuildFieldMap cenv env isPartial ty flds m =
let ad = env.eAccessRights
- if isNil flds then invalidArg "flds" "BuildFieldMap";
+ if isNil flds then invalidArg "flds" "BuildFieldMap"
let frefSets =
flds |> List.map (fun (fld,fldExpr) ->
@@ -1822,7 +1826,7 @@ let BuildFieldMap cenv env isPartial ty flds m =
| [tcref] -> tcref
| _ ->
if isPartial then
- warning (Error(FSComp.SR.tcFieldsDoNotDetermineUniqueRecordType(),m));
+ warning (Error(FSComp.SR.tcFieldsDoNotDetermineUniqueRecordType(),m))
// OK, there isn't a unique 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
@@ -1839,14 +1843,14 @@ let BuildFieldMap cenv env isPartial ty flds m =
let item = FreshenRecdFieldRef cenv.nameResolver m fref2
CallNameResolutionSink cenv.tcSink ((snd fld).idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad)
- CheckRecdFieldAccessible m env.eAccessRights fref2 |> ignore;
- CheckFSharpAttributes cenv.g fref2.PropertyAttribs m |> CommitOperationResult;
+ 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));
+ errorR (Error(FSComp.SR.tcFieldAppearsTwiceInRecord(fref2.FieldName),m))
if not (tyconRefEq cenv.g tcref fref2.TyconRef) then
let (_,frefSet1,_) = List.head frefSets
let fref1 = List.head frefSet1
- errorR (FieldsFromDifferentTypes(env.DisplayEnv,fref1,fref2,m));
+ errorR (FieldsFromDifferentTypes(env.DisplayEnv,fref1,fref2,m))
(fs,rfldsList)
else (Map.add fref2.FieldName fldExpr fs,
(fref2.FieldName,fldExpr)::rfldsList)
@@ -1857,43 +1861,43 @@ let rec ApplyUnionCaseOrExn (makerForUnionCase,makerForExnTag) m cenv env overal
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 m ad ecref |> ignore;
+ 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
+ mkf,recdFieldTysOfExnDefRef ecref, [ for f in (recdFieldsOfExnDefRef ecref) -> f.Name ]
| Item.UnionCase ucinfo ->
let ucref = ucinfo.UnionCaseRef
- CheckUnionCaseAttributes cenv.g ucref m |> CommitOperationResult;
- CheckUnionCaseAccessible m ad ucref |> ignore;
+ 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;
+ UnifyTypes cenv env m overallTy gtyp2
let mkf = makerForUnionCase(ucref,ucinfo.TypeInst)
- mkf,actualTysOfUnionCaseFields inst ucref
+ mkf,actualTysOfUnionCaseFields inst ucref, ([ for f in ucref.AllFieldsAsList -> f.Name ])
| _ -> invalidArg "item" "not a union case or exception reference"
let ApplyUnionCaseOrExnTypes m cenv env overallTy c =
- ApplyUnionCaseOrExn ((fun (a,b) args -> mkUnionCaseExpr(a,b,args,m)),
- (fun a args -> mkExnExpr (a,args,m))) 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) args -> TPat_unioncase(a,b,args,m)),
- (fun a args -> TPat_exnconstr(a,args,m))) 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 =
+ 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));
+ error (UnionCaseWrongNumberOfArgs(env.DisplayEnv,List.length argtys,n,m))
let ty2 = List.nth argtys n
mkf,ty2
@@ -2098,7 +2102,7 @@ module GeneralizationHelpers =
// Condensation solves type variables eagerly and removes them from the generalization set
condensationTypars |> List.iter (fun tp ->
- ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp);
+ ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp)
generalizedTypars
let CanonicalizePartialInferenceProblem (cenv,denv,m) tps =
@@ -2134,7 +2138,7 @@ module GeneralizationHelpers =
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)));
+ error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty),m)))
let generalizedTypars = CondenseTypars(cenv,denv,generalizedTypars,tauTy)
@@ -2147,11 +2151,11 @@ module GeneralizationHelpers =
// Generalization turns inference type variables into rigid, quantified type variables,
// (they may be rigid already)
- generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m);
+ generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m)
// Generalization removes constraints related to generalized type variables
let csenv = MakeConstraintSolverEnv cenv.css m denv
- EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars;
+ EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars
generalizedTypars
@@ -2170,10 +2174,10 @@ module GeneralizationHelpers =
// can't infer extra polymorphism for properties
| MemberKind.PropertyGet | MemberKind.PropertySet ->
if nonNil declaredTypars then
- errorR(Error(FSComp.SR.tcPropertyRequiresExplicitTypeParameters(),m));
+ errorR(Error(FSComp.SR.tcPropertyRequiresExplicitTypeParameters(),m))
| MemberKind.Constructor ->
if nonNil declaredTypars then
- errorR(Error(FSComp.SR.tcConstructorCannotHaveTypeParameters(),m));
+ errorR(Error(FSComp.SR.tcConstructorCannotHaveTypeParameters(),m))
| _ -> ()
/// Properties and Constructors may only generalize the variables associated with the containing class (retrieved from the 'this' pointer)
@@ -2309,7 +2313,7 @@ module BindingNormalization =
let (SynValData(_,valSynInfo,thisIdOpt)) = valSynData
if memberFlags.IsInstance then
// instance method without adhoc "this" argument
- error(Error(FSComp.SR.tcInstanceMemberRequiresTarget(),m));
+ 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))
@@ -2331,7 +2335,7 @@ module BindingNormalization =
let (SynValData(_,valSynInfo,thisIdOpt)) = valSynData
if not memberFlags.IsInstance then
// static method with adhoc "this" argument
- error(Error(FSComp.SR.tcStaticMemberShouldNotHaveThis(),m));
+ 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))
@@ -2357,7 +2361,7 @@ module BindingNormalization =
// 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, args, vis, m) ->
+ | 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 ->
@@ -2396,7 +2400,7 @@ module BindingNormalization =
NormalizedBindingPat(SynPat.Typed(pat'',x,y), e'',valSynData,typars)
| SynPat.Attrib(_,_,m) ->
- error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m));
+ error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m))
| _ ->
NormalizedBindingPat(pat,rhsExpr,valSynData,inferredTyparDecls)
@@ -2495,7 +2499,7 @@ module EventDeclarationNormalization =
/// 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.WarnIfNotRigid else rigid) tcref declaredTyconTypars
+ 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
@@ -2568,9 +2572,9 @@ 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;
+ CheckValAccessible m env.eAccessRights vref
if checkAttributes then
- CheckValAttributes cenv.g vref m |> CommitOperationResult;
+ CheckValAttributes cenv.g vref m |> CommitOperationResult
let vty = vref.Type
// byref-typed values get dereferenced
if isByrefTy cenv.g vty then
@@ -2592,7 +2596,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst m =
if v.BaseOrThisInfo = CtorThisVal && isRefCellTy cenv.g vty then
let exprForVal = exprForValRef m vref
//if AreWithinCtorPreConstruct env then
- // warning(SelfRefObjCtor(AreWithinImplicitCtor env, m));
+ // warning(SelfRefObjCtor(AreWithinImplicitCtor env, m))
let ty = destRefCellTy cenv.g vty
let isSpecial = true
@@ -2605,7 +2609,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst m =
// 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));
+ errorR(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(v.DisplayName),m))
match vrec with
| ValInRecScope false ->
@@ -2621,13 +2625,13 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst m =
| 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));
+ 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));
+ 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
@@ -2636,15 +2640,15 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst m =
| ValInRecScope true
| ValNotInRecScope ->
let tps,tptys,tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty
- //dprintfn "After Freshen: tau = %s" (Layout.showL (typeL tau));
+ //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((List.length tps), (List.length tinst)),m));
- List.iter2 (UnifyTypes cenv env m) tptys tinst;
+ 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));
+ //dprintfn "After Unify: tau = %s" (Layout.showL (typeL tau))
vrefFlags,tinst,tau,tpenv
let exprForVal = Expr.Val (vref,vrefFlags,m)
@@ -2781,18 +2785,18 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr =
/// Checks, warnings and constraint assertions for downcasts
let TcRuntimeTypeTest isCast cenv denv m tgty srcTy =
if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then
- warning(TypeTestUnnecessary(m));
+ warning(TypeTestUnnecessary(m))
if isTyparTy cenv.g srcTy then
- error(IndeterminateRuntimeCoercion(denv,srcTy,tgty,m));
+ error(IndeterminateRuntimeCoercion(denv,srcTy,tgty,m))
if isSealedTy cenv.g srcTy then
- error(RuntimeCoercionSourceSealed(denv,srcTy,m));
+ error(RuntimeCoercionSourceSealed(denv,srcTy,m))
if isSealedTy cenv.g tgty ||
isTyparTy cenv.g tgty ||
not (isInterfaceTy cenv.g srcTy) then
- AddCxTypeMustSubsumeType denv cenv.css m NoTrace srcTy tgty;
+ AddCxTypeMustSubsumeType denv cenv.css m NoTrace srcTy tgty
if isErasedType cenv.g tgty then
if isCast then
@@ -2808,13 +2812,13 @@ let TcRuntimeTypeTest isCast cenv denv m tgty srcTy =
/// 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));
+ error(IndeterminateStaticCoercion(denv,srcTy,tgty,m))
if isSealedTy cenv.g tgty then
- warning(CoercionTargetSealed(denv,tgty,m));
+ warning(CoercionTargetSealed(denv,tgty,m))
if typeEquiv cenv.g srcTy tgty then
- warning(UpcastUnnecessary(m));
+ warning(UpcastUnnecessary(m))
AddCxTypeMustSubsumeType denv cenv.css m NoTrace tgty srcTy
@@ -2830,7 +2834,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF
| Some(d) when not (List.mem d cenv.conditionalDefines) ->
// Methods marked with 'Conditional' must return 'unit'
- UnifyTypes cenv env m cenv.g.unit_ty (minfo.GetFSharpReturnTy(cenv.amap, m, minst));
+ UnifyTypes cenv env m cenv.g.unit_ty (minfo.GetFSharpReturnTy(cenv.amap, m, minst))
mkUnit cenv.g m, cenv.g.unit_ty
| _ ->
@@ -2853,7 +2857,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF
let TryFindIntrinsicOrExtensionMethInfo (cenv:cenv) (env: TcEnv) m ad nm ty =
- AllMethInfosOfTypeInScope cenv.infoReader env.NameEnv.eExtensionMembers (Some(nm),ad) IgnoreOverrides m 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) =
@@ -2916,7 +2920,7 @@ let BuildILFieldSet g m objExpr (finfo:ILFieldInfo) argExpr =
// 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));
+ 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))
@@ -2929,7 +2933,7 @@ let BuildILStaticFieldSet m (finfo:ILFieldInfo) argExpr =
// 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));
+ if finfo.IsInitOnly then error (Error (FSComp.SR.tcFieldIsReadonly(),m))
mkAsmExpr ([ mkNormalStsfld fspec ], tinst,[argExpr],[],m)
let BuildRecdFieldSet g m objExpr (rfinfo:RecdFieldInfo) argExpr =
@@ -3003,7 +3007,7 @@ let GetMethodArgs arg =
let namedCallerArgs =
namedCallerArgs |> List.choose (fun e ->
if not (IsNamedArg e) then
- error(Error(FSComp.SR.tcNameArgumentsMustAppearLast(), e.Range));
+ error(Error(FSComp.SR.tcNameArgumentsMustAppearLast(), e.Range))
TryGetNamedArg e)
unnamedCallerArgs, namedCallerArgs
@@ -3030,6 +3034,7 @@ let CompilePatternForMatchClauses cenv env mExpr matchm warnOnUnused actionOnFai
idv,expr
+
//-------------------------------------------------------------------------
// Helpers dealing with sequence expressions
//-------------------------------------------------------------------------
@@ -3046,7 +3051,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr
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)
- ResultOrException.Exception(Error(msg,m));
+ ResultOrException.Exception(Error(msg,m))
let findMethInfo k m nm ty =
match TryFindIntrinsicOrExtensionMethInfo cenv env m ad nm ty with
@@ -3182,8 +3187,6 @@ let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr:Expr) =
let enumeratorVar, _,retTypeOfGetEnumerator,enumElemTy,getEnumExpr,_,guardExpr,guardTy,betterCurrentExpr =
AnalyzeArbitraryExprAsEnumerable cenv env false m ty enumerableExpr
- // if isStructTy cenv.g getEnumTy then errorR(Error(FSComp.SR.tcBadReturnTypeForGetEnumerator(),m));
-
let expr =
mkCompGenLet m enumerableVar expr
(mkCallSeqOfFunctions cenv.g m retTypeOfGetEnumerator enumElemTy
@@ -3195,43 +3198,43 @@ let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr:Expr) =
let mkSeqEmpty cenv env m genTy =
// We must discover the 'zero' of the monadic algebra being generated in order to compile failing matches.
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
mkCallSeqEmpty cenv.g m genResultTy
let mkSeqCollect cenv env m enumElemTy genTy lam enumExpr =
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
let enumExpr = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g enumElemTy) (tyOfExpr cenv.g enumExpr) enumExpr
mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr
let mkSeqUsing cenv (env: TcEnv) m resourceTy genTy resourceExpr lam =
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam
let mkSeqDelay cenv env m genTy lam =
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
mkCallSeqDelay cenv.g m genResultTy (mkUnitDelayLambda cenv.g m lam)
let mkSeqAppend cenv env m genTy e1 e2 =
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
let e1 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1
let e2 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2
mkCallSeqAppend cenv.g m genResultTy e1 e2
let mkSeqFromFunctions cenv env m genTy e1 e2 =
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
let e2 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2
mkCallSeqGenerated cenv.g m genResultTy e1 e2
let mkSeqFinally cenv env m genTy e1 e2 =
let genResultTy = NewInferenceType ()
- UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy);
+ UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy)
let e1 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1
mkCallSeqFinally cenv.g m genResultTy e1 e2
@@ -3390,12 +3393,12 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout
// NOTE: we can't fixup recursive references inside delegates since the closure delegee of a delegate is not accessible
// from outside. Object expressions implementing interfaces can, on the other hand, be fixed up. See FSharp 1.0 bug 1469
if isInterfaceTy g ty then
- List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> checkDelayed st e) overrides;
- List.iter (snd >> List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> checkDelayed st e)) extraImpls;
+ List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> checkDelayed st e) overrides
+ List.iter (snd >> List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> checkDelayed st e)) extraImpls
else
- CheckExpr (strict st) e;
- List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> CheckExpr (lzy (strict st)) e) overrides;
- List.iter (snd >> List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> CheckExpr (lzy (strict st)) e)) extraImpls;
+ CheckExpr (strict st) e
+ List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> CheckExpr (lzy (strict st)) e) overrides
+ List.iter (snd >> List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> CheckExpr (lzy (strict st)) e)) extraImpls
// Expressions where fixups may be needed
| Expr.Val (v,_,m) -> CheckValSpec st v m
@@ -3407,16 +3410,16 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout
// Composite expressions
| Expr.Const _ -> ()
| Expr.LetRec (binds,e,_,_) ->
- binds |> FlatList.iter (CheckBinding (strict st)) ;
+ binds |> FlatList.iter (CheckBinding (strict st))
CheckExpr (strict st) e
| Expr.Let (bind,e,_,_) ->
- CheckBinding (strict st) bind;
+ CheckBinding (strict st) bind
CheckExpr (strict st) e
| Expr.Match (_,_,pt,targets,_,_) ->
- CheckDecisionTree (strict st) pt;
+ CheckDecisionTree (strict st) pt
Array.iter (CheckDecisionTreeTarget (strict st)) targets
| Expr.App(e1,_,_,args,_) ->
- CheckExpr (strict st) e1;
+ CheckExpr (strict st) e1
List.iter (CheckExpr (strict st)) args
// Binary expressions
| Expr.Sequential (e1,e2,_,_,_)
@@ -3445,18 +3448,18 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout
match st with
| MaybeLazy ->
if ListSet.contains g.valRefEq v rvs then
- warning (RecursiveUseCheckedAtRuntime (denv,v,m));
+ warning (RecursiveUseCheckedAtRuntime (denv,v,m))
if not !reportedEager then
- (warning (LetRecCheckedAtRuntime m); reportedEager := true);
- runtimeChecks := true;
+ (warning (LetRecCheckedAtRuntime m); reportedEager := true)
+ runtimeChecks := true
| Top | DefinitelyStrict ->
if ListSet.contains g.valRefEq v rvs then
if not (ListSet.contains g.valRefEq v availIfInOrder) then
- warning (LetRecEvaluatedOutOfOrder (denv,boundv,v,m));
- outOfOrder := true;
+ warning (LetRecEvaluatedOutOfOrder (denv,boundv,v,m))
+ outOfOrder := true
if not !reportedEager then
- (warning (LetRecCheckedAtRuntime m); reportedEager := true);
+ (warning (LetRecCheckedAtRuntime m); reportedEager := true)
definiteDependencies := (boundv,v) :: !definiteDependencies
| InnerTop ->
if ListSet.contains g.valRefEq v rvs then
@@ -3471,20 +3474,20 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout
CheckExpr Top expr
- List.fold
- (fun availIfInOrder (TBind(v,e,_)) ->
- check availIfInOrder (mkLocalValRef v) e;
+ // Check the bindings one by one, each w.r.t. the previously available set of binding
+ ([], bindsWithoutLaziness) ||> List.fold (fun availIfInOrder (TBind(v,e,_)) ->
+ check availIfInOrder (mkLocalValRef v) e
(mkLocalValRef v::availIfInOrder))
- [] bindsWithoutLaziness |> ignore;
+ |> ignore
- // ddg = definiteDependencyGraph
+ // ddg = definiteDependencyGraph
let ddgNodes = bindsWithoutLaziness |> List.map (fun (TBind(v,_,_)) -> mkLocalValRef v)
let ddg = Graph<ValRef, Stamp>((fun v -> v.Stamp), ddgNodes, !definiteDependencies )
- ddg.IterateCycles (fun path -> error (LetRecUnsound (denv,path,path.Head.Range))) ;
+ ddg.IterateCycles (fun path -> error (LetRecUnsound (denv,path,path.Head.Range)))
let requiresLazyBindings = !runtimeChecks || !outOfOrder
if !directRecursiveData && requiresLazyBindings then
- error(Error(FSComp.SR.tcInvalidMixtureOfRecursiveForms(),bindsm));
+ error(Error(FSComp.SR.tcInvalidMixtureOfRecursiveForms(),bindsm))
let bindsBefore, bindsAfter =
if requiresLazyBindings then
@@ -3508,8 +3511,8 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout
let vlazy,velazy = Tastops.mkCompGenLocal m v.LogicalName vty
let vrhs = (mkLazyDelayed g m ty felazy)
- if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g vty [] [] vrhs));
- fixupPoints |> List.iter (fun (fp,_) -> fp := mkLazyForce g (!fp).Range ty velazy);
+ if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g vty [] [] vrhs))
+ fixupPoints |> List.iter (fun (fp,_) -> fp := mkLazyForce g (!fp).Range ty velazy)
[mkInvisibleBind flazy frhs; mkInvisibleBind vlazy vrhs],
[mkBind seqPtOpt v (mkLazyForce g m ty velazy)])
@@ -3530,7 +3533,7 @@ let CheckAndRewriteObjectCtor g env (ctorLambaExpr:Expr) =
// Rewrite legitimate self-construction calls to CtorValUsedAsSelfInit
let error (expr:Expr) =
- errorR(Error(FSComp.SR.tcInvalidObjectConstructionExpression(),expr.Range));
+ errorR(Error(FSComp.SR.tcInvalidObjectConstructionExpression(),expr.Range))
expr
// Build an assignment into the safeThisValOpt mutable reference cell that holds recursive references to 'this'
@@ -3594,7 +3597,7 @@ let CheckAndRewriteObjectCtor g env (ctorLambaExpr:Expr) =
match expr with
| Expr.Link eref ->
let e = checkAndRewriteCtorUsage !eref
- eref := e;
+ eref := e
expr
// Type applications are ok, e.g.
@@ -3643,7 +3646,7 @@ let buildApp cenv expr exprty arg m =
| ApplicableExpr(_, Expr.App(Expr.Val(vf,_,_),_,_,[],_),_), _
when (valRefEq cenv.g vf cenv.g.addrof_vref ||
valRefEq cenv.g vf cenv.g.addrof2_vref) ->
- if valRefEq cenv.g vf cenv.g.addrof2_vref then warning(UseOfAddressOfOperator(m));
+ if valRefEq cenv.g vf cenv.g.addrof2_vref then warning(UseOfAddressOfOperator(m))
let wrap,e1a' = mkExprAddrOfExpr cenv.g true false DefinitelyMutates arg (Some(vf)) m
MakeApplicableExprNoFlex cenv (wrap(e1a'))
| _ ->
@@ -3766,7 +3769,7 @@ type PreCheckingRecursiveBinding =
type PreGeneralizationRecursiveBinding =
{ ExtraGeneralizableTypars : Typars
- CheckedBinding: CheckedBindingInfo;
+ CheckedBinding: CheckedBindingInfo
RecBindingInfo : RecursiveBindingInfo }
type PostGeneralizationRecursiveBinding =
@@ -3776,7 +3779,7 @@ type PostGeneralizationRecursiveBinding =
member x.GeneralizedTypars = x.ValScheme.GeneralizedTypars
type PostBindCtorThisVarRefCellRecursiveBinding =
- { ValScheme: ValScheme;
+ { ValScheme: ValScheme
Binding: Tast.Binding }
@@ -3810,7 +3813,7 @@ let GetInstanceMemberThisVariable (v:Val,x) =
let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c =
let checkSimpleConstraint tp m constraintAdder =
let tp',tpenv = TcTypar cenv env newOk tpenv tp
- constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') ;
+ constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp')
tpenv
match c with
@@ -3818,15 +3821,15 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c =
let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty
let tp',tpenv = TcTypar cenv env newOk tpenv tp
let csenv = (MakeConstraintSolverEnv cenv.css m env.DisplayEnv)
- AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx,ty',m)) |> CommitOperationResult;
+ AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx,ty',m)) |> CommitOperationResult
tpenv
| WhereTyparSubtypeOfType(tp,ty,m) ->
let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv ty
let tp',tpenv = TcTypar cenv env newOk tpenv tp
if (newOk = NoNewTypars) && isSealedTy cenv.g ty' then
- errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(),m));
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') ;
+ errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(),m))
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp')
tpenv
| WhereTyparSupportsNull(tp,m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull
@@ -3847,10 +3850,10 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c =
match tyargs with
| [underlying] ->
let underlying',tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv underlying
- AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') underlying';
+ AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') underlying'
tpenv
| _ ->
- errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m));
+ errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m))
tpenv
tpenv
@@ -3860,10 +3863,10 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c =
| [a;b] ->
let a',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv a
let b',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv b
- AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') a' b';
+ AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') a' b'
tpenv
| _ ->
- errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m));
+ errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m))
tpenv
| WhereTyparSupportsMember(tps,memSpfn,m) ->
@@ -3872,13 +3875,13 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c =
| TTrait(objtys,".ctor",memberFlags,argtys,returnTy,_) when (memberFlags.MemberKind=MemberKind.Constructor) ->
match objtys,argtys with
| [ty],[] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) ->
- AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty ;
+ AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty
tpenv
| _ ->
- errorR(Error(FSComp.SR.tcInvalidNewConstraint(),m));
+ errorR(Error(FSComp.SR.tcInvalidNewConstraint(),m))
tpenv
| _ ->
- AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo;
+ AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo
tpenv
and TcPseudoMemberSpec cenv newOk env synTypars tpenv memSpfn m =
@@ -3940,7 +3943,7 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv
tpenv
// Enforce "no undeclared constraints allowed on declared typars"
- allDeclaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m);
+ allDeclaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m)
// Process the type, including any constraints
let declaredTy,tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType envinner tpenv ty
@@ -4038,8 +4041,8 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv
| MemberKind.PropertySet ->
generateOneMember(memberFlags), tpenv
| MemberKind.PropertyGetSet ->
- [ yield! generateOneMember({memberFlags with MemberKind=MemberKind.PropertyGet});
- yield! generateOneMember({memberFlags with MemberKind=MemberKind.PropertySet}); ], tpenv
+ [ yield! generateOneMember({memberFlags with MemberKind=MemberKind.PropertyGet})
+ yield! generateOneMember({memberFlags with MemberKind=MemberKind.PropertySet}) ], tpenv
| _ ->
let valSynInfo = AdjustValSynInfoInSignature cenv.g declaredTy valSynInfo
let partialValReprInfo = TranslateTopValSynInfo id.idRange (TcAttributes cenv env) valSynInfo
@@ -4072,7 +4075,7 @@ and TcTyparOrMeasurePar optKind cenv (env:TcEnv) newOk tpenv (Typar(id,_,_) as t
match TryFindUnscopedTypar key tpenv with
| Some res -> checkRes res
| None ->
- if newOk = NoNewTypars then error (UndefinedName(0,FSComp.SR.undefinedNameTypeParameter,id,["<unimplemented>"]));
+ if newOk = NoNewTypars then error (UndefinedName(0,FSComp.SR.undefinedNameTypeParameter,id,["<unimplemented>"]))
// OK, this is an implicit declaration of a type parameter
// The kind defaults to Type
let tp' = NewTypar ((match optKind with None -> TyparKind.Type | Some kind -> kind), TyparRigidity.WarnIfNotRigid,tp,false,TyparDynamicReq.Yes,[],false,false)
@@ -4114,10 +4117,10 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver occ OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No)
match optKind, tcref.TypeOrMeasureKind with
| Some TyparKind.Type, TyparKind.Measure ->
- error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m));
+ error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m))
NewErrorType (), tpenv
| Some TyparKind.Measure, TyparKind.Type ->
- error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m));
+ error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m))
TType_measure (NewErrorMeasure ()), tpenv
| _, TyparKind.Measure ->
TType_measure (MeasureCon tcref), tpenv
@@ -4126,17 +4129,17 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
| SynType.App (SynType.LongIdent(LongIdentWithDots(tc,_)),_,args,_commas,_,postfix,m) ->
let ad = env.eAccessRights
- let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameResEnv ad tc (TypeNameResolutionStaticArgsInfo.FromTyArgs args) PermitDirectReferenceToGeneratedType.No)
+ let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameResEnv ad tc (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length) PermitDirectReferenceToGeneratedType.No)
match optKind, tcref.TypeOrMeasureKind with
| Some TyparKind.Type, TyparKind.Measure ->
- error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m));
+ error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m))
NewErrorType (), tpenv
| Some TyparKind.Measure, TyparKind.Type ->
- error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m));
+ error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m))
TType_measure (NewErrorMeasure ()), tpenv
| _, TyparKind.Type ->
if postfix && tcref.Typars(m) |> List.exists (fun tp -> match tp.Kind with TyparKind.Measure -> true | _ -> false)
- then error(Error(FSComp.SR.tcInvalidUnitsOfMeasurePrefix(), m));
+ then error(Error(FSComp.SR.tcInvalidUnitsOfMeasurePrefix(), m))
TcTypeApp cenv newOk checkCxs occ env tpenv m tcref [] args
| _, TyparKind.Measure ->
match args,postfix with
@@ -4145,15 +4148,15 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
TType_measure (MeasureProd(MeasureCon tcref, ms)), tpenv
| _, _ ->
- errorR(Error(FSComp.SR.tcUnitsOfMeasureInvalidInTypeConstructor(), m));
+ errorR(Error(FSComp.SR.tcUnitsOfMeasureInvalidInTypeConstructor(), m))
NewErrorType (), tpenv
| SynType.LongIdentApp (ltyp,LongIdentWithDots(longId,_),_,args,_commas,_,m) ->
let ad = env.eAccessRights
let ltyp,tpenv = TcType cenv newOk checkCxs occ env tpenv ltyp
- if not (isAppTy cenv.g ltyp) then error(Error(FSComp.SR.tcTypeHasNoNestedTypes(),m));
+ if not (isAppTy cenv.g ltyp) then error(Error(FSComp.SR.tcTypeHasNoNestedTypes(),m))
let tcref,tinst = destAppTy cenv.g ltyp
- let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameResEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args)) ad m tcref longId
+ let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameResEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length)) ad m tcref longId
TcTypeApp cenv newOk checkCxs occ env tpenv m tcref tinst args
| SynType.Tuple(args,m) ->
@@ -4196,29 +4199,29 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
| SynType.HashConstraint(ty,m) ->
let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m
let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) ;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp)
tp.AsType, tpenv
| SynType.StaticConstant (c, m) ->
match c, optKind with
| _, Some TyparKind.Type ->
- errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m));
+ errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m))
NewErrorType (), tpenv
| SynConst.Int32 1, _ ->
TType_measure MeasureOne, tpenv
| _ ->
- errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m));
+ errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m))
NewErrorType (), tpenv
| SynType.StaticConstantNamed (_,_,m)
| SynType.StaticConstantExpr (_,m) ->
- errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m));
+ errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m))
NewErrorType (), tpenv
| SynType.MeasurePower(typ, exponent, m) ->
match optKind with
| Some TyparKind.Type ->
- errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("^"), m));
+ errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("^"), m))
NewErrorType (), tpenv
| _ ->
let ms,tpenv = TcMeasure cenv newOk checkCxs occ env tpenv typ m
@@ -4227,7 +4230,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
| SynType.MeasureDivide(typ1, typ2, m) ->
match optKind with
| Some TyparKind.Type ->
- errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("/"), m));
+ errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("/"), m))
NewErrorType (), tpenv
| _ ->
let ms1,tpenv = TcMeasure cenv newOk checkCxs occ env tpenv typ1 m
@@ -4242,11 +4245,11 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped
TType_measure (MeasureProd(ms1, ms2)), tpenv
| _, _, _ ->
- errorR(Error(FSComp.SR.tcTypeParameterInvalidAsTypeConstructor(), m));
+ errorR(Error(FSComp.SR.tcTypeParameterInvalidAsTypeConstructor(), m))
NewErrorType (), tpenv
| SynType.App(_, _, _, _, _, _, m) ->
- errorR(Error(FSComp.SR.tcIllegalSyntaxInTypeExpression(), m));
+ errorR(Error(FSComp.SR.tcIllegalSyntaxInTypeExpression(), m))
NewErrorType (), tpenv
and TcType cenv newOk checkCxs occ env (tpenv:SyntacticUnscopedTyparEnv) ty =
@@ -4255,18 +4258,18 @@ and TcType cenv newOk checkCxs occ env (tpenv:SyntacticUnscopedTyparEnv) ty =
and TcMeasure cenv newOk checkCxs occ env (tpenv:SyntacticUnscopedTyparEnv) ty m =
match ty with
| SynType.Anon m ->
- error(Error(FSComp.SR.tcAnonymousUnitsOfMeasureCannotBeNested(), m));
+ error(Error(FSComp.SR.tcAnonymousUnitsOfMeasureCannotBeNested(), m))
NewErrorMeasure (), tpenv
| _ ->
match TcTypeOrMeasure (Some TyparKind.Measure) cenv newOk checkCxs occ env tpenv ty with
| TType_measure ms, tpenv -> ms,tpenv
| _, _ ->
- error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m));
+ error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m))
NewErrorMeasure (), tpenv
and TcAnonTypeOrMeasure optKind _cenv rigid dyn newOk m =
- if newOk = NoNewTypars then errorR (Error(FSComp.SR.tcAnonymousTypeInvalidInDeclaration(),m));
+ if newOk = NoNewTypars then errorR (Error(FSComp.SR.tcAnonymousTypeInvalidInDeclaration(),m))
let rigid = (if rigid = TyparRigidity.Anon && newOk = NewTyparsOKButWarnIfNotRigid then TyparRigidity.WarnIfNotRigid else rigid)
let kind = match optKind with Some TyparKind.Measure -> TyparKind.Measure | _ -> TyparKind.Type
NewAnonTypar (kind,m,rigid,NoStaticReq,dyn)
@@ -4281,7 +4284,7 @@ and TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m =
| (isquot,typ)::args ->
let ty,tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv typ
let tys,tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m
- if isquot then errorR(Error(FSComp.SR.tcUnexpectedSlashInType(),m));
+ if isquot then errorR(Error(FSComp.SR.tcUnexpectedSlashInType(),m))
ty::tys,tpenv
// Type-check a list of measures separated by juxtaposition, * or /
@@ -4347,7 +4350,7 @@ and TcStaticConstantParameter cenv (env:TcEnv) tpenv kind (v:SynType) idOpt =
let te,tpenv' = TcExprNoRecover cenv kind env tpenv e
// Evaluate the constant expression using static attribute argument rules
- let te = EvalAttribArg cenv.g te
+ let te = EvalLiteralExprOrAttribArg cenv.g te
let v =
match stripExpr te with
// Check we have a residue constant. We know the type was correct because we checked the expression with this type.
@@ -4395,7 +4398,7 @@ and TcProvidedTypeAppToStaticConstantArgs cenv env optGeneratedTypePath tpenv (t
let namedArgs = otherArgs |> Seq.takeWhile (fst >> isSome) |> Seq.toList |> List.map (map1Of2 Option.get)
let otherArgs = otherArgs |> Seq.skipWhile (fst >> isSome) |> Seq.toList
if not otherArgs.IsEmpty then
- error (Error(FSComp.SR.etBadUnnamedStaticArgs(),m));
+ error (Error(FSComp.SR.etBadUnnamedStaticArgs(),m))
for (n,_) in namedArgs do
match staticParameters |> Array.toList |> List.mapi (fun j x -> (j,x)) |> List.filter (fun (j,sp) -> j >= unnamedArgs.Length && n.idText = sp.PUntaint((fun sp -> sp.Name), m)) with
@@ -4426,12 +4429,12 @@ and TcProvidedTypeAppToStaticConstantArgs cenv env optGeneratedTypePath tpenv (t
| [] ->
if sp.PUntaint((fun sp -> sp.IsOptional), m) then
match sp.PUntaint((fun sp -> sp.RawDefaultValue), m) with
- | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, tcref.DisplayName, tcref.DisplayName, spName) ,m));
+ | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, tcref.DisplayName, tcref.DisplayName, spName) ,m))
| v -> v
else
error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, tcref.DisplayName, tcref.DisplayName, spName),m))
| ps ->
- error (Error(FSComp.SR.etMultipleStaticParameterWithName spName,(fst (List.last ps)).idRange)));
+ error (Error(FSComp.SR.etMultipleStaticParameterWithName spName,(fst (List.last ps)).idRange)))
// Take the static arguments (as SynType's) and convert them to objects of the appropriate type, based on the expected kind.
@@ -4443,6 +4446,23 @@ and TcProvidedTypeAppToStaticConstantArgs cenv env optGeneratedTypePath tpenv (t
let hasNoArgs = (argsInStaticParameterOrderIncludingDefaults.Length = 0)
hasNoArgs, providedTypeAfterStaticArguments, checkTypeName
+and TcProvidedTypeApp cenv env tpenv tcref args m =
+ let hasNoArgs,providedTypeAfterStaticArguments,checkTypeName = TcProvidedTypeAppToStaticConstantArgs cenv env None tpenv tcref args m
+
+ let isGenerated = providedTypeAfterStaticArguments.PUntaint((fun st -> not st.IsErased),m)
+
+ //printfn "adding entity for provided type '%s', isDirectReferenceToGenerated = %b, isGenerated = %b" (st.PUntaint((fun st -> st.Name), m)) isDirectReferenceToGenerated isGenerated
+ let isDirectReferenceToGenerated = isGenerated && ExtensionTyping.IsGeneratedTypeDirectReference (providedTypeAfterStaticArguments, m)
+ if isDirectReferenceToGenerated then
+ error(Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(tcref.DisplayName),m))
+
+ // We put the type name check after the 'isDirectReferenceToGenerated' check because we need the 'isDirectReferenceToGenerated' error to be shown for generated types
+ checkTypeName()
+ if hasNoArgs then
+ mkAppTy tcref [], tpenv
+ else
+ let typ = Import.ImportProvidedType cenv.amap m providedTypeAfterStaticArguments
+ typ,tpenv
#endif
/// Typecheck an application of a generic type to type arguments.
@@ -4451,58 +4471,42 @@ and TcProvidedTypeAppToStaticConstantArgs cenv env optGeneratedTypePath tpenv (t
/// In this case, 'args' is only the instantation of the suffix type arguments, and pathTypeArgs gives
/// the prefix of type arguments.
and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (args: SynType list) =
- CheckTyconAccessible m env.eAccessRights tcref |> ignore;
- CheckEntityAttributes cenv.g tcref m |> CommitOperationResult;
+ CheckTyconAccessible cenv.amap m env.eAccessRights tcref |> ignore
+ CheckEntityAttributes cenv.g tcref m |> CommitOperationResult
#if EXTENSIONTYPING
// Provided types are (currently) always non-generic. Their names may include mangled
// static parameters, which are passed by the provider.
- if tcref.Deref.IsProvided then
- let hasNoArgs,providedTypeAfterStaticArguments,checkTypeName = TcProvidedTypeAppToStaticConstantArgs cenv env None tpenv tcref args m
-
- let isGenerated = providedTypeAfterStaticArguments.PUntaint((fun st -> not st.IsErased),m)
+ if tcref.Deref.IsProvided then TcProvidedTypeApp cenv env tpenv tcref args m else
+#endif
- //printfn "adding entity for provided type '%s', isDirectReferenceToGenerated = %b, isGenerated = %b" (st.PUntaint((fun st -> st.Name), m)) isDirectReferenceToGenerated isGenerated
- let isDirectReferenceToGenerated = isGenerated && ExtensionTyping.IsGeneratedTypeDirectReference (providedTypeAfterStaticArguments, m)
- if isDirectReferenceToGenerated then
- error(Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(tcref.DisplayName),m))
+ let tps,_,tinst,_ = infoOfTyconRef m tcref
+ // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just
+ // clear the constaint lists of the freshly generated type variables. A little ugly but fairly localized.
+ if checkCxs = NoCheckCxs then tps |> List.iter (fun tp -> tp.Data.typar_constraints <- [])
+ if tinst.Length <> pathTypeArgs.Length + args.Length then
+ error (TyconBadArgs(env.DisplayEnv,tcref,pathTypeArgs.Length + args.Length,m))
+ let args',tpenv =
+ // Get the suffix of typars
+ let tpsForArgs = List.drop (tps.Length - args.Length) tps
+ let kindsForArgs = tpsForArgs |> List.map (fun tp -> tp.Kind)
+ TcTypesOrMeasures (Some kindsForArgs) cenv newOk checkCxs occ env tpenv args m
+ let args' = pathTypeArgs @ args'
+ if checkCxs = CheckCxs then
+ List.iter2 (UnifyTypes cenv env m) tinst args'
+ mkAppTy tcref args', tpenv
- // We put the type name check after the 'isDirectReferenceToGenerated' check because we need the 'isDirectReferenceToGenerated' error to be shown for generated types
- checkTypeName()
- if hasNoArgs then
- mkAppTy tcref [], tpenv
- else
- let typ = Import.ImportProvidedType cenv.amap m providedTypeAfterStaticArguments
- typ,tpenv
- else
-#endif
- (
- let tps,_,tinst,_ = infoOfTyconRef m tcref
- // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just
- // clear the constaint lists of the freshly generated type variables. A little ugly but fairly localized.
- if checkCxs = NoCheckCxs then tps |> List.iter (fun tp -> tp.Data.typar_constraints <- []);
- if tinst.Length <> pathTypeArgs.Length + args.Length then
- error (TyconBadArgs(env.DisplayEnv,tcref,pathTypeArgs.Length + args.Length,m));
- let args',tpenv =
- // Get the suffix of typars
- let tpsForArgs = List.drop (tps.Length - args.Length) tps
- let kindsForArgs = tpsForArgs |> List.map (fun tp -> tp.Kind)
- TcTypesOrMeasures (Some kindsForArgs) cenv newOk checkCxs occ env tpenv args m
- let args' = pathTypeArgs @ args'
- List.iter2 (UnifyTypes cenv env m) tinst args';
- mkAppTy tcref args', tpenv
- )
and TcTypeOrMeasureAndRecover optKind cenv newOk checkCxs occ env tpenv ty =
try TcTypeOrMeasure optKind cenv newOk checkCxs occ env tpenv ty
with e ->
- errorRecovery e ty.Range;
+ errorRecovery e ty.Range
(if newOk <> NoNewTypars then NewErrorType () else cenv.g.obj_ty),tpenv
and TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty =
TcTypeOrMeasureAndRecover (Some TyparKind.Type) cenv newOk checkCxs occ env tpenv ty
and TcNestedTypeApplication cenv newOk checkCxs occ env tpenv mWholeTypeApp typ tyargs =
- if not (isAppTy cenv.g typ) then error(Error(FSComp.SR.tcTypeHasNoNestedTypes(),mWholeTypeApp));
+ if not (isAppTy cenv.g typ) then error(Error(FSComp.SR.tcTypeHasNoNestedTypes(),mWholeTypeApp))
match typ with
| TType_app(tcref,tinst) ->
let pathTypeArgs = List.take (max (tinst.Length - tcref.Typars(mWholeTypeApp).Length) 0) tinst
@@ -4528,10 +4532,10 @@ and TcSimplePat optArgsOK checkCxs cenv ty env (tpenv,names,takenNames) p =
| Some altId -> TcSimplePat optArgsOK checkCxs cenv ty env (tpenv,names,takenNames) (SynSimplePat.Id (altId,None,compgen,isMemberThis,isOpt,m) )
| None ->
- if isOpt && not optArgsOK then errorR(Error(FSComp.SR.tcOptionalArgsOnlyOnMembers(),m));
+ if isOpt && not optArgsOK then errorR(Error(FSComp.SR.tcOptionalArgsOnlyOnMembers(),m))
if isOpt then
let tyarg = NewInferenceType ()
- UnifyTypes cenv env m ty (mkOptionTy cenv.g tyarg);
+ UnifyTypes cenv env m ty (mkOptionTy cenv.g tyarg)
let _,names,takenNames = TcPatBindingName cenv env id ty isMemberThis None None (ValInline.Optional,permitInferTypars,noArgOrRetAttribs,false,None,compgen) (names,takenNames)
id.idText,
@@ -4541,8 +4545,8 @@ and TcSimplePat optArgsOK checkCxs cenv ty env (tpenv,names,takenNames) p =
let cty',tpenv = TcTypeAndRecover cenv NewTyparsOK checkCxs ItemOccurence.UseInType env tpenv cty
match p with
// Optional arguments on members
- | SynSimplePat.Id(_,_,_,_,true,_) -> UnifyTypes cenv env m ty (mkOptionTy cenv.g cty');
- | _ -> UnifyTypes cenv env m ty cty';
+ | SynSimplePat.Id(_,_,_,_,true,_) -> UnifyTypes cenv env m ty (mkOptionTy cenv.g cty')
+ | _ -> UnifyTypes cenv env m ty cty'
TcSimplePat optArgsOK checkCxs cenv ty env (tpenv,names,takenNames) p
@@ -4587,7 +4591,7 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv,names,takenNames:Set<_>)
// uniform with the process where we give names to other (more complex)
// patterns used in argument position, e.g. "let f (D(x)) = ..."
let id = ident("unitVar"^string takenNames.Count,m)
- UnifyTypes cenv env m ty cenv.g.unit_ty;
+ UnifyTypes cenv env m ty cenv.g.unit_ty
let _,names,takenNames = TcPatBindingName cenv env id ty false None None (ValInline.Optional,permitInferTypars,noArgOrRetAttribs,false,None,true) (names,takenNames)
[id.idText],(tpenv,names,takenNames)
@@ -4605,8 +4609,8 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv,names,takenNames:Set<_>)
match p with
// Solitary optional arguments on members
- | SynSimplePats.SimplePats([SynSimplePat.Id(_,_,_,_,true,_)],_) -> UnifyTypes cenv env m ty (mkOptionTy cenv.g cty');
- | _ -> UnifyTypes cenv env m ty cty';
+ | SynSimplePats.SimplePats([SynSimplePat.Id(_,_,_,_,true,_)],_) -> UnifyTypes cenv env m ty (mkOptionTy cenv.g cty')
+ | _ -> UnifyTypes cenv env m ty cty'
TcSimplePats cenv optArgsOK checkCxs ty env (tpenv,names,takenNames) p
@@ -4616,7 +4620,7 @@ and TcSimplePatsOfUnknownType cenv optArgsOK checkCxs env tpenv spats =
and TcPatBindingName _cenv _env id ty isMemberThis vis1 topValData (inlineFlag,declaredTypars,argAttribs,isMutable,vis2,compgen) (names,takenNames:Set<string>) =
let vis = if isSome vis1 then vis1 else vis2
- if takenNames.Contains id.idText then errorR (VarBoundTwice id);
+ if takenNames.Contains id.idText then errorR (VarBoundTwice id)
let baseOrThis = if isMemberThis then MemberThisVal else NormalVal
let names = Map.add id.idText (PrelimValScheme1(id,declaredTypars,ty,topValData,None,isMutable,inlineFlag,baseOrThis,argAttribs,vis,compgen)) names
let takenNames = Set.add id.idText takenNames
@@ -4636,7 +4640,7 @@ and TcPatAndRecover warnOnUpper cenv (env:TcEnv) topValInfo vFlags (tpenv,names,
// the type of the current expression with a type variable that indicates an error
let m = pat.Range
errorRecovery e m
- //solveTypAsError cenv env.DisplayEnv m ty;
+ //solveTypAsError cenv env.DisplayEnv m ty
(fun _ -> TPat_wild m), (tpenv,names,takenNames)
/// Typecheck a pattern. Patterns are type-checked in three phases:
@@ -4653,7 +4657,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.Const (c,m) ->
match c with
| SynConst.Bytes (bytes,m) ->
- UnifyTypes cenv env m ty (mkByteArrayTy cenv.g);
+ UnifyTypes cenv env m ty (mkByteArrayTy cenv.g)
TcPat warnOnUpper cenv env None vFlags (tpenv,names,takenNames) ty (SynPat.ArrayOrList (true,[ for b in bytes -> SynPat.Const(SynConst.Byte b,m) ],m))
| SynConst.UserNum _ ->
error(Error(FSComp.SR.tcInvalidNonPrimitiveLiteralInPatternMatch(),m))
@@ -4668,7 +4672,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.Named (SynPat.IsInst(cty,m),_,_,_,_) ->
let srcTy = ty
let tgty,tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty
- TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy;
+ TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy
match pat with
| SynPat.IsInst(_,m) ->
(fun _ -> TPat_isinst (srcTy,tgty,None,m)),(tpenv,names,takenNames)
@@ -4689,11 +4693,11 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.Typed (p,cty,m) ->
let cty',tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty
- UnifyTypes cenv env m ty cty';
+ UnifyTypes cenv env m ty cty'
TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty p
| SynPat.Attrib (_,_,m) ->
- error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m));
+ error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m))
| SynPat.Or (pat1,pat2,m) ->
let pat1',(tpenv,names1,takenNames1) = TcPat warnOnUpper cenv env None vFlags (tpenv,names,takenNames) ty pat1
@@ -4701,12 +4705,12 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
if not (takenNames1 = takenNames2) then
// We don't try to recover from this error since we get later bad internal errors during pattern
// matching
- error (UnionPatternsBindDifferentNames m);
+ error (UnionPatternsBindDifferentNames m)
names1 |> Map.iter (fun _ (PrelimValScheme1(id1,_,ty1,_,_,_,_,_,_,_,_)) ->
match Map.tryFind id1.idText names2 with
| None -> ()
| Some (PrelimValScheme1(_,_,ty2,_,_,_,_,_,_,_,_)) ->
- UnifyTypes cenv env m ty1 ty2);
+ UnifyTypes cenv env m ty1 ty2)
(fun values -> TPat_disjs ([pat1' values;pat2' values],m)), (tpenv,names1,takenNames1)
| SynPat.Ands (pats,m) ->
@@ -4714,15 +4718,20 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
(fun values -> TPat_conjs(List.map (fun f -> f values) pats',m)), acc
| SynPat.LongIdent (LongIdentWithDots(longId,_),_,tyargs,args,vis,m) ->
- if isSome tyargs then errorR(Error(FSComp.SR.tcInvalidTypeArgumentUsage(),m));
- let warnOnUpperForId = if isNil args then warnOnUpper else AllIdsOK
+ if isSome tyargs then errorR(Error(FSComp.SR.tcInvalidTypeArgumentUsage(),m))
+ let warnOnUpperForId =
+ match args with
+ | SynConstructorArgs.Pats [] -> warnOnUpper
+ | _ -> AllIdsOK
begin match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with
| Item.NewDef id ->
match args with
- | [] -> TcPat warnOnUpperForId cenv env topValInfo vFlags (tpenv,names,takenNames) ty (mkSynPatVar vis id)
+ | SynConstructorArgs.Pats []
+ | SynConstructorArgs.NamePatPairs ([], _)-> TcPat warnOnUpperForId cenv env topValInfo vFlags (tpenv,names,takenNames) ty (mkSynPatVar vis id)
| _ -> error (UndefinedName(0,FSComp.SR.undefinedNamePatternDiscriminator,id,[]))
| Item.ActivePatternCase(APElemRef(apinfo,vref,idx)) as item ->
+ let args = match args with SynConstructorArgs.Pats args -> args | _ -> failwith "impossible"
// TOTAL/PARTIAL ACTIVE PATTERNS
let vexp, _, _, tinst, _ = TcVal true cenv env tpenv vref None m
let vexp = MakeApplicableExprWithFlex cenv env vexp
@@ -4742,7 +4751,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
List.frontAndBack args
if nonNil activePatArgsAsSynPats && apinfo.ActiveTags.Length <> 1 then
- error(Error(FSComp.SR.tcRequireActivePatternWithOneResult(),m));
+ error(Error(FSComp.SR.tcRequireActivePatternWithOneResult(),m))
// Parse the arguments to an active pattern
// Note we parse arguments to parameterized pattern labels as patterns, not expressions.
@@ -4754,6 +4763,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.Named (SynPat.Wild _,id,_,None,_) -> SynExpr.Ident(id)
| SynPat.Typed (p,cty,m) -> SynExpr.Typed (convSynPatToSynExpr p,cty,m)
| SynPat.LongIdent (LongIdentWithDots(longId,dotms) as lidwd,_,_tyargs,args,None,m) ->
+ let args = match args with SynConstructorArgs.Pats args -> args | _ -> failwith "impossible: active patterns can be used only with SynConstructorArgs.Pats"
let e =
if dotms.Length = longId.Length then
let e = SynExpr.LongIdent(false,LongIdentWithDots(longId, List.take (dotms.Length - 1) dotms),None,m)
@@ -4774,7 +4784,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
let delayed = activePatArgsAsSynExprs |> List.map (fun arg -> DelayedApp(ExprAtomicFlag.NonAtomic, arg, unionRanges (rangeOfLid longId) arg.Range))
let activePatExpr, tpenv = PropagateThenTcDelayed cenv activePatType env tpenv m vexp vexpty ExprAtomicFlag.NonAtomic delayed
- if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(),m));
+ if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(),m))
let argty = List.nth activePatResTys idx
let arg',(tpenv,names,takenNames) = TcPat warnOnUpper cenv env None vFlags (tpenv,names,takenNames) argty patarg
@@ -4790,9 +4800,42 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| (Item.UnionCase _ | Item.ExnCase _) as item ->
// DATA MATCH CONSTRUTORS
- let mkf,argtys = ApplyUnionCaseOrExnTypesForPat m cenv env ty item
+ let mkf,argtys, argNames = ApplyUnionCaseOrExnTypesForPat m cenv env ty item
let nargtys = argtys.Length
+ let args =
+ match args with
+ | SynConstructorArgs.Pats args -> args
+ | SynConstructorArgs.NamePatPairs (pairs, m) ->
+ // rewrite patterns from the form (name-N = pat-N...) to (..._, pat-N, _...)
+ // so type T = Case of name : int * value : int
+ // | Case(value = v)
+ // will become
+ // | Case(_, v)
+ let result = Array.zeroCreate nargtys
+ for (id, pat) in pairs do
+ match List.tryFindIndex ((=)id.idText) argNames with
+ | None ->
+ let caseName =
+ match item with
+ | Item.UnionCase uci -> uci.Name
+ | Item.ExnCase tcref -> tcref.DisplayName
+ | _ -> failwith "impossible"
+ error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(caseName, id.idText), id.idRange))
+ | Some idx ->
+ match box result.[idx] with
+ | null ->
+ result.[idx] <- pat
+ | _ ->
+ error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange))
+ for i = 0 to nargtys - 1 do
+ if box result.[i] = null then
+ result.[i] <- SynPat.Wild(m.MakeSynthetic())
+
+ let args = List.ofArray result
+ if result.Length = 1 then args
+ else [ SynPat.Tuple(args, m) ]
+
let args =
match args with
| []-> []
@@ -4805,21 +4848,21 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| _ when nargtys = 0 -> error(Error(FSComp.SR.tcUnionCaseDoesNotTakeArguments(),m))
| _ when nargtys = 1 -> error(Error(FSComp.SR.tcUnionCaseRequiresOneArgument(),m))
| _ -> error(Error(FSComp.SR.tcUnionCaseExpectsTupledArguments(nargtys),m))
- UnionCaseOrExnCheck env nargtys args.Length m;
+ UnionCaseOrExnCheck env nargtys args.Length m
let args',acc = TcPatterns warnOnUpper cenv env vFlags (tpenv,names,takenNames) argtys args
(fun values ->
// Report information about the case occurence to IDE
CallNameResolutionSink cenv.tcSink (rangeOfLid longId,env.NameEnv,item,item,ItemOccurence.Pattern,env.DisplayEnv,env.eAccessRights)
- mkf(List.map (fun f -> f values) args')), acc
+ mkf m (List.map (fun f -> f values) args')), acc
| Item.ILField finfo ->
// LITERAL .NET FIELDS
- CheckILFieldInfoAccessible cenv.g cenv.amap m env.eAccessRights finfo;
- if not finfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName),m));
- CheckILFieldAttributes cenv.g finfo m;
+ CheckILFieldInfoAccessible cenv.g cenv.amap m env.eAccessRights finfo
+ if not finfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName),m))
+ CheckILFieldAttributes cenv.g finfo m
match finfo.LiteralValue with
- | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m));
+ | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m))
| Some lit ->
UnifyTypes cenv env m ty (finfo.FieldType(cenv.amap,m))
let c' = TcFieldInit m lit
@@ -4827,23 +4870,23 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| Item.RecdField rfinfo ->
// LITERAL F# FIELDS
- CheckRecdFieldInfoAccessible m env.eAccessRights rfinfo;
- if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name),m));
- CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult;
+ CheckRecdFieldInfoAccessible cenv.amap m env.eAccessRights rfinfo
+ if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name),m))
+ CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult
match rfinfo.LiteralValue with
- | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m));
+ | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m))
| Some lit ->
- UnifyTypes cenv env m ty rfinfo.FieldType;
+ UnifyTypes cenv env m ty rfinfo.FieldType
(fun _ -> TPat_const (lit,m)),(tpenv,names,takenNames)
| Item.Value vref ->
match vref.LiteralValue with
- | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m));
+ | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m))
| Some lit ->
let (_, _, vexpty, _, _) = TcVal true cenv env tpenv vref None m
- CheckValAccessible m env.eAccessRights vref;
- CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult;
- UnifyTypes cenv env m ty vexpty;
+ CheckValAccessible m env.eAccessRights vref
+ CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult
+ UnifyTypes cenv env m ty vexpty
(fun _ -> TPat_const (lit,m)),(tpenv,names,takenNames)
| _ -> error (Error(FSComp.SR.tcRequireVarConstRecogOrLiteral(),m))
@@ -4853,7 +4896,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.Tuple (args,m) ->
let argtys = NewInferenceTypes args
- UnifyTypes cenv env m ty (TType_tuple argtys);
+ UnifyTypes cenv env m ty (TType_tuple argtys)
let args',acc = TcPatterns warnOnUpper cenv env vFlags (tpenv,names,takenNames) argtys args
(fun values -> TPat_tuple(List.map (fun f -> f values) args',argtys,m)), acc
@@ -4862,7 +4905,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
| SynPat.ArrayOrList (isArray,args,m) ->
let argty = NewInferenceType ()
- UnifyTypes cenv env m ty (if isArray then mkArrayType cenv.g argty else Tastops.mkListTy cenv.g argty);
+ UnifyTypes cenv env m ty (if isArray then mkArrayType cenv.g argty else Tastops.mkListTy cenv.g argty)
let args',acc = TcPatterns warnOnUpper cenv env vFlags (tpenv,names,takenNames) (List.map (fun _ -> argty) args) args
(fun values ->
let args' = List.map (fun f -> f values) args'
@@ -4873,7 +4916,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
let tcref,fldsmap,_fldsList = BuildFieldMap cenv env true ty flds m
// REVIEW: use _fldsList to type check pattern in code order not field defn order
let _,inst,tinst,gtyp = infoOfTyconRef m tcref
- UnifyTypes cenv env m ty gtyp;
+ UnifyTypes cenv env m ty gtyp
let fields = tcref.TrueInstanceFieldsAsList
let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp,fsp)
let fldsmap',acc =
@@ -4886,28 +4929,28 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat
acc
| SynPat.DeprecatedCharRange (c1,c2,m) ->
- errorR(Deprecated(FSComp.SR.tcUseWhenPatternGuard(),m));
- UnifyTypes cenv env m ty (cenv.g.char_ty);
+ errorR(Deprecated(FSComp.SR.tcUseWhenPatternGuard(),m))
+ UnifyTypes cenv env m ty (cenv.g.char_ty)
(fun _ -> TPat_range(c1,c2,m)),(tpenv,names,takenNames)
| SynPat.Null m ->
- AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty;
+ AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty
(fun _ -> TPat_null m),(tpenv,names,takenNames)
| SynPat.InstanceMember (_,_,_,_,m) ->
- errorR(Error(FSComp.SR.tcIllegalPattern(),pat.Range));
+ errorR(Error(FSComp.SR.tcIllegalPattern(),pat.Range))
(fun _ -> TPat_wild m), (tpenv,names,takenNames)
| SynPat.FromParseError (pat,_) ->
suppressErrorReporting (fun () -> TcPatAndRecover warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) (NewErrorType()) pat)
and TcPatterns warnOnUpper cenv env vFlags s argtys args =
- assert (List.length args = List.length argtys);
+ assert (List.length args = List.length argtys)
List.mapFold (fun s (ty,pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argtys args)
and solveTypAsError cenv denv m ty =
let ty2 = NewErrorType ()
- assert((destTyparTy cenv.g ty2).IsFromError);
+ assert((destTyparTy cenv.g ty2).IsFromError)
SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv cenv.css m denv) 0 m NoTrace ty ty2 |> ignore
and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr =
@@ -4948,7 +4991,7 @@ and TcExprOfUnknownType cenv env tpenv expr =
and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) =
if flex then
let argty = NewInferenceType ()
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css e.Range NoTrace ty argty ;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css e.Range NoTrace ty argty
let e',tpenv = TcExpr cenv argty env tpenv e
let e' = mkCoerceIfNeeded cenv.g ty argty e'
e',tpenv
@@ -4969,8 +5012,8 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) =
// Error recovery - return some rubbish expression, but replace/annotate
// the type of the current expression with a type variable that indicates an error
- errorRecovery e m;
- solveTypAsError cenv env.DisplayEnv m ty;
+ errorRecovery e m
+ solveTypAsError cenv env.DisplayEnv m ty
mkThrow m ty (mkOne cenv.g m), tpenv
and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) =
@@ -5012,7 +5055,7 @@ and TcStmtThatCantBeCtorBody cenv env tpenv expr =
and TcStmt cenv env tpenv synExpr =
let expr,ty,tpenv = TcExprOfUnknownType cenv env tpenv synExpr
let m = synExpr.Range
- let wasUnit = UnifyUnitType cenv env.DisplayEnv m ty (Some expr);
+ let wasUnit = UnifyUnitType cenv env.DisplayEnv m ty (Some expr)
if wasUnit then
expr,tpenv
else
@@ -5027,7 +5070,7 @@ and TcExprThen cenv overallTy env tpenv synExpr delayed =
match synExpr with
| LongOrSingleIdent (isOpt,longId,altNameRefCellOpt,mLongId) ->
- if isOpt then errorR(Error(FSComp.SR.tcSyntaxErrorUnexpectedQMark(),mLongId));
+ if isOpt then errorR(Error(FSComp.SR.tcSyntaxErrorUnexpectedQMark(),mLongId))
// Check to see if pattern translation decided to use an alternative identifier.
match altNameRefCellOpt with
| Some {contents = Decided altId} -> TcExprThen cenv overallTy env tpenv (SynExpr.LongIdent(isOpt,LongIdentWithDots([altId],[]),None,mLongId)) delayed
@@ -5067,14 +5110,14 @@ and TcExprThen cenv overallTy env tpenv synExpr delayed =
PropagateThenTcDelayed cenv overallTy env tpenv synExpr.Range (MakeApplicableExprNoFlex cenv expr) exprty ExprAtomicFlag.NonAtomic delayed
and TcExprs cenv env m tpenv flexes argtys args =
- if (List.length args <> List.length argtys) then error(Error(FSComp.SR.tcExpressionCountMisMatch((List.length argtys), (List.length args)),m));
+ if (List.length args <> List.length argtys) then error(Error(FSComp.SR.tcExpressionCountMisMatch((List.length argtys), (List.length args)),m))
(tpenv, List.zip3 flexes argtys args) ||> List.mapFold (fun tpenv (flex,ty,e) ->
TcExprFlex cenv flex ty env tpenv e)
and CheckSuperInit cenv objTy m =
// Check the type is not abstract
if isAppTy cenv.g objTy && (let tcref = tcrefOfAppTy cenv.g objTy in isAbstractTycon tcref.Deref) then
- errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(),m));
+ errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(),m))
//-------------------------------------------------------------------------
@@ -5092,18 +5135,18 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
| SynExpr.Paren (expr2,_,_,mWholeExprIncludingParentheses) ->
// We invoke CallExprHasTypeSink for every construct which is atomic in the syntax, i.e. where a '.' immediately following the
// construct is a dot-lookup for the result of the construct.
- CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcExpr cenv overallTy env tpenv expr2
| SynExpr.DotIndexedGet _ | SynExpr.DotIndexedSet _
| SynExpr.TypeApp _ | SynExpr.Ident _ | SynExpr.LongIdent _ | SynExpr.App _ | SynExpr.DotGet _ -> error(Error(FSComp.SR.tcExprUndelayed(), expr.Range))
| SynExpr.Const (SynConst.String (s,m),_) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcConstStringExpr cenv overallTy env m tpenv s
| SynExpr.Const (c,m) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcConstExpr cenv overallTy env m tpenv c
| SynExpr.Lambda _ -> TcIteratedLambdas cenv true env overallTy Set.empty tpenv expr
@@ -5140,16 +5183,16 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
// e : ty
| SynExpr.Typed (e,cty,m) ->
let tgty,tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty
- UnifyTypes cenv env m overallTy tgty;
+ UnifyTypes cenv env m overallTy tgty
let e',tpenv = TcExpr cenv overallTy env tpenv e
e',tpenv
// e :? ty
| SynExpr.TypeTest (e,tgty,m) ->
let e',srcTy,tpenv = TcExprOfUnknownType cenv env tpenv e
- UnifyTypes cenv env m overallTy cenv.g.bool_ty;
+ UnifyTypes cenv env m overallTy cenv.g.bool_ty
let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty
- TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy;
+ TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy
let e' = mkCallTypeTest cenv.g m tgty e'
e', tpenv
@@ -5165,12 +5208,12 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
match expr with
| SynExpr.Upcast (_,tgty,m) ->
let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty
- UnifyTypes cenv env m tgty overallTy;
+ UnifyTypes cenv env m tgty overallTy
tgty,tpenv
| SynExpr.InferredUpcast _ ->
overallTy,tpenv
| _ -> failwith "upcast"
- TcStaticUpcast cenv env.DisplayEnv m tgty srcTy;
+ TcStaticUpcast cenv env.DisplayEnv m tgty srcTy
mkCoerceExpr(e',tgty,m,srcTy),tpenv
| SynExpr.Downcast(e,_,m) | SynExpr.InferredDowncast (e,m) ->
@@ -5179,11 +5222,11 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
match expr with
| SynExpr.Downcast (_,tgty,m) ->
let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty
- UnifyTypes cenv env m tgty overallTy;
+ UnifyTypes cenv env m tgty overallTy
tgty,tpenv
| SynExpr.InferredDowncast _ -> overallTy,tpenv
| _ -> failwith "downcast"
- TcRuntimeTypeTest (*isCast*)true cenv env.DisplayEnv m tgty srcTy;
+ TcRuntimeTypeTest (*isCast*)true cenv env.DisplayEnv m tgty srcTy
// TcRuntimeTypeTest ensures tgty is a nominal type. Hence we can insert a check here
// based on the nullness semantics of the nominal type.
@@ -5191,12 +5234,12 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
e',tpenv
| SynExpr.Null m ->
- AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy;
+ AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy
mkNull m overallTy,tpenv
| SynExpr.Lazy (e,m) ->
let ety = NewInferenceType ()
- UnifyTypes cenv env m overallTy (mkLazyTy cenv.g ety);
+ UnifyTypes cenv env m overallTy (mkLazyTy cenv.g ety)
let e',tpenv = TcExpr cenv ety env tpenv e
mkLazyDelayed cenv.g m ety (mkUnitDelayLambda cenv.g m e'), tpenv
@@ -5208,10 +5251,10 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
mkTupled cenv.g m args' argtys, tpenv
| SynExpr.ArrayOrList (isArray,args,m) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
let argty = NewInferenceType ()
- UnifyTypes cenv env m overallTy (if isArray then mkArrayType cenv.g argty else Tastops.mkListTy cenv.g argty);
+ UnifyTypes cenv env m overallTy (if isArray then mkArrayType cenv.g argty else Tastops.mkListTy cenv.g argty)
// Always allow subsumption if a nominal type is known prior to type checking any arguments
let flex = not (isTyparTy cenv.g argty)
@@ -5224,25 +5267,25 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
| SynExpr.New (superInit,synObjTy,arg,mNewExpr) ->
let objTy,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.Use env tpenv synObjTy
- UnifyTypes cenv env mNewExpr overallTy objTy;
+ UnifyTypes cenv env mNewExpr overallTy objTy
TcNewExpr cenv env tpenv objTy (Some synObjTy.Range) superInit arg mNewExpr
| SynExpr.ObjExpr(objTy,argopt,binds,extraImpls,mNewExpr,m) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcObjectExpr cenv overallTy env tpenv (objTy,argopt,binds,extraImpls,mNewExpr,m)
| SynExpr.Record (inherits, optOrigExpr, flds, mWholeExpr) ->
- CallExprHasTypeSink cenv.tcSink (mWholeExpr,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (mWholeExpr,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcRecdExpr cenv overallTy env tpenv (inherits,optOrigExpr,flds,mWholeExpr)
| SynExpr.While (spWhile,e1,e2,m) ->
- UnifyTypes cenv env m overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env m overallTy cenv.g.unit_ty
let e1',tpenv = TcExpr cenv (cenv.g.bool_ty) env tpenv e1
let e2',tpenv = TcStmt cenv env tpenv e2
mkWhile cenv.g (spWhile,NoSpecialWhileLoopMarker,e1',e2',m),tpenv
| SynExpr.For (spBind,id,start,dir,finish,body,m) ->
- UnifyTypes cenv env m overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env m overallTy cenv.g.unit_ty
let startExpr ,tpenv = TcExpr cenv (cenv.g.int_ty) env tpenv start
let finishExpr,tpenv = TcExpr cenv (cenv.g.int_ty) env tpenv finish
let idv,_ = mkLocal id.idRange id.idText cenv.g.int_ty
@@ -5252,7 +5295,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
| SynExpr.ForEach (spBind, SeqExprOnly seqExprOnly, isFromSource, pat, enumExpr, body, m) ->
assert isFromSource
- if seqExprOnly then warning (Error(FSComp.SR.tcExpressionRequiresSequence(),m));
+ if seqExprOnly then warning (Error(FSComp.SR.tcExpressionRequiresSequence(),m))
TcForEachExpr cenv overallTy env tpenv (pat,enumExpr,body,m,spBind)
| SynExpr.CompExpr (isArrayOrList,isNotNakedRefCell,comp,m) ->
@@ -5260,18 +5303,18 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
if not isArrayOrList then
match comp with
| SynExpr.New _ ->
- errorR(Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm(),m));
+ errorR(Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm(),m))
| SimpleSemicolonSequence false _ ->
- errorR(Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression(),m));
+ errorR(Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression(),m))
| _ ->
()
if not !isNotNakedRefCell && not cenv.g.compilingFslib then
- error(Error(FSComp.SR.tcInvalidSequenceExpressionSyntaxForm(),m));
+ error(Error(FSComp.SR.tcInvalidSequenceExpressionSyntaxForm(),m))
TcComputationOrSequenceExpression cenv env overallTy m None tpenv comp
| SynExpr.ArrayOrListOfSeqExpr (isArray,comp,m) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
match comp with
@@ -5280,7 +5323,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
| SimpleSemicolonSequence false _ ->
()
| _ ->
- errorR(Deprecated(FSComp.SR.tcExpressionWithIfRequiresParenthesis(),m));
+ errorR(Deprecated(FSComp.SR.tcExpressionWithIfRequiresParenthesis(),m))
let replacementExpr =
if isArray then
@@ -5293,17 +5336,17 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
else SynExpr.ArrayOrList(isArray, elems, m)
else
if elems.Length > 500 then
- error(Error(FSComp.SR.tcListLiteralMaxSize(),m));
+ error(Error(FSComp.SR.tcListLiteralMaxSize(),m))
SynExpr.ArrayOrList(isArray, elems, m)
TcExprUndelayed cenv overallTy env tpenv replacementExpr
| _ ->
let genCollElemTy = NewInferenceType ()
let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy
- UnifyTypes cenv env m overallTy genCollTy;
+ UnifyTypes cenv env m overallTy genCollTy
let exprty = NewInferenceType ()
let genEnumTy = mkSeqTy cenv.g genCollElemTy
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genEnumTy exprty;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genEnumTy exprty
let expr,tpenv = TcExpr cenv exprty env tpenv comp
let expr = mkCoerceIfNeeded cenv.g genEnumTy (tyOfExpr cenv.g expr) expr
(if isArray then mkCallSeqToArray else mkCallSeqToList) cenv.g m genCollElemTy
@@ -5368,17 +5411,17 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
// Constructors using "new (...) = <ctor-expr> then <expr>"
let e1',tpenv = TcExprThatCanBeCtorBody cenv overallTy env tpenv e1
if (GetCtorShapeCounter env) <> 1 then
- errorR(Error(FSComp.SR.tcExpressionFormRequiresObjectConstructor(),m));
+ errorR(Error(FSComp.SR.tcExpressionFormRequiresObjectConstructor(),m))
let e2',tpenv = TcStmtThatCantBeCtorBody cenv env tpenv e2
Expr.Sequential(e1',e2',ThenDoSeq,sp,m),tpenv
| SynExpr.Do (e1,m) ->
- UnifyTypes cenv env m overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env m overallTy cenv.g.unit_ty
TcStmtThatCantBeCtorBody cenv env tpenv e1
| SynExpr.IfThenElse (e1,e2,e3opt,spIfToThen,isRecovery,mIfToThen,m) ->
let e1',tpenv = TcExprThatCantBeCtorBody cenv cenv.g.bool_ty env tpenv e1
- (if isNone e3opt && not isRecovery then UnifyTypes cenv env m overallTy cenv.g.unit_ty);
+ (if isNone e3opt && not isRecovery then UnifyTypes cenv env m overallTy cenv.g.unit_ty)
let e2',tpenv = TcExprThatCanBeCtorBody cenv overallTy env tpenv e2
let e3',sp2,tpenv =
match e3opt with
@@ -5440,12 +5483,12 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
let returnTy = GetFSharpViewOfReturnType cenv.g returnTy
let args,namedCallerArgs = GetMethodArgs arg
- if nonNil namedCallerArgs then errorR(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInMemberTraits(),m));
+ if nonNil namedCallerArgs then errorR(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInMemberTraits(),m))
// Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type
let flexes = argtys |> List.map (isTyparTy cenv.g >> not)
let args',tpenv = TcExprs cenv env m tpenv flexes argtys args
- AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo;
- UnifyTypes cenv env m overallTy returnTy;
+ AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo
+ UnifyTypes cenv env m overallTy returnTy
Expr.Op(TOp.TraitCall(traitInfo), [], args', m), tpenv
| SynExpr.LibraryOnlyUnionCaseFieldGet (e1,c,n,m) ->
@@ -5453,18 +5496,18 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
let mkf,ty2 = TcUnionCaseOrExnField cenv env ty1 m c n
((fun (a,b) n -> mkUnionCaseFieldGetUnproven(e1',a,b,n,m)),
(fun a n -> mkExnCaseFieldGet(e1',a,n,m)))
- UnifyTypes cenv env m overallTy ty2;
+ UnifyTypes cenv env m overallTy ty2
mkf n,tpenv
| SynExpr.LibraryOnlyUnionCaseFieldSet (e1,c,n,e2,m) ->
- UnifyTypes cenv env m overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env m overallTy cenv.g.unit_ty
let e1',ty1,tpenv = TcExprOfUnknownType cenv env tpenv e1
let mkf,ty2 = TcUnionCaseOrExnField cenv env ty1 m c n
((fun (a,b) n e2' ->
- if not (isUnionCaseFieldMutable cenv.g a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(),m));
+ if not (isUnionCaseFieldMutable cenv.g a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(),m))
mkUnionCaseFieldSet(e1',a,b,n,e2',m)),
(fun a n e2' ->
- if not (isExnFieldMutable a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(),m));
+ if not (isExnFieldMutable a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(),m))
mkExnCaseFieldSet(e1',a,n,e2',m)))
let e2',tpenv = TcExpr cenv ty2 env tpenv e2
mkf n e2',tpenv
@@ -5481,11 +5524,11 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) =
| [] -> cenv.g.unit_ty
| [ returnTy ] -> returnTy
| _ -> error(InternalError("Only zero or one pushed items are permitted in IL assembly code",m))
- UnifyTypes cenv env m overallTy returnTy;
+ UnifyTypes cenv env m overallTy returnTy
mkAsmExpr(Array.toList s,tyargs',args',rtys',m),tpenv
| SynExpr.Quote(oper,raw,ast,isFromQueryExpression,m) ->
- CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (m,env.NameEnv,overallTy, env.DisplayEnv,env.eAccessRights)
TcQuotationExpr cenv overallTy env tpenv (oper,raw,ast,isFromQueryExpression,m)
| SynExpr.YieldOrReturn ((isTrueYield,_),_,m)
@@ -5535,7 +5578,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg
// has a member called 'Item'
let propName =
match indexArgs with
- | [_] ->
+ | [SynIndexerArg.One _] ->
FoldPrimaryHierarchyOfType (fun typ acc ->
match acc with
| None ->
@@ -5545,7 +5588,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg
TryFindTyconRefStringAttribute cenv.g mWholeExpr cenv.g.attrib_DefaultMemberAttribute tcref
else
- match AllPropInfosOfTypeInScope cenv.infoReader env.NameEnv.eExtensionMembers (Some("Item"), ad) IgnoreOverrides mWholeExpr typ with
+ match AllPropInfosOfTypeInScope cenv.infoReader env.NameEnv (Some("Item"), ad) IgnoreOverrides mWholeExpr typ with
| [] -> None
| _ -> Some "Item"
| _ -> acc)
@@ -5563,46 +5606,59 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg
let isString = typeEquiv cenv.g cenv.g.string_ty e1ty
let idxRange = indexArgs |> List.map (fun e -> e.Range) |> List.reduce unionRanges
+ let GetIndexArgs (es: SynIndexerArg list) = [ for e in es do yield! e.Exprs ]
let MakeIndexParam vopt =
- match indexArgs @ Option.toList vopt with
+ match indexArgs with
| [] -> failwith "unexpected empty index list"
- | [h] -> SynExpr.Paren(h,range0,None,idxRange)
- | es -> SynExpr.Paren(SynExpr.Tuple(es,[],idxRange),range0,None,idxRange)
-
- if isArray || isString then
-
- let indexOpPath = ["Microsoft";"FSharp";"Core";"LanguagePrimitives";"IntrinsicFunctions"]
- let sliceOpPath = ["Microsoft";"FSharp";"Core";"Operators";"OperatorIntrinsics"]
- let path,fnm,indexArgs =
- match isString,isArray,wholeExpr with
- | false,true,SynExpr.DotIndexedGet(_,[SynExpr.Tuple ([_;_] as idxs,_,_)],_,_) -> indexOpPath,"GetArray2D", idxs
- | false,true,SynExpr.DotIndexedGet(_,[SynExpr.Tuple ([_;_;_] as idxs,_,_)],_,_) -> indexOpPath,"GetArray3D", idxs
- | false,true,SynExpr.DotIndexedGet(_,[SynExpr.Tuple ([_;_;_;_] as idxs,_,_)],_,_) -> indexOpPath,"GetArray4D", idxs
- | false,true,SynExpr.DotIndexedGet(_,[_],_,_) -> indexOpPath,"GetArray", indexArgs
- | false,true,SynExpr.DotIndexedSet(_,[SynExpr.Tuple ([_;_] as idxs,_,_)] ,e3,_,_,_) -> indexOpPath,"SetArray2D", (idxs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[SynExpr.Tuple ([_;_;_] as idxs,_,_)] ,e3,_,_,_) -> indexOpPath,"SetArray3D", (idxs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[SynExpr.Tuple ([_;_;_;_] as idxs,_,_)] ,e3,_,_,_) -> indexOpPath,"SetArray4D", (idxs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[_],e3,_,_,_) -> indexOpPath,"SetArray", (indexArgs @ [e3])
- | true,false,SynExpr.DotIndexedGet(_,[_;_],_,_) -> sliceOpPath,"GetStringSlice", indexArgs
- | true,false,SynExpr.DotIndexedGet(_,[_],_,_) -> indexOpPath,"GetString", indexArgs
- | false,true,SynExpr.DotIndexedGet(_,[_;_],_,_) -> sliceOpPath,"GetArraySlice", indexArgs
- | false,true,SynExpr.DotIndexedGet(_,[_;_;_;_],_,_) -> sliceOpPath,"GetArraySlice2D", indexArgs
- | false,true,SynExpr.DotIndexedGet(_,[_;_;_;_;_;_],_,_) -> sliceOpPath,"GetArraySlice3D", indexArgs
- | false,true,SynExpr.DotIndexedGet(_,[_;_;_;_;_;_;_;_],_,_) -> sliceOpPath,"GetArraySlice4D", indexArgs
- | false,true,SynExpr.DotIndexedSet(_,[_;_],e3,_,_,_) -> sliceOpPath,"SetArraySlice", (indexArgs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[_;_;_;_],e3,_,_,_) -> sliceOpPath,"SetArraySlice2D", (indexArgs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[_;_;_;_;_;_],e3,_,_,_) -> sliceOpPath,"SetArraySlice3D", (indexArgs @ [e3])
- | false,true,SynExpr.DotIndexedSet(_,[_;_;_;_;_;_;_;_],e3,_,_,_) -> sliceOpPath,"SetArraySlice4D", (indexArgs @ [e3])
- | _ -> error(Error(FSComp.SR.tcInvalidIndexerExpression(),mWholeExpr))
- let operPath = (mkSynLidGet mDot path (CompileOpName fnm))
- let f,fty,tpenv = TcExprOfUnknownType cenv env tpenv operPath
- let domainTy,resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty
- UnifyTypes cenv env mWholeExpr domainTy e1ty;
- let f' = buildApp cenv (MakeApplicableExprNoFlex cenv f) fty e1' mWholeExpr
- let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic,idx,mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz
- PropagateThenTcDelayed cenv overallTy env tpenv mWholeExpr f' resultTy ExprAtomicFlag.Atomic delayed
-
- elif (isNominal || isSome propName) then
+ | [SynIndexerArg.One h] -> SynExpr.Paren(h,range0,None,idxRange)
+ | _ -> SynExpr.Paren(SynExpr.Tuple(GetIndexArgs indexArgs @ Option.toList vopt,[],idxRange),range0,None,idxRange)
+
+ let attemptArrayString =
+ if isArray || isString then
+
+ let indexOpPath = ["Microsoft";"FSharp";"Core";"LanguagePrimitives";"IntrinsicFunctions"]
+ let sliceOpPath = ["Microsoft";"FSharp";"Core";"Operators";"OperatorIntrinsics"]
+ let info =
+ match isString,isArray,wholeExpr with
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_] as idxs,_,_))],_,_) -> Some (indexOpPath,"GetArray2D", idxs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_;_] as idxs,_,_))],_,_) -> Some (indexOpPath,"GetArray3D", idxs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_;_;_] as idxs,_,_))],_,_) -> Some (indexOpPath,"GetArray4D", idxs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.One idx],_,_) -> Some (indexOpPath,"GetArray", [idx])
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_] as idxs,_,_))] ,e3,_,_,_) -> Some (indexOpPath,"SetArray2D", (idxs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_;_] as idxs,_,_))] ,e3,_,_,_) -> Some (indexOpPath,"SetArray3D", (idxs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.One(SynExpr.Tuple ([_;_;_;_] as idxs,_,_))] ,e3,_,_,_) -> Some (indexOpPath,"SetArray4D", (idxs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.One _],e3,_,_,_) -> Some (indexOpPath,"SetArray", (GetIndexArgs indexArgs @ [e3]))
+ | true,false,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetStringSlice", GetIndexArgs indexArgs)
+ | true,false,SynExpr.DotIndexedGet(_,[SynIndexerArg.One _],_,_) -> Some (indexOpPath,"GetString", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetArraySlice", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.One _;SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetArraySlice2DFixed1", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _;SynIndexerArg.One _],_,_) -> Some (sliceOpPath,"GetArraySlice2DFixed2", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetArraySlice2D", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetArraySlice3D", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedGet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _],_,_) -> Some (sliceOpPath,"GetArraySlice4D", GetIndexArgs indexArgs)
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.Two _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice", (GetIndexArgs indexArgs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice2D", (GetIndexArgs indexArgs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.One _;SynIndexerArg.Two _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice2DFixed1", (GetIndexArgs indexArgs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.Two _;SynIndexerArg.One _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice2DFixed2", (GetIndexArgs indexArgs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice3D", (GetIndexArgs indexArgs @ [e3]))
+ | false,true,SynExpr.DotIndexedSet(_,[SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _;SynIndexerArg.Two _],e3,_,_,_) -> Some (sliceOpPath,"SetArraySlice4D", (GetIndexArgs indexArgs @ [e3]))
+ | _ -> None // error(Error(FSComp.SR.tcInvalidIndexerExpression(),mWholeExpr))
+ match info with
+ | None -> None
+ | Some (path,functionName,indexArgs) ->
+ let operPath = mkSynLidGet mDot path (CompileOpName functionName)
+ let f,fty,tpenv = TcExprOfUnknownType cenv env tpenv operPath
+ let domainTy,resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty
+ UnifyTypes cenv env mWholeExpr domainTy e1ty
+ let f' = buildApp cenv (MakeApplicableExprNoFlex cenv f) fty e1' mWholeExpr
+ let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic,idx,mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz
+ Some (PropagateThenTcDelayed cenv overallTy env tpenv mWholeExpr f' resultTy ExprAtomicFlag.Atomic delayed )
+ else None
+
+ match attemptArrayString with
+ | Some res -> res
+ | None ->
+ if (isNominal || isSome propName) then
let nm =
match propName with
@@ -5624,7 +5680,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg
else
// deprecated constrained lookup
- error(Error(FSComp.SR.tcObjectOfIndeterminateTypeUsedRequireTypeConstraint(),mWholeExpr));
+ error(Error(FSComp.SR.tcObjectOfIndeterminateTypeUsedRequireTypeConstraint(),mWholeExpr))
/// Check a 'new Type(args)' expression, also an 'inheritedTys declaration in an implicit or explicit class
@@ -5635,8 +5691,8 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy =
let ad = env.eAccessRights
// Handle the case 'new 'a()'
if (isTyparTy cenv.g objTy) then
- if superInit then error(Error(FSComp.SR.tcCannotInheritFromVariableType(),mWholeExprOrObjTy));
- AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy NoTrace objTy;
+ if superInit then error(Error(FSComp.SR.tcCannotInheritFromVariableType(),mWholeExprOrObjTy))
+ AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy NoTrace objTy
match arg with
| SynExpr.Const (SynConst.Unit,_) -> ()
@@ -5644,7 +5700,7 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy =
mkCallCreateInstance cenv.g mWholeExprOrObjTy objTy ,tpenv
else
- if not (isAppTy cenv.g objTy) then error(Error(FSComp.SR.tcNamedTypeRequired(if superInit then "inherit" else "new"),mWholeExprOrObjTy));
+ if not (isAppTy cenv.g objTy) then error(Error(FSComp.SR.tcNamedTypeRequired(if superInit then "inherit" else "new"),mWholeExprOrObjTy))
let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mWholeExprOrObjTy ad objTy)
TcCtorCall false cenv env tpenv objTy objTy mObjTyOpt item superInit arg mWholeExprOrObjTy [] None
@@ -5656,13 +5712,13 @@ and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit a
let mItem = match mObjTyOpt with Some m -> m | None -> mWholeCall
if isInterfaceTy cenv.g objTy then
- error(Error((if superInit then FSComp.SR.tcInheritCannotBeUsedOnInterfaceType() else FSComp.SR.tcNewCannotBeUsedOnInterfaceType()),mWholeCall));
+ error(Error((if superInit then FSComp.SR.tcInheritCannotBeUsedOnInterfaceType() else FSComp.SR.tcNewCannotBeUsedOnInterfaceType()),mWholeCall))
match item with
| Item.CtorGroup(methodName,minfos) ->
let meths = List.map (fun minfo -> minfo,None) minfos
if isNaked && TypeFeasiblySubsumesType 0 cenv.g cenv.amap mWholeCall cenv.g.system_IDisposable_typ NoCoerce objTy then
- warning(Error(FSComp.SR.tcIDisposableTypeShouldUseNew(),mWholeCall));
+ warning(Error(FSComp.SR.tcIDisposableTypeShouldUseNew(),mWholeCall))
// Check the type is not abstract
// skip this check if this ctor call is either 'inherit(...)' or call is located within constructor shape
@@ -5697,11 +5753,11 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m =
let tcref = tcrefOfAppTy cenv.g objTy
let tycon = tcref.Deref
let tinst = argsOfAppTy cenv.g objTy
- UnifyTypes cenv env m overallTy objTy;
+ UnifyTypes cenv env m overallTy objTy
// Types with implicit constructors can't use record or object syntax: all constructions must go through the implicit constructor
if tycon.MembersOfFSharpTyconByName |> NameMultiMap.existsInRange (fun v -> v.IsIncrClassConstructor) then
- errorR(Error(FSComp.SR.tcConstructorRequiresCall(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcConstructorRequiresCall(tycon.DisplayName),m))
let fspecs = tycon.TrueInstanceFieldsAsList
// Freshen types and work out their subtype flexibility
@@ -5743,7 +5799,7 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m =
// Check all fields are bound
fspecs |> List.iter (fun fspec ->
if not (fldsList |> List.exists (fun (fname,_) -> fname = fspec.Name)) then
- error(Error(FSComp.SR.tcFieldRequiresAssignment(fspec.rfield_id.idText, fullDisplayTextOfTyconRef tcref),m)));
+ error(Error(FSComp.SR.tcFieldRequiresAssignment(fspec.rfield_id.idText, fullDisplayTextOfTyconRef tcref),m)))
// Other checks (overlap with above check now clear)
let ns1 = NameSet.ofList (List.map fst fldsList)
@@ -5761,8 +5817,8 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m =
// Check accessibility: this is also done in BuildFieldMap, but also need to check
// for fields in { new R with a=1 and b=2 } constructions and { r with a=1 } copy-and-update expressions
rfrefs |> List.iter (fun rfref ->
- CheckRecdFieldAccessible m env.eAccessRights rfref |> ignore;
- CheckFSharpAttributes cenv.g rfref.PropertyAttribs m |> CommitOperationResult);
+ CheckRecdFieldAccessible cenv.amap m env.eAccessRights rfref |> ignore
+ CheckFSharpAttributes cenv.g rfref.PropertyAttribs m |> CommitOperationResult)
let args = List.map snd fldsList
@@ -5810,7 +5866,7 @@ and GetNameAndArityOfObjExprBinding _cenv _env b =
let retInfo = SynInfo.unnamedRetVal //SynInfo.InferSynReturnData pushedRetInfoOpt
let valSynData = SynValInfo(argInfos,retInfo)
(id.idText,valSynData)
- | _ -> error(Error(FSComp.SR.tcObjectExpressionsCanOnlyOverrideAbstractOrVirtual(),mBinding));
+ | _ -> error(Error(FSComp.SR.tcObjectExpressionsCanOnlyOverrideAbstractOrVirtual(),mBinding))
lookPat pat
@@ -5822,9 +5878,9 @@ and FreshenObjExprAbstractSlot cenv (_env: TcEnv) implty virtNameAndArityPairs (
let absSlotsByName = List.filter (fst >> fst >> (=) bindName) virtNameAndArityPairs
match absSlotsByName with
- | [] -> errorR(Error(FSComp.SR.tcNoAbstractOrVirtualMemberFound(bindName),mBinding));
- | [(_,absSlot:MethInfo)] -> errorR(Error(FSComp.SR.tcArgumentArityMismatch(bindName, (List.sum absSlot.NumArgs)),mBinding));
- | (_,absSlot:MethInfo) :: _ -> errorR(Error(FSComp.SR.tcArgumentArityMismatchOneOverload(bindName, (List.sum absSlot.NumArgs)),mBinding));
+ | [] -> errorR(Error(FSComp.SR.tcNoAbstractOrVirtualMemberFound(bindName),mBinding))
+ | [(_,absSlot:MethInfo)] -> errorR(Error(FSComp.SR.tcArgumentArityMismatch(bindName, (List.sum absSlot.NumArgs)),mBinding))
+ | (_,absSlot:MethInfo) :: _ -> errorR(Error(FSComp.SR.tcArgumentArityMismatchOneOverload(bindName, (List.sum absSlot.NumArgs)),mBinding))
None
@@ -5838,9 +5894,7 @@ and FreshenObjExprAbstractSlot cenv (_env: TcEnv) implty virtNameAndArityPairs (
Some(typarsFromAbsSlotAreRigid,typarsFromAbsSlot,bindingTy)
- | _ -> //(_,absSlot1) :: (_,absSlot2) :: _ ->
- //warning(NonUniqueInferredAbstractSlot(cenv.g,env.DisplayEnv, bindName, absSlot1, absSlot2,mBinding));
- //fail()
+ | _ ->
None
@@ -5860,7 +5914,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) =
bindingRhs,logicalMethId,memberFlags
| SynPat.InstanceMember(thisId,memberId,_,_,_),Some memberFlags ->
- CheckMemberFlags cenv.g None NewSlotsOK OverridesOK memberFlags mBinding;
+ CheckMemberFlags cenv.g None NewSlotsOK OverridesOK memberFlags mBinding
let bindingRhs = PushOnePatternToRhs cenv true (mkSynThisPatVar thisId) bindingRhs
let logicalMethId = ident (ComputeLogicalName memberId memberFlags,memberId.idRange)
bindingRhs,logicalMethId,memberFlags
@@ -5894,7 +5948,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) =
| _ ->
declaredTypars
// Canonicalize constraints prior to generalization
- GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,m) declaredTypars;
+ GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,m) declaredTypars
let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env
@@ -5976,7 +6030,7 @@ and CheckSuperType cenv typ m =
typeEquiv cenv.g typ cenv.g.system_Array_typ ||
typeEquiv cenv.g typ cenv.g.system_MulticastDelegate_typ ||
typeEquiv cenv.g typ cenv.g.system_Delegate_typ then
- error(Error(FSComp.SR.tcPredefinedTypeCannotBeUsedAsSuperType(),m));
+ error(Error(FSComp.SR.tcPredefinedTypeCannotBeUsedAsSuperType(),m))
if isErasedType cenv.g typ then
errorR(Error(FSComp.SR.tcCannotInheritFromErasedType(),m))
@@ -5985,13 +6039,13 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew
let mObjTy = synObjTy.Range
let objTy,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synObjTy
- if not (isAppTy cenv.g objTy) then error(Error(FSComp.SR.tcNewMustBeUsedWithNamedType(),mNewExpr));
- if not (isRecdTy cenv.g objTy) && not (isInterfaceTy cenv.g objTy) && isSealedTy cenv.g objTy then errorR(Error(FSComp.SR.tcCannotCreateExtensionOfSealedType(),mNewExpr));
+ if not (isAppTy cenv.g objTy) then error(Error(FSComp.SR.tcNewMustBeUsedWithNamedType(),mNewExpr))
+ if not (isRecdTy cenv.g objTy) && not (isInterfaceTy cenv.g objTy) && isSealedTy cenv.g objTy then errorR(Error(FSComp.SR.tcCannotCreateExtensionOfSealedType(),mNewExpr))
- CheckSuperType cenv objTy synObjTy.Range;
+ CheckSuperType cenv objTy synObjTy.Range
// Add the object type to the ungeneralizable items
- let env = {env with eUngeneralizableItems = addFreeItemOfTy objTy env.eUngeneralizableItems; }
+ let env = {env with eUngeneralizableItems = addFreeItemOfTy objTy env.eUngeneralizableItems }
// Object expression members can access protected members of the implemented type
let env = EnterFamilyRegion (tcrefOfAppTy cenv.g objTy) env
@@ -6002,10 +6056,10 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew
// object construction?
(isFSharpObjModelTy cenv.g objTy && not (isInterfaceTy cenv.g objTy) && isNone argopt) then
- if isSome argopt then error(Error(FSComp.SR.tcNoArgumentsForRecordValue(),mWholeExpr));
- if nonNil extraImpls then error(Error(FSComp.SR.tcNoInterfaceImplementationForConstructionExpression(),mNewExpr));
+ if isSome argopt then error(Error(FSComp.SR.tcNoArgumentsForRecordValue(),mWholeExpr))
+ if nonNil extraImpls then error(Error(FSComp.SR.tcNoInterfaceImplementationForConstructionExpression(),mNewExpr))
if isFSharpObjModelTy cenv.g objTy && GetCtorShapeCounter env <> 1 then
- error(Error(FSComp.SR.tcObjectConstructionCanOnlyBeUsedInClassTypes(),mNewExpr));
+ error(Error(FSComp.SR.tcObjectConstructionCanOnlyBeUsedInClassTypes(),mNewExpr))
let fldsList =
binds |> List.map (fun b ->
match BindingNormalization.NormalizeBinding ObjExprBinding cenv env b with
@@ -6017,20 +6071,20 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew
let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mObjTy ad objTy)
if isFSharpObjModelTy cenv.g objTy && GetCtorShapeCounter env = 1 then
- error(Error(FSComp.SR.tcObjectsMustBeInitializedWithObjectExpression(),mNewExpr));
+ error(Error(FSComp.SR.tcObjectsMustBeInitializedWithObjectExpression(),mNewExpr))
// Work out the type of any interfaces to implement
let extraImpls,tpenv =
(tpenv , extraImpls) ||> List.mapFold (fun tpenv (InterfaceImpl(synIntfTy,overrides,m)) ->
let intfTy,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synIntfTy
if not (isInterfaceTy cenv.g intfTy) then
- error(Error(FSComp.SR.tcExpectedInterfaceType(),m));
+ error(Error(FSComp.SR.tcExpectedInterfaceType(),m))
if isErasedType cenv.g intfTy then
errorR(Error(FSComp.SR.tcCannotInheritFromErasedType(),m))
(m,intfTy,overrides),tpenv)
let realObjTy = (if isObjTy cenv.g objTy && nonNil extraImpls then (p23 (List.head extraImpls)) else objTy)
- UnifyTypes cenv env mWholeExpr overallTy realObjTy;
+ UnifyTypes cenv env mWholeExpr overallTy realObjTy
let ctorCall,baseIdOpt,tpenv =
match item,argopt with
@@ -6044,13 +6098,13 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew
let baseIdOpt = (match baseIdOpt with None -> Some(ident("base",mObjTy)) | Some id -> Some(id))
expr,baseIdOpt,tpenv
| Item.FakeInterfaceCtor intfTy,None ->
- UnifyTypes cenv env mWholeExpr objTy intfTy;
+ UnifyTypes cenv env mWholeExpr objTy intfTy
let expr = BuildObjCtorCall cenv.g mWholeExpr
expr,None,tpenv
| Item.FakeInterfaceCtor _,Some _ ->
- error(Error(FSComp.SR.tcConstructorForInterfacesDoNotTakeArguments(),mNewExpr));
+ error(Error(FSComp.SR.tcConstructorForInterfacesDoNotTakeArguments(),mNewExpr))
| Item.CtorGroup _,None ->
- error(Error(FSComp.SR.tcConstructorRequiresArguments(),mNewExpr));
+ error(Error(FSComp.SR.tcConstructorRequiresArguments(),mNewExpr))
| _ -> error(Error(FSComp.SR.tcNewRequiresObjectConstructor(),mNewExpr))
let baseValOpt = MakeAndPublishBaseVal cenv env baseIdOpt objTy
@@ -6068,9 +6122,9 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew
overridesAndVirts |> List.iter (fun (m,implty,dispatchSlots,dispatchSlotsKeyed,availPriorOverrides,overrides) ->
let overrideSpecs = overrides |> List.map fst
- DispatchSlotChecking.CheckOverridesAreAllUsedOnce env.DisplayEnv cenv.g cenv.amap (true, implty, dispatchSlotsKeyed, availPriorOverrides, overrideSpecs);
+ DispatchSlotChecking.CheckOverridesAreAllUsedOnce (env.DisplayEnv, cenv.g, cenv.amap, true, implty, dispatchSlotsKeyed, availPriorOverrides, overrideSpecs)
- DispatchSlotChecking.CheckDispatchSlotsAreImplemented (env.DisplayEnv,cenv.g,cenv.amap,m,false,implty,dispatchSlots,availPriorOverrides,overrideSpecs) |> ignore);
+ DispatchSlotChecking.CheckDispatchSlotsAreImplemented (env.DisplayEnv, cenv.g, cenv.amap, m, false, implty, dispatchSlots, availPriorOverrides, overrideSpecs) |> ignore)
// 6c. create the specs of overrides
let allTypeImpls =
@@ -6125,11 +6179,11 @@ and TcConstStringExpr cenv overallTy env m tpenv s =
if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then
// Parse the format string to work out the phantom types
let aty',ety' = (try Formats.ParseFormatString m cenv.g s bty cty dty with Failure s -> error (Error(FSComp.SR.tcUnableToParseFormatString(s),m)))
- UnifyTypes cenv env m aty aty';
- UnifyTypes cenv env m ety ety';
+ UnifyTypes cenv env m aty aty'
+ UnifyTypes cenv env m ety ety'
mkCallNewFormat cenv.g m aty bty cty dty ety (mkString cenv.g m s),tpenv
else
- UnifyTypes cenv env m overallTy cenv.g.string_ty;
+ UnifyTypes cenv env m overallTy cenv.g.string_ty
mkString cenv.g m s,tpenv
//-------------------------------------------------------------------------
@@ -6142,7 +6196,7 @@ and TcConstExpr cenv overallTy env m tpenv c =
// NOTE: these aren't "really" constants
| SynConst.Bytes (bytes,m) ->
- UnifyTypes cenv env m overallTy (mkByteArrayTy cenv.g);
+ UnifyTypes cenv env m overallTy (mkByteArrayTy cenv.g)
Expr.Op(TOp.Bytes bytes,[],[],m),tpenv
| SynConst.UInt16s arr ->
@@ -6152,7 +6206,7 @@ and TcConstExpr cenv overallTy env m tpenv c =
let expr =
let modName = ("NumericLiteral"^suffix)
let ad = env.eAccessRights
- match ResolveLongIndentAsModuleOrNamespace OpenQualified env.eNameResEnv ad [ident (modName,m)] with
+ match ResolveLongIndentAsModuleOrNamespace cenv.amap m OpenQualified env.eNameResEnv ad [ident (modName,m)] with
| Result []
| Exception _ -> error(Error(FSComp.SR.tcNumericLiteralRequiresModule(modName),m))
| Result ((_,mref,_) :: _) ->
@@ -6210,7 +6264,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
| None -> None, tpenv
| Some (e, _) ->
match inherits with
- | Some (_,_,mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(),mInherits));
+ | Some (_,_,mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(),mInherits))
| None ->
let e',tpenv = TcExpr cenv overallTy env tpenv e
let v',ve' = mkCompGenLocal mWholeExpr "inputRecord" overallTy
@@ -6233,18 +6287,18 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
| _ ->
let tcref,_,fldsList = BuildFieldMap cenv env (isSome optOrigExpr) overallTy flds mWholeExpr
let _,_,_,gtyp = infoOfTyconRef mWholeExpr tcref
- UnifyTypes cenv env mWholeExpr overallTy gtyp;
+ UnifyTypes cenv env mWholeExpr overallTy gtyp
fldsList
if isSome optOrigExpr && not (isRecdTy cenv.g overallTy) then
- errorR(Error(FSComp.SR.tcExpressionFormRequiresRecordTypes(),mWholeExpr));
+ errorR(Error(FSComp.SR.tcExpressionFormRequiresRecordTypes(),mWholeExpr))
if requiresCtor || haveCtor then
if not (isFSharpObjModelTy cenv.g overallTy) then
// Deliberate no-recovery failure here to prevent cascading internal errors
- error(Error(FSComp.SR.tcInheritedTypeIsNotObjectModelType(),mWholeExpr));
+ error(Error(FSComp.SR.tcInheritedTypeIsNotObjectModelType(),mWholeExpr))
if not requiresCtor then
- errorR(Error(FSComp.SR.tcObjectConstructionExpressionCanOnlyImplementConstructorsInObjectModelTypes(),mWholeExpr));
+ errorR(Error(FSComp.SR.tcObjectConstructionExpressionCanOnlyImplementConstructorsInObjectModelTypes(),mWholeExpr))
else
if isNil flds then
let errorInfo =
@@ -6253,7 +6307,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
error(Error(errorInfo,mWholeExpr))
if isFSharpObjModelTy cenv.g overallTy then errorR(Error(FSComp.SR.tcTypeIsNotARecordTypeNeedConstructor(),mWholeExpr))
- elif not (isRecdTy cenv.g overallTy) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(),mWholeExpr));
+ elif not (isRecdTy cenv.g overallTy) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(),mWholeExpr))
let superTy,tpenv =
match inherits, GetSuperTypeOfType cenv.g cenv.amap mWholeExpr overallTy with
@@ -6268,7 +6322,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
| None,_ ->
None,tpenv
| _, None ->
- errorR(InternalError("Unexpected failure in getting super type",mWholeExpr));
+ errorR(InternalError("Unexpected failure in getting super type",mWholeExpr))
None,tpenv
let expr,tpenv =
@@ -6288,7 +6342,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
//-------------------------------------------------------------------------
and TcForEachExpr cenv overallTy env tpenv (pat,enumSynExpr,body,m,spForLoop) =
- UnifyTypes cenv env m overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env m overallTy cenv.g.unit_ty
let enumExpr,enumExprTy,tpenv =
TcExprOfUnknownType cenv env tpenv enumSynExpr
@@ -6380,7 +6434,7 @@ and TcQuotationExpr cenv overallTy env tpenv (_oper,raw,ast,isFromQueryExpressio
let astTy = NewInferenceType ()
// Assert the overall type for the domain of the quotation template
- UnifyTypes cenv env m overallTy (if raw then mkRawQuotedExprTy cenv.g else mkQuotedExprTy cenv.g astTy);
+ UnifyTypes cenv env m overallTy (if raw then mkRawQuotedExprTy cenv.g else mkQuotedExprTy cenv.g astTy)
// Check the expression
let expr,tpenv = TcExpr cenv astTy env tpenv ast
@@ -6452,7 +6506,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv
| _ -> true
let customOperationMethods =
- AllMethInfosOfTypeInScope cenv.infoReader env.NameEnv.eExtensionMembers (None,ad) IgnoreOverrides mBuilderVal builderTy
+ AllMethInfosOfTypeInScope cenv.infoReader env.NameEnv (None,ad) IgnoreOverrides mBuilderVal builderTy
|> List.filter (IsMethInfoAccessible cenv.amap mBuilderVal ad)
|> List.choose (fun methInfo ->
let nameSearch =
@@ -6912,17 +6966,17 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv
let mkJoinExpr keySelector1 keySelector2 innerPat e =
let mSynthetic = mOpCore.MakeSynthetic()
mkSynCall methInfo.DisplayName mOpCore
- [ firstSource;
- secondSource;
- (mkSynLambda firstSourceSimplePats keySelector1 mSynthetic);
- (mkSynLambda secondSourceSimplePats keySelector2 mSynthetic);
+ [ firstSource
+ secondSource
+ (mkSynLambda firstSourceSimplePats keySelector1 mSynthetic)
+ (mkSynLambda secondSourceSimplePats keySelector2 mSynthetic)
(mkSynLambda firstSourceSimplePats (mkSynLambda innerPat e mSynthetic) mSynthetic) ]
let mkZipExpr e =
let mSynthetic = mOpCore.MakeSynthetic()
mkSynCall methInfo.DisplayName mOpCore
- [ firstSource;
- secondSource;
+ [ firstSource
+ secondSource
(mkSynLambda firstSourceSimplePats (mkSynLambda secondSourceSimplePats e mSynthetic) mSynthetic) ]
// wraps given expression into sequence with result produced by arbExpr so result will look like:
@@ -7042,7 +7096,6 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv
let mTry = match spTry with SequencePointAtTry(m) -> m | _ -> mTryToLast
if isQuery then error(Error(FSComp.SR.tcNoTryFinallyInQuery(),mTry))
- if q then error(Error(FSComp.SR.tcTryFinallyMayNotBeUsedWithCustomOperators(),mTry))
if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "TryFinally" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("TryFinally"),mTry))
if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"),mTry))
Some (translatedCtxt (mkSynCall "TryFinally" mTry [mkSynCall "Delay" mTry [mkSynDelay innerComp.Range (transNoQueryOps innerComp)]; mkSynDelay2 unwindExpr]))
@@ -7228,7 +7281,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv
| SynExpr.IfThenElse (guardExpr,thenComp,elseCompOpt,spIfToThen,isRecovery,mIfToThen,mIfToEndOfElseBranch) ->
match elseCompOpt with
| Some elseComp ->
- if isQuery || q then error(Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithCustomOperators(),mIfToThen))
+ if isQuery then error(Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithinQueries(),mIfToThen))
Some (translatedCtxt (SynExpr.IfThenElse(guardExpr, transNoQueryOps thenComp, Some(transNoQueryOps elseComp), spIfToThen,isRecovery,mIfToThen,mIfToEndOfElseBranch)))
| None ->
let elseComp =
@@ -7324,7 +7377,6 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv
let mTry = match spTry with SequencePointAtTry(m) -> m | _ -> mTryToLast
if isQuery then error(Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries(),mTry))
- if q then error(Error(FSComp.SR.tcTryWithMayNotBeUsedWithCustomOperators(),mTry))
let clauses = clauses |> List.map (fun (Clause(pat,cond,clauseComp,patm,sp)) -> Clause(pat,cond,transNoQueryOps clauseComp,patm,sp))
let consumeExpr = SynExpr.MatchLambda(true,mTryToLast,clauses,NoSequencePointAtStickyBinding,mTryToLast)
if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "TryWith" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("TryWith"),mTry))
@@ -7523,7 +7575,7 @@ and TcSequenceExpression cenv env tpenv comp overallTy m =
let bindPatTy = NewInferenceType ()
let inputExprTy = NewInferenceType ()
let pat',_,vspecs,envinner,tpenv = TcMatchPattern cenv bindPatTy env tpenv (pat,None)
- UnifyTypes cenv env m inputExprTy bindPatTy;
+ UnifyTypes cenv env m inputExprTy bindPatTy
let inputExpr,tpenv = TcExpr cenv inputExprTy env tpenv rhsExpr
let innerExpr,tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp
let inputExprMark = inputExpr.Range
@@ -7556,15 +7608,15 @@ and TcSequenceExpression cenv env tpenv comp overallTy m =
| SynExpr.YieldOrReturnFrom((isYield,_),yieldExpr,m) ->
let resultExpr,genExprTy,tpenv = TcExprOfUnknownType cenv env tpenv yieldExpr
- if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(),m)) ;
+ if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(),m))
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy
Some(mkCoerceExpr(resultExpr,genOuterTy,m,genExprTy), tpenv)
| SynExpr.YieldOrReturn((isYield,_),yieldExpr,m) ->
let genResultTy = NewInferenceType ()
- if not isYield then errorR(Error(FSComp.SR.tcSeqResultsUseYield(),m)) ;
- UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy);
+ if not isYield then errorR(Error(FSComp.SR.tcSeqResultsUseYield(),m))
+ UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy)
let resultExpr,tpenv = TcExpr cenv genResultTy env tpenv yieldExpr
Some(mkCallSeqSingleton cenv.g m genResultTy resultExpr, tpenv )
@@ -7582,7 +7634,7 @@ and TcSequenceExpression cenv env tpenv comp overallTy m =
Expr.Sequential(expr,mkSeqEmpty cenv env m genOuterTy,NormalSeq,SuppressSequencePointOnStmtOfSequential,m),tpenv
let genEnumElemTy = NewInferenceType ()
- UnifyTypes cenv env m overallTy (mkSeqTy cenv.g genEnumElemTy);
+ UnifyTypes cenv env m overallTy (mkSeqTy cenv.g genEnumElemTy)
let coreExpr,tpenv = tcSequenceExprBody env overallTy tpenv comp
let delayedExpr = mkDelayedExpr coreExpr
@@ -7640,7 +7692,7 @@ and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag:ExprAtomicF
// OK, we've typechecked the thing on the left of the delayed lookup chain.
// We can now record for posterity the type of this expression and the location of the expression.
if (atomicFlag = ExprAtomicFlag.Atomic) then
- CallExprHasTypeSink cenv.tcSink (mExpr,env.NameEnv,exprty, env.DisplayEnv,env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (mExpr,env.NameEnv,exprty, env.DisplayEnv,env.eAccessRights)
match delayed with
| [] -> UnifyTypes cenv env mExpr overallTy exprty; expr.Expr,tpenv
@@ -7722,12 +7774,12 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId,_)) delay
// Also determine if type names should resolve to Item.Types or Item.CtorGroup
match delayed with
| DelayedTypeApp (tyargs, _, _) :: DelayedApp _ :: _ ->
- TypeNameResolutionInfo(ResolveTypeNamesToCtors, TypeNameResolutionStaticArgsInfo.FromTyArgs tyargs)
+ TypeNameResolutionInfo(ResolveTypeNamesToCtors, TypeNameResolutionStaticArgsInfo.FromTyArgs tyargs.Length)
| DelayedTypeApp (tyargs, _, _) :: _ ->
// cases like 'MyType<int>.Sth' but also only 'MyType<int>.'
// (without LValue_get), which is needed for VS (when typing)
- TypeNameResolutionInfo(ResolveTypeNamesToTypeRefs, TypeNameResolutionStaticArgsInfo.FromTyArgs tyargs)
+ TypeNameResolutionInfo(ResolveTypeNamesToTypeRefs, TypeNameResolutionStaticArgsInfo.FromTyArgs tyargs.Length)
| _ ->
TypeNameResolutionInfo.Default
@@ -7747,14 +7799,14 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
| (Item.UnionCase _ | Item.ExnCase _ | Item.ActivePatternResult _) as item ->
// ucaseAppTy is the type of the union constructor applied to its (optional) argument
let ucaseAppTy = NewInferenceType ()
- let mkConstrApp,argtys =
+ let mkConstrApp,argtys, argNames =
match item with
| Item.ActivePatternResult(apinfo, _, n, _) ->
let aparity = apinfo.Names.Length
match aparity with
| 0 | 1 ->
- let mkConstrApp = function [arg] -> arg | _ -> error(InternalError("ApplyUnionCaseOrExn",mItem))
- mkConstrApp, [ucaseAppTy]
+ let mkConstrApp _mArgs = function [arg] -> arg | _ -> error(InternalError("ApplyUnionCaseOrExn",mItem))
+ mkConstrApp, [ucaseAppTy], apinfo.Names
| _ ->
let ucref = mkChoiceCaseRef cenv.g mItem aparity n
let _,_,tinst,_ = infoOfTyconRef mItem ucref.TyconRef
@@ -7780,20 +7832,76 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
// assert the overall result type if possible
if isNil otherDelayed then
- UnifyTypes cenv env mExprAndArg overallTy ucaseAppTy;
+ UnifyTypes cenv env mExprAndArg overallTy ucaseAppTy
let nargs = List.length args
- UnionCaseOrExnCheck env nargtys nargs mExprAndArg;
+ UnionCaseOrExnCheck env nargtys nargs mExprAndArg
+
+ // if we manage to get here - number of formal arguments = number of actual arguments
+ // apply named parameters
+ let args =
+ // GetMethodArgs checks that no named parameters are located before positional
+ let unnamedArgs,namedCallerArgs = GetMethodArgs origArg
+ match namedCallerArgs with
+ | [] ->
+ args
+ | _ ->
+ let fittedArgs = Array.zeroCreate nargtys
+
+ // first: put all positional arguments
+ let mutable currentIndex = 0
+ for arg in unnamedArgs do
+ fittedArgs.[currentIndex] <- arg
+ currentIndex <- currentIndex + 1
- if nargtys > 1 then
- let _,namedCallerArgs = GetMethodArgs origArg
- match namedCallerArgs with
- | (_,id,_)::_ -> warning(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInUnionCaseConstructions(), id.idRange));
- | [] -> ()
+ let SEEN_NAMED_ARGUMENT = -1
+
+ // dealing with named arguments is a bit tricky since prior to these changes we have an ambiguous situation:
+ // regular notation for named parameters Some(Value = 5) can mean either 1) create option<bool> with value - result of equality operation or 2) create option<int> using named arg syntax.
+ // so far we've used 1) so we cannot immediately switch to 2) since it will be a definite breaking change.
+
+ for (_, id, arg) in namedCallerArgs do
+ match List.tryFindIndex ((=) id.idText) argNames with
+ | Some i ->
+ if box fittedArgs.[i] = null then
+ fittedArgs.[i] <- arg
+ let item = Item.ArgName (id, (List.nth argtys i))
+ CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad)
+ else error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange))
+ currentIndex <- SEEN_NAMED_ARGUMENT
+ | None ->
+ // ambiguity may apprear only when if argument is boolean\generic.
+ // if
+ // - we didn't find argument with specified name AND
+ // - we have not seen any named arguments so far AND
+ // - type of current argument is bool\generic
+ // then we'll favor old behavior and treat current argument as positional.
+ let isSpecialCaseForBackwardCompatibility =
+ if currentIndex = SEEN_NAMED_ARGUMENT then false
+ else
+ match stripTyEqns cenv.g (List.nth argtys currentIndex) with
+ | TType_app(tcref, _) -> tyconRefEq cenv.g cenv.g.bool_tcr tcref || tyconRefEq cenv.g cenv.g.system_Bool_tcref tcref
+ | TType_var(_) -> true
+ | _ -> false
+
+ if isSpecialCaseForBackwardCompatibility then
+ assert (box fittedArgs.[currentIndex] = null)
+ fittedArgs.[currentIndex] <- List.nth args currentIndex // grab original argument, not item from the list of named parametere
+ currentIndex <- currentIndex + 1
+ else
+ let caseName =
+ match item with
+ | Item.UnionCase uci -> uci.Name
+ | Item.ExnCase tcref -> tcref.DisplayName
+ | _ -> failwith "impossible"
+ error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(caseName, id.idText), id.idRange))
+
+ assert (Seq.forall (box >> ((<>) null) ) fittedArgs)
+ List.ofArray fittedArgs
let args',tpenv = TcExprs cenv env mExprAndArg tpenv flexes argtys args
- PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp args')) ucaseAppTy atomicFlag otherDelayed
+ PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg args')) ucaseAppTy atomicFlag otherDelayed
| DelayedTypeApp (_x, mTypeArgs, _mExprAndTypeArgs) :: _delayed' ->
error(Error(FSComp.SR.tcUnexpectedTypeArguments(),mTypeArgs))
@@ -7807,21 +7915,21 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
// This is where the constructor is an active pattern result applied to no argument
// Unit-taking active pattern result can be applied to no args
if (nargtys = 1 && match item with Item.ActivePatternResult _ -> true | _ -> false) then
- UnifyTypes cenv env mItem (List.head argtys) cenv.g.unit_ty;
- 1,(fun () -> mkConstrApp [mkUnit cenv.g mItem])
+ UnifyTypes cenv env mItem (List.head argtys) cenv.g.unit_ty
+ 1,(fun () -> mkConstrApp mItem [mkUnit cenv.g mItem])
// This is where the constructor expects no arguments and is applied to no argument
elif nargtys = 0 then
- 0,(fun () -> mkConstrApp [])
+ 0,(fun () -> mkConstrApp mItem [])
else
// This is where the constructor expects arguments but is not applied to arguments, hence build a lambda
nargtys,
(fun () ->
let vs,args = argtys |> List.mapi (fun i ty -> mkCompGenLocal mItem ("arg"^string i) ty) |> List.unzip
- let constrApp = mkConstrApp args
+ let constrApp = mkConstrApp mItem args
let lam = mkMultiLambda mItem vs (constrApp, tyOfExpr cenv.g constrApp)
lam)
- UnionCaseOrExnCheck env nargtys nargs mItem;
+ UnionCaseOrExnCheck env nargtys nargs mItem
let expr = mkExpr()
let exprTy = tyOfExpr cenv.g expr
PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.Atomic delayed
@@ -7848,13 +7956,13 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,env.eAccessRights)
// Same error as in the following case
- error(Error(FSComp.SR.tcInvalidUseOfTypeName(),mItem));
+ error(Error(FSComp.SR.tcInvalidUseOfTypeName(),mItem))
| _ ->
// In this case the type is not generic, and indeed we should never have returned Item.Types.
// That's because ResolveTypeNamesToCtors should have been set at the original
// call to ResolveLongIdentAsExprAndComputeRange
- error(Error(FSComp.SR.tcInvalidUseOfTypeName(),mItem));
+ error(Error(FSComp.SR.tcInvalidUseOfTypeName(),mItem))
| Item.MethodGroup (methodName,minfos) ->
// Static method calls Type.Foo(arg1,...,argn)
@@ -7882,14 +7990,14 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
match delayed with
| ((DelayedApp (_, arg, mExprAndArg))::otherDelayed) ->
- CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv,objTy, env.DisplayEnv, env.eAccessRights);
+ CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv,objTy, env.DisplayEnv, env.eAccessRights)
TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false arg mExprAndArg otherDelayed (Some afterTcOverloadResolution)
| ((DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs))::(DelayedApp (_, arg, mExprAndArg))::otherDelayed) ->
let objTy,tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tyargs
- CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.eAccessRights);
- minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.EnclosingType objTy);
+ CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.eAccessRights)
+ minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.EnclosingType objTy)
TcCtorCall true cenv env tpenv overallTy objTy (Some mExprAndTypeArgs) item false arg mExprAndArg otherDelayed (Some afterTcOverloadResolution)
| _ ->
@@ -7901,7 +8009,7 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
| Item.FakeInterfaceCtor _ ->
error(Error(FSComp.SR.tcInvalidUseOfInterfaceType(),mItem))
- | Item.ImplicitOp id ->
+ | Item.ImplicitOp(id, sln) ->
let isPrefix = PrettyNaming.IsPrefixOperator id.idText
let isTernary = PrettyNaming.IsTernaryOperator id.idText
@@ -7910,11 +8018,11 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
if isPrefix then
[ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true) ]
elif isTernary then
- [ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true);
- Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true);
+ [ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true)
+ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true)
Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true) ]
else
- [ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true);
+ [ Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true)
Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true) ]
let retTyData = Typar(mkSynId mItem (cenv.synArgNameGenerator.New()), HeadTypeStaticReq,true)
@@ -7927,9 +8035,9 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
let memberFlags = StaticMemberFlags MemberKind.Member
let logicalCompiledName = ComputeLogicalName id memberFlags
- let traitInfo = TTrait(argTys,logicalCompiledName,memberFlags,argTys,Some retTy,ref None)
+ let traitInfo = TTrait(argTys,logicalCompiledName,memberFlags,argTys,Some retTy, sln)
- AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo;
+ AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo
let expr = Expr.Op(TOp.TraitCall(traitInfo), [], ves, mItem)
let expr = mkLambdas mItem [] vs (expr,retTy)
@@ -7954,14 +8062,14 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
match delayed with
// Mutable value set: 'v <- e'
| DelayedSet(e2,mStmt) :: otherDelayed ->
- if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt));
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt))
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
let vty = vref.Type
let vty2 =
if isByrefTy cenv.g vty then
destByrefTy cenv.g vty
else
- if not vref.IsMutable then error (ValNotMutable(env.DisplayEnv,vref,mStmt));
+ if not vref.IsMutable then error (ValNotMutable(env.DisplayEnv,vref,mStmt))
vty
// Always allow subsumption on assignment to fields
let e2',tpenv = TcExprFlex cenv true vty2 env tpenv e2
@@ -7997,21 +8105,23 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
PropagateThenTcDelayed cenv overallTy env tpenv mItem vexp vexpty ExprAtomicFlag.Atomic delayed
| Item.Property (nm,pinfos) ->
- if isNil pinfos then error (InternalError ("Unexpected error: empty property list",mItem));
+ if isNil pinfos then error (InternalError ("Unexpected error: empty property list",mItem))
+ // if there are both intrinsics and extensions in pinfos, intrinsics will be listed first.
+ // by looking at List.Head we are letting the intrinsics determine indexed/non-indexed
let pinfo = List.head pinfos
let _, tyargsOpt,args,delayed,tpenv =
if pinfo.IsIndexer
then GetMemberApplicationArgs delayed cenv env tpenv
else ExprAtomicFlag.Atomic,None,[mkSynUnit mItem],delayed,tpenv
- if not pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsNotStatic(nm),mItem));
+ if not pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsNotStatic(nm),mItem))
match delayed with
| DelayedSet(e2,mStmt) :: otherDelayed ->
let args = if pinfo.IsIndexer then args else []
- if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt));
+ if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt))
// Static Property Set (possibly indexer)
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
let meths = pinfos |> SettersOfPropInfos
- if isNil meths then error (Error (FSComp.SR.tcPropertyCannotBeSet1 nm,mItem));
+ if isNil meths then error (Error (FSComp.SR.tcPropertyCannotBeSet1 nm,mItem))
let afterTcOverloadResolution = afterOverloadResolution |> AfterTcOverloadResolution.ForProperties nm SettersOfPropInfos
// Note: static calls never mutate a struct object argument
TcMethodApplicationThen cenv env overallTy tpenv tyargsOpt [] mStmt mItem nm ad NeverMutates true meths afterTcOverloadResolution NormalValUse (args@[e2]) ExprAtomicFlag.NonAtomic otherDelayed
@@ -8019,20 +8129,20 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
// Static Property Get (possibly indexer)
let meths = pinfos |> GettersOfPropInfos
let afterTcOverloadResolution = afterOverloadResolution |> AfterTcOverloadResolution.ForProperties nm GettersOfPropInfos
- if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable(nm),mItem));
+ if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable(nm),mItem))
// Note: static calls never mutate a struct object argument
TcMethodApplicationThen cenv env overallTy tpenv tyargsOpt [] mItem mItem nm ad NeverMutates true meths afterTcOverloadResolution NormalValUse args ExprAtomicFlag.Atomic delayed
| Item.ILField finfo ->
- CheckILFieldInfoAccessible cenv.g cenv.amap mItem ad finfo;
- if not finfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName),mItem));
- CheckILFieldAttributes cenv.g finfo mItem;
+ CheckILFieldInfoAccessible cenv.g cenv.amap mItem ad finfo
+ if not finfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName),mItem))
+ CheckILFieldAttributes cenv.g finfo mItem
let fref = finfo.ILFieldRef
let exprty = finfo.FieldType(cenv.amap,mItem)
match delayed with
| DelayedSet(e2,mStmt) :: _delayed' ->
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
// Always allow subsumption on assignment to fields
let e2',tpenv = TcExprFlex cenv true exprty env tpenv e2
let expr = BuildILStaticFieldSet mStmt finfo e2'
@@ -8058,18 +8168,18 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution
| Item.RecdField rfinfo ->
// Get static F# field or literal
- CheckRecdFieldInfoAccessible mItem ad rfinfo;
- if not rfinfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name),mItem));
- CheckRecdFieldInfoAttributes cenv.g rfinfo mItem |> CommitOperationResult;
+ CheckRecdFieldInfoAccessible cenv.amap mItem ad rfinfo
+ if not rfinfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name),mItem))
+ CheckRecdFieldInfoAttributes cenv.g rfinfo mItem |> CommitOperationResult
let fref = rfinfo.RecdFieldRef
let fieldTy = rfinfo.FieldType
match delayed with
| DelayedSet(e2,mStmt) :: otherDelayed ->
- if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt));
+ if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt))
// Set static F# field
- CheckRecdFieldMutation mItem env.DisplayEnv rfinfo;
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ CheckRecdFieldMutation mItem env.DisplayEnv rfinfo
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
let fieldTy = rfinfo.FieldType
// Always allow subsumption on assignment to fields
let e2',tpenv = TcExprFlex cenv true fieldTy env tpenv e2
@@ -8125,7 +8235,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela
// Canonicalize inference problem prior to '.' lookup on variable types
if isTyparTy cenv.g objExprTy then
- GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,env.DisplayEnv,mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy);
+ GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,env.DisplayEnv,mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy)
let item,mItem,rest,afterOverloadResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.eNameResEnv objExprTy longId findFlag false
let mExprAndItem = unionRanges mObjExpr mItem
@@ -8143,21 +8253,23 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela
| Item.Property (nm,pinfos) ->
// Instance property
- if isNil pinfos then error (InternalError ("Unexpected error: empty property list",mItem));
+ if isNil pinfos then error (InternalError ("Unexpected error: empty property list",mItem))
+ // if there are both intrinsics and extensions in pinfos, intrinsics will be listed first.
+ // by looking at List.Head we are letting the intrinsics determine indexed/non-indexed
let pinfo = List.head pinfos
let atomicFlag,tyargsOpt,args,delayed,tpenv =
if pinfo.IsIndexer
then GetMemberApplicationArgs delayed cenv env tpenv
else ExprAtomicFlag.Atomic,None,[mkSynUnit mItem],delayed,tpenv
- if pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsStatic(nm),mItem));
+ if pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsStatic(nm),mItem))
match delayed with
| DelayedSet(e2,mStmt) :: otherDelayed ->
let args = if pinfo.IsIndexer then args else []
- if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt));
+ if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mStmt))
// Instance property setter
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
let meths = SettersOfPropInfos pinfos
if isNil meths then error (Error (FSComp.SR.tcPropertyCannotBeSet1 nm,mItem))
let afterTcOverloadResolution = afterOverloadResolution |> AfterTcOverloadResolution.ForProperties nm SettersOfPropInfos
@@ -8166,24 +8278,24 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela
| _ ->
// Instance property getter
let meths = GettersOfPropInfos pinfos
- if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable(nm),mItem));
+ if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable(nm),mItem))
let afterTcOverloadResolution = afterOverloadResolution |> AfterTcOverloadResolution.ForProperties nm GettersOfPropInfos
TcMethodApplicationThen cenv env overallTy tpenv tyargsOpt objArgs mExprAndItem mItem nm ad PossiblyMutates true meths afterTcOverloadResolution NormalValUse args atomicFlag delayed
| Item.RecdField rfinfo ->
// Get or set instance F# field or literal
- RecdFieldInstanceChecks cenv.g ad mItem rfinfo;
+ RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo
let tgty = rfinfo.EnclosingType
let valu = isStructTy cenv.g tgty
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy
let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,mExprAndItem,objExprTy)
let fieldTy = rfinfo.FieldType
match delayed with
| DelayedSet(e2,mStmt) :: otherDelayed ->
// Mutable value set: 'v <- e'
- if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mItem));
- CheckRecdFieldMutation mItem env.DisplayEnv rfinfo;
- UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty;
+ if nonNil otherDelayed then error(Error(FSComp.SR.tcInvalidAssignment(),mItem))
+ CheckRecdFieldMutation mItem env.DisplayEnv rfinfo
+ UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty
// Always allow subsumption on assignment to fields
let e2',tpenv = TcExprFlex cenv true fieldTy env tpenv e2
BuildRecdFieldSet cenv.g mStmt objExpr rfinfo e2',tpenv
@@ -8196,7 +8308,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela
| Item.ILField finfo ->
// Get or set instance IL field
- ILFieldInstanceChecks cenv.g cenv.amap ad mItem finfo;
+ ILFieldInstanceChecks cenv.g cenv.amap ad mItem finfo
let exprty = finfo.FieldType(cenv.amap,mItem)
match delayed with
@@ -8223,18 +8335,18 @@ and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (ein
let nm = einfo.EventName
let ad = env.eAccessRights
match objDetails, einfo.IsStatic with
- | Some _, true -> error (Error (FSComp.SR.tcEventIsStatic(nm),mItem));
- | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic(nm),mItem));
+ | Some _, true -> error (Error (FSComp.SR.tcEventIsStatic(nm),mItem))
+ | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic(nm),mItem))
| _ -> ()
let delegateType = einfo.GetDelegateType(cenv.amap,mItem)
let (SigOfFunctionForDelegate(invokeMethInfo,compiledViewOfDelArgTys,_,_)) = GetSigOfFunctionForDelegate cenv.infoReader delegateType mItem ad
let objArgs = Option.toList (Option.map fst objDetails)
- MethInfoChecks cenv.g cenv.amap true None objArgs env.eAccessRights mItem invokeMethInfo;
+ MethInfoChecks cenv.g cenv.amap true None objArgs env.eAccessRights mItem invokeMethInfo
// This checks for and drops the 'object' sender
let argsTy = ArgsTypOfEventInfo cenv.infoReader mItem ad einfo
- if not (slotSigHasVoidReturnTy (invokeMethInfo.GetSlotSig(cenv.amap, mItem))) then errorR (nonStandardEventError einfo.EventName mItem);
+ if not (slotSigHasVoidReturnTy (invokeMethInfo.GetSlotSig(cenv.amap, mItem))) then errorR (nonStandardEventError einfo.EventName mItem)
let delEventTy = mkIEventType cenv.g delegateType argsTy
let bindObjArgs f =
@@ -8274,7 +8386,7 @@ and TcMethodApplicationThen
overallTy // The type of the overall expression including "delayed". THe method "application" may actually be a use of a member as
// a first-class function value, when this would be a function type.
tpenv
- userTypeArgs // The return type of the overall expression including "delayed"
+ callerTyArgs // The return type of the overall expression including "delayed"
objArgs // The 'obj' arguments in obj.M(...) and obj.M, if any
m // The range of the object argument or whole application. We immediately union this with the range of the arguments
mItem // The range of the item that resolved to the method name
@@ -8299,13 +8411,12 @@ and TcMethodApplicationThen
// Call the helper below to do the real checking
let (expr,attributeAssignedNamedItems,delayed),tpenv =
- TcMethodApplication false cenv env tpenv userTypeArgs objArgs mWholeExpr mItem methodName ad mut isProp meths afterTcOverloadResolution isSuperInit args exprTy delayed
+ TcMethodApplication false cenv env tpenv callerTyArgs objArgs mWholeExpr mItem methodName ad mut isProp meths afterTcOverloadResolution isSuperInit args exprTy delayed
// Give errors if some things couldn't be assigned
- if nonNil attributeAssignedNamedItems then (
+ if nonNil attributeAssignedNamedItems then
let (CallerNamedArg(id,_)) = List.head attributeAssignedNamedItems
- errorR(Error(FSComp.SR.tcNamedArgumentDidNotMatch(id.idText),id.idRange));
- );
+ errorR(Error(FSComp.SR.tcNamedArgumentDidNotMatch(id.idText),id.idRange))
// Resolve the "delayed" lookups
@@ -8347,7 +8458,7 @@ and TcMethodApplication
let isSimpleFormalArg (isParamArrayArg,isOutArg,optArgInfo: OptionalArgInfo) =
not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional
- let objArgTys = objArgs |> List.map (tyOfExpr cenv.g)
+ let callerObjArgTys = objArgs |> List.map (tyOfExpr cenv.g)
let calledMeths = calledMethsAndProps |> List.map fst
@@ -8364,7 +8475,7 @@ and TcMethodApplication
curriedCallerArgs,exprTy,delayed
let candidateMethsAndProps =
- match calledMethsAndProps |> List.filter (fun (meth,_prop) -> (IsMethInfoAccessible cenv.amap mItem ad meth)) with
+ match calledMethsAndProps |> List.filter (fun (meth,_prop) -> IsMethInfoAccessible cenv.amap mItem ad meth) with
| [] -> calledMethsAndProps
| accessibleMeths -> accessibleMeths
@@ -8463,8 +8574,8 @@ and TcMethodApplication
let returnTy =
(exprTy,curriedArgTys) ||> List.fold (fun exprTy argTys ->
let domainTy,resultTy = UnifyFunctionType None cenv denv mMethExpr exprTy
- UnifyTypes cenv env mMethExpr domainTy (mkTupledTy cenv.g argTys);
- resultTy);
+ UnifyTypes cenv env mMethExpr domainTy (mkTupledTy cenv.g argTys)
+ resultTy)
curriedArgTys,returnTy
if isProp && isNone curriedCallerArgsOpt then
@@ -8474,7 +8585,7 @@ and TcMethodApplication
// Extract what we know about the caller arguments, either type-directed if
// no arguments are given or else based on the syntax of the arguments.
let uniquelyResolved,preArgumentTypeCheckingCalledMethGroup =
- let dummyExpr = mkUnit cenv.g mItem
+ let dummyExpr = mkSynUnit mItem
// Build the CallerArg values for the caller's arguments.
// Fake up some arguments if this is the use of a method as a first class function
@@ -8512,114 +8623,116 @@ and TcMethodApplication
let unnamedCurriedCallerArgs = [argTys |> List.map (fun ty -> CallerArg(ty,mMethExpr,false,dummyExpr)) ]
let namedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.map (fun _ -> [])
unnamedCurriedCallerArgs, namedCurriedCallerArgs, returnTy
-
| Some (unnamedCurriedCallerArgs,namedCurriedCallerArgs),_ ->
- let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared (fun (_,xty,xm) -> CallerArg(xty,xm,false,dummyExpr))
- let namedCurriedCallerArgs = namedCurriedCallerArgs |> List.mapSquared (fun (id,isOpt,_,xty,xm) -> CallerNamedArg(id,CallerArg(xty,xm,isOpt,dummyExpr)))
+ let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared (fun (argExpr,argTy,mArg) -> CallerArg(argTy,mArg,false,argExpr))
+ let namedCurriedCallerArgs = namedCurriedCallerArgs |> List.mapSquared (fun (id,isOpt,argExpr,argTy,mArg) -> CallerNamedArg(id,CallerArg(argTy,mArg,isOpt,argExpr)))
unnamedCurriedCallerArgs, namedCurriedCallerArgs, exprTy
let callerArgCounts = (List.sumBy List.length unnamedCurriedCallerArgs, List.sumBy List.length namedCurriedCallerArgs)
- let mk_CalledMeth (minfo,pinfoOpt,usesParamArrayConversion) =
+ let makeOneCalledMeth (minfo,pinfoOpt,usesParamArrayConversion) =
let minst = FreshenMethInfo mItem minfo
- let userTypeArgs = Option.otherwise tyargsOpt minst
+ let callerTyArgs =
+ match tyargsOpt with
+ | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs)
+ | None -> minst
let allArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs
- MakeCalledMeth(cenv.infoReader,checkingAttributeCall, FreshenMethInfo, mMethExpr,ad,minfo,minst,userTypeArgs,pinfoOpt,objArgTys,allArgs,usesParamArrayConversion,true)
+ CalledMeth<SynExpr>(cenv.infoReader,checkingAttributeCall, FreshenMethInfo, mMethExpr,ad,minfo,minst,callerTyArgs,pinfoOpt,callerObjArgTys,allArgs,usesParamArrayConversion,true)
-
- let methsAndPropsToCalledMeths methsAndProps =
- [ for (minfo,pinfoOpt) in methsAndProps do
- let meth = mk_CalledMeth (minfo,pinfoOpt,true)
+ let preArgumentTypeCheckingCalledMethGroup =
+ [ for (minfo,pinfoOpt) in candidateMethsAndProps do
+ let meth = makeOneCalledMeth (minfo,pinfoOpt,true)
yield meth
if meth.UsesParamArrayConversion then
- yield mk_CalledMeth (minfo,pinfoOpt,false) ]
-
- let preArgumentTypeCheckingCalledMethGroup = candidateMethsAndProps |> methsAndPropsToCalledMeths
-
- let isUniquelyResolved calledMethGroup =
- let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv
- UnifyUniqueOverloading csenv callerArgCounts methodName ad calledMethGroup returnTy
+ yield makeOneCalledMeth (minfo,pinfoOpt,false) ]
let uniquelyResolved =
- let res = isUniquelyResolved preArgumentTypeCheckingCalledMethGroup
+ let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv
+ let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy
match res with
| ErrorResult _ -> afterTcOverloadResolution.OnOverloadResolutionFailure()
| _ -> ()
res |> CommitOperationResult
+
uniquelyResolved,preArgumentTypeCheckingCalledMethGroup
// STEP 2. Type check arguments
let unnamedCurriedCallerArgs,namedCurriedCallerArgs,lambdaVars,returnTy,tpenv =
-
+
// STEP 2a. First extract what we know about the caller arguments, either type-directed if
// no arguments are given or else based on the syntax of the arguments.
- let unnamedCurriedCallerArgs,namedCurriedCallerArgs,lambdaVars,returnTy,tpenv =
- match curriedCallerArgsOpt with
- | None ->
- let curriedArgTys,returnTy =
- match candidates with
- // "single named item" rule. This is where we have a single accessible method
- // member x.M(arg1,...,argN)
- // being used in a first-class way, i.e.
- // x.M
- // Because there is only one accessible method info available based on the name of the item
- // being accessed we know the number of arguments the first class use of this
- // method will take. Optional and out args are _not_ included, which means they will be resolved
- // to their default values (for optionals) and be part of the return tuple (for out args).
- | [calledMeth] ->
- UnifyMatchingSimpleArgumentTypes exprTy calledMeth
- | _ ->
- let domainTy,returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy
- let argTys = if isUnitTy cenv.g domainTy then [] else tryDestTupleTy cenv.g domainTy
- // Only apply this rule if a candidate method exists with this number of arguments
- let argTys =
- if candidates |> List.exists (CalledMethHasSingleArgumentGroupOfThisLength argTys.Length) then
- argTys
- else
- [domainTy]
- [argTys],returnTy
+ match curriedCallerArgsOpt with
+ | None ->
+ let curriedArgTys,returnTy =
+ match candidates with
+ // "single named item" rule. This is where we have a single accessible method
+ // member x.M(arg1,...,argN)
+ // being used in a first-class way, i.e.
+ // x.M
+ // Because there is only one accessible method info available based on the name of the item
+ // being accessed we know the number of arguments the first class use of this
+ // method will take. Optional and out args are _not_ included, which means they will be resolved
+ // to their default values (for optionals) and be part of the return tuple (for out args).
+ | [calledMeth] ->
+ UnifyMatchingSimpleArgumentTypes exprTy calledMeth
+ | _ ->
+ let domainTy,returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy
+ let argTys = if isUnitTy cenv.g domainTy then [] else tryDestTupleTy cenv.g domainTy
+ // Only apply this rule if a candidate method exists with this number of arguments
+ let argTys =
+ if candidates |> List.exists (CalledMethHasSingleArgumentGroupOfThisLength argTys.Length) then
+ argTys
+ else
+ [domainTy]
+ [argTys],returnTy
- let lambdaVarsAndExprs = curriedArgTys |> List.mapiSquared (fun i j ty -> mkCompGenLocal mMethExpr ("arg"^string i^string j) ty)
- let unnamedCurriedCallerArgs = lambdaVarsAndExprs |> List.mapSquared (fun (_,e) -> CallerArg(tyOfExpr cenv.g e,e.Range,false,e))
- let namedCurriedCallerArgs = lambdaVarsAndExprs |> List.map (fun _ -> [])
- unnamedCurriedCallerArgs,namedCurriedCallerArgs,Some(List.map (List.map fst) lambdaVarsAndExprs), returnTy,tpenv
-
- | Some (unnamedCurriedCallerArgs,namedCurriedCallerArgs) ->
- let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared (fun (x,xty,xm) -> CallerArg(xty,xm,false,x))
- let unnamedCurriedCallerArgs,tpenv = TcMethodArgs cenv env tpenv unnamedCurriedCallerArgs
- unnamedCurriedCallerArgs,namedCurriedCallerArgs,None,exprTy,tpenv
+ let lambdaVarsAndExprs = curriedArgTys |> List.mapiSquared (fun i j ty -> mkCompGenLocal mMethExpr ("arg"+string i+string j) ty)
+ let unnamedCurriedCallerArgs = lambdaVarsAndExprs |> List.mapSquared (fun (_,e) -> CallerArg(tyOfExpr cenv.g e,e.Range,false,e))
+ let namedCurriedCallerArgs = lambdaVarsAndExprs |> List.map (fun _ -> [])
+ let lambdaVars = List.mapSquared fst lambdaVarsAndExprs
+ unnamedCurriedCallerArgs, namedCurriedCallerArgs, Some lambdaVars, returnTy, tpenv
+
+ | Some (unnamedCurriedCallerArgs,namedCurriedCallerArgs) ->
+ // This is the case where some explicit aguments have been given.
+
+ let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared (fun (argExpr,argTy,mArg) -> CallerArg(argTy,mArg,false,argExpr))
+ let namedCurriedCallerArgs = namedCurriedCallerArgs |> List.mapSquared (fun (id,isOpt,argExpr,argTy,mArg) -> CallerNamedArg(id,CallerArg(argTy,mArg,isOpt,argExpr)))
+
+ // Collect the information for F# 3.1 lambda propagation rule, and apply the caller's object type to the method's object type if the rule is relevant.
+ let lambdaPropagationInfo =
+ if preArgumentTypeCheckingCalledMethGroup.Length > 1 then
+ [| for meth in preArgumentTypeCheckingCalledMethGroup do
+ match ExamineMethodForLambdaPropagation meth with
+ | Some (unnamedInfo, namedInfo) ->
+ let calledObjArgTys = meth.CalledObjArgTys(mMethExpr)
+ if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv cenv.css mMethExpr calledTy callerTy) then
+ yield (List.toArraySquared unnamedInfo, List.toArraySquared namedInfo)
+ | None -> () |]
+ else
+ [| |]
- // Now check the named arguments
- let namedCurriedCallerArgs = namedCurriedCallerArgs |> List.mapSquared (fun (id,isOpt,x,xty,xm) -> CallerNamedArg(id,CallerArg(xty,xm,isOpt,x)))
- let namedCurriedCallerArgs,tpenv = TcMethodNamedArgs cenv env tpenv namedCurriedCallerArgs
- unnamedCurriedCallerArgs,namedCurriedCallerArgs,lambdaVars,returnTy,tpenv
+ // Now typecheck the argument expressions
+ let unnamedCurriedCallerArgs,(lambdaPropagationInfo,tpenv) = TcUnnamedMethodArgs cenv env lambdaPropagationInfo tpenv unnamedCurriedCallerArgs
+ let namedCurriedCallerArgs,(_,tpenv) = TcMethodNamedArgs cenv env lambdaPropagationInfo tpenv namedCurriedCallerArgs
+ unnamedCurriedCallerArgs, namedCurriedCallerArgs, None, exprTy, tpenv
let preArgumentTypeCheckingCalledMethGroup =
preArgumentTypeCheckingCalledMethGroup |> List.map (fun cmeth -> (cmeth.Method, cmeth.CalledTyArgs, cmeth.AssociatedPropertyInfo, cmeth.UsesParamArrayConversion))
// STEP 3. Resolve overloading
/// Select the called method that's the result of overload resolution
- let (CalledMeth(finalCalledMethInfo,
- finalCalledMethInst,
- _,
- _,
- argSets,
- _,
- assignedNamedProps,
- finalCalledPropInfoOpt,_,
- attributeAssignedNamedItems,
- unnamedCalledOptArgs,
- unnamedCalledOutArgs) as finalCalledMeth) =
-
- let mk_CalledMeth2 (minfo:MethInfo,minst,pinfoOpt,usesParamArrayConversion) =
- let userTypeArgs = Option.otherwise tyargsOpt minst
-
- let callerArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs
- MakeCalledMeth(cenv.infoReader,checkingAttributeCall, FreshenMethInfo, mMethExpr,ad,minfo,minst,userTypeArgs,pinfoOpt,objArgTys,callerArgs,usesParamArrayConversion,true)
+ let finalCalledMeth =
+
+ let postArgumentTypeCheckingCalledMethGroup =
+ preArgumentTypeCheckingCalledMethGroup |> List.map (fun (minfo:MethInfo,minst,pinfoOpt,usesParamArrayConversion) ->
+ let callerTyArgs =
+ match tyargsOpt with
+ | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs)
+ | None -> minst
+ let callerArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs
+ CalledMeth<Expr>(cenv.infoReader,checkingAttributeCall,FreshenMethInfo, mMethExpr,ad,minfo,minst,callerTyArgs,pinfoOpt,callerObjArgTys,callerArgs,usesParamArrayConversion,true))
- let postArgumentTypeCheckingCalledMethGroup = List.map mk_CalledMeth2 preArgumentTypeCheckingCalledMethGroup
-
let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length)
let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv
@@ -8628,7 +8741,7 @@ and TcMethodApplication
if not uniquelyResolved then
GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,mItem)
(//freeInTypeLeftToRight cenv.g false returnTy @
- (unnamedCurriedCallerArgs |> List.collectSquared (fun (CallerArg(xty,_,_,_)) -> freeInTypeLeftToRight cenv.g false xty)));
+ (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.Type)))
let result, errors =
ResolveOverloading csenv NoTrace methodName 0 false callerArgCounts ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy)
@@ -8660,22 +8773,31 @@ and TcMethodApplication
// Raise the errors from the constraint solving
- RaiseOperationResult errors;
+ RaiseOperationResult errors
match result with
| None -> error(InternalError("at least one error should be returned by failed method overloading",mItem))
| Some res -> res
- let assignedNamedArgs = argSets |> List.collect (fun argSet -> argSet.AssignedNamedArgs)
- let paramArrayCallerArgs = argSets |> List.collect (fun argSet -> argSet.ParamArrayCallerArgs)
- let unnamedCalledArgs = argSets |> List.collect (fun argSet -> argSet.UnnamedCalledArgs)
- let unnamedCallerArgs = argSets |> List.collect (fun argSet -> argSet.UnnamedCallerArgs)
+ let finalCalledMethInfo = finalCalledMeth.Method
+ let finalCalledMethInst = finalCalledMeth.CalledTyArgs
+ let finalArgSets = finalCalledMeth.ArgSets
+ let finalAssignedItemSetters = finalCalledMeth.AssignedItemSetters
+ let finalCalledPropInfoOpt = finalCalledMeth.AssociatedPropertyInfo
+ let finalAttributeAssignedNamedItems = finalCalledMeth.AttributeAssignedNamedArgs
+ let finalUnnamedCalledOptArgs = finalCalledMeth.UnnamedCalledOptArgs
+ let finalUnnamedCalledOutArgs = finalCalledMeth.UnnamedCalledOutArgs
+
+ let finalAssignedNamedArgs = finalArgSets |> List.collect (fun argSet -> argSet.AssignedNamedArgs)
+ let finalParamArrayCallerArgs = finalArgSets |> List.collect (fun argSet -> argSet.ParamArrayCallerArgs)
+ let finalUnnamedCalledArgs = finalArgSets |> List.collect (fun argSet -> argSet.UnnamedCalledArgs)
+ let finalUnnamedCallerArgs = finalArgSets |> List.collect (fun argSet -> argSet.UnnamedCallerArgs)
// STEP 4. Check the attributes on the method and the corresponding event/property, if any
- finalCalledPropInfoOpt |> Option.iter (fun pinfo -> CheckPropInfoAttributes pinfo mItem |> CommitOperationResult) ;
+ finalCalledPropInfoOpt |> Option.iter (fun pinfo -> CheckPropInfoAttributes pinfo mItem |> CommitOperationResult)
let isInstance = nonNil objArgs
- MethInfoChecks cenv.g cenv.amap isInstance tyargsOpt objArgs ad mItem finalCalledMethInfo;
+ MethInfoChecks cenv.g cenv.amap isInstance tyargsOpt objArgs ad mItem finalCalledMethInfo
// Adhoc constraints on use of .NET methods
begin
@@ -8686,7 +8808,7 @@ and TcMethodApplication
typeEquiv cenv.g finalCalledMethInfo.EnclosingType cenv.g.obj_ty &&
(finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then
- objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr));
+ objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr))
// Uses of a Dictionary() constructor without an IEqualityComparer argument imply an equality constraint
// on the first type argument.
@@ -8697,12 +8819,12 @@ and TcMethodApplication
HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then
match argsOfAppTy cenv.g finalCalledMethInfo.EnclosingType with
- | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty;
+ | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty
| _ -> ()
- end;
+ end
- if (argSets |> List.existsi (fun i argSet -> argSet.UnnamedCalledArgs |> List.existsi (fun j ca -> ca.Position <> (i,j)))) then
- errorR(Deprecated(FSComp.SR.tcUnnamedArgumentsDoNotFormPrefix(),mMethExpr));
+ if (finalArgSets |> List.existsi (fun i argSet -> argSet.UnnamedCalledArgs |> List.existsi (fun j ca -> ca.Position <> (i,j)))) then
+ errorR(Deprecated(FSComp.SR.tcUnnamedArgumentsDoNotFormPrefix(),mMethExpr))
// STEP 5. Build the argument list. Adjust for optional arguments, byref arguments and coercions.
@@ -8758,17 +8880,20 @@ and TcMethodApplication
let optArgPreBinder,allArgs,outArgExprs,outArgTmpBinds =
let normalUnnamedArgs =
- (unnamedCalledArgs,unnamedCallerArgs) ||> List.map2 (fun called caller -> AssignedCalledArg(None,called,caller))
+ (finalUnnamedCalledArgs,finalUnnamedCallerArgs) ||> List.map2 (fun called caller -> { NamedArgIdOpt = None; CalledArg=called; CallerArg=caller })
let paramArrayArgs =
match finalCalledMeth.ParamArrayCalledArgOpt with
| None -> []
| Some paramArrayCalledArg ->
- let paramArrayCalledArgElementType = destArrayTy cenv.g paramArrayCalledArg.Type
+ let paramArrayCalledArgElementType = destArrayTy cenv.g paramArrayCalledArg.CalledArgumentType
- let es = paramArrayCallerArgs |> List.map (fun (CallerArg(callerArgTy,m,isOutArg,callerArgExpr)) ->
- coerceExpr isOutArg paramArrayCalledArgElementType callerArgTy m callerArgExpr)
- [ AssignedCalledArg(None,paramArrayCalledArg,CallerArg(paramArrayCalledArg.Type,mMethExpr,false,Expr.Op(TOp.Array,[paramArrayCalledArgElementType], es ,mMethExpr))) ]
+ let es =
+ finalParamArrayCallerArgs |> List.map (fun callerArg ->
+ let (CallerArg(callerArgTy,m,isOutArg,callerArgExpr)) = callerArg
+ coerceExpr isOutArg paramArrayCalledArgElementType callerArgTy m callerArgExpr)
+
+ [ { NamedArgIdOpt = None; CalledArg=paramArrayCalledArg; CallerArg=CallerArg(paramArrayCalledArg.CalledArgumentType,mMethExpr,false,Expr.Op(TOp.Array,[paramArrayCalledArgElementType], es ,mMethExpr)) } ]
// CLEANUP: Move all this code into some isolated file, e.g. "optional.fs"
//
@@ -8790,62 +8915,62 @@ and TcMethodApplication
// typed as Object. What we do in this case is we box the intrinsic value."
//
let optArgs,optArgPreBinder =
- (emptyPreBinder,unnamedCalledOptArgs)
- ||> List.mapFold (fun wrapper (CalledArg(_,_,optArgInfo,_,_,calledArgTy) as calledArg) ->
- let wrapper2,expr =
-
- match optArgInfo with
- | NotOptional ->
- error(InternalError("Unexpected NotOptional",mItem))
- | CallerSide dfltVal ->
- let rec build = function
- | MissingValue ->
- // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr.
- emptyPreBinder,mkAsmExpr ([ mkNormalLdsfld (fspec_Missing_Value cenv.g.ilg); AI_nop ],[],[],[calledArgTy],mMethExpr)
- | DefaultValue ->
- emptyPreBinder,mkDefault(mMethExpr,calledArgTy)
- | Constant fieldInit ->
- emptyPreBinder,Expr.Const(TcFieldInit mMethExpr fieldInit,mMethExpr,calledArgTy)
- | WrapperForIDispatch ->
- let tref = mkILNonGenericBoxedTy(mkILTyRef(cenv.g.ilg.mscorlibScopeRef,"System.Runtime.InteropServices.DispatchWrapper"))
- let mref = mkILCtorMethSpecForTy(tref,[cenv.g.ilg.typ_Object]).MethodRef
- let expr = Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,false,mref,[],[],[cenv.g.obj_ty]),[],[mkDefault(mMethExpr,calledArgTy)],mMethExpr)
- emptyPreBinder,expr
- | WrapperForIUnknown ->
- let tref = mkILNonGenericBoxedTy(mkILTyRef(cenv.g.ilg.mscorlibScopeRef,"System.Runtime.InteropServices.UnknownWrapper"))
- let mref = mkILCtorMethSpecForTy(tref,[cenv.g.ilg.typ_Object]).MethodRef
- let expr = Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,false,mref,[],[],[cenv.g.obj_ty]),[],[mkDefault(mMethExpr,calledArgTy)],mMethExpr)
- emptyPreBinder,expr
- | PassByRef (ty, dfltVal2) ->
- let v,_ = mkCompGenLocal mMethExpr "defaultByrefArg" ty
- let wrapper2,rhs = build dfltVal2
- (wrapper2 >> mkCompGenLet mMethExpr v rhs), mkValAddr mMethExpr (mkLocalValRef v)
- build dfltVal
-
- | CalleeSide ->
- let calledNonOptTy =
- if isOptionTy cenv.g calledArgTy then
- destOptionTy cenv.g calledArgTy
- else
- calledArgTy // should be unreachable
- emptyPreBinder,mkUnionCaseExpr(mkNoneCase cenv.g,[calledNonOptTy],[],mMethExpr)
-
- // Combine the variable allocators (if any)
- let wrapper = (wrapper >> wrapper2)
- let callerArg = CallerArg(calledArgTy,mMethExpr,false,expr)
- AssignedCalledArg(None,calledArg,callerArg),wrapper)
+ (emptyPreBinder,finalUnnamedCalledOptArgs) ||> List.mapFold (fun wrapper calledArg ->
+ let calledArgTy = calledArg.CalledArgumentType
+ let wrapper2,expr =
+ match calledArg.OptArgInfo with
+ | NotOptional ->
+ error(InternalError("Unexpected NotOptional",mItem))
+ | CallerSide dfltVal ->
+ let rec build = function
+ | MissingValue ->
+ // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr.
+ emptyPreBinder,mkAsmExpr ([ mkNormalLdsfld (fspec_Missing_Value cenv.g.ilg); AI_nop ],[],[],[calledArgTy],mMethExpr)
+ | DefaultValue ->
+ emptyPreBinder,mkDefault(mMethExpr,calledArgTy)
+ | Constant fieldInit ->
+ emptyPreBinder,Expr.Const(TcFieldInit mMethExpr fieldInit,mMethExpr,calledArgTy)
+ | WrapperForIDispatch ->
+ let tref = mkILNonGenericBoxedTy(mkILTyRef(cenv.g.ilg.traits.SystemRuntimeInteropServicesScopeRef.Value, "System.Runtime.InteropServices.DispatchWrapper"))
+ let mref = mkILCtorMethSpecForTy(tref,[cenv.g.ilg.typ_Object]).MethodRef
+ let expr = Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,false,mref,[],[],[cenv.g.obj_ty]),[],[mkDefault(mMethExpr,calledArgTy)],mMethExpr)
+ emptyPreBinder,expr
+ | WrapperForIUnknown ->
+ let tref = mkILNonGenericBoxedTy(mkILTyRef(cenv.g.ilg.traits.SystemRuntimeInteropServicesScopeRef.Value, "System.Runtime.InteropServices.UnknownWrapper"))
+ let mref = mkILCtorMethSpecForTy(tref,[cenv.g.ilg.typ_Object]).MethodRef
+ let expr = Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,false,mref,[],[],[cenv.g.obj_ty]),[],[mkDefault(mMethExpr,calledArgTy)],mMethExpr)
+ emptyPreBinder,expr
+ | PassByRef (ty, dfltVal2) ->
+ let v,_ = mkCompGenLocal mMethExpr "defaultByrefArg" ty
+ let wrapper2,rhs = build dfltVal2
+ (wrapper2 >> mkCompGenLet mMethExpr v rhs), mkValAddr mMethExpr (mkLocalValRef v)
+ build dfltVal
+
+ | CalleeSide ->
+ let calledNonOptTy =
+ if isOptionTy cenv.g calledArgTy then
+ destOptionTy cenv.g calledArgTy
+ else
+ calledArgTy // should be unreachable
+ emptyPreBinder,mkUnionCaseExpr(mkNoneCase cenv.g,[calledNonOptTy],[],mMethExpr)
+
+ // Combine the variable allocators (if any)
+ let wrapper = (wrapper >> wrapper2)
+ let callerArg = CallerArg(calledArgTy,mMethExpr,false,expr)
+ { NamedArgIdOpt = None; CalledArg = calledArg; CallerArg = callerArg },wrapper)
// Handle optional arguments
- let wrapOptionalArg (AssignedCalledArg(idOpt,(CalledArg(_,_,optArgInfo,_,_,calledArgTy) as calledArg) ,CallerArg(callerArgTy,m,isOptCallerArg,expr)) as assignedArg) =
- match optArgInfo with
+ let wrapOptionalArg (assignedArg: AssignedCalledArg<_>) =
+ let (CallerArg(callerArgTy,m,isOptCallerArg,expr)) = assignedArg.CallerArg
+ match assignedArg.CalledArg.OptArgInfo with
| NotOptional ->
- if isOptCallerArg then errorR(Error(FSComp.SR.tcFormalArgumentIsNotOptional(),m));
+ if isOptCallerArg then errorR(Error(FSComp.SR.tcFormalArgumentIsNotOptional(),m))
assignedArg
| _ ->
let expr =
- match optArgInfo with
+ match assignedArg.CalledArg.OptArgInfo with
| CallerSide _ ->
if isOptCallerArg then
mkUnionCaseFieldGetUnproven(expr,mkSomeCase cenv.g,[destOptionTy cenv.g callerArgTy],0,m)
@@ -8857,6 +8982,7 @@ and TcMethodApplication
expr
else
// M(x=b) when M(A) --> M(?x=Some(b :> A))
+ let calledArgTy = assignedArg.CalledArg.CalledArgumentType
if isOptionTy cenv.g calledArgTy then
let calledNonOptTy = destOptionTy cenv.g calledArgTy
mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[mkCoerceIfNeeded cenv.g calledNonOptTy callerArgTy expr],m)
@@ -8864,23 +8990,24 @@ and TcMethodApplication
expr // should be unreachable
| _ -> failwith "Unreachable"
- AssignedCalledArg(idOpt,calledArg,CallerArg((tyOfExpr cenv.g expr),m,isOptCallerArg,expr))
+ { assignedArg with CallerArg=CallerArg((tyOfExpr cenv.g expr),m,isOptCallerArg,expr) }
let outArgsAndExprs,outArgTmpBinds =
- unnamedCalledOutArgs
- |> List.map (fun (CalledArg(_,_,_,_,_,calledArgTy) as calledArg) ->
+ finalUnnamedCalledOutArgs |> List.map (fun calledArg ->
+ let calledArgTy = calledArg.CalledArgumentType
let outArgTy = destByrefTy cenv.g calledArgTy
let outv,outArgExpr = mkMutableCompGenLocal mMethExpr "outArg" outArgTy // mutable!
let expr = mkDefault(mMethExpr,outArgTy)
let callerArg = CallerArg(calledArgTy,mMethExpr,false,mkValAddr mMethExpr (mkLocalValRef outv))
- (AssignedCalledArg(None,calledArg,callerArg), outArgExpr), mkCompGenBind outv expr)
+ let outArg = { NamedArgIdOpt=None;CalledArg=calledArg;CallerArg=callerArg }
+ (outArg, outArgExpr), mkCompGenBind outv expr)
|> List.unzip
let outArgs, outArgExprs = List.unzip outArgsAndExprs
let allArgs =
List.map wrapOptionalArg normalUnnamedArgs @
- List.map wrapOptionalArg assignedNamedArgs @
+ List.map wrapOptionalArg finalAssignedNamedArgs @
paramArrayArgs @
optArgs @
outArgs
@@ -8890,17 +9017,20 @@ and TcMethodApplication
optArgPreBinder,allArgs,outArgExprs,outArgTmpBinds
- let coerce (AssignedCalledArg(_,CalledArg(_,_,_,isOutArg,_,calledArgTy),CallerArg(callerArgTy,m,_,e))) =
+ let coerce (assignedArg: AssignedCalledArg<_>) =
+ let isOutArg = assignedArg.CalledArg.IsOutArg
+ let calledArgTy = assignedArg.CalledArg.CalledArgumentType
+ let (CallerArg(callerArgTy,m,_,e)) = assignedArg.CallerArg
- coerceExpr isOutArg calledArgTy callerArgTy m e
+ coerceExpr isOutArg calledArgTy callerArgTy m e
// Record the resolution of the named argument for the Language Service
- allArgs |> List.iter (fun (AssignedCalledArg(idOpt,calledArg,_)) ->
- match idOpt with
+ allArgs |> List.iter (fun assignedArg ->
+ match assignedArg.NamedArgIdOpt with
| None -> ()
| Some id ->
- let item = Item.ArgName (id, calledArg.Type)
- CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad));
+ let item = Item.ArgName (id, assignedArg.CalledArg.CalledArgumentType)
+ CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad))
let allArgsCoerced = List.map coerce allArgs
@@ -8922,43 +9052,43 @@ and TcMethodApplication
// Handle post-hoc property assignments
let expr =
- if isNil assignedNamedProps then expr else
+ if isNil finalAssignedItemSetters then expr else
// This holds the result of the call
let objv,objExpr = mkMutableCompGenLocal mMethExpr "returnVal" exprty // mutable in case it's a struct
// This expression mutates the properties on the result of the call
let propSetExpr =
- (mkUnit cenv.g mMethExpr, assignedNamedProps) ||> List.fold (fun acc (AssignedItemSetter(id,setter,CallerArg(callerArgTy,m,isOptCallerArg,argExpr))) ->
- if isOptCallerArg then error(Error(FSComp.SR.tcInvalidOptionalAssignmentToPropertyOrField(),m));
+ (mkUnit cenv.g mMethExpr, finalAssignedItemSetters) ||> List.fold (fun acc (AssignedItemSetter(id,setter,CallerArg(callerArgTy,m,isOptCallerArg,argExpr))) ->
+ if isOptCallerArg then error(Error(FSComp.SR.tcInvalidOptionalAssignmentToPropertyOrField(),m))
let action, defnItem =
match setter with
| AssignedPropSetter (pinfo,pminfo,pminst) ->
- MethInfoChecks cenv.g cenv.amap true None [objExpr] ad m pminfo;
+ MethInfoChecks cenv.g cenv.amap true None [objExpr] ad m pminfo
let calledArgTy = List.head (List.head (pminfo.GetParamTypes(cenv.amap, m, pminst)))
let argExpr = coerceExpr false calledArgTy callerArgTy m argExpr
let mut = (if isStructTy cenv.g (tyOfExpr cenv.g objExpr) then DefinitelyMutates else PossiblyMutates)
let action = BuildPossiblyConditionalMethodCall cenv env mut m true pminfo NormalValUse pminst [objExpr] [argExpr] |> fst
action, Item.Property (pinfo.PropertyName, [pinfo])
- | AssignedIlFieldSetter finfo ->
+ | AssignedILFieldSetter finfo ->
// Get or set instance IL field
- ILFieldInstanceChecks cenv.g cenv.amap ad m finfo;
+ ILFieldInstanceChecks cenv.g cenv.amap ad m finfo
let calledArgTy = finfo.FieldType (cenv.amap, m)
let argExpr = coerceExpr false calledArgTy callerArgTy m argExpr
let action = BuildILFieldSet cenv.g m objExpr finfo argExpr
action, Item.ILField finfo
| AssignedRecdFieldSetter rfinfo ->
- RecdFieldInstanceChecks cenv.g ad m rfinfo;
+ RecdFieldInstanceChecks cenv.g cenv.amap ad m rfinfo
let calledArgTy = rfinfo.FieldType
- CheckRecdFieldMutation m denv rfinfo;
+ CheckRecdFieldMutation m denv rfinfo
let argExpr = coerceExpr false calledArgTy callerArgTy m argExpr
let action = BuildRecdFieldSet cenv.g m objExpr rfinfo argExpr
action, Item.RecdField rfinfo
// Record the resolution for the Language Service
let item = Item.SetterArg (id, defnItem)
- CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad);
+ CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,ad)
mkCompGenSequential m acc action)
@@ -8993,61 +9123,125 @@ and TcMethodApplication
let expr = optArgPreBinder expr
let expr = objArgPreBinder expr
- (expr,attributeAssignedNamedItems,delayed),tpenv
+ (expr,finalAttributeAssignedNamedItems,delayed),tpenv
-and TcMethodArgs cenv env tpenv args =
- List.mapfoldSquared (TcMethodArg cenv env) tpenv args
-
-and TcMethodArg cenv env tpenv (CallerArg(ty,m,isOpt,e)) =
- let e',tpenv = TcExpr cenv ty env tpenv e
- CallerArg(ty,m,isOpt,e'),tpenv
-
-and TcMethodNamedArgs cenv env tpenv args =
- List.mapfoldSquared (TcMethodNamedArg cenv env) tpenv args
-
-and TcMethodNamedArg cenv env tpenv (CallerNamedArg(id,arg)) =
- let arg',tpenv = TcMethodArg cenv env tpenv arg
- CallerNamedArg(id,arg'),tpenv
+and TcUnnamedMethodArgs cenv env lambdaPropagationInfo tpenv args =
+ List.mapiFoldSquared (TcUnnamedMethodArg cenv env) (lambdaPropagationInfo,tpenv) args
+
+and TcUnnamedMethodArg cenv env (lambdaPropagationInfo,tpenv) (i,j,CallerArg(argTy,mArg,isOpt,argExpr)) =
+ // Try to find the lambda propagation info for the corresponding unnamed argument at this position
+ let lambdaPropagationInfoForArg =
+ [| for (unnamedInfo,_) in lambdaPropagationInfo ->
+ if i < unnamedInfo.Length && j < unnamedInfo.[i].Length then unnamedInfo.[i].[j] else NoInfo |]
+ TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoForArg,CallerArg(argTy,mArg,isOpt,argExpr))
+
+and TcMethodNamedArgs cenv env lambdaPropagationInfo tpenv args =
+ List.mapFoldSquared (TcMethodNamedArg cenv env) (lambdaPropagationInfo,tpenv) args
+
+and TcMethodNamedArg cenv env (lambdaPropagationInfo,tpenv) (CallerNamedArg(id,arg)) =
+ // Try to find the lambda propagation info for the corresponding named argument
+ let lambdaPropagationInfoForArg =
+ [| for (_,namedInfo) in lambdaPropagationInfo ->
+ namedInfo |> Array.tryPick (fun namedInfoForArgSet ->
+ namedInfoForArgSet |> Array.tryPick (fun (nm,info) ->
+ if nm.idText = id.idText then Some info else None)) |]
+ |> Array.map (fun x -> defaultArg x NoInfo)
+
+ let arg',(lambdaPropagationInfo,tpenv) = TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoForArg,arg)
+ CallerNamedArg(id,arg'),(lambdaPropagationInfo,tpenv)
+
+and TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoForArg,CallerArg(argTy,mArg,isOpt,argExpr)) =
+
+ // Apply the F# 3.1 rule for extracting information for lambdas
+ //
+ // Before we check the argume, check to see if we can propagate info from a called lambda expression into the arguments of a received lambda
+ begin
+ if lambdaPropagationInfoForArg.Length > 0 then
+ let allOverloadsAreFuncOrMismatchForThisArg =
+ lambdaPropagationInfoForArg |> Array.forall (function ArgDoesNotMatch | CallerLambdaHasArgTypes _ -> true | NoInfo | CalledArgMatchesType _ -> false)
+
+ if allOverloadsAreFuncOrMismatchForThisArg then
+ let overloadsWhichAreFuncAtThisPosition = lambdaPropagationInfoForArg |> Array.choose (function CallerLambdaHasArgTypes r -> Some r | _ -> None)
+ if overloadsWhichAreFuncAtThisPosition.Length > 0 then
+ let minFuncArity = overloadsWhichAreFuncAtThisPosition |> Array.minBy List.length |> List.length
+ let prefixOfLambdaArgsForEachOverload = overloadsWhichAreFuncAtThisPosition |> Array.map (Array.take minFuncArity)
+
+ if prefixOfLambdaArgsForEachOverload.Length > 0 then
+ let numLambdaVars = prefixOfLambdaArgsForEachOverload.[0].Length
+ // Fold across the lambda var positions checking if all method overloads imply the same argument type for a lambda variable.
+ // If so, force the caller to have a function type that looks like the calledLambdaArgTy.
+ // The loop variable callerLambdaTyOpt becomes None if something failed.
+ let rec loop callerLambdaTy lambdaVarNum =
+ if lambdaVarNum < numLambdaVars then
+ let col = [ for row in prefixOfLambdaArgsForEachOverload -> row.[lambdaVarNum] ]
+ // Check if all the rows give the same argument type
+ if col |> ListSet.setify (typeEquiv cenv.g) |> List.length |> ((=) 1) then
+ let calledLambdaArgTy = col.[0]
+ // Force the caller to be a function type.
+ match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv mArg callerLambdaTy with
+ | Some (callerLambdaDomainTy,callerLambdaRangeTy) ->
+ if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then
+ loop callerLambdaRangeTy (lambdaVarNum + 1)
+ | None -> ()
+ loop argTy 0
+ end
+
+ let e',tpenv = TcExpr cenv argTy env tpenv argExpr
+
+ // After we have checked, propagate the info from argument into the overloads that receive it.
+ //
+ // Filter out methods where an argument doesn't match. This just filters them from lambda propagation but not from
+ // later method overload resolution.
+ let lambdaPropagationInfo =
+ [| for (info, argInfo) in Array.zip lambdaPropagationInfo lambdaPropagationInfoForArg do
+ match argInfo with
+ | ArgDoesNotMatch _ -> ()
+ | NoInfo | CallerLambdaHasArgTypes _ ->
+ yield info
+ | CalledArgMatchesType adjustedCalledTy ->
+ if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv cenv.css mArg adjustedCalledTy argTy then
+ yield info |]
+
+ CallerArg(argTy,mArg,isOpt,e'),(lambdaPropagationInfo,tpenv)
/// Typecheck "new Delegate(fun x y z -> ...)" constructs
and TcNewDelegateThen cenv overallTy env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed =
let ad = env.eAccessRights
- UnifyTypes cenv env mExprAndArg overallTy delegateTy;
+ UnifyTypes cenv env mExprAndArg overallTy delegateTy
let (SigOfFunctionForDelegate(invokeMethInfo,delArgTys,_,fty)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad
// We pass isInstance = true here because we're checking the rights to access the "Invoke" method
- MethInfoChecks cenv.g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo;
+ MethInfoChecks cenv.g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo
let args = GetMethodArgs arg
match args with
| [farg],[] ->
let m = arg.Range
- let (CallerArg(_,_,_,farg')),tpenv = TcMethodArg cenv env tpenv (CallerArg(fty,m,false,farg))
- let expr = BuildNewDelegateExpr (None, cenv.g, cenv.amap, delegateTy, invokeMethInfo, delArgTys, farg', fty, m)
+ let callerArg,(_,tpenv) = TcMethodArg cenv env (Array.empty,tpenv) (Array.empty,CallerArg(fty,m,false,farg))
+ let expr = BuildNewDelegateExpr (None, cenv.g, cenv.amap, delegateTy, invokeMethInfo, delArgTys, callerArg.Expr, fty, m)
PropagateThenTcDelayed cenv overallTy env tpenv m (MakeApplicableExprNoFlex cenv expr) delegateTy atomicFlag delayed
| _ ->
error(Error(FSComp.SR.tcDelegateConstructorMustBePassed(),mExprAndArg))
-and bind_letrec (binds:Bindings) m e =
+and bindLetRec (binds:Bindings) m e =
if FlatList.isEmpty binds then
e
else
Expr.LetRec (binds,e,m,NewFreeVarsCache())
-// Check for duplicate bindings in simple recursive patterns
-and checkRecursiveBindingIds binds =
- let hashOfBinds = new Dictionary<string,_>()
+/// Check for duplicate bindings in simple recursive patterns
+and CheckRecursiveBindingIds binds =
+ let hashOfBinds = new Dictionary<string,_>()
- let checkDupBinding (SynBinding.Binding(_,_,_,_,_,_,_,b,_,_,m,_)) =
- let nm =
- match b with
- | SynPat.Named(_,id,_,_,_) -> id.idText
- | SynPat.LongIdent(LongIdentWithDots([id],_),_,_,_,_,_) -> id.idText
- | _ -> ""
- if nm <> "" then
- if hashOfBinds.ContainsKey(nm) then
- error(Duplicate("value",nm,m))
- else hashOfBinds.[nm] <- b
- binds |> List.iter checkDupBinding
+ for (SynBinding.Binding(_,_,_,_,_,_,_,b,_,_,m,_)) in binds do
+ let nm =
+ match b with
+ | SynPat.Named(_,id,_,_,_) -> id.idText
+ | SynPat.LongIdent(LongIdentWithDots([id],_),_,_,_,_,_) -> id.idText
+ | _ -> ""
+ if nm <> "" then
+ if hashOfBinds.ContainsKey(nm) then
+ error(Duplicate("value",nm,m))
+ else hashOfBinds.[nm] <- b
/// Process a sequence of iterated lets "let ... in let ... in ..." in a tail recursive way
/// This avoids stack overflow on really larger "let" and "letrec" lists
@@ -9056,12 +9250,12 @@ and TcLinearLetExprs bodyChecker cenv env overallTy builder tpenv (processUseBin
if isRec then
// TcLinearLetExprs processes at most one recursive binding
- checkRecursiveBindingIds binds
+ CheckRecursiveBindingIds binds
let binds = List.map (fun x -> RecBindingDefn(ExprContainerInfo,NoNewSlots,ExpressionBinding,x)) binds
- if isUse then errorR(Error(FSComp.SR.tcBindingCannotBeUseAndRec(),m));
+ if isUse then errorR(Error(FSComp.SR.tcBindingCannotBeUseAndRec(),m))
let binds,envinner,tpenv = TcLetrec ErrorOnOverrides cenv env tpenv (binds,m,m)
let bodyExpr,tpenv = bodyChecker overallTy envinner tpenv body
- let bodyExpr = bind_letrec (FlatList.ofList binds) m bodyExpr
+ let bodyExpr = bindLetRec (FlatList.ofList binds) m bodyExpr
fst (builder (bodyExpr,overallTy)),tpenv
else
// TcLinearLetExprs processes multiple 'let' bindings in a tail recursive way
@@ -9102,13 +9296,13 @@ and TcStaticOptimizationConstraint cenv env tpenv c =
match c with
| WhenTyparTyconEqualsTycon(tp,ty,m) ->
if not cenv.g.compilingFslib then
- errorR(Error(FSComp.SR.tcStaticOptimizationConditionalsOnlyForFSharpLibrary(),m));
+ errorR(Error(FSComp.SR.tcStaticOptimizationConditionalsOnlyForFSharpLibrary(),m))
let ty',tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv ty
let tp',tpenv = TcTypar cenv env NewTyparsOK tpenv tp
TTyconEqualsTycon(mkTyparTy tp', ty'),tpenv
| WhenTyparIsStruct(tp,m) ->
if not cenv.g.compilingFslib then
- errorR(Error(FSComp.SR.tcStaticOptimizationConditionalsOnlyForFSharpLibrary(),m));
+ errorR(Error(FSComp.SR.tcStaticOptimizationConditionalsOnlyForFSharpLibrary(),m))
let tp',tpenv = TcTypar cenv env NewTyparsOK tpenv tp
TTyconIsStruct(mkTyparTy tp'),tpenv
@@ -9146,23 +9340,23 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt
let argAndRetAttribs = ArgAndRetAttribs(argAttribs, retAttribs)
if HasFSharpAttribute cenv.g cenv.g.attrib_DefaultValueAttribute valAttribs then
- errorR(Error(FSComp.SR.tcDefaultValueAttributeRequiresVal(),mBinding));
+ errorR(Error(FSComp.SR.tcDefaultValueAttributeRequiresVal(),mBinding))
let isThreadStatic = isThreadOrContextStatic cenv.g valAttribs
- if isThreadStatic then errorR(DeprecatedThreadStaticBindingWarning(mBinding));
+ if isThreadStatic then errorR(DeprecatedThreadStaticBindingWarning(mBinding))
if isVolatile then
if declKind <> ClassLetBinding then
- errorR(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),mBinding));
+ errorR(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),mBinding))
if (not isMutable || isThreadStatic) then
- errorR(Error(FSComp.SR.tcVolatileFieldsMustBeMutable(),mBinding));
+ errorR(Error(FSComp.SR.tcVolatileFieldsMustBeMutable(),mBinding))
if HasFSharpAttribute cenv.g cenv.g.attrib_DllImportAttribute valAttribs then
if not declKind.CanBeDllImport || (match memberFlagsOpt with Some memberFlags -> memberFlags.IsInstance | _ -> false) then
- errorR(Error(FSComp.SR.tcDllImportNotAllowed(),mBinding));
+ errorR(Error(FSComp.SR.tcDllImportNotAllowed(),mBinding))
if HasFSharpAttribute cenv.g cenv.g.attrib_ConditionalAttribute valAttribs && isNone(memberFlagsOpt) then
- errorR(Error(FSComp.SR.tcConditionalAttributeRequiresMembers(),mBinding));
+ errorR(Error(FSComp.SR.tcConditionalAttributeRequiresMembers(),mBinding))
if HasFSharpAttribute cenv.g cenv.g.attrib_EntryPointAttribute valAttribs then
if isSome(memberFlagsOpt) then
@@ -9170,13 +9364,13 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt
else
UnifyTypes cenv env mBinding overallTy (mkArrayType cenv.g cenv.g.string_ty --> cenv.g.int_ty)
- if isMutable && isInline then errorR(Error(FSComp.SR.tcMutableValuesCannotBeInline(),mBinding));
- if isMutable && nonNil declaredTypars then errorR(Error(FSComp.SR.tcMutableValuesMayNotHaveGenericParameters(),mBinding));
+ if isMutable && isInline then errorR(Error(FSComp.SR.tcMutableValuesCannotBeInline(),mBinding))
+ if isMutable && nonNil declaredTypars then errorR(Error(FSComp.SR.tcMutableValuesMayNotHaveGenericParameters(),mBinding))
let flex = if isMutable then dontInferTypars else flex
- if isMutable && nonNil spatsL then errorR(Error(FSComp.SR.tcMutableValuesSyntax(),mBinding));
+ if isMutable && nonNil spatsL then errorR(Error(FSComp.SR.tcMutableValuesSyntax(),mBinding))
let isInline =
if isInline && isNil spatsL && isNil declaredTypars then
- errorR(Error(FSComp.SR.tcOnlyFunctionsCanBeInline(),mBinding));
+ errorR(Error(FSComp.SR.tcOnlyFunctionsCanBeInline(),mBinding))
false
else
isInline
@@ -9205,7 +9399,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt
match apinfoOpt with
| Some (apinfo,ty,m) ->
if isSome memberFlagsOpt || (not apinfo.IsTotal && apinfo.ActiveTags.Length > 1) then
- error(Error(FSComp.SR.tcInvalidActivePatternName(),mBinding));
+ error(Error(FSComp.SR.tcInvalidActivePatternName(),mBinding))
ModifyNameResEnv (fun nenv -> AddActivePatternResultTagsToNameEnv apinfo nenv ty m) envinner
| None ->
@@ -9230,41 +9424,46 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt
tc cenv overallTy envinner tpenv rhsExpr)
if bkind = StandaloneExpression && not cenv.isScript then
- UnifyUnitType cenv env.DisplayEnv mBinding overallTy (Some rhsExpr') |> ignore<bool>;
+ UnifyUnitType cenv env.DisplayEnv mBinding overallTy (Some rhsExpr') |> ignore<bool>
// Assert the return type of an active pattern
match apinfoOpt with
| Some (apinfo,ty,_) ->
let activePatResTys = NewInferenceTypes apinfo.ActiveTags
let _,rty = stripFunTy cenv.g ty
- UnifyTypes cenv env mBinding (apinfo.ResultType cenv.g rhsExpr.Range activePatResTys) rty;
+ UnifyTypes cenv env mBinding (apinfo.ResultType cenv.g rhsExpr.Range activePatResTys) rty
| None ->
()
// Check other attributes
let hasLiteralAttr,konst = TcLiteral cenv overallTy env tpenv (valAttribs,rhsExpr)
if hasLiteralAttr && isThreadStatic then
- errorR(Error(FSComp.SR.tcIllegalAttributesForLiteral(),mBinding));
+ errorR(Error(FSComp.SR.tcIllegalAttributesForLiteral(),mBinding))
if hasLiteralAttr && isMutable then
- errorR(Error(FSComp.SR.tcLiteralCannotBeMutable(),mBinding));
+ errorR(Error(FSComp.SR.tcLiteralCannotBeMutable(),mBinding))
if hasLiteralAttr && isInline then
- errorR(Error(FSComp.SR.tcLiteralCannotBeInline(),mBinding));
+ errorR(Error(FSComp.SR.tcLiteralCannotBeInline(),mBinding))
if hasLiteralAttr && nonNil declaredTypars then
- errorR(Error(FSComp.SR.tcLiteralCannotHaveGenericParameters(),mBinding));
+ errorR(Error(FSComp.SR.tcLiteralCannotHaveGenericParameters(),mBinding))
CheckedBindingInfo(inlineFlag,true,valAttribs,doc,tcPatPhase2,flex,nameToPrelimValSchemeMap,rhsExpr',argAndRetAttribs,overallTy,mBinding,spBind,compgen,konst),tpenv
and TcLiteral cenv overallTy env tpenv (attrs,synLiteralValExpr) =
let hasLiteralAttr = HasFSharpAttribute cenv.g cenv.g.attrib_LiteralAttribute attrs
- if not hasLiteralAttr then hasLiteralAttr,None else
+ if hasLiteralAttr then
let literalValExpr,_ = TcExpr cenv overallTy env tpenv synLiteralValExpr
- let rec eval e =
- match stripExpr e with
- | Expr.Const(c,_,_) -> c
- | _ ->
- errorR(Error(FSComp.SR.tcInvalidConstantExpression(),e.Range));
- Const.Unit
- hasLiteralAttr,Some(eval literalValExpr)
+ match EvalLiteralExprOrAttribArg cenv.g literalValExpr with
+ | Expr.Const(c,_, ty) ->
+ if c = Const.Zero && isStructTy cenv.g ty then
+ warning(Error(FSComp.SR.tcIllegalStructTypeForConstantExpression(), synLiteralValExpr.Range))
+ false, None
+ else
+ true, Some c
+ | _ ->
+ errorR(Error(FSComp.SR.tcInvalidConstantExpression(),synLiteralValExpr.Range))
+ true, Some Const.Unit
+
+ else hasLiteralAttr, None
and TcBindingTyparDecls alwaysRigid cenv env tpenv (SynValTyparDecls(synTypars,infer,synTyparConstraints)) =
let declaredTypars = TcTyparDecls cenv env synTypars
@@ -9273,14 +9472,14 @@ and TcBindingTyparDecls alwaysRigid cenv env tpenv (SynValTyparDecls(synTypars,i
let rigidCopyOfDeclaredTypars =
if alwaysRigid then
- declaredTypars |> List.iter (fun tp -> SetTyparRigid cenv.g env.DisplayEnv tp.Range tp);
+ declaredTypars |> List.iter (fun tp -> SetTyparRigid cenv.g env.DisplayEnv tp.Range tp)
declaredTypars
else
let rigidCopyOfDeclaredTypars = copyTypars declaredTypars
// The type parameters used to check rigidity after inference are marked rigid straight away
- rigidCopyOfDeclaredTypars |> List.iter (fun tp -> SetTyparRigid cenv.g env.DisplayEnv tp.Range tp);
+ rigidCopyOfDeclaredTypars |> List.iter (fun tp -> SetTyparRigid cenv.g env.DisplayEnv tp.Range tp)
// The type parameters using during inference will be marked rigid after inference
- declaredTypars |> List.iter (fun tp -> tp.SetRigidity TyparRigidity.WillBeRigid);
+ declaredTypars |> List.iter (fun tp -> tp.SetRigidity TyparRigidity.WillBeRigid)
rigidCopyOfDeclaredTypars
ExplicitTyparInfo(rigidCopyOfDeclaredTypars,declaredTypars,infer) , tpenv
@@ -9322,7 +9521,7 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) =
let ad = env.eAccessRights
- if not (IsTypeAccessible cenv.g ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(),mAttr));
+ if not (IsTypeAccessible cenv.g cenv.amap mAttr ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(),mAttr))
let tcref = tcrefOfAppTy cenv.g ty
@@ -9356,8 +9555,8 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) =
match (TryFindFSharpAttribute cenv.g cenv.g.attrib_AttributeUsageAttribute tcref.Attribs) with
| Some(Attrib(_,_,[ AttribInt32Arg(validOn) ],_,_,_,_)) ->
(validOn, inheritedDefault)
- | Some(Attrib(_,_,[ AttribInt32Arg(validOn);
- AttribBoolArg(_allowMultiple);
+ | Some(Attrib(_,_,[ AttribInt32Arg(validOn)
+ AttribBoolArg(_allowMultiple)
AttribBoolArg(inherited)],_,_,_,_)) ->
(validOn, inherited)
| Some _ ->
@@ -9379,7 +9578,7 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) =
| Some id when id.idText = "constructor" -> AttributeTargets.Constructor
| Some id when id.idText = "event" -> AttributeTargets.Event
| Some id ->
- errorR(Error(FSComp.SR.tcUnrecognizedAttributeTarget(),id.idRange));
+ errorR(Error(FSComp.SR.tcUnrecognizedAttributeTarget(),id.idRange))
possibleTgts
| _ -> possibleTgts
let constrainedTgts = possibleTgts &&& directedTgts
@@ -9387,7 +9586,7 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) =
if (directedTgts = AttributeTargets.Assembly || directedTgts = AttributeTargets.Module) then
error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElementUseDo(),mAttr))
else
- error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(),mAttr));
+ error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(),mAttr))
let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty)
let attrib =
@@ -9398,46 +9597,46 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) =
let (expr,namedCallerArgs,_),_ =
TcMethodApplication true cenv env tpenv None [] mAttr mAttr methodName ad PossiblyMutates false meths afterTcOverloadResolution NormalValUse [arg] (NewInferenceType ()) []
- UnifyTypes cenv env mAttr ty (tyOfExpr cenv.g expr);
+ UnifyTypes cenv env mAttr ty (tyOfExpr cenv.g expr)
let mkAttribExpr e =
- AttribExpr(e,EvalAttribArg cenv.g e)
+ AttribExpr(e,EvalLiteralExprOrAttribArg cenv.g e)
let namedAttribArgMap =
namedCallerArgs |> List.map (fun (CallerNamedArg(id,CallerArg(argtyv,m,isOpt,expr))) ->
- if isOpt then error(Error(FSComp.SR.tcOptionalArgumentsCannotBeUsedInCustomAttribute(),m));
+ if isOpt then error(Error(FSComp.SR.tcOptionalArgumentsCannotBeUsedInCustomAttribute(),m))
let m = expr.Range
let setterItem, _ = ResolveLongIdentInType cenv.tcSink cenv.nameResolver env.NameEnv Nameres.LookupKind.Expr m ad [id] IgnoreOverrides TypeNameResolutionInfo.Default ty
let nm, isProp, argty =
match setterItem with
| Item.Property (_,[pinfo]) ->
if not pinfo.HasSetter then
- errorR(Error(FSComp.SR.tcPropertyCannotBeSet0(),m));
+ errorR(Error(FSComp.SR.tcPropertyCannotBeSet0(),m))
id.idText, true, pinfo.GetPropertyType(cenv.amap,m)
| Item.ILField finfo ->
- CheckILFieldInfoAccessible cenv.g cenv.amap m ad finfo;
- CheckILFieldAttributes cenv.g finfo m;
+ CheckILFieldInfoAccessible cenv.g cenv.amap m ad finfo
+ CheckILFieldAttributes cenv.g finfo m
id.idText,false, finfo.FieldType(cenv.amap, m)
| Item.RecdField rfinfo when not rfinfo.IsStatic ->
- CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult;
- CheckRecdFieldInfoAccessible m ad rfinfo;
+ CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult
+ CheckRecdFieldInfoAccessible cenv.amap m ad rfinfo
// This uses the F# backend name mangling of fields....
let nm = ComputeFieldName rfinfo.Tycon rfinfo.RecdField
nm,false,rfinfo.FieldType
| _ ->
- errorR(Error(FSComp.SR.tcPropertyOrFieldNotFoundInAttribute(),m));
+ errorR(Error(FSComp.SR.tcPropertyOrFieldNotFoundInAttribute(),m))
id.idText,false,cenv.g.unit_ty
let propNameItem = Item.SetterArg(id, setterItem)
- CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,propNameItem,propNameItem,ItemOccurence.Use,env.DisplayEnv,ad);
+ CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,propNameItem,propNameItem,ItemOccurence.Use,env.DisplayEnv,ad)
- AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace argty argtyv;
+ AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace argty argtyv
AttribNamedArg(nm,argty,isProp,mkAttribExpr expr))
match expr with
| Expr.Op(TOp.ILCall(_,_,valu,_,_,_,_,ilMethRef,[],[],_rtys),[],args,m) ->
- if valu then error (Error(FSComp.SR.tcCustomAttributeMustBeReferenceType(),m));
- if args.Length <> ilMethRef.ArgTypes.Length then error (Error(FSComp.SR.tcCustomAttributeArgumentMismatch(),m));
+ if valu then error (Error(FSComp.SR.tcCustomAttributeMustBeReferenceType(),m))
+ if args.Length <> ilMethRef.ArgTypes.Length then error (Error(FSComp.SR.tcCustomAttributeArgumentMismatch(),m))
let args = args |> List.map mkAttribExpr
Attrib(tcref,ILAttrib(ilMethRef),args,namedAttribArgMap,isAppliedToGetterOrSetter,Some constrainedTgts,m)
@@ -9466,12 +9665,12 @@ and TcAttributesWithPossibleTargets cenv env attrTgt synAttribs =
if HasFSharpAttribute cenv.g cenv.g.attrib_TypeForwardedToAttribute attribs ||
HasFSharpAttribute cenv.g cenv.g.attrib_CompilationArgumentCountsAttribute attribs ||
HasFSharpAttribute cenv.g cenv.g.attrib_CompilationMappingAttribute attribs then
- errorR(Error(FSComp.SR.tcUnsupportedAttribute(),synAttrib.Range));
+ errorR(Error(FSComp.SR.tcUnsupportedAttribute(),synAttrib.Range))
attribsAndTargets
with e ->
- errorRecovery e synAttrib.Range;
+ errorRecovery e synAttrib.Range
[])
and TcAttributes cenv env attrTgt synAttribs =
@@ -9494,7 +9693,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope
let (CheckedBindingInfo(_,_,_,_,_,flex,_,_,_,tauTy,_,_,_,_)) = tbinfo
let (ExplicitTyparInfo(_,declaredTypars,_)) = flex
let maxInferredTypars = (freeInTypeLeftToRight cenv.g false tauTy)
- declaredTypars @ maxInferredTypars));
+ declaredTypars @ maxInferredTypars))
let lazyFreeInEnv = lazy (GeneralizationHelpers.ComputeUngeneralizableTypars env)
@@ -9553,13 +9752,13 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope
| _ ->
let tmp,_ = mkCompGenLocal m "patternInput" (generalizedTypars +-> tauTy)
if isUse then
- errorR(Error(FSComp.SR.tcInvalidUseBinding(),m));
+ errorR(Error(FSComp.SR.tcInvalidUseBinding(),m))
// This assignment forces representation as module value, to maintain the invariant from the
// type checker that anything related to binding module-level values is marked with an
// val_repr_info, val_actual_parent and is_topbind
if (DeclKind.MustHaveArity declKind) then
- AdjustValToTopVal tmp altActualParent (InferArityOfExprBinding cenv.g tmp rhse);
+ AdjustValToTopVal tmp altActualParent (InferArityOfExprBinding cenv.g tmp rhse)
tmp,pat'
let mkRhsBind (tm,tmty) = (mkLet spBind m tmp rhse tm),tmty
@@ -9573,7 +9772,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope
let mkCleanup (tm,tmty) =
if isUse then
(allValsDefinedByPattern,(tm,tmty)) ||> FlatList.foldBack (fun v (tm,tmty) ->
- AddCxTypeMustSubsumeType denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type;
+ AddCxTypeMustSubsumeType denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type
let cleanupE = BuildDisposableCleanup cenv env m v
mkTryFinally cenv.g (tm,cleanupE,m,tmty,SequencePointInBodyOfTry,NoSequencePointAtFinally),tmty)
else
@@ -9592,7 +9791,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope
/// If bindings are linearised, then this fork is pushed to the RHS.
/// In this case, the let bindings type check to a sequence of bindings.
and TcLetBindings cenv env containerInfo declKind tpenv (binds,bindsm,scopem) =
- assert(DeclKind.ConvertToLinearBindings declKind);
+ assert(DeclKind.ConvertToLinearBindings declKind)
let mkf,env,tpenv = TcLetBinding cenv false env containerInfo declKind tpenv (binds,bindsm,scopem)
let unite = mkUnit cenv.g bindsm
let expr,_ = mkf (unite,cenv.g.unit_ty)
@@ -9606,7 +9805,7 @@ and TcLetBindings cenv env containerInfo declKind tpenv (binds,bindsm,scopem) =
and CheckMemberFlags _g optIntfSlotTy newslotsOK overridesOK memberFlags m =
if newslotsOK = NoNewSlots && memberFlags.IsDispatchSlot then
- errorR(Error(FSComp.SR.tcAbstractMembersIllegalInAugmentation(),m));
+ errorR(Error(FSComp.SR.tcAbstractMembersIllegalInAugmentation(),m))
if overridesOK = WarnOnOverrides && memberFlags.IsOverrideOrExplicitImpl && isNone optIntfSlotTy then
warning(OverrideInIntrinsicAugmentation(m))
if overridesOK = ErrorOnOverrides && memberFlags.IsOverrideOrExplicitImpl then
@@ -9634,7 +9833,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz
let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty
// We apply the type information from the patterns by type checking the
// "simple" patterns against 'domainTy'. They get re-typechecked later.
- ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv,Map.empty,Set.empty) pushedPat);
+ ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv,Map.empty,Set.empty) pushedPat)
ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, resultTy, m, tpenv, NormalizedBindingRhs (morePushedPats, retInfoOpt, e), memberFlagsOpt)
@@ -9675,14 +9874,14 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
let uniqueAbstractMethSigs =
match dispatchSlots with
| [] ->
- errorR(Error(FSComp.SR.tcNoMemberFoundForOverride(),memberId.idRange));
+ errorR(Error(FSComp.SR.tcNoMemberFoundForOverride(),memberId.idRange))
[]
| _ ->
match dispatchSlotsArityMatch with
| meths when meths |> makeUniqueBySig |> List.length = 1 -> meths
| [] ->
- errorR(Error(FSComp.SR.tcOverrideArityMismatch(),memberId.idRange));
+ errorR(Error(FSComp.SR.tcOverrideArityMismatch(),memberId.idRange))
[]
| _ -> [] // check that method to override is sealed is located at CheckOverridesAreAllUsedOnce (typrelns.fs)
// We hit this case when it is ambiguous which abstract method is being implemented.
@@ -9694,7 +9893,7 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
match uniqueAbstractMethSigs with
| uniqueAbstractMeth :: _ ->
- let uniqueAbstractMeth = InstMethInfo cenv.amap m renaming uniqueAbstractMeth
+ let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming)
let typarsFromAbsSlotAreRigid,typarsFromAbsSlot,argTysFromAbsSlot, retTyFromAbsSlot =
FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth
@@ -9703,11 +9902,11 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
let absSlotTy = mkMethodTy cenv.g argTysFromAbsSlot retTyFromAbsSlot
- UnifyTypes cenv envinner m bindingTy absSlotTy;
+ UnifyTypes cenv envinner m bindingTy absSlotTy
declaredTypars
| _ -> declaredTypars
- // Retained to ensure use of an FSComp.txt entry, can be removed at a later date: errorR(Error(FSComp.SR.tcDefaultAmbiguous(),memberId.idRange));
+ // Retained to ensure use of an FSComp.txt entry, can be removed at a later date: errorR(Error(FSComp.SR.tcDefaultAmbiguous(),memberId.idRange))
// What's the type containing the abstract slot we're implementing? Used later on in MakeMemberDataAndMangledNameForMemberVal.
// This type must be in terms of the enclosing type's formal type parameters, hence the application of revRenaming
@@ -9734,7 +9933,7 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
let uniqueAbstractPropSigs =
match dispatchSlots with
| [] when not (CompileAsEvent cenv.g attribs) ->
- errorR(Error(FSComp.SR.tcNoPropertyFoundForOverride(),memberId.idRange));
+ errorR(Error(FSComp.SR.tcNoPropertyFoundForOverride(),memberId.idRange))
[]
| [uniqueAbstractProp] -> [uniqueAbstractProp]
| _ ->
@@ -9747,17 +9946,17 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
let kIsGet = (k = MemberKind.PropertyGet)
if not (if kIsGet then uniqueAbstractProp.HasGetter else uniqueAbstractProp.HasSetter) then
- error(Error(FSComp.SR.tcAbstractPropertyMissingGetOrSet(if kIsGet then "getter" else "setter"),memberId.idRange));
+ error(Error(FSComp.SR.tcAbstractPropertyMissingGetOrSet(if kIsGet then "getter" else "setter"),memberId.idRange))
let uniqueAbstractMeth = if kIsGet then uniqueAbstractProp.GetterMethod else uniqueAbstractProp.SetterMethod
- let uniqueAbstractMeth = InstMethInfo cenv.amap m renaming uniqueAbstractMeth
+ let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming)
let _,typarsFromAbsSlot,argTysFromAbsSlot, retTyFromAbsSlot =
FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth
if nonNil typarsFromAbsSlot then
- errorR(InternalError("Unexpected generic property",memberId.idRange));
+ errorR(InternalError("Unexpected generic property",memberId.idRange))
let absSlotTy =
if (memberFlags.MemberKind = MemberKind.PropertyGet)
@@ -9766,14 +9965,10 @@ and ApplyAbstractSlotInference cenv (envinner:TcEnv) (bindingTy,m,synTyparDecls,
match argTysFromAbsSlot with
| [argTysFromAbsSlot] -> mkTupledTy cenv.g argTysFromAbsSlot --> cenv.g.unit_ty
| _ ->
- error(Error(FSComp.SR.tcInvalidSignatureForSet(),memberId.idRange));
+ error(Error(FSComp.SR.tcInvalidSignatureForSet(),memberId.idRange))
retTyFromAbsSlot --> cenv.g.unit_ty
- UnifyTypes cenv envinner m bindingTy absSlotTy);
-
-
- // Retained to ensure use of an FSComp.txt entry, can be removed at a later date: errorR(Error(FSComp.SR.tcPropertyAlreadyHasDefaultImplementation(),memberId.idRange));
- // Retained to ensure use of an FSComp.txt entry, can be removed at a later date: errorR(Error(FSComp.SR.tcPropertyImplementedIsAmbiguous(),memberId.idRange));
+ UnifyTypes cenv envinner m bindingTy absSlotTy)
// What's the type containing the abstract slot we're implementing? Used later on in MakeMemberDataAndMangledNameForMemberVal.
// This type must be in terms of the enclosing type's formal type parameters, hence the application of revRenaming.
@@ -9819,12 +10014,12 @@ and AnalyzeRecursiveStaticMemberOrValDecl (cenv, envinner: TcEnv, tpenv, declKin
| (Some(MemberOrValContainerInfo(tcref, optIntfSlotTy, baseValOpt, _safeInitInfo, declaredTyconTypars)),Some memberFlags) ->
assert (isNone(optIntfSlotTy))
- CheckMemberFlags cenv.g None newslotsOK overridesOK memberFlags id.idRange;
- CheckForNonAbstractInterface declKind tcref memberFlags id.idRange;
+ CheckMemberFlags cenv.g None newslotsOK overridesOK memberFlags id.idRange
+ CheckForNonAbstractInterface declKind tcref memberFlags id.idRange
if tcref.Deref.IsExceptionDecl &&
(memberFlags.MemberKind = MemberKind.Constructor) then
- error(Error(FSComp.SR.tcConstructorsDisallowedInExceptionAugmentation(),id.idRange));
+ error(Error(FSComp.SR.tcConstructorsDisallowedInExceptionAugmentation(),id.idRange))
let isExtrinsic = (declKind = ExtrinsicExtensionBinding)
let _,enclosingDeclaredTypars,_,objTy,thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars
@@ -9838,10 +10033,10 @@ and AnalyzeRecursiveStaticMemberOrValDecl (cenv, envinner: TcEnv, tpenv, declKin
| MemberKind.Constructor ->
// A fairly adhoc place to put this check
if tcref.IsStructOrEnumTycon && (match valSynInfo with SynValInfo([[]],_) -> true | _ -> false) then
- errorR(Error(FSComp.SR.tcStructsCannotHaveConstructorWithNoArguments(),mBinding));
+ errorR(Error(FSComp.SR.tcStructsCannotHaveConstructorWithNoArguments(),mBinding))
if not tcref.IsFSharpObjectModelTycon then
- errorR(Error(FSComp.SR.tcConstructorsIllegalForThisType(),id.idRange));
+ errorR(Error(FSComp.SR.tcConstructorsIllegalForThisType(),id.idRange))
let safeThisValOpt = MakeAndPublishSafeThisVal cenv envinner thisIdOpt thisTy
@@ -9857,7 +10052,7 @@ and AnalyzeRecursiveStaticMemberOrValDecl (cenv, envinner: TcEnv, tpenv, declKin
// This is the type we pretend a constructor has, because its implementation must ultimately appear to return a value of the given type
// This is somewhat awkward later in codegen etc.
- UnifyTypes cenv envinner mBinding ty (domainTy --> objTy);
+ UnifyTypes cenv envinner mBinding ty (domainTy --> objTy)
safeThisValOpt, baseValOpt
@@ -9882,10 +10077,10 @@ and AnalyzeRecursiveInstanceMemberDecl (cenv,envinner: TcEnv, tpenv, declKind, s
// Normal instance members.
| Some(MemberOrValContainerInfo(tcref, optIntfSlotTy, baseValOpt, _safeInitInfo, declaredTyconTypars)), Some memberFlags ->
- CheckMemberFlags cenv.g optIntfSlotTy newslotsOK overridesOK memberFlags mBinding;
+ CheckMemberFlags cenv.g optIntfSlotTy newslotsOK overridesOK memberFlags mBinding
if isSome vis && memberFlags.IsOverrideOrExplicitImpl then
- errorR(Error(FSComp.SR.tcOverridesCannotHaveVisibilityDeclarations(),memberId.idRange));
+ errorR(Error(FSComp.SR.tcOverridesCannotHaveVisibilityDeclarations(),memberId.idRange))
// Syntactically push the "this" variable across to be a lambda on the right
@@ -9904,9 +10099,9 @@ and AnalyzeRecursiveInstanceMemberDecl (cenv,envinner: TcEnv, tpenv, declKind, s
// Apply the known type of 'this'
let bindingTy = NewInferenceType ()
- UnifyTypes cenv envinner mBinding ty (thisTy --> bindingTy);
+ UnifyTypes cenv envinner mBinding ty (thisTy --> bindingTy)
- CheckForNonAbstractInterface declKind tcref memberFlags memberId.idRange;
+ CheckForNonAbstractInterface declKind tcref memberFlags memberId.idRange
// Determine if a uniquely-identified-override List.exists based on the information
// at the member signature. If so, we know the type of this member, and the full slotsig
@@ -9938,10 +10133,10 @@ and AnalyzeRecursiveDecl (cenv,envinner,tpenv,declKind,synTyparDecls,declaredTyp
| SynPat.FromParseError(pat',_) -> analyzeRecursiveDeclPat tpenv pat'
| SynPat.Typed(pat',cty,_) ->
let cty',tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType envinner tpenv cty
- UnifyTypes cenv envinner mBinding ty cty';
+ UnifyTypes cenv envinner mBinding ty cty'
analyzeRecursiveDeclPat tpenv pat'
| SynPat.Attrib(_pat',_attribs,m) ->
- error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m));
+ error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m))
//analyzeRecursiveDeclPat pat'
// This is for the construct
@@ -9986,7 +10181,7 @@ and AnalyzeAndMakeRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv
let inlineFlag = ComputeInlineFlag memberFlagsOpt isInline isMutable mBinding
- if isMutable then errorR(Error(FSComp.SR.tcOnlyRecordFieldsAndSimpleLetCanBeMutable(),mBinding));
+ if isMutable then errorR(Error(FSComp.SR.tcOnlyRecordFieldsAndSimpleLetCanBeMutable(),mBinding))
// Typecheck the typar decls, if any
@@ -10005,7 +10200,7 @@ and AnalyzeAndMakeRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv
let optArgsOK = isSome(memberFlagsOpt)
// Assert the types given in the argument patterns
- ApplyTypesFromArgumentPatterns(cenv,envinner,optArgsOK,ty,mBinding,tpenv,bindingRhs,memberFlagsOpt);
+ ApplyTypesFromArgumentPatterns(cenv,envinner,optArgsOK,ty,mBinding,tpenv,bindingRhs,memberFlagsOpt)
// Do the type annotations give the full and complete generic type?
// If so, generic recursion can be used when using this type.
@@ -10084,8 +10279,6 @@ and TcLetrecBinding
let allDeclaredTypars = enclosingDeclaredTypars @ rbind.RecBindingInfo.DeclaredTypars
- // dprintf "TcLetrec (before): tau = %s\n" (Layout.showL (typeL tau));
-
// Notes on FSharp 1.0, 3187:
// - Progressively collect the "eligible for early generalization" set of bindings -- DONE
// - After checking each binding, check this set to find generalizable bindings
@@ -10118,9 +10311,8 @@ and TcLetrecBinding
let checkedBind,tpenv =
TcNormalizedBinding declKind cenv envRec tpenv tau safeThisValOpt safeInitInfo (enclosingDeclaredTypars,flex) rbind.SyntacticBinding
- // dprintf "TcLetrec (%s, after): tau = %s\n" vspec.LogicalName (Layout.showL (typeL tau));
(try UnifyTypes cenv envRec vspec.Range (allDeclaredTypars +-> tau) vspec.Type
- with e -> error (Recursion(envRec.DisplayEnv,vspec.Id,tau,vspec.Type,vspec.Range)));
+ with e -> error (Recursion(envRec.DisplayEnv,vspec.Id,tau,vspec.Type,vspec.Range)))
// Inside the incremental class sytntax we assert the type of the 'this' variable to be precisely the same type as the
// this variable for the implicit class constructor. For static members, we assert the type variables associated
@@ -10137,12 +10329,10 @@ and TcLetrecBinding
| Some thisVal ->
reqdThisValTy, thisVal.Type, thisVal.Range
if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then
- errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName,vspec.Range));
+ errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName,vspec.Range))
- // dprintf "TcLetrec (%s, after unify): typeOfVal v = %s\n" v.LogicalName (Layout.showL (typeL v.Type));
-
- let preGeneralizationRecBind = { RecBindingInfo = rbind.RecBindingInfo;
- CheckedBinding= checkedBind;
+ let preGeneralizationRecBind = { RecBindingInfo = rbind.RecBindingInfo
+ CheckedBinding= checkedBind
ExtraGeneralizableTypars= extraGeneralizableTypars }
// Remove one binding from the unchecked list
@@ -10308,7 +10498,7 @@ and TcIncrementalLetRecGeneralization cenv scopem
else
let supportForBindings = newGeneralizableBindings |> List.collect (TcLetrecComputeSupportForBinding cenv)
- GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,scopem) supportForBindings;
+ GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,scopem) supportForBindings
let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv)
@@ -10383,7 +10573,7 @@ and TcLetrecGeneralizeBinding cenv denv generalizedTypars (pgrbind : PreGenerali
let pvalscheme2 = GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars pvalscheme1
let valscheme = UseCombinedArity cenv.g declKind expr pvalscheme2
- AdjustRecType cenv vspec valscheme;
+ AdjustRecType cenv vspec valscheme
{ ValScheme = valscheme
CheckedBinding = pgrbind.CheckedBinding
@@ -10471,7 +10661,7 @@ and TcLetrecAdjustMemberForSpecialVals cenv (pgrbind: PostGeneralizationRecursiv
let tps,vsl,body,returnTy = stripTopLambda (expr,vspec.Type)
mkMemberLambdas m tps None baseValOpt vsl (body, returnTy)
- { ValScheme = pgrbind.ValScheme;
+ { ValScheme = pgrbind.ValScheme
Binding = TBind(vspec,expr,spBind) }
and FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock (bind : PostBindCtorThisVarRefCellRecursiveBinding) =
@@ -10480,11 +10670,11 @@ and FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock (bind : PostBin
// Check coherence of generalization of variables for memberInfo members in generic classes
match vspec.MemberInfo with
#if EXTENDED_EXTENSION_MEMBERS // indicates if extension members can add additional constraints to type parameters
- | Some _ when (* not vspec.IsExtensionMember *) ->
+ | Some _ when not vspec.IsExtensionMember ->
#else
| Some _ ->
#endif
- match PartitionValTypars cenv.g vspec with
+ match PartitionValTyparsForApparentEnclosingType cenv.g vspec with
| Some(parentTypars,memberParentTypars,_,_,_) ->
ignore(SignatureConformance.Checker(cenv.g, cenv.amap, denv, SignatureRepackageInfo.Empty, false).CheckTypars vspec.Range TypeEquivEnv.Empty memberParentTypars parentTypars)
| None ->
@@ -10494,13 +10684,11 @@ and FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock (bind : PostBin
// Fixup recursive references...
let fixupPoints = GetAllUsesOfRecValue cenv vspec
- AdjustAndForgetUsesOfRecValue cenv (mkLocalValRef vspec) bind.ValScheme;
-
- // dprintf "TcLetrec (%s, after gen): #fixupPoints = %d, ty = %s\n" vspec.LogicalName (List.length fixupPoints) (Layout.showL (typeL vspec.Type));
+ AdjustAndForgetUsesOfRecValue cenv (mkLocalValRef vspec) bind.ValScheme
let expr = mkGenericBindRhs cenv.g vspec.Range generalizedTyparsForRecursiveBlock bind.ValScheme.TypeScheme expr
- { FixupPoints = fixupPoints;
+ { FixupPoints = fixupPoints
Binding = TBind(vspec,expr,spBind) }
//-------------------------------------------------------------------------
@@ -10603,18 +10791,17 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF
| None ->
let hasLiteralAttr = HasFSharpAttribute cenv.g cenv.g.attrib_LiteralAttribute attrs
if hasLiteralAttr then
- errorR(Error(FSComp.SR.tcLiteralAttributeRequiresConstantValue(),m));
+ errorR(Error(FSComp.SR.tcLiteralAttributeRequiresConstantValue(),m))
None
-
- | Some(e) ->
+ | Some e ->
let hasLiteralAttr,konst = TcLiteral cenv ty env tpenv (attrs,e)
if not hasLiteralAttr then
- errorR(Error(FSComp.SR.tcValueInSignatureRequiresLiteralAttribute(), e.Range));
+ errorR(Error(FSComp.SR.tcValueInSignatureRequiresLiteralAttribute(), e.Range))
konst
let vspec = MakeAndPublishVal cenv env (altActualParent,true,declKind,ValNotInRecScope,valscheme,attrs,doc.ToXmlDoc(),konst,false)
- assert(vspec.InlineInfo = inlineFlag);
+ assert(vspec.InlineInfo = inlineFlag)
vspec,tpenv)
@@ -10636,7 +10823,7 @@ let CheckDuplicates (idf : _ -> Ident) k elems =
let id1 = (idf uc1)
let id2 = (idf uc2)
if j > i && id1.idText = id2.idText then
- errorR (Duplicate(k,id1.idText,id1.idRange))));
+ errorR (Duplicate(k,id1.idText,id1.idRange))))
elems
@@ -10663,13 +10850,13 @@ module TcRecdUnionAndEnumDeclarations = begin
let isThreadStatic = isThreadOrContextStatic cenv.g attrsForField
if isThreadStatic && (not zeroInit || not isStatic) then
- error(Error(FSComp.SR.tcThreadStaticAndContextStaticMustBeStatic(),m));
+ error(Error(FSComp.SR.tcThreadStaticAndContextStaticMustBeStatic(),m))
if isVolatile then
- error(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),m));
+ error(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),m))
- if isIncrClass && (not zeroInit || not isMutable) then errorR(Error(FSComp.SR.tcUninitializedValFieldsMustBeMutable(),m));
- if isStatic && (not zeroInit || not isMutable || vis <> Some SynAccess.Private ) then errorR(Error(FSComp.SR.tcStaticValFieldsMustBeMutableAndPrivate(),m));
+ if isIncrClass && (not zeroInit || not isMutable) then errorR(Error(FSComp.SR.tcUninitializedValFieldsMustBeMutable(),m))
+ if isStatic && (not zeroInit || not isMutable || vis <> Some SynAccess.Private ) then errorR(Error(FSComp.SR.tcStaticValFieldsMustBeMutableAndPrivate(),m))
let konst = if zeroInit then Some Const.Zero else None
let rfspec = MakeRecdFieldSpec cenv env parent (isStatic,konst,ty',attrsForProperty,attrsForField,id,isMutable,isVolatile,xmldoc,vis,m)
match parent with
@@ -10698,10 +10885,25 @@ module TcRecdUnionAndEnumDeclarations = begin
//-------------------------------------------------------------------------
let CheckUnionCaseName cenv realUnionCaseName m =
- CheckNamespaceModuleOrTypeName cenv.g (mkSynId m realUnionCaseName);
+ CheckNamespaceModuleOrTypeName cenv.g (mkSynId m realUnionCaseName)
if not (String.isUpper realUnionCaseName) && realUnionCaseName <> opNameCons && realUnionCaseName <> opNameNil then
- errorR(NotUpperCaseConstructor(m));
-
+ errorR(NotUpperCaseConstructor(m))
+
+ let ValidateFieldNames (synFields : SynField list, tastFields : RecdField list) =
+ let seen = Dictionary()
+ for (sf, f) in List.zip synFields tastFields do
+ let mutable synField = Unchecked.defaultof<_>
+ if seen.TryGetValue(f.Name, &synField) then
+ match sf, synField with
+ | Field(_, _, Some(id), _, _, _, _, _), Field(_, _, Some(_), _, _, _, _, _) ->
+ error(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(id.idText), id.idRange))
+ | Field(_, _, Some(id), _, _, _, _, _), Field(_, _, None, _, _, _, _, _)
+ | Field(_, _, None, _, _, _, _, _), Field(_, _, Some(id), _, _, _, _, _) ->
+ error(Error(FSComp.SR.tcFieldNameConflictsWithGeneratedNameForAnonymousField(id.idText), id.idRange))
+ | _ -> assert false
+ else
+ seen.Add(f.Name, sf)
+
let TcUnionCaseDecl cenv env parent thisTy tpenv (UnionCase (synAttrs,id,args,xmldoc,vis,m)) =
let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs // the attributes of a union case decl get attached to the generated "static factory" method
let vis,_ = ComputeAccessAndCompPath env None m vis parent
@@ -10721,13 +10923,15 @@ module TcRecdUnionAndEnumDeclarations = begin
match args with
| UnionCaseFields flds ->
let nFields = flds.Length
- let rfields = flds |> List.mapi (fun i fld -> TcAnonFieldDecl cenv env parent tpenv (mkName nFields i) fld)
+ let rfields = flds |> List.mapi (fun i fld -> TcAnonFieldDecl cenv env parent tpenv (mkName nFields i) fld)
+ ValidateFieldNames(flds, rfields)
+
rfields,thisTy
| UnionCaseFullType (ty,arity) ->
let ty',_ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty
let argtysl,recordTy = GetTopTauTypeInFSharpForm cenv.g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos ty' m
if argtysl.Length > 1 then
- errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(),m));
+ errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(),m))
let argtys = argtysl |> List.concat
let nFields = argtys.Length
let rfields =
@@ -10754,7 +10958,7 @@ module TcRecdUnionAndEnumDeclarations = begin
let v = TcConst cenv fieldTy m env v
let vis,_ = ComputeAccessAndCompPath env None m None parent
let vis = CombineReprAccess parent vis
- if id.idText = "value__" then errorR(Error(FSComp.SR.tcNotValidEnumCaseName(),id.idRange));
+ if id.idText = "value__" then errorR(Error(FSComp.SR.tcNotValidEnumCaseName(),id.idRange))
NewRecdField true (Some v) id thisTy false false [] attrs (xmldoc.ToXmlDoc()) vis false
let TcEnumDecls cenv env parent thisTy enumCases =
@@ -10769,10 +10973,10 @@ end
//-------------------------------------------------------------------------
let PublishInterface cenv denv (tcref:TyconRef) m compgen ty' =
- if not (isInterfaceTy cenv.g ty') then errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalStringOfType denv ty'),m));
+ if not (isInterfaceTy cenv.g ty') then errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalStringOfType denv ty'),m))
let tcaug = tcref.TypeContents
if tcref.HasInterface cenv.g ty' then
- errorR(Error(FSComp.SR.tcDuplicateSpecOfInterface(),m));
+ errorR(Error(FSComp.SR.tcDuplicateSpecOfInterface(),m))
tcaug.tcaug_interfaces <- (ty',compgen,m) :: tcaug.tcaug_interfaces
let TcAndPublishMemberSpec cenv env containerInfo declKind tpenv memb =
@@ -10796,14 +11000,15 @@ let TcTyconMemberSpecs cenv env containerInfo declKind tpenv (augSpfn: SynMember
// Bind 'open' declarations
//-------------------------------------------------------------------------
-let TcModuleOrNamespaceLidAndPermitAutoResolve env longId =
+let TcModuleOrNamespaceLidAndPermitAutoResolve env amap (longId : Ident list) =
let ad = env.eAccessRights
- match ResolveLongIndentAsModuleOrNamespace OpenQualified env.eNameResEnv ad longId with
+ let m = longId |> List.map(fun id -> id.idRange) |> List.reduce unionRanges
+ match ResolveLongIndentAsModuleOrNamespace amap m OpenQualified env.eNameResEnv ad longId with
| Result res -> Result res
| Exception err -> raze err
let TcOpenDecl tcSink g amap m scopem env (longId : Ident list) =
- let modrefs = ForceRaise (TcModuleOrNamespaceLidAndPermitAutoResolve env longId)
+ let modrefs = ForceRaise (TcModuleOrNamespaceLidAndPermitAutoResolve env amap longId)
// validate opened namespace names
longId |> List.filter (fun id -> id.idText <> MangledGlobalName) |> List.iter (CheckNamespaceModuleOrTypeName g)
@@ -10827,7 +11032,7 @@ let TcOpenDecl tcSink g amap m scopem env (longId : Ident list) =
if IsPartiallyQualifiedNamespace modref then
errorR(Error(FSComp.SR.tcOpenUsedWithPartiallyQualifiedPath(fullDisplayTextOfModRef modref),m)))
- modrefs |> List.iter (fun (_,modref,_) -> CheckEntityAttributes g modref m |> CommitOperationResult);
+ modrefs |> List.iter (fun (_,modref,_) -> CheckEntityAttributes g modref m |> CommitOperationResult)
let env = OpenModulesOrNamespaces tcSink g amap scopem env (List.map p23 modrefs)
env
@@ -10846,31 +11051,31 @@ module IncrClassChecking = begin
/// Typechecked info for implicit constructor and it's arguments
type IncrClassCtorLhs =
{/// The TyconRef for the type being defined
- TyconRef : TyconRef;
+ TyconRef : TyconRef
/// The type parameters allocated for the implicit instance constructor.
/// These may be equated with other (WillBeRigid) type parameters through equirecursive inference, and so
/// should always be renormalized/canonicalized when used.
- InstanceCtorDeclaredTypars : Typars;
+ InstanceCtorDeclaredTypars : Typars
/// The value representing the static implicit constructor.
/// Lazy to ensure the static ctor value is ony published if needed.
- StaticCtorValInfo : Lazy<(Val list * Val * ValScheme)>;
+ StaticCtorValInfo : Lazy<(Val list * Val * ValScheme)>
/// The value representing the implicit constructor.
- InstanceCtorVal : Val;
+ InstanceCtorVal : Val
/// The type of the implicit constructor, representing as a ValScheme.
- InstanceCtorValScheme : ValScheme;
+ InstanceCtorValScheme : ValScheme
/// The values representing the arguments to the implicit constructor.
- InstanceCtorArgs : Val list;
+ InstanceCtorArgs : Val list
/// The reference cell holding the 'this' parameter within the implicit constructor so it can be referenced in the
/// arguments passed to the base constructor
- InstanceCtorSafeThisValOpt : Val option;
+ InstanceCtorSafeThisValOpt : Val option
/// Data indicating if safe-initialization checks need to be inserted for this type.
- InstanceCtorSafeInitInfo : SafeInitData;
+ InstanceCtorSafeInitInfo : SafeInitData
/// The value representing the 'base' variable within the implicit instance constructor.
- InstanceCtorBaseValOpt : Val option;
+ InstanceCtorBaseValOpt : Val option
/// The value representing the 'this' variable within the implicit instance constructor.
- InstanceCtorThisVal : Val;
+ InstanceCtorThisVal : Val
/// The name generator used to generate the names of fields etc. within the type.
- NameGenerator : NiceNameGenerator;
+ NameGenerator : NiceNameGenerator
}
/// Get the type parameters of the implicit constructor, after taking equi-recursive inference into account.
member ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv denv m =
@@ -10898,7 +11103,7 @@ module IncrClassChecking = begin
let _,vspecs = MakeSimpleVals cenv env names
if tcref.IsStructOrEnumTycon && isNil spats then
- errorR (ParameterlessStructCtor(tcref.Range));
+ errorR (ParameterlessStructCtor(tcref.Range))
// Put them in order
let ctorArgs = List.map (fun v -> NameMap.find v vspecs) ctorArgNames
@@ -10918,7 +11123,7 @@ module IncrClassChecking = begin
let valSynData = SynValInfo([synArgInfos],SynInfo.unnamedRetVal)
let id = ident ("new",m)
- CheckForNonAbstractInterface ModuleOrMemberBinding tcref memberFlags id.idRange;
+ CheckForNonAbstractInterface ModuleOrMemberBinding tcref memberFlags id.idRange
let memberInfo = MakeMemberDataAndMangledNameForMemberVal(cenv.g,tcref,false,attribs,[],memberFlags,valSynData,id,false)
let partialValReprInfo = TranslateTopValSynInfo m (TcAttributes cenv env) valSynData
let prelimTyschemeG = TypeScheme(copyOfTyconTypars,ctorTy)
@@ -10938,7 +11143,7 @@ module IncrClassChecking = begin
let cctorTy = mkFunTy cenv.g.unit_ty cenv.g.unit_ty
let valSynData = SynValInfo([[]],SynInfo.unnamedRetVal)
let id = ident ("cctor",m)
- CheckForNonAbstractInterface ModuleOrMemberBinding tcref ClassCtorMemberFlags id.idRange;
+ CheckForNonAbstractInterface ModuleOrMemberBinding tcref ClassCtorMemberFlags id.idRange
let memberInfo = MakeMemberDataAndMangledNameForMemberVal(cenv.g,tcref,false,[(*no attributes*)],[],ClassCtorMemberFlags,valSynData,id,false)
let partialValReprInfo = TranslateTopValSynInfo m (TcAttributes cenv env) valSynData
let prelimTyschemeG = TypeScheme(copyOfTyconTypars,cctorTy)
@@ -10955,16 +11160,16 @@ module IncrClassChecking = begin
let thisVal = MakeAndPublishVal cenv env (ParentNone,false,ClassLetBinding,ValNotInRecScope,thisValScheme,[],XmlDoc.Empty,None,false)
thisVal
- {TyconRef = tcref;
- InstanceCtorDeclaredTypars = copyOfTyconTypars;
- StaticCtorValInfo = cctorValInfo;
- InstanceCtorArgs = ctorArgs;
- InstanceCtorVal = ctorVal;
- InstanceCtorValScheme = ctorValScheme;
- InstanceCtorBaseValOpt = baseValOpt;
- InstanceCtorSafeThisValOpt = safeThisValOpt;
- InstanceCtorSafeInitInfo = safeInitInfo;
- InstanceCtorThisVal = thisVal;
+ {TyconRef = tcref
+ InstanceCtorDeclaredTypars = copyOfTyconTypars
+ StaticCtorValInfo = cctorValInfo
+ InstanceCtorArgs = ctorArgs
+ InstanceCtorVal = ctorVal
+ InstanceCtorValScheme = ctorValScheme
+ InstanceCtorBaseValOpt = baseValOpt
+ InstanceCtorSafeThisValOpt = safeThisValOpt
+ InstanceCtorSafeInitInfo = safeInitInfo
+ InstanceCtorThisVal = thisVal
// For generating names of local fields
NameGenerator = NiceNameGenerator()
@@ -11001,17 +11206,17 @@ module IncrClassChecking = begin
/// type defined with implicit class construction.
type IncrClassReprInfo =
{ /// Indicates the set of field names taken within one incremental class
- TakenFieldNames:Set<string>;
- RepInfoTcGlobals:TcGlobals;
+ TakenFieldNames:Set<string>
+ RepInfoTcGlobals:TcGlobals
/// vals mapped to representations
- ValReprs : Zmap<Val,IncrClassValRepr>;
+ ValReprs : Zmap<Val,IncrClassValRepr>
/// vals represented as fields or members from this point on
- ValsWithRepresentation : Val Zset; }
+ ValsWithRepresentation : Zset<Val> }
static member Empty(g,names) =
- { TakenFieldNames=Set.ofList names;
- RepInfoTcGlobals=g;
- ValReprs = Zmap.empty valOrder;
+ { TakenFieldNames=Set.ofList names
+ RepInfoTcGlobals=g
+ ValReprs = Zmap.empty valOrder
ValsWithRepresentation = Zset.empty valOrder }
/// Find the representation of a value
@@ -11128,7 +11333,7 @@ module IncrClassChecking = begin
let repr,takenFieldNames = localRep.ChooseRepresentation (cenv,env,isStatic,isCtorArg,ctorInfo,staticForcedFieldVars,instanceForcedFieldVars,localRep.TakenFieldNames,bind )
// OK, representation chosen, now add it
{localRep with
- TakenFieldNames=takenFieldNames;
+ TakenFieldNames=takenFieldNames
ValReprs = Zmap.add v repr localRep.ValReprs}
member localRep.ValNowWithRepresentation (v:Val) =
@@ -11272,7 +11477,7 @@ module IncrClassChecking = begin
Some (localRep.MakeValueGetAddress thisValOpt thisTyInst safeStaticInitInfo v m)
| _ -> None
- Tastops.RewriteExpr { PreIntercept=Some FixupExprNode;
+ Tastops.RewriteExpr { PreIntercept=Some FixupExprNode
PostTransform = (fun _ -> None)
IsUnderQuotations=true } expr
@@ -11308,7 +11513,7 @@ module IncrClassChecking = begin
let m = thisVal.Range
let ctorDeclaredTypars = ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv denv m
- ctorDeclaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m) ;
+ ctorDeclaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m)
// Reconstitute the type with the correct quantified type variables.
ctorInfo.InstanceCtorVal.SetType (tryMkForallTy ctorDeclaredTypars ctorInfo.InstanceCtorVal.TauType)
@@ -11375,7 +11580,7 @@ module IncrClassChecking = begin
// 'let' or 'let rec' binding in the implicit class construction sequence
let TransBind (reps:IncrClassReprInfo) (TBind(v,rhsExpr,spBind)) =
if v.MustInline then
- error(Error(FSComp.SR.tcLocalClassBindingsCannotBeInline(),v.Range));
+ error(Error(FSComp.SR.tcLocalClassBindingsCannotBeInline(),v.Range))
let rhsExpr = reps.FixupIncrClassExprPassC (Some thisVal) safeStaticInitInfo thisTyInst rhsExpr
// The initialization of the 'ref cell' variable for 'this' is the only binding which comes prior to the super init
@@ -11452,7 +11657,6 @@ module IncrClassChecking = begin
let actions,methodBinds = binds |> List.map (TransBind reps) |> List.unzip // since can occur in RHS of own defns
actions,reps,methodBinds
else
- if debug then dprintf "TransDec: %d bindings, isRec=%b\n" binds.Length isRec;
let actions,methodBinds = binds |> List.map (TransBind reps) |> List.unzip
let reps = (reps,binds) ||> List.fold (fun rep bind -> rep.ValNowWithRepresentation bind.Var) // inscope after
actions,reps,methodBinds
@@ -11732,13 +11936,13 @@ module TyconBindingChecking = begin
let (TyconBindingDefn(containerInfo,newslotsOK,declKind,classMemberDef,m)) = defn
let (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) = innerState
- if tcref.IsTypeAbbrev then error(Error(FSComp.SR.tcTypeAbbreviationsMayNotHaveMembers(),(trimRangeToLine m))); // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx
- if tcref.IsEnumTycon then error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(),(trimRangeToLine m))); // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx
+ if tcref.IsTypeAbbrev then error(Error(FSComp.SR.tcTypeAbbreviationsMayNotHaveMembers(),(trimRangeToLine m))) // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx
+ if tcref.IsEnumTycon && (declKind <> ExtrinsicExtensionBinding) then error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(),(trimRangeToLine m))) // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx
match classMemberDef, containerInfo with
| SynMemberDefn.ImplicitCtor (vis,attrs,spats,thisIdOpt, m), ContainerInfo(_,Some(MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _))) ->
- match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> ();
+ match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> ()
// PassA: make incrClassCtorLhs - ctorv, thisVal etc, type depends on argty(s)
let incrClassCtorLhs = TcImplictCtorLhsPassA(cenv,env,tpenv,tcref,vis,attrs,spats,thisIdOpt,baseValOpt,safeInitInfo,m,copyOfTyconTypars,objTy,thisTy)
@@ -11749,7 +11953,7 @@ module TyconBindingChecking = begin
[PassAIncrClassCtor incrClassCtorLhs],innerState
| SynMemberDefn.ImplicitInherit (typ,arg,_baseIdOpt,m),_ ->
- match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> ();
+ match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> ()
// PassA: inherit typ(arg) as base - pass through
// PassA: pick up baseValOpt!
let baseValOpt = incrClassCtorLhsOpt |> Option.bind (fun x -> x.InstanceCtorBaseValOpt)
@@ -11761,21 +11965,21 @@ module TyconBindingChecking = begin
| SynMemberDefn.LetBindings (letBinds,isStatic,isRec,m),_ ->
match tcref.TypeOrMeasureKind,isStatic with
| TyparKind.Measure,false -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m))
- | _,_ -> ();
+ | _,_ -> ()
if tcref.IsStructOrEnumTycon && not isStatic then
let allDo = letBinds |> List.forall (function (Binding(_,DoBinding,_,_,_,_,_,_,_,_,_,_)) -> true | _ -> false)
// Code for potential future design change to allow functions-compiled-as-members in structs
//let allFun = letBinds |> List.forall (function (Binding(_,NormalBinding,_,_,_,_,SynValData(_,info,_),_,_,_,_,_)) -> not (SynInfo.HasNoArgs info) | _ -> false)
if allDo then
- errorR(Deprecated(FSComp.SR.tcStructsMayNotContainDoBindings(),(trimRangeToLine m)));
+ errorR(Deprecated(FSComp.SR.tcStructsMayNotContainDoBindings(),(trimRangeToLine m)))
else
// Code for potential future design change to allow functions-compiled-as-members in structs
//elif not allFun then
- errorR(Error(FSComp.SR.tcStructsMayNotContainLetBindings(),(trimRangeToLine m)));
+ errorR(Error(FSComp.SR.tcStructsMayNotContainLetBindings(),(trimRangeToLine m)))
if isStatic && isNone incrClassCtorLhsOpt then
- errorR(Error(FSComp.SR.tcStaticLetBindingsRequireClassesWithImplicitConstructors(),m));
+ errorR(Error(FSComp.SR.tcStaticLetBindingsRequireClassesWithImplicitConstructors(),m))
// PassA: let-bindings - pass through
let innerState = (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev)
@@ -11791,7 +11995,7 @@ module TyconBindingChecking = begin
match memberFlagsOpt with
| None -> ()
| Some memberFlags ->
- if memberFlags.IsInstance then error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m));
+ if memberFlags.IsInstance then error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m))
match memberFlags.MemberKind with
| MemberKind.Constructor -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembersNotConstructors(), m))
| _ -> ()
@@ -11889,7 +12093,7 @@ module TyconBindingChecking = begin
// Set up the environment so use-before-definition warnings are given, at least
// until we reach a PassAIncrClassCtorJustAfterSuperInit.
- let envForTycon = { envForTycon with eCtorInfo = Some (InitialImplicitCtorInfo()); }
+ let envForTycon = { envForTycon with eCtorInfo = Some (InitialImplicitCtorInfo()) }
// Loop through the definition elements in a type...
// State:
@@ -11959,14 +12163,14 @@ module TyconBindingChecking = begin
for bind in binds do
if HasFSharpAttribute cenv.g cenv.g.attrib_DllImportAttribute bind.Var.Attribs && not isStatic then
- errorR(Error(FSComp.SR.tcDllImportNotAllowed(),bind.Var.Range));
+ errorR(Error(FSComp.SR.tcDllImportNotAllowed(),bind.Var.Range))
let nm = bind.Var.DisplayName
let ty = generalizedTyconRef tcref
match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty,
TryFindPropInfo cenv.infoReader bind.Var.Range ad nm ty with
| [],[] -> ()
- | _ -> errorR (Error(FSComp.SR.tcMemberAndLocalClassBindingHaveSameName(nm),bind.Var.Range));
+ | _ -> errorR (Error(FSComp.SR.tcMemberAndLocalClassBindingHaveSameName(nm),bind.Var.Range))
// Also add static entries to the envInstance if necessary
let envInstance = (if isStatic then (binds,envInstance) ||> List.foldBack (fun b e -> AddLocalVal cenv.tcSink scopem b.Var e) else env)
@@ -12053,7 +12257,7 @@ module TyconBindingChecking = begin
| PassBIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) ->
let valscheme = incrClassCtorLhs.InstanceCtorValScheme
let valscheme = ChooseCanonicalValSchemeAfterInference cenv.g denv valscheme scopem
- AdjustRecType cenv incrClassCtorLhs.InstanceCtorVal valscheme;
+ AdjustRecType cenv incrClassCtorLhs.InstanceCtorVal valscheme
PassCIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt),tpenv
| PassBInherit (inheritsExpr,basevOpt) ->
@@ -12196,7 +12400,7 @@ module TyconBindingChecking = begin
FixupLetrecBind cenv envInitial.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] )
// Publish the fields of the representation to the type
- localReps.PublishIncrClassFields (cenv, denv, cpath, incrClassCtorLhs, safeStaticInitInfo); (* mutation *)
+ localReps.PublishIncrClassFields (cenv, denv, cpath, incrClassCtorLhs, safeStaticInitInfo) (* mutation *)
// Fixup members
let memberBindsWithFixups =
@@ -12229,18 +12433,29 @@ module TyconBindingChecking = begin
/// Main routine
let TcTyconBindings cenv (env: TcEnv) tpenv bindsm scopem (bindsl : TyconBindingDefns list) =
+ let g = cenv.g
let ad = env.eAccessRights
let denv = env.DisplayEnv
let envInitial = env
let env = () // hide this to make sure it is not used inadvertently
env |> ignore // mark it as used
+ let tcrefsWithCSharpExtensionMembers =
+ bindsl |> List.choose (fun (TyconBindingDefns(tcref, _, declKind, _)) ->
+ if TyconRefHasAttribute g scopem g.attrib_ExtensionAttribute tcref && (declKind <> DeclKind.ExtrinsicExtensionBinding) then
+ Some tcref
+ else
+ None)
+
+ // Re-add the any tycons to get any C#-style extension members
+ let envInternal = AddLocalTyconRefs true g cenv.amap scopem tcrefsWithCSharpExtensionMembers envInitial
+
// PassA: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals
// PassA: also processes their arg patterns - collecting type assertions
- let (defnsAs, prelimRecValues, uncheckedRecBinds, tpenv) = TcTyconBindings_PassA_CreateRecursiveValuesAndCheckArgumentPatterns cenv envInitial tpenv bindsl
+ let (defnsAs, prelimRecValues, uncheckedRecBinds, tpenv) = TcTyconBindings_PassA_CreateRecursiveValuesAndCheckArgumentPatterns cenv envInternal tpenv bindsl
// PassB: type check pass, convert from ast to tast and collects type assertions, and generalize
- let defnsBs, generalizedRecBinds, tpenv = TcTyconBindings_PassB_TypeCheckAndIncrementalGeneralization cenv envInitial tpenv (ad, defnsAs, prelimRecValues, uncheckedRecBinds, scopem)
+ let defnsBs, generalizedRecBinds, tpenv = TcTyconBindings_PassB_TypeCheckAndIncrementalGeneralization cenv envInternal tpenv (ad, defnsAs, prelimRecValues, uncheckedRecBinds, scopem)
let generalizedTyparsForRecursiveBlock =
@@ -12266,7 +12481,7 @@ module TyconBindingChecking = begin
for extraTypar in allExtraGeneralizableTypars do
if Zset.memberOf freeInInitialEnv extraTypar then
let ty = mkTyparTy extraTypar
- error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty),extraTypar.Range));
+ error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty),extraTypar.Range))
// Solve any type variables in any part of the overall type signature of the class whose
// constraints involve generalized type variables.
@@ -12323,8 +12538,10 @@ module TyconBindingChecking = begin
let binds = binds @ methodBinds
// Post letrec env
- let envbody = AddLocalVals cenv.tcSink scopem prelimRecValues envInitial
- binds,envbody,tpenv
+ let envFinal = AddLocalTyconRefs false g cenv.amap scopem tcrefsWithCSharpExtensionMembers envInitial
+ let envFinal = AddLocalVals cenv.tcSink scopem prelimRecValues envFinal
+
+ binds,envFinal,tpenv
end
@@ -12339,26 +12556,26 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers =
| SynMemberDefn.Interface(ity,defnOpt,_) ->
let _,typ = if tcref.Deref.IsExceptionDecl then [],cenv.g.exn_ty else generalizeTyconRef tcref
let m = ity.Range
- if tcref.IsTypeAbbrev then error(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveInterfaceDeclaration(),m));
- if tcref.IsEnumTycon then error(Error(FSComp.SR.tcEnumerationsCannotHaveInterfaceDeclaration(),m));
+ if tcref.IsTypeAbbrev then error(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveInterfaceDeclaration(),m))
+ if tcref.IsEnumTycon then error(Error(FSComp.SR.tcEnumerationsCannotHaveInterfaceDeclaration(),m))
let ity' =
let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars env
TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner emptyUnscopedTyparEnv ity |> fst
- if not (isInterfaceTy cenv.g ity') then errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType0(),ity.Range));
+ if not (isInterfaceTy cenv.g ity') then errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType0(),ity.Range))
if not (tcref.HasInterface cenv.g ity') then
- error(Error(FSComp.SR.tcAllImplementedInterfacesShouldBeDeclared(),ity.Range));
+ error(Error(FSComp.SR.tcAllImplementedInterfacesShouldBeDeclared(),ity.Range))
if (typeEquiv cenv.g ity' cenv.g.mk_IComparable_ty && isSome tcref.GeneratedCompareToValues) ||
(typeEquiv cenv.g ity' cenv.g.mk_IStructuralComparable_ty && isSome tcref.GeneratedCompareToWithComparerValues) ||
(typeEquiv cenv.g ity' ((mkAppTy cenv.g.system_GenericIComparable_tcref [typ])) && isSome tcref.GeneratedCompareToValues) ||
(typeEquiv cenv.g ity' ((mkAppTy cenv.g.system_GenericIEquatable_tcref [typ])) && isSome tcref.GeneratedHashAndEqualsWithComparerValues) ||
(typeEquiv cenv.g ity' cenv.g.mk_IStructuralEquatable_ty && isSome tcref.GeneratedHashAndEqualsWithComparerValues) then
- errorR(Error(FSComp.SR.tcDefaultImplementationForInterfaceHasAlreadyBeenAdded(),ity.Range));
+ errorR(Error(FSComp.SR.tcDefaultImplementationForInterfaceHasAlreadyBeenAdded(),ity.Range))
if overridesOK = WarnOnOverrides then
- warning(IntfImplInIntrinsicAugmentation(ity.Range));
+ warning(IntfImplInIntrinsicAugmentation(ity.Range))
if overridesOK = ErrorOnOverrides then
- errorR(IntfImplInExtrinsicAugmentation(ity.Range));
+ errorR(IntfImplInExtrinsicAugmentation(ity.Range))
match defnOpt with
| Some(defn) -> [ (ity',defn,m) ]
| _-> []
@@ -12380,7 +12597,7 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers =
tyconDefnMembers |> List.iter (fun (TyconMemberData(declKind, tcref, _, _, _, members, m, newslotsOK)) ->
let tcaug = tcref.TypeContents
if tcaug.tcaug_closed && declKind <> ExtrinsicExtensionBinding then
- error(InternalError("Intrinsic augmentations of types are only permitted in the same file as the definition of the type",m));
+ error(InternalError("Intrinsic augmentations of types are only permitted in the same file as the definition of the type",m))
members |> List.iter (fun mem ->
match mem with
| SynMemberDefn.Member _ -> ()
@@ -12391,7 +12608,7 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers =
| SynMemberDefn.ImplicitCtor _ // accept implicit ctor pattern, should be first!
| SynMemberDefn.ImplicitInherit _ when newslotsOK = NewSlotsOK -> () // accept implicit ctor pattern, should be first!
// The rest should have been removed by splitting, they belong to "core" (they are "shape" of type, not implementation)
- | _ -> error(Error(FSComp.SR.tcDeclarationElementNotPermittedInAugmentation(),mem.Range))));
+ | _ -> error(Error(FSComp.SR.tcDeclarationElementNotPermittedInAugmentation(),mem.Range))))
let tyconBindingsOfTypeDefn (TyconMemberData(declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, _, newslotsOK)) =
let containerInfo = ContainerInfo(parent,Some(MemberOrValContainerInfo(tcref, None, baseValOpt, safeInitInfo, declaredTyconTypars)))
@@ -12454,23 +12671,23 @@ module AddAugmentationDeclarations = begin
let hasExplicitIStructuralComparable = tycon.HasInterface cenv.g cenv.g.mk_IStructuralComparable_ty
if hasExplicitIComparable then
- errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName),m))
elif hasExplicitGenericIComparable then
- errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName),m))
elif hasExplicitIStructuralComparable then
- errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName),m))
else
let hasExplicitGenericIComparable = tycon.HasInterface cenv.g genericIComparableTy
let cvspec1,cvspec2 = Augment.MakeValsForCompareAugmentation cenv.g tcref
let cvspec3 = Augment.MakeValsForCompareWithComparerAugmentation cenv.g tcref
- PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IStructuralComparable_ty;
- PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IComparable_ty;
+ PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IStructuralComparable_ty
+ PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IComparable_ty
if not tycon.IsExceptionDecl && not hasExplicitGenericIComparable then
- PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy;
- tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2);
- tcaug.SetCompareWith (mkLocalValRef cvspec3);
+ PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy
+ tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2)
+ tcaug.SetCompareWith (mkLocalValRef cvspec3)
PublishValueDefn cenv env ModuleOrMemberBinding cvspec1
PublishValueDefn cenv env ModuleOrMemberBinding cvspec2
PublishValueDefn cenv env ModuleOrMemberBinding cvspec3
@@ -12486,10 +12703,10 @@ module AddAugmentationDeclarations = begin
let hasExplicitIStructuralEquatable = tycon.HasInterface cenv.g cenv.g.mk_IStructuralEquatable_ty
if hasExplicitIStructuralEquatable then
- errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName),m))
else
let evspec1,evspec2,evspec3 = Augment.MakeValsForEqualityWithComparerAugmentation cenv.g tcref
- PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IStructuralEquatable_ty;
+ PublishInterface cenv env.DisplayEnv tcref m true cenv.g.mk_IStructuralEquatable_ty
tcaug.SetHashAndEqualsWith (mkLocalValRef evspec1, mkLocalValRef evspec2, mkLocalValRef evspec3)
PublishValueDefn cenv env ModuleOrMemberBinding evspec1
PublishValueDefn cenv env ModuleOrMemberBinding evspec2
@@ -12537,7 +12754,7 @@ module AddAugmentationDeclarations = begin
let hasExplicitGenericIEquatable = tcaug_has_nominal_interface cenv.g tcaug cenv.g.system_GenericIEquatable_tcref
if hasExplicitGenericIEquatable then
- errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName),m))
// Note: only provide the equals method if Equals is not implemented explicitly, and
// we're actually generating Hash/Equals for this type
@@ -12545,11 +12762,11 @@ module AddAugmentationDeclarations = begin
isSome tycon.GeneratedHashAndEqualsWithComparerValues then
let vspec1,vspec2 = Augment.MakeValsForEqualsAugmentation cenv.g tcref
- tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2);
+ tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2)
if not tycon.IsExceptionDecl then
PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy cenv.g.system_GenericIEquatable_tcref [typ])
- PublishValueDefn cenv env ModuleOrMemberBinding vspec1;
- PublishValueDefn cenv env ModuleOrMemberBinding vspec2;
+ PublishValueDefn cenv env ModuleOrMemberBinding vspec1
+ PublishValueDefn cenv env ModuleOrMemberBinding vspec2
Augment.MakeBindingsForEqualsAugmentation cenv.g tycon
else []
else []
@@ -12592,7 +12809,7 @@ module TyconConstraintInference = begin
// Within structural types, type parameters can be optimistically assumed to have comparison
// We record the ones for which we have made this assumption.
elif tycon.TyparsNoRange |> List.exists (fun tp2 -> typarRefEq tp tp2) then
- assumedTyparsAcc := (!assumedTyparsAcc).Add(tp.Stamp);
+ assumedTyparsAcc := (!assumedTyparsAcc).Add(tp.Stamp)
true
else
@@ -12632,7 +12849,7 @@ module TyconConstraintInference = begin
assumedTycons |> Set.filter (fun tyconStamp ->
let (tycon,structuralTypes) = tab.[tyconStamp]
if cenv.g.compilingFslib && Augment.TyconIsCandidateForAugmentationWithCompare cenv.g tycon && not (HasFSharpAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoComparisonAttribute tycon.Attribs) then
- errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(),tycon.Range));
+ errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(),tycon.Range))
let res = (structuralTypes |> List.forall (fst >> checkIfFieldTypeSupportsComparison tycon))
@@ -12646,9 +12863,9 @@ module TyconConstraintInference = begin
failwith "unreachble"
| Some (ty,_) ->
if isTyparTy g ty then
- errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range));
+ errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range))
else
- errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range));
+ errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range))
| Some(false) ->
()
@@ -12662,9 +12879,9 @@ module TyconConstraintInference = begin
// PERF: this call to prettyStringOfTy is always being executed, even when the warning
// is not being reported (the normal case).
if isTyparTy g ty then
- warning(Error(FSComp.SR.tcNoComparisonNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range));
+ warning(Error(FSComp.SR.tcNoComparisonNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range))
else
- warning(Error(FSComp.SR.tcNoComparisonNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range));
+ warning(Error(FSComp.SR.tcNoComparisonNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range))
res)
@@ -12718,7 +12935,7 @@ module TyconConstraintInference = begin
// Within structural types, type parameters can be optimistically assumed to have ewquality
// We record the ones for which we have made this assumption.
elif tycon.Typars(tycon.Range) |> List.exists (fun tp2 -> typarRefEq tp tp2) then
- assumedTyparsAcc := (!assumedTyparsAcc).Add(tp.Stamp);
+ assumedTyparsAcc := (!assumedTyparsAcc).Add(tp.Stamp)
true
else
false
@@ -12756,7 +12973,7 @@ module TyconConstraintInference = begin
assumedTycons |> Set.filter (fun tyconStamp ->
let (tycon,structuralTypes) = tab.[tyconStamp]
if cenv.g.compilingFslib && Augment.TyconIsCandidateForAugmentationWithEquals cenv.g tycon && not (HasFSharpAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoEqualityAttribute tycon.Attribs) then
- errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(),tycon.Range));
+ errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(),tycon.Range))
// Remove structural types with incomparable elements from the assumedTycons
let res = (structuralTypes |> List.forall (fst >> checkIfFieldTypeSupportsEquality tycon))
@@ -12772,9 +12989,9 @@ module TyconConstraintInference = begin
failwith "unreachble"
| Some (ty,_) ->
if isTyparTy g ty then
- errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range));
+ errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range))
else
- errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range));
+ errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range))
else
()
| Some(false) ->
@@ -12787,9 +13004,9 @@ module TyconConstraintInference = begin
failwith "unreachble"
| Some (ty,_) ->
if isTyparTy g ty then
- warning(Error(FSComp.SR.tcNoEqualityNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range));
+ warning(Error(FSComp.SR.tcNoEqualityNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range))
else
- warning(Error(FSComp.SR.tcNoEqualityNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range));
+ warning(Error(FSComp.SR.tcNoEqualityNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range))
res)
@@ -12819,7 +13036,7 @@ end
//-------------------------------------------------------------------------
let ComputeModuleName (longPath: Ident list) =
- if longPath.Length <> 1 then error(Error(FSComp.SR.tcInvalidModuleName(),(List.head longPath).idRange));
+ if longPath.Length <> 1 then error(Error(FSComp.SR.tcInvalidModuleName(),(List.head longPath).idRange))
longPath.Head
let CheckForDuplicateConcreteType _cenv env nm m =
@@ -12846,7 +13063,8 @@ module TcExceptionDeclarations = begin
let ad = env.eAccessRights
let args' = List.mapi (fun i fdef -> TcRecdUnionAndEnumDeclarations.TcAnonFieldDecl cenv env parent tpenv ("Data"^string i) fdef) args
- if not (String.isUpper id.idText) then errorR(NotUpperCaseConstructor(m));
+ TcRecdUnionAndEnumDeclarations.ValidateFieldNames(args, args')
+ if not (String.isUpper id.idText) then errorR(NotUpperCaseConstructor(m))
let vis,cpath = ComputeAccessAndCompPath env None m vis parent
let vis = TcRecdUnionAndEnumDeclarations.CombineReprAccess parent vis
let exnc =
@@ -12854,35 +13072,27 @@ module TcExceptionDeclarations = begin
| Some longId ->
match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with
| Item.ExnCase exnc, [] ->
- CheckTyconAccessible m env.eAccessRights exnc |> ignore;
+ CheckTyconAccessible cenv.amap m env.eAccessRights exnc |> ignore
if List.length args' <> 0 then
- errorR (Error(FSComp.SR.tcExceptionAbbreviationsShouldNotHaveArgumentList(),m));
+ errorR (Error(FSComp.SR.tcExceptionAbbreviationsShouldNotHaveArgumentList(),m))
NewExn cpath id vis (TExnAbbrevRepr exnc) attrs (doc.ToXmlDoc())
| Item.CtorGroup(_,meths) , [] ->
// REVIEW: check this really is an exception type
match args' with
| [] -> ()
- | _ -> error (Error(FSComp.SR.tcAbbreviationsFordotNetExceptionsCannotTakeArguments(),m));
+ | _ -> error (Error(FSComp.SR.tcAbbreviationsFordotNetExceptionsCannotTakeArguments(),m))
let candidates =
meths |> List.filter (fun minfo ->
minfo.NumArgs = [args'.Length] &&
minfo.GenericArity = 0)
match candidates with
| [minfo] ->
- let err() =
- Error(FSComp.SR.tcExceptionAbbreviationsMustReferToValidExceptions(),m)
- if not (TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m cenv.g.exn_ty minfo.EnclosingType) then
- errorR(err());
- let tref =
- match minfo with
- | ILMeth(_,minfo,_) -> minfo.ILTypeRef
- | FSMeth _ ->
- match (tcrefOfAppTy cenv.g minfo.EnclosingType).CompiledRepresentation with
- | CompiledTypeRepr.ILAsmNamed (tref,_,_) -> tref
- | _ ->
- error (err())
- | _ -> error (err())
- NewExn cpath id vis (TExnAsmRepr tref) attrs (doc.ToXmlDoc())
+ match minfo.EnclosingType with
+ | AppTy cenv.g (tcref,_) as ety when (TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m cenv.g.exn_ty ety) ->
+ let tref = tcref.CompiledRepresentationForNamedType
+ NewExn cpath id vis (TExnAsmRepr tref) attrs (doc.ToXmlDoc())
+ | _ ->
+ error(Error(FSComp.SR.tcExceptionAbbreviationsMustReferToValidExceptions(),m))
| _ ->
error (Error(FSComp.SR.tcAbbreviationsFordotNetExceptionsMustHaveMatchingObjectConstructor(),m))
| _ ->
@@ -12891,11 +13101,11 @@ module TcExceptionDeclarations = begin
NewExn cpath id vis (TExnFresh (MakeRecdFieldsTable args')) attrs (doc.ToXmlDoc())
let tcaug = exnc.TypeContents
- tcaug.tcaug_super <- Some cenv.g.exn_ty;
+ tcaug.tcaug_super <- Some cenv.g.exn_ty
- CheckForDuplicateConcreteType cenv env (id.idText ^ "Exception") id.idRange;
- CheckForDuplicateConcreteType cenv env id.idText id.idRange;
- PublishTypeDefn cenv env exnc;
+ CheckForDuplicateConcreteType cenv env (id.idText ^ "Exception") id.idRange
+ CheckForDuplicateConcreteType cenv env id.idText id.idRange
+ PublishTypeDefn cenv env exnc
let structuralTypes = args' |> List.map (fun rf -> (rf.FormalType, rf.Range))
let scSet = TyconConstraintInference.InferSetOfTyconsSupportingComparable cenv env [structuralTypes] [exnc]
@@ -12958,7 +13168,7 @@ module EstablishTypeDefinitionCores = begin
/// Compute the mangled name of a type definition. 'doErase' is true for all type definitions except type abbreviations.
let private ComputeTyconName (longPath: Ident list, doErase:bool, typars: Typars) =
- if longPath.Length <> 1 then error(Error(FSComp.SR.tcInvalidTypeExtension(),longPath.Head.idRange));
+ if longPath.Length <> 1 then error(Error(FSComp.SR.tcInvalidTypeExtension(),longPath.Head.idRange))
let id = longPath.Head
let erasedArity =
if doErase then typars |> Seq.sumBy (fun tp -> if tp.IsErased then 0 else 1)
@@ -12982,7 +13192,7 @@ module EstablishTypeDefinitionCores = begin
let bi b = (if b then 1 else 0)
if (bi hasClassAttr + bi hasInterfaceAttr + bi hasStructAttr + bi hasMeasureAttr) > 1 ||
(bi hasAbstractClassAttr + bi hasInterfaceAttr + bi hasStructAttr + bi hasMeasureAttr) > 1 then
- error(Error(FSComp.SR.tcAttributesOfTypeSpecifyMultipleKindsForType(),m));
+ error(Error(FSComp.SR.tcAttributesOfTypeSpecifyMultipleKindsForType(),m))
match kind with
| TyconUnspecified ->
@@ -12997,7 +13207,7 @@ module EstablishTypeDefinitionCores = begin
hasMeasureAttr && not (match k with TyconClass | TyconAbbrev | TyconHiddenRepr -> true | _ -> false) ||
hasInterfaceAttr && not (match k with TyconInterface -> true | _ -> false) ||
hasStructAttr && not (match k with TyconStruct -> true | _ -> false) then
- error(Error(FSComp.SR.tcKindOfTypeSpecifiedDoesNotMatchDefinition(),m));
+ error(Error(FSComp.SR.tcKindOfTypeSpecifiedDoesNotMatchDefinition(),m))
k
@@ -13012,7 +13222,9 @@ module EstablishTypeDefinitionCores = begin
| _ ->
None
- // Used when determining if a structural type supports structual comparison
+ /// Get the component types that make a record, union or struct type.
+ ///
+ /// Used when determining if a structural type supports structual comparison.
let private GetStructuralElementsOfTyconDefn cenv env tpenv (TyconDefnCoreIndexed(_,synTyconRepr,_,_,_,_)) tycon =
let thisTyconRef = mkLocalTyconRef tycon
let m = tycon.Range
@@ -13031,7 +13243,7 @@ module EstablishTypeDefinitionCores = begin
let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty
let argtysl,_ = GetTopTauTypeInFSharpForm cenv.g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos ty' m
if argtysl.Length > 1 then
- errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(),m));
+ errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(),m))
for argtys in argtysl do
for (argty,_) in argtys do
yield (argty ,m)
@@ -13050,7 +13262,7 @@ module EstablishTypeDefinitionCores = begin
let ty = names.[arg].Type
let m = names.[arg].Ident.idRange
if nonNil (ListSet.subtract typarEq (freeInTypeLeftToRight cenv.g false ty) tycon.TyparsNoRange) then
- errorR(Error(FSComp.SR.tcStructsMustDeclareTypesOfImplicitCtorArgsExplicitly(),m));
+ errorR(Error(FSComp.SR.tcStructsMustDeclareTypesOfImplicitCtorArgsExplicitly(),m))
yield (ty, m)
| SynTypeDefnSimpleRepr.Record (_,fields,_) ->
@@ -13067,12 +13279,12 @@ module EstablishTypeDefinitionCores = begin
let private TcTyconDefnCore_Phase0_BuildInitialTycon cenv env parent (TyconDefnCoreIndexed(synTyconInfo,synTyconRepr,_,preEstablishedHasDefaultCtor,hasSelfReferentialCtor,_)) =
let (ComponentInfo(_,synTypars, _,id,doc,preferPostfix, vis,_)) = synTyconInfo
let checkedTypars = TcTyparDecls cenv env synTypars
- id |> List.iter (CheckNamespaceModuleOrTypeName cenv.g);
+ id |> List.iter (CheckNamespaceModuleOrTypeName cenv.g)
let id = ComputeTyconName (id, (match synTyconRepr with SynTypeDefnSimpleRepr.TypeAbbrev _ -> false | _ -> true), checkedTypars)
// Augmentations of type definitions are allowed within the same file as long as no new type representation or abbreviation is given
- CheckForDuplicateConcreteType cenv env id.idText id.idRange;
- CheckForDuplicateModule cenv env id.idText id.idRange;
+ CheckForDuplicateConcreteType cenv env id.idText id.idRange
+ CheckForDuplicateModule cenv env id.idText id.idRange
let vis,cpath = ComputeAccessAndCompPath env None id.idRange vis parent
// Establish the visibility of the representation, e.g.
@@ -13119,8 +13331,8 @@ module EstablishTypeDefinitionCores = begin
tycon.Data.entity_compiled_name <- TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs
if hasMeasureAttr then
- tycon.Data.entity_kind <- TyparKind.Measure;
- if nonNil typars then error(Error(FSComp.SR.tcMeasureDefinitionsCannotHaveTypeParameters(),m));
+ tycon.Data.entity_kind <- TyparKind.Measure
+ if nonNil typars then error(Error(FSComp.SR.tcMeasureDefinitionsCannotHaveTypeParameters(),m))
let repr =
match synTyconRepr with
@@ -13128,10 +13340,10 @@ module EstablishTypeDefinitionCores = begin
// Run InferTyconKind to raise errors on inconsistent attribute sets
InferTyconKind cenv.g (TyconHiddenRepr,attrs,[],[],inSig,true,m) |> ignore
if not inSig && not hasMeasureAttr then
- errorR(Error(FSComp.SR.tcTypeRequiresDefinition(),m));
+ errorR(Error(FSComp.SR.tcTypeRequiresDefinition(),m))
if hasMeasureAttr then
- TFsObjModelRepr { fsobjmodel_kind=TTyconClass;
- fsobjmodel_vslots=[];
+ TFsObjModelRepr { fsobjmodel_kind=TTyconClass
+ fsobjmodel_vslots=[]
fsobjmodel_rfields=MakeRecdFieldsTable [] }
else
TNoRepr
@@ -13169,19 +13381,19 @@ module EstablishTypeDefinitionCores = begin
match kind with
| TyconClass -> TTyconClass
| TyconInterface -> TTyconInterface
- | TyconDelegate _ -> TTyconDelegate (mkSlotSig("Invoke",cenv.g.unit_ty,[],[],[], None))
+ | TyconDelegate _ -> TTyconDelegate (MakeSlotSig("Invoke",cenv.g.unit_ty,[],[],[], None))
| TyconStruct -> TTyconStruct
| _ -> error(InternalError("should have inferred tycon kind",m))
- let repr = { fsobjmodel_kind=kind;
- fsobjmodel_vslots=[];
+ let repr = { fsobjmodel_kind=kind
+ fsobjmodel_vslots=[]
fsobjmodel_rfields=MakeRecdFieldsTable [] }
TFsObjModelRepr repr
| SynTypeDefnSimpleRepr.Enum _ ->
let kind = TTyconEnum
- let repr = { fsobjmodel_kind=kind;
- fsobjmodel_vslots=[];
+ let repr = { fsobjmodel_kind=kind
+ fsobjmodel_vslots=[]
fsobjmodel_rfields=MakeRecdFieldsTable [] }
TFsObjModelRepr repr
@@ -13374,7 +13586,7 @@ module EstablishTypeDefinitionCores = begin
cenv.amap.assemblyLoader.RecordGeneratedTypeRoot (ProviderGeneratedType(ilOrigRootTypeRef, ilTgtRootTyRef, nested))
with e ->
- errorRecovery e rhsType.Range;
+ errorRecovery e rhsType.Range
#endif
/// Establish any type abbreviations
@@ -13510,7 +13722,7 @@ module EstablishTypeDefinitionCores = begin
// Publish interfaces, but only on the first pass, to avoid a duplicate interface check
if firstPass then
- implementedTys |> List.iter (fun (ty,m) -> PublishInterface cenv envinner.DisplayEnv tcref m false ty) ;
+ implementedTys |> List.iter (fun (ty,m) -> PublishInterface cenv envinner.DisplayEnv tcref m false ty)
attrs,inheritedTys)
@@ -13538,8 +13750,8 @@ module EstablishTypeDefinitionCores = begin
| [(ty,m)] ->
if not firstPass && not (match kind with TyconClass -> true | _ -> false) then
- errorR (Error(FSComp.SR.tcStructsInterfacesEnumsDelegatesMayNotInheritFromOtherTypes(),m));
- CheckSuperType cenv ty m;
+ errorR (Error(FSComp.SR.tcStructsInterfacesEnumsDelegatesMayNotInheritFromOtherTypes(),m))
+ CheckSuperType cenv ty m
if isTyparTy cenv.g ty then
if firstPass then
errorR(Error(FSComp.SR.tcCannotInheritFromVariableType(),m))
@@ -13586,9 +13798,9 @@ module EstablishTypeDefinitionCores = begin
let hasAllowNullLiteralAttr = HasFSharpAttribute cenv.g cenv.g.attrib_AllowNullLiteralAttribute attrs
if hasAbstractAttr then
- tycon.TypeContents.tcaug_abstract <- true;
+ tycon.TypeContents.tcaug_abstract <- true
- tycon.Data.entity_attribs <- attrs;
+ tycon.Data.entity_attribs <- attrs
let noAbstractClassAttributeCheck() =
if hasAbstractAttr then errorR (Error(FSComp.SR.tcOnlyClassesCanHaveAbstract(),m))
@@ -13605,16 +13817,16 @@ module EstablishTypeDefinitionCores = begin
let structLayoutAttributeCheck(allowed) =
if hasStructLayoutAttr then
if allowed then
- warning(PossibleUnverifiableCode(m));
+ warning(PossibleUnverifiableCode(m))
elif thisTyconRef.Typars(m).Length > 0 then
errorR (Error(FSComp.SR.tcGenericTypesCannotHaveStructLayout(),m))
else
errorR (Error(FSComp.SR.tcOnlyStructsCanHaveStructLayout(),m))
let hiddenReprChecks(hasRepr) =
- structLayoutAttributeCheck(false);
+ structLayoutAttributeCheck(false)
if hasSealedAttr = Some(false) || (hasRepr && hasSealedAttr <> Some(true) && not (id.idText = "Unit" && cenv.g.compilingFslib) ) then
- errorR(Error(FSComp.SR.tcRepresentationOfTypeHiddenBySignature(),m));
+ errorR(Error(FSComp.SR.tcRepresentationOfTypeHiddenBySignature(),m))
if hasAbstractAttr then
errorR (Error(FSComp.SR.tcOnlyClassesCanHaveAbstract(),m))
@@ -13625,7 +13837,7 @@ module EstablishTypeDefinitionCores = begin
if hasCLIMutable then errorR (Error(FSComp.SR.tcThisTypeMayNotHaveACLIMutableAttribute(),m))
let noSealedAttributeCheck(k) =
- if hasSealedAttr = Some(true) then errorR (Error(k(),m));
+ if hasSealedAttr = Some(true) then errorR (Error(k(),m))
let noFieldsCheck(fields':RecdField list) =
match fields' with
@@ -13652,7 +13864,7 @@ module EstablishTypeDefinitionCores = begin
CallEnvSink cenv.tcSink (fspec.Range, nenv', ad)
// Notify the Language Service about constructors in discriminated union declaration
- let writeFakeUnionCtorsToSink unionCases =
+ let writeFakeUnionCtorsToSink (unionCases: UnionCase list) =
let nenv = envinner.NameEnv
// Constructors should be visible from IntelliSense, so add fake names for them
for unionCase in unionCases do
@@ -13670,8 +13882,8 @@ module EstablishTypeDefinitionCores = begin
hiddenReprChecks(false)
noAllowNullLiteralAttributeCheck()
if hasMeasureAttr then
- let repr = TFsObjModelRepr { fsobjmodel_kind=TTyconClass;
- fsobjmodel_vslots=[];
+ let repr = TFsObjModelRepr { fsobjmodel_kind=TTyconClass
+ fsobjmodel_vslots=[]
fsobjmodel_rfields= MakeRecdFieldsTable [] }
repr, None, NoSafeInitInfo
else
@@ -13683,9 +13895,9 @@ module EstablishTypeDefinitionCores = begin
// "type x = | A" can always be used instead.
| TyconCoreAbbrevThatIsReallyAUnion (hasMeasureAttr,envinner,id) (unionCaseName,_) ->
- structLayoutAttributeCheck(false);
- noAllowNullLiteralAttributeCheck();
- TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName.idText unionCaseName.idRange;
+ structLayoutAttributeCheck(false)
+ noAllowNullLiteralAttributeCheck()
+ TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName.idText unionCaseName.idRange
let unionCase = NewUnionCase unionCaseName unionCaseName.idText [] thisTy [] XmlDoc.Empty tycon.Accessibility
MakeUnionRepr [ unionCase ], None, NoSafeInitInfo
@@ -13694,9 +13906,9 @@ module EstablishTypeDefinitionCores = begin
| SynTypeDefnSimpleRepr.TypeAbbrev(ParserDetail.Ok, rhsType,_) ->
if hasSealedAttr = Some(true) then
- errorR (Error(FSComp.SR.tcAbbreviatedTypesCannotBeSealed(),m));
- noAbstractClassAttributeCheck();
- noAllowNullLiteralAttributeCheck();
+ errorR (Error(FSComp.SR.tcAbbreviatedTypesCannotBeSealed(),m))
+ noAbstractClassAttributeCheck()
+ noAllowNullLiteralAttributeCheck()
if hasMeasureableAttr then
let kind = if hasMeasureAttr then TyparKind.Measure else TyparKind.Type
let theTypeAbbrev,_ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner tpenv rhsType
@@ -13709,34 +13921,34 @@ module EstablishTypeDefinitionCores = begin
TNoRepr, None, NoSafeInitInfo
| SynTypeDefnSimpleRepr.Union (_,unionCases,_) ->
- noCLIMutableAttributeCheck();
- noMeasureAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedDU;
- noAbstractClassAttributeCheck();
- noAllowNullLiteralAttributeCheck();
- structLayoutAttributeCheck(false);
+ noCLIMutableAttributeCheck()
+ noMeasureAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedDU
+ noAbstractClassAttributeCheck()
+ noAllowNullLiteralAttributeCheck()
+ structLayoutAttributeCheck(false)
let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy tpenv unionCases
writeFakeUnionCtorsToSink unionCases
MakeUnionRepr unionCases, None, NoSafeInitInfo
| SynTypeDefnSimpleRepr.Record (_,fields,_) ->
- noMeasureAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedRecord;
- noAbstractClassAttributeCheck();
- noAllowNullLiteralAttributeCheck();
- structLayoutAttributeCheck(true); // these are allowed for records
+ noMeasureAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedRecord
+ noAbstractClassAttributeCheck()
+ noAllowNullLiteralAttributeCheck()
+ structLayoutAttributeCheck(true) // these are allowed for records
let recdFields = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent false tpenv fields
recdFields |> CheckDuplicates (fun f -> f.Id) "field" |> ignore
writeFakeRecordFieldsToSink recdFields
TRecdRepr (MakeRecdFieldsTable recdFields), None, NoSafeInitInfo
| SynTypeDefnSimpleRepr.LibraryOnlyILAssembly (s,_) ->
- noCLIMutableAttributeCheck();
- noMeasureAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedAssemblyCode;
- noAllowNullLiteralAttributeCheck();
- structLayoutAttributeCheck(false);
- noAbstractClassAttributeCheck();
+ noCLIMutableAttributeCheck()
+ noMeasureAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedAssemblyCode
+ noAllowNullLiteralAttributeCheck()
+ structLayoutAttributeCheck(false)
+ noAbstractClassAttributeCheck()
TAsmRepr s, None, NoSafeInitInfo
| SynTypeDefnSimpleRepr.General (kind,inherits,slotsigs,fields,isConcrete,isIncrClass,implicitCtorSynPats,_) ->
@@ -13764,7 +13976,7 @@ module EstablishTypeDefinitionCores = begin
match kind with
| TyconHiddenRepr ->
hiddenReprChecks(true)
- noAllowNullLiteralAttributeCheck();
+ noAllowNullLiteralAttributeCheck()
TNoRepr, None, NoSafeInitInfo
| _ ->
@@ -13775,47 +13987,47 @@ module EstablishTypeDefinitionCores = begin
if isSealedTy cenv.g ty then
errorR(Error(FSComp.SR.tcCannotInheritFromSealedType(),m))
elif not (isClassTy cenv.g ty) then
- errorR(Error(FSComp.SR.tcCannotInheritFromInterfaceType(),m)));
+ errorR(Error(FSComp.SR.tcCannotInheritFromInterfaceType(),m)))
let kind =
match kind with
| TyconStruct ->
- noCLIMutableAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedStruct;
- noAbstractClassAttributeCheck();
- noAllowNullLiteralAttributeCheck();
+ noCLIMutableAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedStruct
+ noAbstractClassAttributeCheck()
+ noAllowNullLiteralAttributeCheck()
if nonNil slotsigs then
- errorR (Error(FSComp.SR.tcStructTypesCannotContainAbstractMembers(),m));
- structLayoutAttributeCheck(true);
+ errorR (Error(FSComp.SR.tcStructTypesCannotContainAbstractMembers(),m))
+ structLayoutAttributeCheck(true)
TTyconStruct
| TyconInterface ->
if hasSealedAttr = Some(true) then errorR (Error(FSComp.SR.tcInterfaceTypesCannotBeSealed(),m))
- noCLIMutableAttributeCheck();
- structLayoutAttributeCheck(false);
- noAbstractClassAttributeCheck();
- allowNullLiteralAttributeCheck();
- noFieldsCheck(userFields);
+ noCLIMutableAttributeCheck()
+ structLayoutAttributeCheck(false)
+ noAbstractClassAttributeCheck()
+ allowNullLiteralAttributeCheck()
+ noFieldsCheck(userFields)
TTyconInterface
| TyconClass ->
- noCLIMutableAttributeCheck();
- structLayoutAttributeCheck(not isIncrClass);
- allowNullLiteralAttributeCheck();
+ noCLIMutableAttributeCheck()
+ structLayoutAttributeCheck(not isIncrClass)
+ allowNullLiteralAttributeCheck()
TTyconClass
| TyconDelegate (ty,arity) ->
- noCLIMutableAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedDelegate;
- structLayoutAttributeCheck(false);
- noAllowNullLiteralAttributeCheck();
- noAbstractClassAttributeCheck();
- noFieldsCheck(userFields);
+ noCLIMutableAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedDelegate
+ structLayoutAttributeCheck(false)
+ noAllowNullLiteralAttributeCheck()
+ noAbstractClassAttributeCheck()
+ noFieldsCheck(userFields)
let ty',_ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner tpenv ty
let _,curriedArgInfos,returnTy,_ = GetTopValTypeInCompiledForm cenv.g (arity |> TranslateTopValSynInfo m (TcAttributes cenv envinner) |> TranslatePartialArity []) ty' m
- if curriedArgInfos.Length < 1 then error(Error(FSComp.SR.tcInvalidDelegateSpecification(),m));
- if curriedArgInfos.Length > 1 then error(Error(FSComp.SR.tcDelegatesCannotBeCurried(),m));
+ if curriedArgInfos.Length < 1 then error(Error(FSComp.SR.tcInvalidDelegateSpecification(),m))
+ if curriedArgInfos.Length > 1 then error(Error(FSComp.SR.tcDelegatesCannotBeCurried(),m))
let ttps = thisTyconRef.Typars(m)
- let fparams = curriedArgInfos.Head |> List.map mkSlotParam
- TTyconDelegate (mkSlotSig("Invoke",thisTy,ttps,[],[fparams], returnTy))
+ let fparams = curriedArgInfos.Head |> List.map MakeSlotParam
+ TTyconDelegate (MakeSlotSig("Invoke",thisTy,ttps,[],[fparams], returnTy))
| _ ->
error(InternalError("should have inferred tycon kind",m))
@@ -13840,7 +14052,7 @@ module EstablishTypeDefinitionCores = begin
let (ValSpfn(_, _, _, _, _valSynData, _, _, _, _,_, m)) = valSpfn
- CheckMemberFlags cenv.g None NewSlotsOK OverridesOK memberFlags m;
+ CheckMemberFlags cenv.g None NewSlotsOK OverridesOK memberFlags m
let slots = fst (TcAndPublishValSpec (cenv,envinner,containerInfo,ModuleOrMemberBinding,Some memberFlags,tpenv,valSpfn))
// Multiple slots may be returned, e.g. for
@@ -13855,32 +14067,32 @@ module EstablishTypeDefinitionCores = begin
let repr =
TFsObjModelRepr
- { fsobjmodel_kind=kind;
- fsobjmodel_vslots= abstractSlots;
+ { fsobjmodel_kind=kind
+ fsobjmodel_vslots= abstractSlots
fsobjmodel_rfields=MakeRecdFieldsTable (userFields @ implicitStructFields @ safeInitFields) }
repr, baseValOpt, safeInitInfo
| SynTypeDefnSimpleRepr.Enum (decls,m) ->
let fieldTy,fields' = TcRecdUnionAndEnumDeclarations.TcEnumDecls cenv envinner innerParent thisTy decls
let kind = TTyconEnum
- structLayoutAttributeCheck(false);
- noCLIMutableAttributeCheck();
- noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedEnum;
- noAllowNullLiteralAttributeCheck();
+ structLayoutAttributeCheck(false)
+ noCLIMutableAttributeCheck()
+ noSealedAttributeCheck FSComp.SR.tcTypesAreAlwaysSealedEnum
+ noAllowNullLiteralAttributeCheck()
let vfld = NewRecdField false None (ident("value__",m)) fieldTy false false [] [] XmlDoc.Empty taccessPublic true
if not (ListSet.contains (typeEquiv cenv.g) fieldTy [ cenv.g.int32_ty; cenv.g.int16_ty; cenv.g.sbyte_ty; cenv.g.int64_ty; cenv.g.char_ty; cenv.g.bool_ty; cenv.g.uint32_ty; cenv.g.uint16_ty; cenv.g.byte_ty; cenv.g.uint64_ty ]) then
- errorR(Error(FSComp.SR.tcInvalidTypeForLiteralEnumeration(),m));
+ errorR(Error(FSComp.SR.tcInvalidTypeForLiteralEnumeration(),m))
writeFakeRecordFieldsToSink fields'
let repr =
TFsObjModelRepr
- { fsobjmodel_kind=kind;
- fsobjmodel_vslots=[];
+ { fsobjmodel_kind=kind
+ fsobjmodel_vslots=[]
fsobjmodel_rfields= MakeRecdFieldsTable (vfld :: fields') }
repr, None, NoSafeInitInfo
- tycon.Data.entity_tycon_repr <- theTypeRepresentation;
+ tycon.Data.entity_tycon_repr <- theTypeRepresentation
// We check this just after establishing the representation
if TyconHasUseNullAsTrueValueAttribute cenv.g tycon && not (CanHaveUseNullAsTrueValueAttribute cenv.g tycon) then
errorR(Error(FSComp.SR.tcInvalidUseNullAsTrueValue(),m))
@@ -13889,12 +14101,12 @@ module EstablishTypeDefinitionCores = begin
match attrs |> List.tryFind (IsMatchingFSharpAttribute cenv.g cenv.g.attrib_ConditionalAttribute) with
| Some _ ->
if not(ExistsInEntireHierarchyOfType (fun t -> typeEquiv cenv.g t (mkAppTy cenv.g.tcref_System_Attribute [])) cenv.g cenv.amap m AllowMultiIntfInstantiations.No thisTy) then
- errorR(Error(FSComp.SR.tcConditionalAttributeUsage(),m));
+ errorR(Error(FSComp.SR.tcConditionalAttributeUsage(),m))
| _ -> ()
(baseValOpt, safeInitInfo, tyconIdx)
with e ->
- errorRecovery e m;
+ errorRecovery e m
None, NoSafeInitInfo, tyconIdx
/// Check that a set of type definitions is free of cycles in abbreviations
@@ -13947,7 +14159,7 @@ module EstablishTypeDefinitionCores = begin
| None -> acc
| Some ty ->
//if not cenv.isSig && not cenv.haveSig && (tycon.Accessibility <> taccessPublic || tycon.TypeReprAccessibility <> taccessPublic) then
- // errorR(Error(FSComp.SR.tcTypeAbbreviationMustBePublic(),tycon.Range));
+ // errorR(Error(FSComp.SR.tcTypeAbbreviationMustBePublic(),tycon.Range))
accInAbbrevType ty acc
acc
@@ -13959,7 +14171,7 @@ module EstablishTypeDefinitionCores = begin
// The thing is cyclic. Set the abbreviation and representation to be "None" to stop later VS crashes
tycon.Data.entity_tycon_abbrev <- None
tycon.Data.entity_tycon_repr <- TNoRepr
- errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclic(),tycon.Range)));
+ errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclic(),tycon.Range)))
/// Check that a set of type definitions is free of inheritance cycles
@@ -14082,7 +14294,7 @@ module EstablishTypeDefinitionCores = begin
// The thing is cyclic. Set the abbreviation and representation to be "None" to stop later VS crashes
tycon.Data.entity_tycon_abbrev <- None
tycon.Data.entity_tycon_repr <- TNoRepr
- errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclicThroughInheritance(),tycon.Range)));
+ errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclicThroughInheritance(),tycon.Range)))
let isAugmentationTyconDefnRepr x = match x with (SynTypeDefnSimpleRepr.General(TyconAugmentation,_,_,_,_,_,_,_)) -> true | _ -> false
@@ -14101,7 +14313,7 @@ module EstablishTypeDefinitionCores = begin
// recheck these in case type is a duplicate in a mutually recursive set
CheckForDuplicateConcreteType cenv env tycon.LogicalName tycon.Range
CheckForDuplicateModule cenv env tycon.LogicalName tycon.Range
- PublishTypeDefn cenv env tycon);
+ PublishTypeDefn cenv env tycon)
// Add them to the environment, though this does not add the fields and
// constructors (because we haven't established them yet).
@@ -14189,14 +14401,15 @@ module TcTypeDeclarations = begin
/// Given a type definition, compute whether its members form an extension of an existing type, and if so if it is an
/// intrinsic or extrinsic extension
- let private ComputeTyconDeclKind isAtOriginalTyconDefn cenv env inSig m typars cs longPath =
+ let private ComputeTyconDeclKind isAtOriginalTyconDefn cenv env inSig m (typars:SynTyparDecl list) cs longPath =
let ad = env.eAccessRights
+
let tcref =
- let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs (typars |> List.map (fun (TyparDecl(_,tp)) -> SynType.Var(tp,m)))
+ let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs typars.Length
match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified env.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with
| Result res -> res
| res when inSig && longPath.Length = 1 ->
- errorR(Deprecated(FSComp.SR.tcReservedSyntaxForAugmentation(),m));
+ errorR(Deprecated(FSComp.SR.tcReservedSyntaxForAugmentation(),m))
ForceRaise res
| res -> ForceRaise res
@@ -14236,7 +14449,7 @@ module TcTypeDeclarations = begin
let declaredTypars = TcTyparDecls cenv env typars
let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTypars env
let _tpenv = TcTyparConstraints cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner emptyUnscopedTyparEnv cs
- declaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m);
+ declaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m)
if not (typarsAEquiv cenv.g TypeEquivEnv.Empty reqTypars declaredTypars) then
errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m))
ExtrinsicExtensionBinding, declaredTypars
@@ -14280,14 +14493,10 @@ module TcTypeDeclarations = begin
| _ -> ds
// Skip over 'let' and 'do' bindings
- let _ ,ds =
- ds |> List.takeUntil (function
- | SynMemberDefn.LetBindings _ -> false
- | _ -> true)
+ let _,ds = ds |> List.takeUntil (function SynMemberDefn.LetBindings _ -> false | _ -> true)
// Skip over 'let' and 'do' bindings
- let _,ds =
- ds |> List.takeUntil (allFalse [isMember;isAbstractSlot;isInterface;isAutoProperty])
+ let _,ds = ds |> List.takeUntil (allFalse [isMember;isAbstractSlot;isInterface;isAutoProperty])
match ds with
| SynMemberDefn.Member (_,m) :: _ -> errorR(InternalError("List.takeUntil is wrong, have binding",m))
@@ -14330,7 +14539,7 @@ module TcTypeDeclarations = begin
let implements1 = List.choose (function SynMemberDefn.Interface (ty,_,_) -> Some(ty,ty.Range) | _ -> None) extraMembers
match trepr with
| SynTypeDefnRepr.ObjectModel(kind,cspec,m) ->
- CheckMembersForm cspec;
+ CheckMembersForm cspec
let fields = cspec |> List.choose (function SynMemberDefn.ValField (f,_) -> Some(f) | _ -> None)
let implements2 = cspec |> List.choose (function SynMemberDefn.Interface (ty,_,_) -> Some(ty,ty.Range) | _ -> None)
let inherits = cspec |> List.choose (function
@@ -14365,7 +14574,7 @@ module TcTypeDeclarations = begin
let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> true | _ -> false)
let mLetPortion = synExpr.Range
let fldId = ident (CompilerGeneratedName id.idText, mLetPortion)
- let headPat = SynPat.LongIdent (LongIdentWithDots([fldId],[]),None,Some noInferredTypars,[],None,mLetPortion)
+ let headPat = SynPat.LongIdent (LongIdentWithDots([fldId],[]),None,Some noInferredTypars, SynConstructorArgs.Pats [],None,mLetPortion)
let retInfo = match tyOpt with None -> None | Some ty -> Some (SynReturnInfo((ty,SynInfo.unnamedRetVal),ty.Range))
let isMutable =
match propKind with
@@ -14392,10 +14601,10 @@ module TcTypeDeclarations = begin
let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> false | _ -> true)
let fldId = ident (CompilerGeneratedName id.idText, mMemberPortion)
let headPatIds = if isStatic then [id] else [ident ("__",mMemberPortion);id]
- let headPat = SynPat.LongIdent (LongIdentWithDots(headPatIds,[]),None,Some noInferredTypars,[],None,mMemberPortion)
+ let headPat = SynPat.LongIdent (LongIdentWithDots(headPatIds,[]),None,Some noInferredTypars, SynConstructorArgs.Pats [],None,mMemberPortion)
match propKind,mGetSetOpt with
- | MemberKind.PropertySet,Some m -> errorR(Error(FSComp.SR.parsMutableOnAutoPropertyShouldBeGetSetNotJustSet(),m));
+ | MemberKind.PropertySet,Some m -> errorR(Error(FSComp.SR.parsMutableOnAutoPropertyShouldBeGetSetNotJustSet(),m))
| _ -> ()
[
@@ -14416,7 +14625,7 @@ module TcTypeDeclarations = begin
| MemberKind.PropertyGetSet ->
let setter =
let vId = ident("v",mMemberPortion)
- let headPat = SynPat.LongIdent (LongIdentWithDots(headPatIds,[]),None,Some noInferredTypars,[mkSynPatVar None vId],None,mMemberPortion)
+ let headPat = SynPat.LongIdent (LongIdentWithDots(headPatIds,[]),None,Some noInferredTypars, SynConstructorArgs.Pats [mkSynPatVar None vId],None,mMemberPortion)
let rhsExpr = mkSynAssign (SynExpr.Ident fldId) (SynExpr.Ident vId)
//let retInfo = match tyOpt with None -> None | Some ty -> Some (SynReturnInfo((ty,SynInfo.unnamedRetVal),ty.Range))
let binding = mkSynBinding (xmlDoc,headPat) (access,false,false,mMemberPortion,NoSequencePointAtInvisibleBinding,None,rhsExpr,rhsExpr.Range,[],[],Some (memberFlags MemberKind.PropertySet))
@@ -14493,7 +14702,7 @@ module TcTypeDeclarations = begin
let newslotsOK = (if isAtOriginalTyconDefn && tcref.IsFSharpObjectModelTycon then NewSlotsOK else NoNewSlots) // NewSlotsOK only on fsobjs
- if nonNil members && tcref.IsTypeAbbrev then errorR(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveAugmentations(), tyDeclm));
+ if nonNil members && tcref.IsTypeAbbrev then errorR(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveAugmentations(), tyDeclm))
TyconMemberData(declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, m, newslotsOK)
@@ -14517,7 +14726,7 @@ module TcTypeDeclarations = begin
let binds3 = tycons |> List.collect (AddAugmentationDeclarations.AddGenericEqualityBindings cenv env)
// Check for cyclic structs and inheritance all over again, since we may have added some fields to the struct when generating the implicit construction syntax
- EstablishTypeDefinitionCores.CheckForCyclicStructsAndInheritance cenv tycons;
+ EstablishTypeDefinitionCores.CheckForCyclicStructsAndInheritance cenv tycons
(binds @ valExprBuilders @ binds3),tycons,env
@@ -14647,13 +14856,13 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually<TcEnv> =
| SynModuleSigDecl.ModuleAbbrev (id,p,m) ->
let ad = env.eAccessRights
- let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace OpenQualified env.eNameResEnv ad p)
+ let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.amap m OpenQualified env.eNameResEnv ad p)
let scopem = unionRanges m endm
let modrefs = mvvs |> List.map p23
if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then
- errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m));
+ errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m))
let modrefs = modrefs |> List.filter (fun modref -> not modref.IsNamespace)
- modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult);
+ modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult)
let env =
if modrefs.Length > 0 then AddModuleAbbreviation cenv.tcSink scopem id modrefs env
@@ -14667,7 +14876,7 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually<TcEnv> =
| SynModuleSigDecl.NamespaceFragment (SynModuleOrNamespaceSig(longId,isModule,defs,xml,attribs,vis,m)) ->
do for id in longId do
- CheckNamespaceModuleOrTypeName cenv.g id;
+ CheckNamespaceModuleOrTypeName cenv.g id
let enclosingNamespacePath = if isModule then fst (List.frontAndBack longId) else longId
let defs =
@@ -14693,7 +14902,7 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually<TcEnv> =
return env
with e ->
- errorRecovery e endm;
+ errorRecovery e endm
return env
}
@@ -14701,7 +14910,7 @@ and TcSignatureElements cenv parent endm env xml defs =
eventually {
// Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds
if cenv.compilingCanonicalFslibModuleType then
- ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc());
+ ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc())
return! Eventually.fold (TcSignatureElement cenv parent endm) env defs
}
@@ -14714,10 +14923,10 @@ and ComputeModuleOrNamespaceKind g isModule attribs =
and TcModuleOrNamespaceSignature cenv env (id:Ident,isModule,defs,xml,attribs,vis,m) =
eventually {
let attribs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs
- CheckNamespaceModuleOrTypeName cenv.g id;
+ CheckNamespaceModuleOrTypeName cenv.g id
let modKind = ComputeModuleOrNamespaceKind cenv.g isModule attribs
- if isModule then CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) id.idRange;
- if isModule then CheckForDuplicateModule cenv env id.idText id.idRange;
+ if isModule then CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) id.idRange
+ if isModule then CheckForDuplicateModule cenv env id.idText id.idRange
// Now typecheck the signature, accumulating and then recording the submodule description.
let id = ident (AdjustModuleName modKind id.idText, id.idRange)
@@ -14728,12 +14937,7 @@ and TcModuleOrNamespaceSignature cenv env (id:Ident,isModule,defs,xml,attribs,vi
let! (mtyp,envAtEnd) = TcModuleOrNamespaceSignatureElements cenv (Parent innerParent) env (id,modKind,defs,m,xml)
-#if DEBUG
- if !verboseStamps then
- dprintf "TcModuleOrNamespaceSignature: %s#%d, vis = %s\n" mspec.LogicalName mspec.Stamp (stringOfAccess vis);
-#endif
-
- mspec.Data.entity_modul_contents <- notlazy mtyp;
+ mspec.Data.entity_modul_contents <- notlazy mtyp
return (mspec, envAtEnd)
}
@@ -14768,12 +14972,12 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
| SynModuleDecl.ModuleAbbrev (id,p,m) ->
let ad = env.eAccessRights
- let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace OpenQualified env.eNameResEnv ad p)
+ let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.amap m OpenQualified env.eNameResEnv ad p)
let modrefs = mvvs |> List.map p23
if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then
- errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m));
+ errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m))
let modrefs = modrefs |> List.filter (fun mvv -> not mvv.IsNamespace)
- modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult);
+ modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult)
let env = (if modrefs.Length > 0 then AddModuleAbbreviation cenv.tcSink scopem id modrefs env else env)
return ((fun e -> e), []), env, env
@@ -14790,12 +14994,12 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
tycons |> List.iter(fun tycon ->
if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then
let nm = tycon.DisplayName
- errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)));
+ errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)))
let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTraitSolutions env
binds |> List.iter(fun bind ->
let nm = bind.Var.DisplayName
- if Zset.contains bind.Var freeInEnv then errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)));
+ if Zset.contains bind.Var freeInEnv then errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)))
TMDefRec(tycons,FlatList.ofList binds,[],m) :: e
@@ -14870,8 +15074,8 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
let modAttrs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs
let modKind = ComputeModuleOrNamespaceKind cenv.g true modAttrs
- CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) im;
- CheckForDuplicateModule cenv env id.idText id.idRange;
+ CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) im
+ CheckForDuplicateModule cenv env id.idText id.idRange
let vis,_ = ComputeAccessAndCompPath env None id.idRange vis parent
let! (topAttrsNew, _,ModuleOrNamespaceBinding(mspecPriorToOuterOrExplicitSig,mexpr)),_,envAtEnd =
@@ -14879,7 +15083,7 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
let mspec = mspecPriorToOuterOrExplicitSig
let mdef = TMDefRec([],FlatList.empty,[ModuleOrNamespaceBinding(mspecPriorToOuterOrExplicitSig,mexpr)],m)
- PublishModuleDefn cenv env mspec;
+ PublishModuleDefn cenv env mspec
let env = AddLocalSubModule cenv.tcSink cenv.g cenv.amap m scopem env mspec
// isContinuingModule is true for all of the following
@@ -14894,11 +15098,11 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
| SynModuleDecl.NamespaceFragment(SynModuleOrNamespace(longId,isModule,defs,xml,attribs,vis,m)) ->
- if !progress then dprintn ("Typecheck implementation "^textOfLid longId);
+ if !progress then dprintn ("Typecheck implementation "^textOfLid longId)
let endm = m.EndRange
do for id in longId do
- CheckNamespaceModuleOrTypeName cenv.g id;
+ CheckNamespaceModuleOrTypeName cenv.g id
let enclosingNamespacePath = if isModule then fst (List.frontAndBack longId) else longId
let defs =
@@ -14927,7 +15131,7 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu
return ((fun e -> mexprRoot :: e),topAttrs), env, envAtEnd
with exn ->
- errorRecovery exn e.Range;
+ errorRecovery exn e.Range
return ((fun e -> e), []), env, env
}
@@ -14954,7 +15158,7 @@ and TcModuleOrNamespaceElements cenv parent endm env xml defs =
eventually {
// Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds
if cenv.compilingCanonicalFslibModuleType then
- ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc());
+ ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc())
let! compiledDefs, env, envAtEnd = TcModuleOrNamespaceElementsAux cenv parent endm ([], env, env) defs
// Apply the functions for each declaration to build the overall expression-builder
@@ -14971,7 +15175,7 @@ and TcModuleOrNamespace cenv env (id,isModule,defs,xml,modAttrs,vis,m:range) =
let modKind = ComputeModuleOrNamespaceKind cenv.g isModule modAttrs
let id = ident (AdjustModuleName modKind id.idText, id.idRange)
- CheckNamespaceModuleOrTypeName cenv.g id;
+ CheckNamespaceModuleOrTypeName cenv.g id
let envinner, mtypeAcc = MakeInnerEnv env id modKind
@@ -14979,11 +15183,6 @@ and TcModuleOrNamespace cenv env (id,isModule,defs,xml,modAttrs,vis,m:range) =
// Also record this in the environment as the accumulator
let mspec = NewModuleOrNamespace (Some env.eCompPath) vis id (xml.ToXmlDoc()) modAttrs (notlazy (NewEmptyModuleOrNamespaceType modKind))
-#if DEBUG
- if !verboseStamps then
- dprintf "TcModuleOrNamespace: %s#%d\n" mspec.LogicalName mspec.Stamp;
-#endif
-
let innerParent = mkLocalModRef mspec
// Now typecheck.
@@ -14991,7 +15190,7 @@ and TcModuleOrNamespace cenv env (id,isModule,defs,xml,modAttrs,vis,m:range) =
// Get the inferred type of the decls. It's precisely the one we created before checking
// and mutated as we went. Record it in the mspec.
- mspec.Data.entity_modul_contents <- notlazy !mtypeAcc ;
+ mspec.Data.entity_modul_contents <- notlazy !mtypeAcc
return (topAttrs,mspec,ModuleOrNamespaceBinding(mspec,mexpr)), env, envAtEnd
}
@@ -15010,7 +15209,7 @@ let AddCcuToTcEnv(g,amap,scopem,env,ccu,autoOpens,internalsVisible) =
let env =
(env,autoOpens) ||> List.fold (fun env p ->
let warn() =
- warning(Error(FSComp.SR.tcAttributeAutoOpenWasIgnored(p, ccu.AssemblyName),scopem));
+ warning(Error(FSComp.SR.tcAttributeAutoOpenWasIgnored(p, ccu.AssemblyName),scopem))
env
let p = splitNamespace p
if isNil p then warn() else
@@ -15031,22 +15230,22 @@ type ConditionalDefines =
/// The attributes that don't get attached to any declaration
type TopAttribs =
- { mainMethodAttrs: Attribs;
- netModuleAttrs: Attribs;
+ { mainMethodAttrs: Attribs
+ netModuleAttrs: Attribs
assemblyAttrs : Attribs }
let EmptyTopAttrs =
- { mainMethodAttrs=[];
- netModuleAttrs=[];
+ { mainMethodAttrs=[]
+ netModuleAttrs=[]
assemblyAttrs =[] }
let CombineTopAttrs topAttrs1 topAttrs2 =
- { mainMethodAttrs = topAttrs1.mainMethodAttrs @ topAttrs2.mainMethodAttrs;
- netModuleAttrs = topAttrs1.netModuleAttrs @ topAttrs2.netModuleAttrs;
+ { mainMethodAttrs = topAttrs1.mainMethodAttrs @ topAttrs2.mainMethodAttrs
+ netModuleAttrs = topAttrs1.netModuleAttrs @ topAttrs2.netModuleAttrs
assemblyAttrs = topAttrs1.assemblyAttrs @ topAttrs2.assemblyAttrs }
let rec IterTyconsOfModuleOrNamespaceType f (mty:ModuleOrNamespaceType) =
- mty.AllEntities |> QueueList.iter (fun tycon -> f tycon);
+ mty.AllEntities |> QueueList.iter (fun tycon -> f tycon)
mty.ModuleAndNamespaceDefinitions |> List.iter (fun v ->
IterTyconsOfModuleOrNamespaceType f v.ModuleOrNamespaceType)
@@ -15057,7 +15256,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs =
try
let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr,extraAttribs)
- GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denvAtEnd,m) unsolved;
+ GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denvAtEnd,m) unsolved
let applyDefaults priority =
unsolved |> List.iter (fun tp ->
@@ -15069,12 +15268,11 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs =
| TyparConstraint.DefaultsTo(priority2,ty2,m) when priority2 = priority ->
let ty1 = mkTyparTy tp
if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then
- if verbose then dprintf "assigning default '%s' for variable '%s' near %a at priority %d\n" ((DebugPrint.showType ty2)) ((DebugPrint.showType ty1)) outputRange m priority2;
let csenv = MakeConstraintSolverEnv cenv.css m denvAtEnd
TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2)
- (fun e -> solveTypAsError cenv denvAtEnd m ty1;
+ (fun e -> solveTypAsError cenv denvAtEnd m ty1
ErrorD(ErrorFromApplyingDefault(g,denvAtEnd,tp,ty2,e,m)))
- |> RaiseOperationResult;
+ |> RaiseOperationResult
| _ -> ()))
for priority = 10 downto 0 do
@@ -15084,7 +15282,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs =
unsolved |> List.iter (fun tp ->
if not tp.IsSolved then
if (tp.StaticReq <> NoStaticReq) then
- ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp);
+ ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp)
with e -> errorRecovery e m
@@ -15104,7 +15302,7 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m =
(match v.ValReprInfo with None -> true | Some tvi -> tvi.HasNoArgs)) then
match ftyvs with
| tp :: _ -> errorR (ValueRestriction(denvAtEnd,false,v, tp,v.Range))
- | _ -> ();
+ | _ -> ()
mty.ModuleAndNamespaceDefinitions |> List.iter (fun v -> check v.ModuleOrNamespaceType)
try check implFileTypePriorToSig with e -> errorRecovery e m
@@ -15120,22 +15318,14 @@ let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig im
match rootSigOpt with
| None ->
// Deep copy the inferred type of the module
- let implFileTypePriorToSigCopied =
-#if DEBUG
- if !verboseStamps then dprintf "Compilation unit type before copy:\n%s\n" (Layout.showL (Layout.squashTo 192 (entityTypeL implFileTypePriorToSig)));
-#endif
- let res = copyModuleOrNamespaceType g CloneAll implFileTypePriorToSig
-#if DEBUG
- if !verboseStamps then dprintf "Compilation unit type after copy:\n%s\n" (Layout.showL (Layout.squashTo 192 (entityTypeL res)));
-#endif
- res
+ let implFileTypePriorToSigCopied = copyModuleOrNamespaceType g CloneAll implFileTypePriorToSig
ModuleOrNamespaceExprWithSig(implFileTypePriorToSigCopied,mexpr,m)
| Some sigFileType ->
// We want to show imperative type variables in any types in error messages at this late point
- let denv = { denvAtEnd with showImperativeTyparAnnotations=true; }
+ let denv = { denvAtEnd with showImperativeTyparAnnotations=true }
begin
try
@@ -15143,7 +15333,7 @@ let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig im
// Here we (a) check there are enough names, (b) match them up to build a renaming and
// (c) check signature conformance up to this renaming.
if not (SignatureConformance.CheckNamesOfModuleOrNamespace denv (mkLocalTyconRef implFileSpecPriorToSig) sigFileType) then
- raise (ReportedError None);
+ raise (ReportedError None)
// Compute the remapping from implementation to signature
let remapInfo ,_ = ComputeRemappingFromInferredSignatureToExplicitSignature cenv.g implFileTypePriorToSig sigFileType
@@ -15152,10 +15342,10 @@ let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig im
if not (SignatureConformance.Checker(cenv.g, cenv.amap, denv, remapInfo, true).CheckSignature aenv (mkLocalModRef implFileSpecPriorToSig) sigFileType) then (
// We can just raise 'ReportedError' since CheckModuleOrNamespace raises its own error
- raise (ReportedError None);
+ raise (ReportedError None)
)
- with e -> errorRecovery e m;
- end;
+ with e -> errorRecovery e m
+ end
ModuleOrNamespaceExprWithSig(sigFileType,mexpr,m)
@@ -15184,8 +15374,8 @@ let TypecheckOneImplFile
let assemblyAttrs,others = others |> List.partition (fun (possTargets,_) -> possTargets &&& AttributeTargets.Assembly <> enum 0)
// REVIEW: consider checking if '_others' is empty
let netModuleAttrs, _others = others |> List.partition (fun (possTargets,_) -> possTargets &&& AttributeTargets.Module <> enum 0)
- { mainMethodAttrs = List.map snd mainMethodAttrs;
- netModuleAttrs = List.map snd netModuleAttrs;
+ { mainMethodAttrs = List.map snd mainMethodAttrs
+ netModuleAttrs = List.map snd netModuleAttrs
assemblyAttrs = List.map snd assemblyAttrs}
let denvAtEnd = envAtEnd.DisplayEnv
let m = qualNameOfFile.Range
@@ -15202,7 +15392,7 @@ let TypecheckOneImplFile
// NOTE: this is not a great technique if inner signatures are permitted to hide
// virtual dispatch slots.
conditionallySuppressErrorReporting (checkForErrors()) (fun () ->
- try implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope cenv.infoReader true denvAtEnd);
+ try implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope cenv.infoReader true denvAtEnd)
with e -> errorRecovery e m)
// Check the value restriction. Only checked if there is no signature.
@@ -15261,7 +15451,7 @@ let TypecheckOneSigFile
let sigFileType = !mtypeAcc
if not (checkForErrors()) then
- try sigFileType |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope cenv.infoReader false tcEnv.DisplayEnv);
+ try sigFileType |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope cenv.infoReader false tcEnv.DisplayEnv)
with e -> errorRecovery e qualNameOfFile.Range
return (tcEnv,tcEnv,sigFileType)
diff --git a/src/fsharp/tc.fsi b/src/fsharp/tc.fsi
index f1e1613..ea684cd 100755
--- a/src/fsharp/tc.fsi
+++ b/src/fsharp/tc.fsi
@@ -119,4 +119,4 @@ val internal TcFieldInit : range -> ILFieldInit -> Tast.Const
val IsSecurityAttribute : TcGlobals -> ImportMap -> Dictionary<Stamp,bool> -> Attrib -> range -> bool
val IsSecurityCriticalAttribute : TcGlobals -> Attrib -> bool
-val LightweightTcValForUsingInBuildMethodCall : g : TcGlobals -> vref:ValRef -> vrefFlags : ValUseFlag -> vrefTypeInst : TTypes -> m : range -> Expr * TType
+val LightweightTcValForUsingInBuildMethodCall : g : TcGlobals -> vref:ValRef -> vrefFlags : ValUseFlag -> vrefTypeInst : TTypes -> m : range -> Expr * TType
\ No newline at end of file
diff --git a/src/fsharp/tlr.fs b/src/fsharp/tlr.fs
index 360b940..8fc9946 100755
--- a/src/fsharp/tlr.fs
+++ b/src/fsharp/tlr.fs
@@ -605,7 +605,7 @@ module Pass2_DetermineReqdItems =
let rec fixpoint reqdItemsMap =
let changed = false
- let changed,reqdItemsMap = Zmap.fmap (closeStep reqdItemsMap) changed reqdItemsMap
+ let changed,reqdItemsMap = Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap
if changed then
fixpoint reqdItemsMap
else
@@ -799,7 +799,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap<BindingGroupShari
ep_unpack = FlatList.ofList unpack})
let carriedMaps = Zmap.empty fclassOrder
- let _carriedMaps,envPacks = List.fmap packEnv carriedMaps declist (* List.fmap in dec order *)
+ let _carriedMaps,envPacks = List.foldMap packEnv carriedMaps declist (* List.foldMap in dec order *)
let envPacks = Zmap.ofList fclassOrder envPacks
envPacks
@@ -1128,7 +1128,7 @@ module Pass4_RewriteAssembly =
| Expr.App (f,fty,tys,args,m) ->
// pass over f,args subexprs
let z,f = TransExpr penv z f
- let z,args = List.fmap (TransExpr penv) z args
+ let z,args = List.foldMap (TransExpr penv) z args
// match app, and fixup if needed
let f,fty,tys,args,m = destApp (f,fty,tys,args,m)
let expr = TransApp penv (f,fty,tys,args,m)
@@ -1147,8 +1147,8 @@ module Pass4_RewriteAssembly =
// ilobj - has implicit lambda exprs and recursive/base references
| Expr.Obj (_,ty,basev,basecall,overrides,iimpls,m) ->
let z,basecall = TransExpr penv z basecall
- let z,overrides = List.fmap (TransMethod penv) z overrides
- let z,iimpls = List.fmap (fmap2Of2 (List.fmap (TransMethod penv))) z iimpls
+ let z,overrides = List.foldMap (TransMethod penv) z overrides
+ let z,iimpls = List.foldMap (fmap2Of2 (List.foldMap (TransMethod penv))) z iimpls
let expr = Expr.Obj(newUnique(),ty,basev,basecall,overrides,iimpls,m)
let z,pds = ExtractPreDecs z
z,WrapPreDecs m pds expr (* if TopLevel, lift preDecs over the ilobj expr *)
@@ -1173,7 +1173,7 @@ module Pass4_RewriteAssembly =
| Expr.Match(spBind,exprm,dtree,targets,m,ty) ->
let targets = Array.toList targets
let z,dtree = TransDecisionTree penv z dtree
- let z,targets = List.fmap (TransDecisionTreeTarget penv) z targets
+ let z,targets = List.foldMap (TransDecisionTreeTarget penv) z targets
// TransDecisionTreeTarget wraps EnterInner/exitInnter, so need to collect any top decs
let z,pds = ExtractPreDecs z
z,WrapPreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets)
@@ -1181,12 +1181,12 @@ module Pass4_RewriteAssembly =
// all others - below - rewrite structurally - so boiler plate code after this point...
| Expr.Const _ -> z,expr (* constant wrt Val *)
| Expr.Quote (a,{contents=Some(argTypes,argExprs,data)},isFromQueryExpression,m,ty) ->
- let z,argExprs = List.fmap (TransExpr penv) z argExprs
+ let z,argExprs = List.foldMap (TransExpr penv) z argExprs
z,Expr.Quote(a,{contents=Some(argTypes,argExprs,data)},isFromQueryExpression,m,ty)
| Expr.Quote (a,{contents=None},isFromQueryExpression,m,ty) ->
z,Expr.Quote(a,{contents=None},isFromQueryExpression,m,ty)
| Expr.Op (c,tyargs,args,m) ->
- let z,args = List.fmap (TransExpr penv) z args
+ let z,args = List.foldMap (TransExpr penv) z args
z,Expr.Op(c,tyargs,args,m)
| Expr.StaticOptimization (constraints,e2,e3,m) ->
let z,e2 = TransExpr penv z e2
@@ -1209,7 +1209,7 @@ module Pass4_RewriteAssembly =
let z = EnterInner z
// For letrec, preDecs from RHS must mutually recurse with those from the bindings
let z,pdsPrior = PopPreDecs z
- let z,binds = FlatList.fmap (TransBindingRhs penv) z binds
+ let z,binds = FlatList.foldMap (TransBindingRhs penv) z binds
let z,pdsRhs = PopPreDecs z
let binds,rebinds = TransBindings IsRec penv binds
let z,binds = LiftTopBinds IsRec penv z binds (* factor Top* repr binds *)
@@ -1263,7 +1263,7 @@ module Pass4_RewriteAssembly =
and TransDecisionTree penv z x =
match x with
| TDSuccess (es,n) ->
- let z,es = FlatList.fmap (TransExpr penv) z es
+ let z,es = FlatList.foldMap (TransExpr penv) z es
z,TDSuccess(es,n)
| TDBind (bind,rest) ->
let z,bind = TransBindingRhs penv z bind
@@ -1275,8 +1275,8 @@ module Pass4_RewriteAssembly =
let z,dtree = TransDecisionTree penv z dtree
z,TCase(discrim,dtree)
- let z,cases = List.fmap (TransDecisionTreeCase penv) z cases
- let z,dflt = Option.fmap (TransDecisionTree penv) z dflt
+ let z,cases = List.foldMap (TransDecisionTreeCase penv) z cases
+ let z,dflt = Option.foldMap (TransDecisionTree penv) z dflt
z,TDSwitch (e,cases,dflt,m)
and TransDecisionTreeTarget penv z (TTarget(vs,e,spTarget)) =
@@ -1286,14 +1286,14 @@ module Pass4_RewriteAssembly =
z,TTarget(vs,e,spTarget)
and TransValBinding penv z bind = TransBindingRhs penv z bind
- and TransValBindings penv z binds = FlatList.fmap (TransValBinding penv) z binds
+ and TransValBindings penv z binds = FlatList.foldMap (TransValBinding penv) z binds
and TransModuleExpr penv z x =
match x with
| ModuleOrNamespaceExprWithSig(mty,def,m) ->
let z,def = TransModuleDef penv z def
z,ModuleOrNamespaceExprWithSig(mty,def,m)
- and TransModuleDefs penv z x = List.fmap (TransModuleDef penv) z x
+ and TransModuleDefs penv z x = List.foldMap (TransModuleDef penv) z x
and TransModuleDef penv (z: RewriteState) x =
match x with
| TMDefRec(tycons,binds,mbinds,m) ->
@@ -1312,7 +1312,7 @@ module Pass4_RewriteAssembly =
| TMAbstract(mexpr) ->
let z,mexpr = TransModuleExpr penv z mexpr
z,TMAbstract(mexpr)
- and TransModuleBindings penv z binds = List.fmap (TransModuleBinding penv) z binds
+ and TransModuleBindings penv z binds = List.foldMap (TransModuleBinding penv) z binds
and TransModuleBinding penv z (ModuleOrNamespaceBinding(nm, rhs)) =
let z,rhs = TransModuleDef penv z rhs
z,ModuleOrNamespaceBinding(nm,rhs)
@@ -1320,7 +1320,7 @@ module Pass4_RewriteAssembly =
let TransImplFile penv z mv = fmapTImplFile (TransModuleExpr penv) z mv
let TransAssembly penv z (TAssembly(mvs)) =
- let _z,mvs = List.fmap (TransImplFile penv) z mvs
+ let _z,mvs = List.foldMap (TransImplFile penv) z mvs
TAssembly(mvs)
//-------------------------------------------------------------------------
diff --git a/src/fsharp/typrelns.fs b/src/fsharp/typrelns.fs
index 3008f36..5b3588a 100755
--- a/src/fsharp/typrelns.fs
+++ b/src/fsharp/typrelns.fs
@@ -55,7 +55,7 @@ open Microsoft.FSharp.Compiler.ExtensionTyping
// ilxgen.fs: GenCoerce (omit unecessary castclass or isinst instruction)
//
let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =
- if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeDefinitelySubsumesTypeNoCoercion), ty1 = "^(DebugPrint.showType ty1),m));
+ if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeDefinitelySubsumesTypeNoCoercion), ty1 = "^(DebugPrint.showType ty1),m))
if ty1 === ty2 then true
// QUERY : quadratic
elif typeEquiv g ty1 ty2 then true
@@ -114,7 +114,7 @@ let rec TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =
/// The feasible coercion relation. Part of the language spec.
let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
- if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m));
+ if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m))
let ty1 = stripTyEqns g ty1
let ty2 = stripTyEqns g ty2
match ty1,ty2 with
@@ -167,10 +167,10 @@ let ChooseTyparSolutionAndRange g amap (tp:Typar) =
| TyparConstraint.CoercesTo(x,m) ->
join m x,m
| TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m) ->
- errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m));
+ errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m))
maxSoFar,m
| TyparConstraint.SimpleChoice(_,m) ->
- errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m));
+ errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m))
maxSoFar,m
| TyparConstraint.SupportsNull m ->
maxSoFar,m
@@ -179,10 +179,10 @@ let ChooseTyparSolutionAndRange g amap (tp:Typar) =
| TyparConstraint.SupportsEquality m ->
maxSoFar,m
| TyparConstraint.IsEnum(_,m) ->
- errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInEnum(),m));
+ errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInEnum(),m))
maxSoFar,m
| TyparConstraint.IsDelegate(_,_,m) ->
- errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInDelegate(),m));
+ errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInDelegate(),m))
maxSoFar,m
| TyparConstraint.IsNonNullableStruct m ->
join m g.int_ty,m
@@ -200,7 +200,7 @@ let ChooseTyparSolutionAndRange g amap (tp:Typar) =
let ChooseTyparSolution g amap tp =
let ty,_m = ChooseTyparSolutionAndRange g amap tp
if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure MeasureOne) then
- warning(Error(FSComp.SR.csCodeLessGeneric(),tp.Range));
+ warning(Error(FSComp.SR.csCodeLessGeneric(),tp.Range))
ty
// Solutions can, in theory, refer to each other
@@ -280,7 +280,7 @@ let tryDestTopLambda g amap (ValReprInfo (tpNames,_,_) as tvd) (e,ty) =
let destTopLambda g amap topValInfo (e,ty) =
match tryDestTopLambda g amap topValInfo (e,ty) with
- | None -> error(Error(FSComp.SR.typrelInvalidValue(), e.Range));
+ | None -> error(Error(FSComp.SR.typrelInvalidValue(), e.Range))
| Some res -> res
let IteratedAdjustArityOfLambdaBody g arities vsl body =
@@ -391,14 +391,14 @@ module SignatureConformance = begin
let rec checkTypars m (aenv: TypeEquivEnv) (implTypars:Typars) (sigTypars:Typars) =
if implTypars.Length <> sigTypars.Length then
- errorR (Error(FSComp.SR.typrelSigImplNotCompatibleParamCountsDiffer(),m));
+ errorR (Error(FSComp.SR.typrelSigImplNotCompatibleParamCountsDiffer(),m))
false
else
let aenv = aenv.BindEquivTypars implTypars sigTypars
(implTypars,sigTypars) ||> List.forall2 (fun implTypar sigTypar ->
let m = sigTypar.Range
if implTypar.StaticReq <> sigTypar.StaticReq then
- errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m));
+ errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m))
// Adjust the actual type parameter name to look look like the signature
implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText)
@@ -440,10 +440,10 @@ module SignatureConformance = begin
let implTypars = implTycon.Typars m
let sigTypars = sigTycon.Typars m
if implTypars.Length <> sigTypars.Length then
- errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer));
+ errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer))
false
elif isLessAccessible implTycon.Accessibility sigTycon.Accessibility then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer))
false
else
let aenv = aenv.BindEquivTypars implTypars sigTypars
@@ -463,39 +463,39 @@ module SignatureConformance = begin
let unimpl = ListSet.subtract (fun fity aity -> typeAEquiv g aenv aity fity) fintfs aintfs
(unimpl |> List.forall (fun ity -> errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(x, NicePrint.minimalStringOfType denv ity))); false)) &&
let hidden = ListSet.subtract (typeAEquiv g aenv) aintfsUser fintfs
- hidden |> List.iter (fun ity -> (if implTycon.IsFSharpInterfaceTycon then error else warning) (InterfaceNotRevealed(denv,ity,implTycon.Range)));
+ hidden |> List.iter (fun ity -> (if implTycon.IsFSharpInterfaceTycon then error else warning) (InterfaceNotRevealed(denv,ity,implTycon.Range)))
let aNull = IsUnionTypeWithNullAsTrueValue g implTycon
let fNull = IsUnionTypeWithNullAsTrueValue g sigTycon
if aNull && not fNull then
errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull))
elif fNull && not aNull then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull))
let aNull2 = TypeNullIsExtraValue g (generalizedTyconRef (mkLocalTyconRef implTycon))
let fNull2 = TypeNullIsExtraValue g (generalizedTyconRef (mkLocalTyconRef implTycon))
if aNull2 && not fNull2 then
errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2))
elif fNull2 && not aNull2 then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2))
let aSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef implTycon))
let fSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef sigTycon))
if aSealed && not fSealed then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed))
if not aSealed && fSealed then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed))
let aPartial = isAbstractTycon implTycon
let fPartial = isAbstractTycon sigTycon
if aPartial && not fPartial then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract))
if not aPartial && fPartial then
- errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract));
+ errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract))
if not (typeAEquiv g aenv (superOfTycon g implTycon) (superOfTycon g sigTycon)) then
- errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes));
+ errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes))
checkTypars m aenv implTypars sigTypars &&
checkTypeRepr err aenv implTycon.TypeReprInfo sigTycon.TypeReprInfo &&
@@ -544,7 +544,6 @@ module SignatureConformance = begin
// Propagate defn location information from implementation to signature .
sigVal.SetDefnRange implVal.DefinitionRange
- if verbose then dprintf "checking value %s, %d, %d\n" implVal.DisplayName implVal.Stamp sigVal.Stamp;
let mk_err denv f = ValueNotContained(denv,implModRef,implVal,sigVal,f)
let err denv f = errorR(mk_err denv f); false
let m = implVal.Range
@@ -777,7 +776,7 @@ module SignatureConformance = begin
| Some ty1, Some ty2 ->
if not (typeAEquiv g aenv ty1 ty2) then
let s1, s2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2
- errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(x, s1, s2)));
+ errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(x, s1, s2)))
false
else
true
@@ -787,7 +786,7 @@ module SignatureConformance = begin
and checkModuleOrNamespaceContents m aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) =
let implModType = implModRef.ModuleOrNamespaceType
- (if implModType.ModuleOrNamespaceKind <> signModType.ModuleOrNamespaceKind then errorR(Error(FSComp.SR.typrelModuleNamespaceAttributesDifferInSigAndImpl(),m)));
+ (if implModType.ModuleOrNamespaceKind <> signModType.ModuleOrNamespaceKind then errorR(Error(FSComp.SR.typrelModuleNamespaceAttributesDifferInSigAndImpl(),m)))
(implModType.TypesByMangledName , signModType.TypesByMangledName)
@@ -911,11 +910,14 @@ type OverrideCanImplement =
/// The overall information about a method implementation in a class or object expression
type OverrideInfo =
- | Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * (*argTypes:*)TType list list * (*Type:*)TType option * (*isFakeEventProperty:*)bool
- member x.IsFakeEventProperty = let (Override(_,_,_,_,_,_,b)) = x in b
+ | Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * TType list list * TType option * bool
+ member x.CanImplement = let (Override(a,_,_,_,_,_,_)) = x in a
+ member x.BoundingTyconRef = let (Override(_,ty,_,_,_,_,_)) = x in ty
member x.LogicalName = let (Override(_,_,id,_,_,_,_)) = x in id.idText
member x.Range = let (Override(_,_,id,_,_,_,_)) = x in id.idRange
- member x.BoundingTyconRef = let (Override(_,ty,_,_,_,_,_)) = x in ty
+ member x.IsFakeEventProperty = let (Override(_,_,_,_,_,_,b)) = x in b
+ member x.ArgTypes = let (Override(_,_,_,_,b,_,_)) = x in b
+ member x.ReturnType = let (Override(_,_,_,_,_,b,_)) = x in b
// If the bool is true then the slot is optional, i.e. is an interface slot
// which does not _have_ to be implemented, because an inherited implementation
@@ -929,6 +931,7 @@ exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option
module DispatchSlotChecking =
+ /// Print the signature of an override to a buffer as part of an error message
let PrintOverrideToBuffer denv os (Override(_,_,id,(mtps,memberToParentInst),argTys,retTy,_)) =
let denv = { denv with showTyparBinding = true }
let retTy = (retTy |> GetFSharpViewOfReturnType denv.g)
@@ -938,6 +941,7 @@ module DispatchSlotChecking =
| _ -> argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1))
Layout.bufferL os (NicePrint.layoutMemberSig denv (memberToParentInst,id.idText,mtps, argInfos, retTy))
+ /// Print the signature of a MethInfo to a buffer as part of an error message
let PrintMethInfoSigToBuffer g amap m denv os minfo =
let denv = { denv with showTyparBinding = true }
let (CompiledSig(argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo
@@ -946,16 +950,21 @@ module DispatchSlotChecking =
let nm = minfo.LogicalName
Layout.bufferL os (NicePrint.layoutMemberSig denv (ttpinst,nm,fmtps, argInfos, retTy))
+ /// Format the signature of an override as a string as part of an error message
let FormatOverride denv d = bufs (fun buf -> PrintOverrideToBuffer denv buf d)
+
+ /// Format the signature of a MethInfo as a string as part of an error message
let FormatMethInfoSig g amap m denv d = bufs (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d)
+ /// Get the override info for an existing (inherited) method being used to implement a dispatch slot.
let GetInheritedMemberOverrideInfo g amap m parentType (minfo:MethInfo) =
let nm = minfo.LogicalName
let (CompiledSig (argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo
- let isFakeEventProperty = minfo.IsFSharpEventProperty
+ let isFakeEventProperty = minfo.IsFSharpEventPropertyMethod
Override(parentType,tcrefOfAppTy g minfo.EnclosingType,mkSynId m nm, (fmtps,ttpinst),argTys,retTy,isFakeEventProperty)
+ /// Get the override info for a value being used to implement a dispatch slot.
let GetTypeMemberOverrideInfo g reqdTy (overrideBy:ValRef) =
let _,argInfos,retTy,_ = GetTypeOfMemberInMemberForm g overrideBy
let nm = overrideBy.LogicalName
@@ -981,7 +990,7 @@ module DispatchSlotChecking =
CanImplementAnyInterfaceSlot
else
CanImplementNoSlots
- else if MemberRefIsDispatchSlot overrideBy then
+ else if overrideBy.IsDispatchSlotMember then
CanImplementNoSlots
// abstract slots can only implement interface slots
//CanImplementAnyInterfaceSlot <<----- Change to this to enable implicit interface implementation
@@ -993,6 +1002,7 @@ module DispatchSlotChecking =
let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g)
Override(implKind,overrideBy.MemberApparentParent, mkSynId overrideBy.Range nm, (memberMethodTypars,memberToParentInst),argTys,retTy,isFakeEventProperty)
+ /// Get the override information for an object expression method being used to implement dispatch slots
let GetObjectExprOverrideInfo g amap (implty, id:Ident, memberFlags, ty, arityInfo, bindingAttribs, rhsExpr) =
// Dissect the type
let tps, argInfos, retTy, _ = GetMemberTypeInMemberForm g memberFlags arityInfo ty id.idRange
@@ -1018,23 +1028,27 @@ module DispatchSlotChecking =
| _ ->
error(InternalError("Unexpected shape for object expression override",id.idRange))
+ /// Check if an override matches a dispatch slot by name
let IsNameMatch (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) =
(overrideBy.LogicalName = dispatchSlot.LogicalName)
- let IsImplMatch g (dispatchSlot:MethInfo) (Override(implKind,_,_,_,_,_,_)) =
+ /// Check if an override matches a dispatch slot by name
+ let IsImplMatch g (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) =
// If the override is listed as only relevant to one type, and we're matching it against an abstract slot of an interface type,
// then check that interface type is the right type.
- (match implKind with
+ (match overrideBy.CanImplement with
| CanImplementNoSlots -> false
| CanImplementAnySlot -> true
| CanImplementAnyClassHierarchySlot -> not (isInterfaceTy g dispatchSlot.EnclosingType)
//| CanImplementSpecificInterfaceSlot parentTy -> isInterfaceTy g dispatchSlot.EnclosingType && typeEquiv g parentTy dispatchSlot.EnclosingType
| CanImplementAnyInterfaceSlot -> isInterfaceTy g dispatchSlot.EnclosingType)
+ /// Check if the kinds of type parameters match between a dispatch slot and an override.
let IsTyparKindMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),_,_,_)) =
let (CompiledSig(_,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot
List.lengthsEqAndForall2 (fun (tp1:Typar) (tp2:Typar) -> tp1.Kind = tp2.Kind) mtps fvmtps
+ /// Check if an override is a partial match for the requirements for a dispatch slot
let IsPartialMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),argTys,_retTy,_) as overrideBy) =
IsNameMatch dispatchSlot overrideBy &&
let (CompiledSig (vargtys,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot
@@ -1043,12 +1057,15 @@ module DispatchSlotChecking =
argTys.Length = vargtys.Length &&
IsImplMatch g dispatchSlot overrideBy
- let reverseTyparRenaming g tinst =
+ /// Compute the reverse of a type parameter renaming.
+ let ReverseTyparRenaming g tinst =
tinst |> List.map (fun (tp,ty) -> (destTyparTy g ty, mkTyparTy tp))
- let composeTyparInsts inst1 inst2 =
+ /// Compose two instantiations of type parameters.
+ let ComposeTyparInsts inst1 inst2 =
inst1 |> List.map (map2Of2 (instType inst2))
+ /// Check if an override exactly matches the requirements for a dispatch slot
let IsExactMatch g amap m dispatchSlot (Override(_,_,_,(mtps,mtpinst),argTys,retTy,_) as overrideBy) =
IsPartialMatch g amap m dispatchSlot overrideBy &&
let (CompiledSig (vargtys,vrty,fvmtps,ttpinst)) = CompiledSigOfMeth g amap m dispatchSlot
@@ -1087,26 +1104,27 @@ module DispatchSlotChecking =
let ttpinst =
// check we can reverse - in some error recovery situations we can't
if mtpinst |> List.exists (snd >> isTyparTy g >> not) then ttpinst
- else composeTyparInsts ttpinst (reverseTyparRenaming g mtpinst)
+ else ComposeTyparInsts ttpinst (ReverseTyparRenaming g mtpinst)
// Compare under the composed substitutions
let aenv = TypeEquivEnv.FromTyparInst ttpinst
typarsAEquiv g aenv fvmtps mtps
+ /// Check if an override implements a dispatch slot
let OverrideImplementsDispatchSlot g amap m dispatchSlot availPriorOverride =
IsExactMatch g amap m dispatchSlot availPriorOverride &&
// The override has to actually be in some subtype of the dispatch slot
ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef availPriorOverride.BoundingTyconRef) (tcrefOfAppTy g dispatchSlot.EnclosingType)
+ /// Check if a dispatch slot is already implemented
let DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed (dispatchSlot: MethInfo) =
availPriorOverridesKeyed
|> NameMultiMap.find dispatchSlot.LogicalName
|> List.exists (OverrideImplementsDispatchSlot g amap m dispatchSlot)
- /// 6a. check all interface and abstract methods are implemented
-
+ /// Check all dispatch slots are implemented by some override.
let CheckDispatchSlotsAreImplemented (denv,g,amap,m,
isOverallTyAbstract,
reqdTy,
@@ -1164,34 +1182,29 @@ module DispatchSlotChecking =
| _ ->
fail(Error(FSComp.SR.typrelOverrideWasAmbiguous(FormatMethInfoSig g amap m denv dispatchSlot),m))
- | _ -> fail(Error(FSComp.SR.typrelMoreThenOneOverride(FormatMethInfoSig g amap m denv dispatchSlot),m)));
+ | _ -> fail(Error(FSComp.SR.typrelMoreThenOneOverride(FormatMethInfoSig g amap m denv dispatchSlot),m)))
!res
- /// 6b. check all implementations implement some virtual method
- let CheckOverridesAreAllUsedOnce denv g amap (isObjExpr, reqdTy,
- dispatchSlotsKeyed: NameMultiMap<RequiredSlot>,
- availPriorOverrides: OverrideInfo list,
- overrides
- ) =
+ /// Check all implementations implement some dispatch slot.
+ let CheckOverridesAreAllUsedOnce(denv, g, amap, isObjExpr, reqdTy,
+ dispatchSlotsKeyed: NameMultiMap<RequiredSlot>,
+ availPriorOverrides: OverrideInfo list,
+ overrides: OverrideInfo list) =
let availPriorOverridesKeyed = availPriorOverrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName)
- for (Override _ as overrideBy) in overrides do
+ for overrideBy in overrides do
if not overrideBy.IsFakeEventProperty then
let m = overrideBy.Range
let relevantVirts = NameMultiMap.find overrideBy.LogicalName dispatchSlotsKeyed
-
let relevantVirts = relevantVirts |> List.map (fun (RequiredSlot(dispatchSlot,_)) -> dispatchSlot)
- match relevantVirts
- |> List.filter (fun dispatchSlot ->
- OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) with
+
+ match relevantVirts |> List.filter (fun dispatchSlot -> OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) with
| [] ->
// This is all error reporting
- match relevantVirts
- |> List.filter (fun dispatchSlot -> IsPartialMatch g amap m dispatchSlot overrideBy) with
+ match relevantVirts |> List.filter (fun dispatchSlot -> IsPartialMatch g amap m dispatchSlot overrideBy) with
| [dispatchSlot] ->
errorR(OverrideDoesntOverride(denv,overrideBy,Some dispatchSlot,g,amap,m))
| _ ->
- match relevantVirts
- |> List.filter (fun dispatchSlot -> IsNameMatch dispatchSlot overrideBy) with
+ match relevantVirts |> List.filter (fun dispatchSlot -> IsNameMatch dispatchSlot overrideBy) with
| [dispatchSlot] ->
errorR(OverrideDoesntOverride(denv, overrideBy, Some dispatchSlot, g, amap, m))
| _ ->
@@ -1211,7 +1224,7 @@ module DispatchSlotChecking =
// dispatch slots are ordered from the derived classes to base
// so we can check the topmost dispatch slot if it is final
match dispatchSlots with
- | meth::_ when meth.IsFinal -> errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod((sprintf "%s::%s" (meth.EnclosingType.ToString()) (meth.LogicalName))), m)); ()
+ | meth::_ when meth.IsFinal -> errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod((sprintf "%s::%s" (meth.EnclosingType.ToString()) (meth.LogicalName))), m))
| _ -> ()
@@ -1262,7 +1275,7 @@ module DispatchSlotChecking =
// duplicates.
for (_i, reqdTy, m, impliedTys) in reqdTyInfos do
if isInterfaceTy g reqdTy && isNil impliedTys then
- errorR(Error(FSComp.SR.typrelDuplicateInterface(),m));
+ errorR(Error(FSComp.SR.typrelDuplicateInterface(),m))
// Check that no interface type is implied twice
//
@@ -1273,7 +1286,7 @@ module DispatchSlotChecking =
let overlap = ListSet.intersect (TypesFeasiblyEquiv 0 g amap reqdTyRange) impliedTys impliedTys2
overlap |> List.iter (fun overlappingTy ->
if nonNil(GetImmediateIntrinsicMethInfosOfType (None,AccessibleFromSomewhere) g amap reqdTyRange overlappingTy |> List.filter (fun minfo -> minfo.IsVirtual)) then
- errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalStringOfType denv (List.head overlap)),reqdTyRange)));
+ errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalStringOfType denv (List.head overlap)),reqdTyRange)))
// Get the SlotImplSet for each implemented type
// This contains the list of required members and the list of available members
@@ -1351,15 +1364,15 @@ module DispatchSlotChecking =
yield SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, reqdProperties) ]
+ /// Check that a type definition implements all its required interfaces after processing all declarations
+ /// within a file.
let CheckImplementationRelationAtEndOfInferenceScope (infoReader:InfoReader,denv,tycon:Tycon,isImplementation) =
let g = infoReader.g
let amap = infoReader.amap
- let tcaug = tycon.TypeContents
- let interfaces = tycon.ImmediateInterfacesOfFSharpTycon
-
- let interfaces = interfaces |> List.map (fun (ity,_compgen,m) -> (ity,m))
+ let tcaug = tycon.TypeContents
+ let interfaces = tycon.ImmediateInterfacesOfFSharpTycon |> List.map (fun (ity,_compgen,m) -> (ity,m))
let overallTy = generalizedTyconRef (mkLocalTyconRef tycon)
@@ -1374,13 +1387,12 @@ module DispatchSlotChecking =
let allImpls = List.zip allReqdTys slotImplSets
-
// Find the methods relevant to implementing the abstract slots listed under the reqdType being checked.
let allImmediateMembersThatMightImplementDispatchSlots =
- allImmediateMembers
- |> List.filter (fun overrideBy -> overrideBy.IsInstanceMember && // exclude static
- MemberRefIsVirtual overrideBy && // exclude non virtual (e.g. keep override/default). [4469]
- not (MemberRefIsDispatchSlot overrideBy))
+ allImmediateMembers |> List.filter (fun overrideBy ->
+ overrideBy.IsInstanceMember && // exclude static
+ overrideBy.IsVirtualMember && // exclude non virtual (e.g. keep override/default). [4469]
+ not overrideBy.IsDispatchSlotMember)
let mustOverrideSomething reqdTy (overrideBy:ValRef) =
let memberInfo = overrideBy.MemberInfo.Value
@@ -1420,16 +1432,16 @@ module DispatchSlotChecking =
// Tell the user to mark the thing abstract if it was missing implementations
if not allCorrect && not tcaug.tcaug_abstract && not (isInterfaceTy g reqdTy) then
- errorR(TypeIsImplicitlyAbstract(m));
+ errorR(TypeIsImplicitlyAbstract(m))
let overridesToCheck =
allImmediateMembersThatMightImplementDispatchSlots
|> List.filter (fst >> mustOverrideSomething reqdTy)
|> List.map snd
- CheckOverridesAreAllUsedOnce denv g amap (false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck);
+ CheckOverridesAreAllUsedOnce (denv, g, amap, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck)
- with e -> errorRecovery e m; ()
+ with e -> errorRecovery e m
// Now record the full slotsigs of the abstract members implemented by each override.
// This is used to generate IL MethodImpls in the code generator.
@@ -1447,7 +1459,7 @@ module DispatchSlotChecking =
if tyconRefEq g overrideByInfo.BoundingTyconRef (tcrefOfAppTy g dispatchSlot.EnclosingType) then
match dispatchSlot.ArbitraryValRef with
| Some virtMember ->
- if virtMember.MemberInfo.Value.IsImplemented then errorR(Error(FSComp.SR.tcDefaultImplementationAlreadyExists(),overrideByInfo.Range));
+ if virtMember.MemberInfo.Value.IsImplemented then errorR(Error(FSComp.SR.tcDefaultImplementationAlreadyExists(),overrideByInfo.Range))
virtMember.MemberInfo.Value.IsImplemented <- true
| None -> () // not an F# slot
@@ -1464,7 +1476,8 @@ module DispatchSlotChecking =
// assert nonNil overridenForThisSlotImplSet
yield! overridenForThisSlotImplSet ]
- overrideBy.MemberInfo.Value.ImplementedSlotSigs <- overriden);
+ overrideBy.MemberInfo.Value.ImplementedSlotSigs <- overriden)
+
//-------------------------------------------------------------------------
// Sets of methods involved in overload resolution and trait constraint
@@ -1483,174 +1496,178 @@ module DispatchSlotChecking =
///
/// The bool indicates if named using a '?'
type CallerArg<'T> =
+ /// CallerArg(ty, range, isOpt, exprInfo)
| CallerArg of TType * range * bool * 'T
member x.Type = (let (CallerArg(ty,_,_,_)) = x in ty)
+ member x.Range = (let (CallerArg(_,m,_,_)) = x in m)
+ member x.IsOptional = (let (CallerArg(_,_,isOpt,_)) = x in isOpt)
+ member x.Expr = (let (CallerArg(_,_,_,expr)) = x in expr)
-/// CalledArg(pos,isParamArray,optArgInfo,isOutArg,nmOpt,argType)
+/// Represents the information about an argument in the method being called
type CalledArg =
- | CalledArg of (int * int) * bool (* isParamArray *) * OptionalArgInfo * bool (* isOutArg *) * string option * TType
- member x.Type = (let (CalledArg(_,_,_,_,_,ty)) = x in ty)
- member x.Position = (let (CalledArg(i,_,_,_,_,_)) = x in i)
-
+ { Position: (int * int)
+ IsParamArray : bool
+ OptArgInfo : OptionalArgInfo
+ IsOutArg: bool
+ NameOpt: string option
+ CalledArgumentType : TType }
+
+let CalledArg(pos,isParamArray,optArgInfo,isOutArg,nameOpt,calledArgTy) =
+ { Position=pos; IsParamArray=isParamArray; OptArgInfo =optArgInfo; IsOutArg=isOutArg; NameOpt=nameOpt; CalledArgumentType = calledArgTy}
+
+/// Represents a match between a caller argument and a called argument, arising from either
+/// a named argument or an unnamed argument.
type AssignedCalledArg<'T> =
- | AssignedCalledArg of Ident option * CalledArg * CallerArg<'T>
- member x.CalledArg = (let (AssignedCalledArg(_,calledArg,_)) = x in calledArg)
+ { /// The identifier for a named argument, if any
+ NamedArgIdOpt : Ident option
+ /// The called argument in the method
+ CalledArg: CalledArg
+ /// The argument on the caller side
+ CallerArg: CallerArg<'T> }
member x.Position = x.CalledArg.Position
+/// Represents the possibilities for a named-setter argument (a property, field , or a record field setter)
type AssignedItemSetterTarget =
| AssignedPropSetter of PropInfo * MethInfo * TypeInst (* the MethInfo is a non-indexer setter property *)
- | AssignedIlFieldSetter of ILFieldInfo
+ | AssignedILFieldSetter of ILFieldInfo
| AssignedRecdFieldSetter of RecdFieldInfo
+/// Represents the resolution of a caller argument as a named-setter argument
type AssignedItemSetter<'T> = AssignedItemSetter of Ident * AssignedItemSetterTarget * CallerArg<'T>
type CallerNamedArg<'T> =
| CallerNamedArg of Ident * CallerArg<'T>
- member x.Ident = (let (CallerNamedArg(id,_carg)) = x in id)
+ member x.Ident = (let (CallerNamedArg(id,_)) = x in id)
member x.Name = x.Ident.idText
+ member x.CallerArg = (let (CallerNamedArg(_,a)) = x in a)
+
+//-------------------------------------------------------------------------
+// Callsite conversions
+//-------------------------------------------------------------------------
+
+// F# supports three adhoc conversions at method callsites (note C# supports more, though ones
+// such as implicit conversions interact badly with type inference).
+//
+// 1. The use of "(fun x y -> ...)" when a delegate it expected. This is not part of
+// the ":>" coercion relationship or inference constraint problem as
+// such, but is a special rule applied only to method arguments.
+//
+// The function AdjustCalledArgType detects this case based on types and needs to know that the type being applied
+// is a function type.
+//
+// 2. The use of "(fun x y -> ...)" when Expression<delegate> it expected. This is similar to above.
+//
+// 3. Two ways to pass a value where a byref is expected. The first (default)
+// is to use a reference cell, and the interior address is taken automatically
+// The second is an explicit use of the "address-of" operator "&e". Here we detect the second case,
+// and record the presence of the sytnax "&e" in the pre-inferred actual type for the method argument.
+// The function AdjustCalledArgType detects this and refuses to apply the default byref-to-ref transformation.
+//
+// The function AdjustCalledArgType also adjusts for optional arguments.
+let AdjustCalledArgType (infoReader:InfoReader) isConstraint (calledArg: CalledArg) (callerArg: CallerArg<_>) =
+ let g = infoReader.g
+ // #424218 - when overload resolution is part of constraint solving - do not perform type-directed conversions
+ let calledArgTy = calledArg.CalledArgumentType
+ let callerArgTy = callerArg.Type
+ let m = callerArg.Range
+ if isConstraint then calledArgTy else
+ // If the called method argument is a byref type, then the caller may provide a byref or ref
+ if isByrefTy g calledArgTy then
+ if isByrefTy g callerArgTy then
+ calledArgTy
+ else
+ mkRefCellTy g (destByrefTy g calledArgTy)
+ else
+ // If the called method argument is a delegate type, then the caller may provide a function
+ let calledArgTy =
+ let adjustDelegateTy calledTy =
+ let (SigOfFunctionForDelegate(_,delArgTys,_,fty)) = GetSigOfFunctionForDelegate infoReader calledTy m AccessibleFromSomeFSharpCode
+ let delArgTys = (if isNil delArgTys then [g.unit_ty] else delArgTys)
+ if (fst (stripFunTy g callerArgTy)).Length = delArgTys.Length
+ then fty
+ else calledArgTy
+
+ if isDelegateTy g calledArgTy && isFunTy g callerArgTy then
+ adjustDelegateTy calledArgTy
+ elif isLinqExpressionTy g calledArgTy && isFunTy g callerArgTy then
+ let origArgTy = calledArgTy
+ let calledArgTy = destLinqExpressionTy g calledArgTy
+ if isDelegateTy g calledArgTy then
+ adjustDelegateTy calledArgTy
+ else
+ // BUG 435170: called arg is Expr<'t> where 't is not delegate - such conversion is not legal -> return original type
+ origArgTy
+ else calledArgTy
+
+ // Adjust the called argument type to take into account whether the caller's argument is M(?arg=Some(3)) or M(arg=1)
+ // If the called method argument is optional with type Option<T>, then the caller may provide a T, unless their argument is propogating-optional (i.e. isOptCallerArg)
+ let calledArgTy =
+ match calledArg.OptArgInfo with
+ | NotOptional -> calledArgTy
+ | CalleeSide when not callerArg.IsOptional && isOptionTy g calledArgTy -> destOptionTy g calledArgTy
+ | CalleeSide | CallerSide _ -> calledArgTy
+ calledArgTy
+
+
+//-------------------------------------------------------------------------
+// CalledMeth
+//-------------------------------------------------------------------------
type CalledMethArgSet<'T> =
- | CalledMethArgSet of
- // The called arguments corresponding to "unnamed" arguments
- CalledArg list *
- // Any unnamed caller arguments not otherwise assigned
- CallerArg<'T> list *
- // The called "ParamArray" argument, if any
- CalledArg option *
- // Any unnamed caller arguments assigned to a "param array" argument
- CallerArg<'T> list *
- // named args
- AssignedCalledArg<'T> list
- member x.UnnamedCalledArgs = match x with (CalledMethArgSet(unnamedCalledArgs,_,_,_,_)) -> unnamedCalledArgs
- member x.UnnamedCallerArgs = match x with (CalledMethArgSet(_,unnamedCallerArgs,_,_,_)) -> unnamedCallerArgs
- member x.ParamArrayCalledArgOpt = match x with (CalledMethArgSet(_,_,paramArrayCalledArgOpt,_,_)) -> paramArrayCalledArgOpt
- member x.ParamArrayCallerArgs = match x with (CalledMethArgSet(_,_,_,paramArrayCallerArgs,_)) -> paramArrayCallerArgs
- member x.AssignedNamedArgs = match x with (CalledMethArgSet(_,_,_,_,namedArgs)) -> namedArgs
+ { /// The called arguments corresponding to "unnamed" arguments
+ UnnamedCalledArgs : CalledArg list
+ /// Any unnamed caller arguments not otherwise assigned
+ UnnamedCallerArgs : CallerArg<'T> list
+ /// The called "ParamArray" argument, if any
+ ParamArrayCalledArgOpt : CalledArg option
+ /// Any unnamed caller arguments assigned to a "param array" argument
+ ParamArrayCallerArgs : CallerArg<'T> list
+ /// Named args
+ AssignedNamedArgs: AssignedCalledArg<'T> list }
member x.NumUnnamedCallerArgs = x.UnnamedCallerArgs.Length
member x.NumAssignedNamedArgs = x.AssignedNamedArgs.Length
member x.NumUnnamedCalledArgs = x.UnnamedCalledArgs.Length
-// CLEANUP: make this a record or class
-type CalledMeth<'T> =
- | CalledMeth of
- // the method we're attempting to call
- MethInfo *
- // the instantiation of the method we're attempting to call
- TypeInst *
- // the formal instantiation of the method we're attempting to call
- TypeInst *
- // The types of the actual object arguments, if any
- TType list *
-
- // The argument analysis for each set of curried arguments
- CalledMethArgSet<'T> list *
-
- // return type
- TType *
- // named property setters
- AssignedItemSetter<'T> list *
- // the property related to the method we're attempting to call, if any
- PropInfo option *
- // unassigned args
- CallerNamedArg<'T> list *
- // args assigned to specifiy values for attribute fields and properties (these are not necessarily "property sets")
- CallerNamedArg<'T> list *
- // unnamed called optional args: pass defaults for these
- CalledArg list *
- // unnamed called out args: return these as part of the return tuple
- CalledArg list
-
- member x.Method = match x with (CalledMeth(minfo,_,_,_,_,_,_,_,_,_,_,_)) -> minfo
- static member GetMethod (x:CalledMeth<'T>) = x.Method
-
- member x.CalledTyArgs = match x with (CalledMeth(_,minst,_,_,_,_,_,_,_,_,_,_)) -> minst
- member x.CallerTyArgs = match x with (CalledMeth(_,_,userTypeArgs,_,_,_,_,_,_,_,_,_)) -> userTypeArgs
- member x.CallerObjArgTys = match x with (CalledMeth(_,_,_,callerObjArgTys,_,_,_,_,_,_,_,_)) -> callerObjArgTys
- member x.ArgSets = match x with (CalledMeth(_,_,_,_,argSets,_,_,_,_,_,_,_)) -> argSets
- member x.NumArgSets = x.ArgSets.Length
-
- member x.AssignedProps = match x with (CalledMeth(_,_,_,_,_,_,namedProps,_,_,_,_,_)) -> namedProps
- member x.AssociatedPropertyInfo = match x with (CalledMeth(_,_,_,_,_,_,_,x,_,_,_,_)) -> x
- member x.UnassignedNamedArgs = match x with (CalledMeth(_,_,_,_,_,_,_,_,unassignedNamedItems,_,_,_)) -> unassignedNamedItems
- member x.AttributeAssignedNamedArgs = match x with (CalledMeth(_,_,_,_,_,_,_,_,_,x,_,_)) -> x
- member x.HasOptArgs = match x with (CalledMeth(_,_,_,_,_,_,_,_,_,_,unnamedCalledOptArgs,_)) -> nonNil unnamedCalledOptArgs
- member x.HasOutArgs = match x with (CalledMeth(_,_,_,_,_,_,_,_,_,_,_,unnamedCalledOutArgs)) -> nonNil unnamedCalledOutArgs
- member x.UsesParamArrayConversion =
- x.ArgSets |> List.exists (fun argSet -> argSet.ParamArrayCalledArgOpt.IsSome)
- member x.ParamArrayCalledArgOpt =
- x.ArgSets |> List.tryPick (fun argSet -> argSet.ParamArrayCalledArgOpt)
- member x.ParamArrayCallerArgs =
- x.ArgSets |> List.tryPick (fun argSet -> if isSome argSet.ParamArrayCalledArgOpt then Some argSet.ParamArrayCallerArgs else None )
- member x.ParamArrayElementType(g) =
- assert (x.UsesParamArrayConversion)
- x.ParamArrayCalledArgOpt.Value.Type |> destArrayTy g
- member x.NumAssignedProps = x.AssignedProps.Length
- member x.CalledObjArgTys(amap,m) = x.Method.GetObjArgTypes(amap, m, x.CalledTyArgs)
- member x.NumCalledTyArgs = x.CalledTyArgs.Length
- member x.NumCallerTyArgs = x.CallerTyArgs.Length
-
- member x.AssignsAllNamedArgs = isNil x.UnassignedNamedArgs
-
- member x.HasCorrectArity =
- (x.NumCalledTyArgs = x.NumCallerTyArgs) &&
- x.ArgSets |> List.forall (fun argSet -> argSet.NumUnnamedCalledArgs = argSet.NumUnnamedCallerArgs)
-
- member x.HasCorrectGenericArity =
- (x.NumCalledTyArgs = x.NumCallerTyArgs)
-
- member x.IsAccessible(amap,m,ad) =
- IsMethInfoAccessible amap m ad x.Method
-
- member x.HasCorrectObjArgs(amap,m,_ad) =
- x.CalledObjArgTys(amap,m).Length = x.CallerObjArgTys.Length
-
- member x.IsCandidate(_g,amap,m,ad) =
- x.IsAccessible(amap,m,ad) &&
- x.HasCorrectArity &&
- x.HasCorrectObjArgs(amap,m,ad) &&
- x.AssignsAllNamedArgs
- member x.AllUnnamedCalledArgs = x.ArgSets |> List.collect (fun x -> x.UnnamedCalledArgs)
- member x.TotalNumUnnamedCalledArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCalledArgs)
- member x.TotalNumUnnamedCallerArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCallerArgs)
- member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs)
-
let MakeCalledArgs amap m (minfo:MethInfo) minst =
// Mark up the arguments with their position, so we can sort them back into order later
let paramDatas = minfo.GetParamDatas(amap, m, minst)
paramDatas |> List.mapiSquared (fun i j (ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,typeOfCalledArg)) ->
- CalledArg((i,j),isParamArrayArg,optArgInfo,isOutArg,nmOpt,typeOfCalledArg))
+ { Position=(i,j); IsParamArray=isParamArrayArg; OptArgInfo=optArgInfo; IsOutArg=isOutArg; NameOpt=nmOpt; CalledArgumentType=typeOfCalledArg })
-let MakeCalledMeth
+/// Represents the syntactic matching between a caller of a method and the called method.
+///
+/// The constructor takes all the information about the caller and called side of a method, match up named arguments, property setters etc.,
+/// and returns a CalledMeth object for further analysis.
+type CalledMeth<'T>
(infoReader:InfoReader,
- checkingAttributeCall,
+ isCheckingAttributeCall,
freshenMethInfo,// a function to help generate fresh type variables the property setters methods in generic classes
m,
ad, // the access domain of the place where the call is taking place
minfo:MethInfo, // the method we're attempting to call
- minst, // the instantiation of the method we're attempting to call
- uminst, // the formal instantiation of the method we're attempting to call
- pinfoOpt, // the property related to the method we're attempting to call, if any
- objArgs, // the types of the actual object argument, if any
- callerArgs: (CallerArg<_> list * CallerNamedArg<_> list) list, // the data about any arguments supplied by the caller
+ calledTyArgs, // the 'called type arguments', i.e. the fresh generic instantiation of the method we're attempting to call
+ callerTyArgs: TType list, // the 'caller type arguments', i.e. user-given generic instantiation of the method we're attempting to call
+ pinfoOpt: PropInfo option, // the property related to the method we're attempting to call, if any
+ callerObjArgTys: TType list, // the types of the actual object argument, if any
+ curriedCallerArgs: (CallerArg<'T> list * CallerNamedArg<'T> list) list, // the data about any arguments supplied by the caller
allowParamArgs:bool, // do we allow the use of a param args method in its "expanded" form?
allowOutAndOptArgs: bool) // do we allow the use of the transformation that converts out arguments as tuple returns?
=
let g = infoReader.g
- let amap = infoReader.amap
- let methodRetTy = minfo.GetFSharpReturnTy(amap, m, minst)
+ let methodRetTy = minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs)
- let fullCalledArgs = MakeCalledArgs amap m minfo minst
- assert (callerArgs.Length = fullCalledArgs.Length)
+ let fullCurriedCalledArgs = MakeCalledArgs infoReader.amap m minfo calledTyArgs
+ do assert (fullCurriedCalledArgs.Length = fullCurriedCalledArgs.Length)
let argSetInfos =
- (callerArgs, fullCalledArgs) ||> List.map2 (fun (unnamedCallerArgs,namedCallerArgs) fullCalledArgs ->
+ (curriedCallerArgs, fullCurriedCalledArgs) ||> List.map2 (fun (unnamedCallerArgs,namedCallerArgs) fullCalledArgs ->
// Find the arguments not given by name
let unnamedCalledArgs =
- fullCalledArgs |> List.filter (function
- | (CalledArg(_,_,_,_,Some nm,_)) ->
- namedCallerArgs |> List.forall (fun (CallerNamedArg(nm2,_e)) -> nm <> nm2.idText)
- | _ -> true)
+ fullCalledArgs |> List.filter (fun calledArg ->
+ match calledArg.NameOpt with
+ | Some nm -> namedCallerArgs |> List.forall (fun (CallerNamedArg(nm2,_e)) -> nm <> nm2.idText)
+ | None -> true)
// See if any of them are 'out' arguments being returned as part of a return tuple
let unnamedCalledArgs, unnamedCalledOptArgs, unnamedCalledOutArgs =
@@ -1659,13 +1676,11 @@ let MakeCalledMeth
let unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs = List.chop nUnnamedCallerArgs unnamedCalledArgs
// Check if all optional/out arguments are byref-out args
- if unnamedCalledOptOrOutArgs |> List.forall (fun (CalledArg(_i,_,_,isOutArg,_,typeOfCalledArg)) -> isOutArg && isByrefTy g typeOfCalledArg) then
- let unnamedCalledOutArgs = unnamedCalledOptOrOutArgs |> List.map (fun (CalledArg(i,isParamArrayArg,optArgInfo,isOutArg,nmOpt,typeOfCalledArg)) -> (CalledArg(i,isParamArrayArg,optArgInfo,isOutArg,nmOpt,typeOfCalledArg)))
- unnamedCalledArgsTrimmed,[],unnamedCalledOutArgs
+ if unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.IsOutArg && isByrefTy g x.CalledArgumentType) then
+ unnamedCalledArgsTrimmed,[],unnamedCalledOptOrOutArgs
// Check if all optional/out arguments are optional args
- elif unnamedCalledOptOrOutArgs |> List.forall (fun (CalledArg(_i,_,optArgInfo,_isOutArg,_,_typeOfCalledArg)) -> optArgInfo.IsOptional) then
- let unnamedCalledOptArgs = unnamedCalledOptOrOutArgs
- unnamedCalledArgsTrimmed,unnamedCalledOptArgs,[]
+ elif unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.OptArgInfo.IsOptional) then
+ unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs,[]
// Otherwise drop them on the floor
else
unnamedCalledArgs,[],[]
@@ -1677,20 +1692,32 @@ let MakeCalledMeth
let supportsParamArgs =
allowParamArgs &&
minArgs >= 0 &&
- unnamedCalledArgs |> List.last |> (fun (CalledArg(_,isParamArray,_,_,_,ty)) -> isParamArray && isArray1DTy g ty)
+ unnamedCalledArgs |> List.last |> (fun calledArg -> calledArg.IsParamArray && isArray1DTy g calledArg.CalledArgumentType)
if supportsParamArgs && unnamedCallerArgs.Length >= minArgs then
let a,b = List.frontAndBack unnamedCalledArgs
List.chop minArgs unnamedCallerArgs, a, Some(b)
else
(unnamedCallerArgs, []),unnamedCalledArgs, None
- //dprintfn "Calling %s: paramArrayCallerArgs = %d, paramArrayCalledArgOpt = %d" minfo.LogicalName paramArrayCallerArgs.Length (Option.length paramArrayCalledArgOpt)
- let assignedNamedArgs = fullCalledArgs |> List.choose (function CalledArg(_,_,_,_,Some nm,_) as arg -> List.tryPick (fun (CallerNamedArg(nm2,arg2)) -> if nm = nm2.idText then Some (AssignedCalledArg(Some(nm2),arg,arg2)) else None) namedCallerArgs | _ -> None)
- let unassignedNamedItem = namedCallerArgs |> List.filter (fun (CallerNamedArg(nm,_e)) -> List.forall (function CalledArg(_,_,_,_,Some nm2,_) -> nm.idText <> nm2 | _ -> true) fullCalledArgs)
+ let assignedNamedArgs =
+ fullCalledArgs |> List.choose (fun calledArg ->
+ match calledArg.NameOpt with
+ | Some nm ->
+ namedCallerArgs |> List.tryPick (fun (CallerNamedArg(nm2,callerArg)) ->
+ if nm = nm2.idText then Some { NamedArgIdOpt = Some nm2; CallerArg=callerArg; CalledArg=calledArg }
+ else None)
+ | _ -> None)
+
+ let unassignedNamedItem =
+ namedCallerArgs |> List.filter (fun (CallerNamedArg(nm,_e)) ->
+ fullCalledArgs |> List.forall (fun calledArg ->
+ match calledArg.NameOpt with
+ | Some nm2 -> nm.idText <> nm2
+ | None -> true))
let attributeAssignedNamedItems,unassignedNamedItem =
- if checkingAttributeCall then
+ if isCheckingAttributeCall then
// the assignment of names to properties is substantially for attribute specifications
// permits bindings of names to non-mutable fields and properties, so we do that using the old
// reliable code for this later on.
@@ -1703,7 +1730,7 @@ let MakeCalledMeth
unassignedNamedItem |> List.splitChoose (fun (CallerNamedArg(id,e) as arg) ->
let nm = id.idText
let pinfos = GetIntrinsicPropInfoSetsOfType infoReader (Some(nm),ad,AllowMultiIntfInstantiations.No) IgnoreOverrides id.idRange returnedObjTy
- let pinfos = pinfos |> ExcludeHiddenOfPropInfos g amap m
+ let pinfos = pinfos |> ExcludeHiddenOfPropInfos g infoReader.amap m
match pinfos with
| [pinfo] when pinfo.HasSetter && not pinfo.IsIndexer ->
let pminfo = pinfo.SetterMethod
@@ -1712,7 +1739,7 @@ let MakeCalledMeth
| _ ->
match infoReader.GetILFieldInfosOfType(Some(nm),ad,m,returnedObjTy) with
| finfo :: _ ->
- Choice1Of2(AssignedItemSetter(id,AssignedIlFieldSetter(finfo), e))
+ Choice1Of2(AssignedItemSetter(id,AssignedILFieldSetter(finfo), e))
| _ ->
match infoReader.TryFindRecdOrClassFieldInfoOfType(nm,m,returnedObjTy) with
| Some rfinfo ->
@@ -1720,14 +1747,13 @@ let MakeCalledMeth
| None ->
Choice2Of2(arg))
- let names = namedCallerArgs |> List.map (function CallerNamedArg(nm,_) -> nm.idText)
+ let names = namedCallerArgs |> List.map (fun (CallerNamedArg(nm,_)) -> nm.idText)
if (List.noRepeats String.order names).Length <> namedCallerArgs.Length then
- errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce(),m));
+ errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce(),m))
- if verbose then dprintf "#fullCalledArgs = %d, #unnamedCalledArgs = %d, #assignedNamedArgs = %d, #residueNamedArgs = %d, #attributeAssignedNamedItems = %d\n"
- fullCalledArgs.Length unnamedCalledArgs.Length assignedNamedArgs.Length unassignedNamedItem.Length attributeAssignedNamedItems.Length;
- let argSet = CalledMethArgSet(unnamedCalledArgs,unnamedCallerArgs,paramArrayCalledArgOpt,paramArrayCallerArgs,assignedNamedArgs)
+ let argSet = { UnnamedCalledArgs=unnamedCalledArgs; UnnamedCallerArgs=unnamedCallerArgs; ParamArrayCalledArgOpt=paramArrayCalledArgOpt; ParamArrayCallerArgs=paramArrayCallerArgs; AssignedNamedArgs=assignedNamedArgs }
+
(argSet,assignedNamedProps,unassignedNamedItem,attributeAssignedNamedItems,unnamedCalledOptArgs,unnamedCalledOutArgs))
let argSets = argSetInfos |> List.map (fun (x,_,_,_,_,_) -> x)
@@ -1736,24 +1762,144 @@ let MakeCalledMeth
let attributeAssignedNamedItems = argSetInfos |> List.collect (fun (_,_,_,x,_,_) -> x)
let unnamedCalledOptArgs = argSetInfos |> List.collect (fun (_,_,_,_,x,_) -> x)
let unnamedCalledOutArgs = argSetInfos |> List.collect (fun (_,_,_,_,_,x) -> x)
- CalledMeth(minfo,minst,uminst,objArgs,argSets,methodRetTy,assignedNamedProps,pinfoOpt,unassignedNamedItems,attributeAssignedNamedItems,unnamedCalledOptArgs,unnamedCalledOutArgs)
-
-let NamesOfCalledArgs calledArgs =
- calledArgs |> List.choose (fun (CalledArg(_,_,_,_,nmOpt,_)) -> nmOpt)
+ member x.infoReader = infoReader
+ member x.amap = infoReader.amap
+
+ /// the method we're attempting to call
+ member x.Method=minfo
+ /// the instantiation of the method we're attempting to call
+ member x.CalledTyArgs=calledTyArgs
+ /// the formal instantiation of the method we're attempting to call
+ member x.CallerTyArgs=callerTyArgs
+ /// The types of the actual object arguments, if any
+ member x.CallerObjArgTys=callerObjArgTys
+ /// The argument analysis for each set of curried arguments
+ member x.ArgSets=argSets
+ /// return type
+ member x.ReturnType=methodRetTy
+ /// named setters
+ member x.AssignedItemSetters=assignedNamedProps
+ /// the property related to the method we're attempting to call, if any
+ member x.AssociatedPropertyInfo=pinfoOpt
+ /// unassigned args
+ member x.UnassignedNamedArgs=unassignedNamedItems
+ /// args assigned to specifiy values for attribute fields and properties (these are not necessarily "property sets")
+ member x.AttributeAssignedNamedArgs=attributeAssignedNamedItems
+ /// unnamed called optional args: pass defaults for these
+ member x.UnnamedCalledOptArgs=unnamedCalledOptArgs
+ /// unnamed called out args: return these as part of the return tuple
+ member x.UnnamedCalledOutArgs=unnamedCalledOutArgs
+
+ static member GetMethod (x:CalledMeth<'T>) = x.Method
+
+ member x.NumArgSets = x.ArgSets.Length
+
+ member x.HasOptArgs = nonNil x.UnnamedCalledOptArgs
+ member x.HasOutArgs = nonNil x.UnnamedCalledOutArgs
+ member x.UsesParamArrayConversion = x.ArgSets |> List.exists (fun argSet -> argSet.ParamArrayCalledArgOpt.IsSome)
+ member x.ParamArrayCalledArgOpt = x.ArgSets |> List.tryPick (fun argSet -> argSet.ParamArrayCalledArgOpt)
+ member x.ParamArrayCallerArgs = x.ArgSets |> List.tryPick (fun argSet -> if isSome argSet.ParamArrayCalledArgOpt then Some argSet.ParamArrayCallerArgs else None )
+ member x.ParamArrayElementType =
+ assert (x.UsesParamArrayConversion)
+ x.ParamArrayCalledArgOpt.Value.CalledArgumentType |> destArrayTy x.amap.g
+ member x.NumAssignedProps = x.AssignedItemSetters.Length
+ member x.CalledObjArgTys(m) = x.Method.GetObjArgTypes(x.amap, m, x.CalledTyArgs)
+ member x.NumCalledTyArgs = x.CalledTyArgs.Length
+ member x.NumCallerTyArgs = x.CallerTyArgs.Length
+
+ member x.AssignsAllNamedArgs = isNil x.UnassignedNamedArgs
+
+ member x.HasCorrectArity =
+ (x.NumCalledTyArgs = x.NumCallerTyArgs) &&
+ x.ArgSets |> List.forall (fun argSet -> argSet.NumUnnamedCalledArgs = argSet.NumUnnamedCallerArgs)
+
+ member x.HasCorrectGenericArity =
+ (x.NumCalledTyArgs = x.NumCallerTyArgs)
+
+ member x.IsAccessible(m,ad) =
+ IsMethInfoAccessible x.amap m ad x.Method
+
+ member x.HasCorrectObjArgs(m) =
+ x.CalledObjArgTys(m).Length = x.CallerObjArgTys.Length
+
+ member x.IsCandidate(m,ad) =
+ x.IsAccessible(m,ad) &&
+ x.HasCorrectArity &&
+ x.HasCorrectObjArgs(m) &&
+ x.AssignsAllNamedArgs
+
+ member x.AssignedUnnamedArgs =
+ // We use Seq.map2 to tolerate there being mismatched caller/called args
+ x.ArgSets |> List.map (fun argSet ->
+ (argSet.UnnamedCalledArgs, argSet.UnnamedCallerArgs) ||> Seq.map2 (fun calledArg callerArg ->
+ { NamedArgIdOpt=None; CalledArg=calledArg; CallerArg=callerArg }) |> Seq.toList)
+
+ member x.AssignedNamedArgs =
+ x.ArgSets |> List.map (fun argSet -> argSet.AssignedNamedArgs)
+
+ member x.AllUnnamedCalledArgs = x.ArgSets |> List.collect (fun x -> x.UnnamedCalledArgs)
+ member x.TotalNumUnnamedCalledArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCalledArgs)
+ member x.TotalNumUnnamedCallerArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCallerArgs)
+ member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs)
+
+let NamesOfCalledArgs (calledArgs: CalledArg list) =
+ calledArgs |> List.choose (fun x -> x.NameOpt)
+
+//-------------------------------------------------------------------------
+// Helpers dealing with propagating type information in method overload resolution
+//-------------------------------------------------------------------------
+
+type ArgumentAnalysis =
+ | NoInfo
+ | ArgDoesNotMatch
+ | CallerLambdaHasArgTypes of TType list
+ | CalledArgMatchesType of TType
+
+let InferLambdaArgsForLambdaPropagation origRhsExpr =
+ let rec loop e =
+ match e with
+ | SynExpr.Lambda(_,_,_,rest,_) -> 1 + loop rest
+ | SynExpr.MatchLambda _ -> 1
+ | _ -> 0
+ loop origRhsExpr
-let showAccessDomain ad =
- match ad with
- | AccessibleFromEverywhere -> "public"
- | AccessibleFrom(_,_) -> "accessible"
- | AccessibleFromSomeFSharpCode -> "public, protected or internal"
- | AccessibleFromSomewhere -> ""
+let ExamineArgumentForLambdaPropagation (infoReader:InfoReader) (arg: AssignedCalledArg<SynExpr>) =
+ let g = infoReader.g
+ // Find the explicit lambda arguments of the caller. Ignore parentheses.
+ let argExpr = match arg.CallerArg.Expr with SynExpr.Paren(x,_,_,_) -> x | x -> x
+ let countOfCallerLambdaArg = InferLambdaArgsForLambdaPropagation argExpr
+ // Adjust for Expression<_>, Func<_,_>, ...
+ let adjustedCalledArgTy = AdjustCalledArgType infoReader false arg.CalledArg arg.CallerArg
+ if countOfCallerLambdaArg > 0 then
+ // Decompose the explicit function type of the target
+ let calledLambdaArgTys,_calledLambdaRetTy = Tastops.stripFunTy g adjustedCalledArgTy
+ if calledLambdaArgTys.Length >= countOfCallerLambdaArg then
+ // success
+ CallerLambdaHasArgTypes calledLambdaArgTys
+ elif isDelegateTy g (if isLinqExpressionTy g adjustedCalledArgTy then destLinqExpressionTy g adjustedCalledArgTy else adjustedCalledArgTy) then
+ ArgDoesNotMatch // delegate arity mismatch
+ else
+ NoInfo // not a function type on the called side - no information
+ else CalledArgMatchesType(adjustedCalledArgTy) // not a lambda on the caller side - push information from caller to called
+
+let ExamineMethodForLambdaPropagation(x:CalledMeth<SynExpr>) =
+ let unnamedInfo = x.AssignedUnnamedArgs |> List.mapSquared (ExamineArgumentForLambdaPropagation x.infoReader)
+ let namedInfo = x.AssignedNamedArgs |> List.mapSquared (fun arg -> (arg.NamedArgIdOpt.Value, ExamineArgumentForLambdaPropagation x.infoReader arg))
+ if unnamedInfo |> List.existsSquared (function CallerLambdaHasArgTypes _ -> true | _ -> false) ||
+ namedInfo |> List.existsSquared (function (_,CallerLambdaHasArgTypes _) -> true | _ -> false) then
+ Some (unnamedInfo, namedInfo)
+ else
+ None
+//-------------------------------------------------------------------------
+// "Type Completion" inference and a few other checks at the end of the inference scope
+//-------------------------------------------------------------------------
-/// "Type Completion" inference and a few other checks at the end of the
-/// inference scope
+
+/// "Type Completion" inference and a few other checks at the end of the inference scope
let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader) isImplementation denv (tycon:Tycon) =
let g = infoReader.g
@@ -1778,7 +1924,7 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader) isImp
else
warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName),tycon.Range))
- Augment.CheckAugmentationAttribs isImplementation g amap tycon;
+ Augment.CheckAugmentationAttribs isImplementation g amap tycon
// Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation
if isImplementation
#if EXTENSIONTYPING
@@ -1792,17 +1938,17 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader) isImp
if (isSome tycon.GeneratedHashAndEqualsWithComparerValues) &&
(hasExplicitObjectGetHashCode || hasExplicitObjectEqualsOverride) then
- errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(tycon.DisplayName),m));
+ errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(tycon.DisplayName),m))
if not hasExplicitObjectEqualsOverride && hasExplicitObjectGetHashCode then
- warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(tycon.DisplayName),m));
+ warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(tycon.DisplayName),m))
if hasExplicitObjectEqualsOverride && not hasExplicitObjectGetHashCode then
- warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(tycon.DisplayName),m));
+ warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(tycon.DisplayName),m))
// remember these values to ensure we don't generate these methods during codegen
- tcaug.SetHasObjectGetHashCode hasExplicitObjectGetHashCode;
+ tcaug.SetHasObjectGetHashCode hasExplicitObjectGetHashCode
if not tycon.IsHiddenReprTycon
&& not tycon.IsTypeAbbrev
@@ -1813,6 +1959,10 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader) isImp
DispatchSlotChecking.CheckImplementationRelationAtEndOfInferenceScope (infoReader,denv,tycon,isImplementation)
+//-------------------------------------------------------------------------
+// Additional helpers for type checking and constraint solving
+//-------------------------------------------------------------------------
+
/// "Single Feasible Type" inference
/// Look for the unique supertype of ty2 for which ty2 :> ty1 might feasibly hold
let FindUniqueFeasibleSupertype g amap m ty1 ty2 =
@@ -1850,6 +2000,9 @@ let GetAbstractPropInfosForSynPropertyDecl(infoReader:InfoReader,ad,memberName:I
let dispatchSlots = pinfos |> List.filter (fun pinfo -> pinfo.IsVirtualProperty)
dispatchSlots
+//-------------------------------------------------------------------------
+// Additional helpers for building method calls and doing TAST generation
+//-------------------------------------------------------------------------
/// Is this a 'base' call (in the sense of C#)
let IsBaseCall objArgs =
@@ -1969,7 +2122,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
#if EXTENSIONTYPING
// By this time this is an erased method info, e.g. one returned from an expression
// REVIEW: copied from tastops, which doesn't allow protected methods
- | ProvidedMeth (g,providedMeth,amap,_) ->
+ | ProvidedMeth (amap,providedMeth,_,_) ->
// TODO: there is a fair bit of duplication here with mk_il_minfo_call. We should be able to merge these
/// Build an expression node that is a call to a extension method in a generated assembly
@@ -1982,7 +2135,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
let valu = isStructTy g enclTy
let isCtor = minfo.IsConstructor
if minfo.IsClassConstructor then
- error (InternalError (minfo.LogicalName ^": cannot call a class constructor",m));
+ error (InternalError (minfo.LogicalName ^": cannot call a class constructor",m))
let useCallvirt = not valu && not direct && minfo.IsVirtual
let isProtected = minfo.IsProtectedAccessiblity
let exprTy = if isCtor then enclTy else minfo.GetFSharpReturnTy(amap, m, minst)
@@ -1993,7 +2146,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
if valRefEq amap.g fsValRef amap.g.reraise_vref then
mkReraise m exprTy, exprTy
else
- let vexp, vexpty = tcVal fsValRef valUseFlags (minfo.ActualTypeInst @ minst) m
+ let vexp, vexpty = tcVal fsValRef valUseFlags (minfo.DeclaringTypeInst @ minst) m
BuildFSharpMethodApp g m fsValRef vexp vexpty allArgs
| None ->
let ilMethRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m providedMeth
@@ -2001,7 +2154,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
let actualTypeInst =
if isTupleTy g enclTy then argsOfAppTy g (mkCompiledTupleTy g (destTupleTy g enclTy)) // provided expressions can include method calls that get properties of tuple types
elif isFunTy g enclTy then [ domainOfFunTy g enclTy; rangeOfFunTy g enclTy ] // provided expressions can call Invoke
- else minfo.ActualTypeInst
+ else minfo.DeclaringTypeInst
let actualMethInst = minst
let retTy = (if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy])
let noTailCall = false
@@ -2015,17 +2168,17 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
BuildILMethInfoCall g amap m isProp ilMethInfo valUseFlags minst direct allArgs
// Build a call to an F# method
- | FSMeth(_,typ,vref,_) ->
+ | FSMeth(_, _, vref, _) ->
// Go see if this is a use of a recursive definition... Note we know the value instantiation
// we want to use so we pass that in in order not to create a new one.
- let vexp, vexpty = tcVal vref valUseFlags (argsOfAppTy g typ @ minst) m
+ let vexp, vexpty = tcVal vref valUseFlags (minfo.DeclaringTypeInst @ minst) m
BuildFSharpMethodApp g m vref vexp vexpty allArgs
// Build a 'call' to a struct default constructor
| DefaultStructCtor (g,typ) ->
if not (TypeHasDefaultValue g typ) then
- errorR(Error(FSComp.SR.tcDefaultStructConstructorCall(),m));
+ errorR(Error(FSComp.SR.tcDefaultStructConstructorCall(),m))
mkDefault (m,typ), typ)
//-------------------------------------------------------------------------
@@ -2049,7 +2202,7 @@ let BuildNewDelegateExpr (eventInfoOpt:EventInfo option, g, amap, delegateTy, in
| None ->
if List.exists (isByrefTy g) delArgTys then
- error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m));
+ error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m))
let delArgVals = delArgTys |> List.map (fun argty -> fst (mkCompGenLocal m "delegateArg" argty))
let expr =
@@ -2376,7 +2529,7 @@ module ProvidedMethodCalls =
and ctorCallToExpr (ne:Tainted<_>) =
let (ctor,args) = ne.PApply2(id,m)
- let targetMethInfo = ProvidedMeth(g,ctor.PApply((fun ne -> upcast ne),m),amap,m)
+ let targetMethInfo = ProvidedMeth(amap,ctor.PApply((fun ne -> upcast ne),m),None,m)
let objArgs = []
let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpresson", m) -> exprToExpr ea ]
let callExpr = BuildMethodCall tcVal g amap Mutates.PossiblyMutates m false targetMethInfo isSuperInit [] objArgs arguments
@@ -2397,7 +2550,7 @@ module ProvidedMethodCalls =
and methodCallToExpr top _origExpr (mce:Tainted<_>) =
let (objOpt,meth,args) = mce.PApply3(id,m)
- let targetMethInfo = ProvidedMeth(g,meth.PApply((fun mce -> upcast mce), m),amap,m)
+ let targetMethInfo = ProvidedMeth(amap,meth.PApply((fun mce -> upcast mce), m),None,m)
let objArgs =
match objOpt.PApplyOption(id, m) with
| None -> []
diff --git a/src/fsharp/unilex.fs b/src/fsharp/unilex.fs
index 959fa97..148747f 100755
--- a/src/fsharp/unilex.fs
+++ b/src/fsharp/unilex.fs
@@ -10,7 +10,7 @@
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-module Microsoft.FSharp.Compiler.UnicodeLexing
+module internal Microsoft.FSharp.Compiler.UnicodeLexing
//------------------------------------------------------------------
// Functions for Unicode char-based lexing (new code).
diff --git a/src/fsharp/unilex.fsi b/src/fsharp/unilex.fsi
index aa2e0fd..4bd1ae7 100755
--- a/src/fsharp/unilex.fsi
+++ b/src/fsharp/unilex.fsi
@@ -10,7 +10,7 @@
// You must not remove this notice, or any other, from this software.
//----------------------------------------------------------------------------
-module Microsoft.FSharp.Compiler.UnicodeLexing
+module internal Microsoft.FSharp.Compiler.UnicodeLexing
open Microsoft.FSharp.Text
open Internal.Utilities.Text.Lexing
diff --git a/src/fsharp/unittests/TestLib.ProjectSystem.fs b/src/fsharp/unittests/TestLib.ProjectSystem.fs
index 6050392..70acf87 100755
--- a/src/fsharp/unittests/TestLib.ProjectSystem.fs
+++ b/src/fsharp/unittests/TestLib.ProjectSystem.fs
@@ -36,6 +36,7 @@ type internal UnitTestingFSharpProjectNode(package:FSharpProjectPackage) as this
this.InteropSafeIVsUIHierarchy <- this
this.InteropSafeIVsProject <- this
this.InteropSafeIVsSccProject2 <- this
+ this.InteropSafeIVsProjectFlavorCfgProvider <- this
type AddReferenceDialogTab =
| DotNetTab = 0
@@ -138,7 +139,7 @@ type TheTests() =
project.Load(filename, null, null, 2u, &guid, &cancelled)
printfn "loaded"
let slfpe = new SolutionListenerForProjectEvents(project.Site)
- (project :> IProjectEventsProvider).ProjectEventsProvider <- (slfpe :> IProjectEvents)
+ project.ProjectEventsProvider <- (slfpe :> IProjectEvents)
slfpe.OnAfterOpenProject((project :> IVsHierarchy), 0) |> ignore
MSBuildProject.SetGlobalProperty(project.BuildProject, "UTF8Output", forceUTF8)
project
@@ -174,8 +175,8 @@ type TheTests() =
| :? FSharpFileNode
| :? FSharpFolderNode ->
TheTests.EnsureMoveDownEnabled(node)
- node.ExecCommandOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet,
- uint32 FSharpProjectFileConstants.MoveDownCmd.ID,
+ node.ExecCommandOnNode(VSProjectConstants.guidFSharpProjectCmdSet,
+ uint32 VSProjectConstants.MoveDownCmd.ID,
uint32 0, new IntPtr(0), new IntPtr(0)) |> ignore
| _ -> failwith "unexpected node type"
()
@@ -185,8 +186,8 @@ type TheTests() =
| :? FSharpFileNode
| :? FSharpFolderNode ->
TheTests.EnsureMoveUpEnabled(node)
- node.ExecCommandOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet,
- uint32 FSharpProjectFileConstants.MoveUpCmd.ID,
+ node.ExecCommandOnNode(VSProjectConstants.guidFSharpProjectCmdSet,
+ uint32 VSProjectConstants.MoveUpCmd.ID,
uint32 0, new IntPtr(0), new IntPtr(0)) |> ignore
| _ -> failwith "unexpected node type"
()
@@ -194,28 +195,28 @@ type TheTests() =
static member EnsureMoveDownDisabled(node : HierarchyNode) =
// Move Down appears on menu, but is greyed out
let mutable qsr = new QueryStatusResult()
- ValidateOK(node.QueryStatusOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet, uint32 FSharpProjectFileConstants.MoveDownCmd.ID, 0n, &qsr))
+ ValidateOK(node.QueryStatusOnNode(VSProjectConstants.guidFSharpProjectCmdSet, uint32 VSProjectConstants.MoveDownCmd.ID, 0n, &qsr))
let expected = QueryStatusResult.SUPPORTED
AssertEqual expected qsr
static member EnsureMoveDownEnabled(node : HierarchyNode) =
// Move Down appears on menu, and can be clicked
let mutable qsr = new QueryStatusResult()
- ValidateOK(node.QueryStatusOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet, uint32 FSharpProjectFileConstants.MoveDownCmd.ID, 0n, &qsr))
+ ValidateOK(node.QueryStatusOnNode(VSProjectConstants.guidFSharpProjectCmdSet, uint32 VSProjectConstants.MoveDownCmd.ID, 0n, &qsr))
let expected = QueryStatusResult.SUPPORTED ||| QueryStatusResult.ENABLED
AssertEqual expected qsr
static member EnsureMoveUpDisabled(node : HierarchyNode) =
// Move Up appears on menu, but is greyed out
let mutable qsr = new QueryStatusResult()
- ValidateOK(node.QueryStatusOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet, uint32 FSharpProjectFileConstants.MoveUpCmd.ID, 0n, &qsr))
+ ValidateOK(node.QueryStatusOnNode(VSProjectConstants.guidFSharpProjectCmdSet, uint32 VSProjectConstants.MoveUpCmd.ID, 0n, &qsr))
let expected = QueryStatusResult.SUPPORTED
AssertEqual expected qsr
static member EnsureMoveUpEnabled(node : HierarchyNode) =
// Move Up appears on menu, and can be clicked
let mutable qsr = new QueryStatusResult()
- ValidateOK(node.QueryStatusOnNode(FSharpProjectFileConstants.guidFSharpProjectCmdSet, uint32 FSharpProjectFileConstants.MoveUpCmd.ID, 0n, &qsr))
+ ValidateOK(node.QueryStatusOnNode(VSProjectConstants.guidFSharpProjectCmdSet, uint32 VSProjectConstants.MoveUpCmd.ID, 0n, &qsr))
let expected = QueryStatusResult.SUPPORTED ||| QueryStatusResult.ENABLED
AssertEqual expected qsr
@@ -309,6 +310,7 @@ type TheTests() =
File.AppendAllText(file, TheTests.FsprojTextWithProjectReferencesAndOtherFlags(compileItems, references, [], null, other, targetFramework))
let sp, cnn =
match targetFramework with
+ | "v4.5" -> VsMocks.MakeMockServiceProviderAndConfigChangeNotifier45()
| "v4.0" -> VsMocks.MakeMockServiceProviderAndConfigChangeNotifier40()
| "v3.5" -> VsMocks.MakeMockServiceProviderAndConfigChangeNotifier35()
| "v3.0" -> VsMocks.MakeMockServiceProviderAndConfigChangeNotifier30()
diff --git a/src/fsharp/unittests/Tests.LanguageService.Completion.fs b/src/fsharp/unittests/Tests.LanguageService.Completion.fs
index b7b559e..0890e7a 100755
--- a/src/fsharp/unittests/Tests.LanguageService.Completion.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.Completion.fs
@@ -227,6 +227,52 @@ type AutoCompletionListTests() as this =
TakeCoffeeBreak(this.VS)
let completions = time1 AutoCompleteAtCursor file "Time of first autocomplete."
AssertCompListIsEmpty(completions)
+
+ [<Test>]
+ member this.``AutoCompletion.ObjectMethods``() =
+ let code =
+ [
+ "type DU1 = DU_1"
+
+ "[<NoEquality>]"
+ "type DU2 = DU_2"
+
+ "[<NoEquality>]"
+ "type DU3 ="
+ " | DU_3"
+ " with member this.Equals(b : string) = 1"
+
+ "[<NoEquality>]"
+ "type DU4 ="
+ " | DU_4"
+ " with member this.GetHashCode(b : string) = 1"
+
+
+ "module Extensions ="
+ " type System.Object with"
+ " member this.ExtensionPropObj = 42"
+ " member this.ExtensionMethodObj () = 42"
+
+ "open Extensions"
+ ]
+ let (_, _, file) = this.CreateSingleFileProject(code)
+ let test tail marker expected notExpected =
+ let code = code @ [tail]
+ ReplaceFileInMemory file code
+ MoveCursorToEndOfMarker(file,marker)
+
+ let completions = AutoCompleteAtCursor file
+ AssertCompListContainsAll(completions, expected)
+ AssertCompListDoesNotContainAny(completions, notExpected)
+
+ test "obj()." ")." ["Equals"; "ExtensionPropObj"; "ExtensionMethodObj"] []
+ test "System.Object." "Object." ["Equals"; "ReferenceEquals"] []
+ test "System.String." "String." ["Equals"] []
+ test "DU_1." "DU_1." ["Equals"; "GetHashCode"; "ExtensionMethodObj"; "ExtensionPropObj"] []
+ test "DU_2." "DU_2." ["ExtensionPropObj"; "ExtensionMethodObj"] ["Equals"; "GetHashCode"] // no equals\gethashcode
+ test "DU_3." "DU_3." ["ExtensionPropObj"; "ExtensionMethodObj"; "Equals"] ["GetHashCode"] // no gethashcode, has equals defined in DU3 type
+ test "DU_4." "DU_4." ["ExtensionPropObj"; "ExtensionMethodObj"; "GetHashCode"] ["Equals"] // no equals, has gethashcode defined in DU4 type
+
[<Test>]
member this.``AutoCompletion.BeforeThis``() =
@@ -338,16 +384,29 @@ type AutoCompletionListTests() as this =
[<Test>] member public this.``AdjacentToDot_21_Negative``() = testAutoCompleteAdjacentToDotNegative ".+."
[<Test>]
- member public this.``Query.CompletionInGroupJoinOn``() =
- let code =
+ member public this.``LambdaOverloads.Completion``() =
+ let prologue = "open System.Linq"
+ let cases =
[
- "query {"
- " for a in [1] do"
- " groupJoin b in [2] on (a.) into c"
- " select c"
- "}"
+ "[\"\"].Sum(fun x -> (*$*)x.Len )"
+ "[\"\"].Select(fun x -> (*$*)x.Len )"
+ "[\"\"].Select(fun x i -> (*$*)x.Len )"
+ "[\"\"].GroupBy(fun x -> (*$*)x.Len )"
+ "[\"\"].Join([\"\"], (fun x -> (*$*)x.Len), (fun x -> x.Len), (fun x y -> x.Len+ y.Len))"
+ "[\"\"].Join([\"\"], (fun x -> x.Len), (fun x -> (*$*)x.Len), (fun x y -> x.Len+ y.Len))"
+ "[\"\"].Join([\"\"], (fun x -> x.Len), (fun x -> x.Len), (fun x y -> (*$*)x.Len + y.Len))"
+ "[\"\"].Join([\"\"], (fun x -> x.Len), (fun x -> x.Len), (fun y x -> y.Len + (*$*)x.Len))"
+ "[\"\"].Where(fun x -> (*$*)x.Len )"
+ "[\"\"].Where(fun x -> (*$*)x.Len % 3 )"
+ "[\"\"].Where(fun x -> (*$*)x.Len % 3 = 0)"
+ "[\"\"].AsQueryable().Select(fun x -> (*$*)x.Len )"
+ "[\"\"].AsQueryable().Select(fun x i -> (*$*)x.Len )"
+ "[\"\"].AsQueryable().Where(fun x -> (*$*)x.Len )"
]
- AssertCtrlSpaceCompleteContains code "(a." ["GetHashCode"; "CompareTo"] []
+
+ for case in cases do
+ let code = [prologue; case]
+ AssertCtrlSpaceCompleteContains code "(*$*)x.Len" ["Length"] []
[<Test>]
member public this.``Query.CompletionInJoinOn``() =
@@ -1000,7 +1059,28 @@ derived.derivedField"]
[ "baseFieldPrivate"; "derivedFieldPrivate" ] // should not contain
[<Test>]
- member public this.``Visibility.InheritedClass.MethodsWitfDiffAccessibility``() =
+ member public this.``ObjInstance.InheritedClass.MethodsWithDiffAccessbilityWithSameNameMethod``() =
+ AssertAutoCompleteContainsNoCoffeeBreak
+ [ "type Base =
+ val mutable baseField : int
+ val mutable private baseFieldPrivate : int
+ new () = { baseField = 0; baseFieldPrivate=1 }
+
+type Derived =
+ val mutable baseField : int
+ val mutable derivedField : int
+ val mutable private derivedFieldPrivate : int
+ inherit Base
+ new () = { baseField = 0; derivedField = 0; derivedFieldPrivate = 0 }
+
+let derived = Derived()
+derived.derivedField"]
+ "derived."
+ [ "baseField"; "derivedField" ] // should contain
+ [ "baseFieldPrivate"; "derivedFieldPrivate" ] // should not contain
+
+ [<Test>]
+ member public this.``Visibility.InheritedClass.MethodsWithDiffAccessibility``() =
AssertAutoCompleteContainsNoCoffeeBreak
[ "type Base =
val mutable baseField : int
@@ -1019,6 +1099,47 @@ type Derived =
[ "baseFieldPrivate" ] // should not contain
[<Test>]
+ member public this.``Visibility.InheritedClass.MethodsWithDiffAccessibilityWithSameNameMethod``() =
+ AssertAutoCompleteContainsNoCoffeeBreak
+ [ "type Base =
+ val mutable baseField : int
+ val mutable private baseFieldPrivate : int
+ new () = { baseField = 0; baseFieldPrivate=1 }
+
+type Derived =
+ val mutable baseField : int
+ val mutable derivedField : int
+ val mutable private derivedFieldPrivate : int
+ inherit Base
+ new () = { baseField = 0; derivedField = 0; derivedFieldPrivate = 0 }
+ member this.Method() =
+ (*marker*)this.baseField"]
+ "(*marker*)this."
+ [ "baseField"; "derivedField"; "derivedFieldPrivate" ] // should contain
+ [ "baseFieldPrivate" ] // should not contain
+
+ [<Test>]
+ member public this.``Visibility.InheritedClass.MethodsWithSameNameMethod``() =
+ AssertAutoCompleteContainsNoCoffeeBreak
+ [ "type MyClass =
+ val foo : int
+ new (foo) = { foo = foo }
+
+type MyClass2 =
+ inherit MyClass
+ val foo : int
+ new (foo) = {
+ inherit MyClass(foo)
+ foo = foo
+ }
+
+let x = new MyClass2(0)
+(*marker*)x.foo"]
+ "(*marker*)x."
+ [ "foo" ] // should contain
+ [ ] // should not contain
+
+ [<Test>]
member public this.``Identifier.Array.AfterassertKeyword``() =
AssertAutoCompleteContainsNoCoffeeBreak
[ "let x = [1;2;3] "
@@ -4440,7 +4561,38 @@ let x = query { for bbbb in abbbbc(*D0*) do
// isUnique=true means it will be selected on ctrl-space invocation
// isPrefix=true means it will be selected, instead of just outlined
AssertEqual(Some ("OSVersion", true, true), Match "o")
-
+
+ [<Test>]
+ member public this.``COMPILED.DefineNotPropagatedToIncrementalBuilder``() =
+ use _guard = this.UsingNewVS()
+
+ let solution = this.CreateSolution()
+ let projName = "testproject"
+ let project = CreateProject(solution,projName)
+ let dir = ProjectDirectory(project)
+ let file1 = AddFileFromText(project,"File1.fs",
+ [
+ "module File1"
+ "#if COMPILED"
+ "let x = 0"
+ "#else"
+ "let y = 1"
+ "#endif"
+ ])
+ let file2 = AddFileFromText(project,"File2.fs",
+ [
+ "module File2"
+ "File1."
+ ])
+
+ let file = OpenFile(project, "File2.fs")
+ MoveCursorToEndOfMarker(file, "File1.")
+ let completionItems =
+ AutoCompleteAtCursor(file)
+ |> Array.map (fun (name, _, _, _) -> name)
+ Assert.AreEqual(1, completionItems.Length, "Expected 1 item in the list")
+ Assert.AreEqual("x", completionItems.[0], "Expected 'x' in the list")
+
[<Test>]
member public this.``VisualStudio.CloseAndReopenSolution``() =
use _guard = this.UsingNewVS()
diff --git a/src/fsharp/unittests/Tests.LanguageService.General.fs b/src/fsharp/unittests/Tests.LanguageService.General.fs
index 1a43344..c612242 100755
--- a/src/fsharp/unittests/Tests.LanguageService.General.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.General.fs
@@ -165,7 +165,7 @@ type GeneralTests() =
let lsbase = publicTypesInAsm @"FSharp.LanguageService.Base.dll"
Assert.AreEqual(0, lsbase)
let psbase = publicTypesInAsm @"FSharp.ProjectSystem.Base.dll"
- Assert.AreEqual(12, psbase)
+ Assert.AreEqual(14, psbase)
let fsi = publicTypesInAsm @"FSharp.VS.FSI.dll"
Assert.AreEqual(1, fsi)
diff --git a/src/fsharp/unittests/Tests.LanguageService.GotoDefinition.fs b/src/fsharp/unittests/Tests.LanguageService.GotoDefinition.fs
index 6a7139d..1854dcf 100755
--- a/src/fsharp/unittests/Tests.LanguageService.GotoDefinition.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.GotoDefinition.fs
@@ -25,7 +25,17 @@ type GotoDefinitionTests() =
(GotoDefnSuccess identifier definitionCode)
file
result
-
+
+ member private this.VerifyGotoDefnSuccessForNonIdentifierAtStartOfMarker(fileContents : string, marker: string, pos : int * int, ?extraRefs) =
+ let (_, _, file) = this.CreateSingleFileProject(fileContents, ?references = extraRefs)
+ MoveCursorToStartOfMarker (file, marker)
+ let result = GotoDefinitionAtCursor file
+ Assert.IsTrue(result.Success)
+ let actualPos = (result.Span.iStartLine, result.Span.iStartIndex)
+ let line = GetLineNumber file (result.Span.iStartLine + 1)
+ printfn "Actual line:%s, actual pos:%A" line actualPos
+ Assert.AreEqual(pos, actualPos)
+
//GoToDefinitionFail Helper Function
member private this.VerifyGoToDefnFailAtStartOfMarker(fileContents : string, marker :string,?addtlRefAssy : list<string>) =
@@ -66,7 +76,31 @@ type GotoDefinitionTests() =
(GotoDefnSuccess identifier definitionCode)
file
result
-
+
+ [<Test>]
+ member this.``Operators.TopLevel``() =
+ this.VerifyGotoDefnSuccessForNonIdentifierAtStartOfMarker(
+ fileContents = """
+ let (===) a b = a = b
+ let _ = 1 === 2
+ """,
+ marker = "=== 2",
+ pos=(1,21)
+ )
+
+ [<Test>]
+ member this.``Operators.Member``() =
+ this.VerifyGotoDefnSuccessForNonIdentifierAtStartOfMarker(
+ fileContents = """
+ type U = U
+ with
+ static member (+++) (U, U) = U
+ let _ = U +++ U
+ """,
+ marker = "++ U",
+ pos=(3,35)
+ )
+
[<Test>]
member public this.``Value``() =
this.VerifyGoToDefnSuccessAtStartOfMarker(
diff --git a/src/fsharp/unittests/Tests.LanguageService.ParameterInfo.fs b/src/fsharp/unittests/Tests.LanguageService.ParameterInfo.fs
index bfe1c04..555a045 100755
--- a/src/fsharp/unittests/Tests.LanguageService.ParameterInfo.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.ParameterInfo.fs
@@ -269,6 +269,42 @@ type ParameterInfoTests() =
let foo(x) = 1
foo((*Mark*)"""
this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark*)",[["'a"]])
+
+ [<Test>]
+ member public this.``Single.DiscriminatedUnion.Construction``() =
+ let fileContent = """
+ type MyDU =
+ | Case1 of int * string
+ | Case2 of V1 : int * string * V3 : bool
+ | Case3 of ``Long Name`` : int * Item2 : string
+ | Case4 of int
+
+ let x1 = Case1((*Mark1*)
+ let x2 = Case2((*Mark2*)
+ let x3 = Case3((*Mark3*)
+ let x4 = Case4((*Mark4*)
+ """
+
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark1*)",[["int"; "string"]])
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark2*)",[["V1: int"; "string"; "V3: bool"]])
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark3*)",[["Long Name: int"; "string"]])
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark4*)",[["int"]])
+
+ [<Test>]
+ member public this.``Single.Exception.Construction``() =
+ let fileContent = """
+ exception E1 of int * string
+ exception E2 of V1 : int * string * V3 : bool
+ exception E3 of ``Long Name`` : int * Data1 : string
+
+ let x1 = E1((*Mark1*)
+ let x2 = E2((*Mark2*)
+ let x3 = E3((*Mark3*)
+ """
+
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark1*)",[["int"; "string"]])
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark2*)",[["V1: int"; "string"; "V3: bool" ]])
+ this.VerifyParameterInfoAtStartOfMarker(fileContent,"(*Mark3*)",[["Long Name: int"; "string" ]])
[<Test>]
[<Category("TypeProvider")>]
@@ -1874,7 +1910,40 @@ We really need to rewrite some code paths here to use the real parse tree rather
let foo = new Foo()
foo.A1(1,1,(*Mark*)"""
this.VerifyParameterInfoAtStartOfMarker(fileContents,"(*Mark*)",[["int";"int";"string";"bool"];["int";"string";"int";"bool"]])
-
+
+ [<Test>]
+ member public this.``ExtensionMethod.Overloads``() =
+ let fileContents = """
+ module MyCode =
+ type A() =
+ member this.Method(a:string) = ""
+ module MyExtension =
+ type MyCode.A with
+ member this.Method(a:int) = ""
+
+ open MyCode
+ open MyExtension
+ let foo = A()
+ foo.Method((*Mark*)"""
+ this.VerifyParameterInfoAtStartOfMarker(fileContents,"(*Mark*)",[["string"];["int"]])
+
+ [<Test>]
+ [<Ignore("Parameterinfo not retrieved properly for indexed properties by test infra")>]
+ member public this.``ExtensionProperty.Overloads``() =
+ let fileContents = """
+ module MyCode =
+ type A() =
+ member this.Prop with get(a:string) = ""
+ module MyExtension =
+ type MyCode.A with
+ member this.Prop with get(a:int) = ""
+
+ open MyCode
+ open MyExtension
+ let foo = A()
+ foo.Prop((*Mark*)"""
+ this.VerifyParameterInfoAtStartOfMarker(fileContents,"(*Mark*)",[["string"];["int"]])
+
(* Generic functions for multi-parameterinfo tests ------------------------------------------------ *)
[<Test>]
diff --git a/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs b/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs
index 6878923..28c2757 100755
--- a/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs
@@ -134,6 +134,36 @@ type QuickInfoTests() =
)
[<Test>]
+ member public this.``Operators.TopLevel``() =
+ let source = """
+ /// tooltip for operator
+ let (===) a b = a + b
+ let _ = "" === ""
+ """
+ this.CheckTooltip(
+ code = source,
+ marker = "== \"\"",
+ atStart = true,
+ f = (fun ((text, _), _) -> printfn "actual %s" text; Assert.IsTrue(text.Contains "tooltip for operator"))
+ )
+
+ [<Test>]
+ member public this.``Operators.Member``() =
+ let source = """
+ type U = U
+ with
+ /// tooltip for operator
+ static member (+++) (U, U) = U
+ let _ = U +++ U
+ """
+ this.CheckTooltip(
+ code = source,
+ marker = "++ U",
+ atStart = true,
+ f = (fun ((text, _), _) -> printfn "actual %s" text; Assert.IsTrue(text.Contains "tooltip for operator"))
+ )
+
+ [<Test>]
member public this.``QuickInfo.OverriddenMethods``() =
let source = """
type A() =
@@ -700,6 +730,30 @@ type QuickInfoTests() =
this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "PriorityQueue(*MarkerModule*)" expectedquickinfoPriorityQueueinModule
this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "pq(*MarkerVal*)" expectedquickinfoVal
this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "singleton(*MarkerLastLine*)" expectedquickinfoLastLine
+
+ [<Test>]
+ member public this.NamedDUFieldQuickInfo() =
+
+ let fileContents = """
+ type NamedFieldDU(*MarkerType*) =
+ | Case1(*MarkerCase1*) of V1 : int * bool * V3 : float
+ | Case2(*MarkerCase2*) of ``Big Name`` : int * Item2 : bool
+ | Case3(*MarkerCase3*) of Item : int
+
+ exception NamedExn(*MarkerException*) of int * V2 : string * bool * Data9 : float
+ """
+ //Verify the quick info as expected
+ let expectedquickinfoType = "type NamedFieldDU = | Case1 of V1: int * bool * V3: float | Case2 of Big Name: int * bool | Case3 of int"
+ let expectedquickinfoCase1 = "union case NamedFieldDU.Case1: V1: int * bool * V3: float -> NamedFieldDU"
+ let expectedquickinfoCase2 = "union case NamedFieldDU.Case2: Big Name: int * bool -> NamedFieldDU"
+ let expectedquickinfoCase3 = "union case NamedFieldDU.Case3: int -> NamedFieldDU"
+ let expectedquickinfoException = "exception NamedExn of int * V2: string * bool * Data9: float"
+
+ this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "NamedFieldDU(*MarkerType*)" expectedquickinfoType
+ this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "Case1(*MarkerCase1*)" expectedquickinfoCase1
+ this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "Case2(*MarkerCase2*)" expectedquickinfoCase2
+ this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "Case3(*MarkerCase3*)" expectedquickinfoCase3
+ this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "NamedExn(*MarkerException*)" expectedquickinfoException
[<Test>]
member public this.``EnsureNoAssertFromBadParserRangeOnAttribute``() =
@@ -2269,8 +2323,12 @@ query."
type System.Random with
/// BCL class Extension method
member this.NextDice() = this.Next() + 1
+ /// new BCL class Extension method with overload
+ member this.NextDice(a : bool) = this.Next() + 1
+ /// existing BCL class Extension method with overload
+ member this.Next(a : bool) = this.Next() + 1
/// BCL class Extension property
- member this.DiceValue with get() = this.NextDice
+ member this.DiceValue with get() = 6
type System.ConsoleKeyInfo with
/// BCL struct extension method
@@ -2278,24 +2336,36 @@ query."
/// BCL struct extension property
member this.ExtentionProperty with get() = "Foo"
- module OwnCodeExtensions =
+ module OwnCode =
/// fs class
type FSClass() =
class
+ /// fs class method original
+ member this.Method(a:string) = ""
+ /// fs class property original
+ member this.Prop with get(a:string) = ""
end
/// fs struct
type FSStruct(x:int) =
struct
- end
- type FSClass with
+ end
+
+ module OwnCodeExtensions =
+ type OwnCode.FSClass with
/// fs class extension method
member this.ExtentionMethod() = 100
/// fs class extension property
- member this.ExtentionProperty with get() = "Foo"
-
- type FSStruct with
+ member this.ExtentionProperty with get() = "Foo"
+
+ /// fs class method extension overload
+ member this.Method(a:int) = ""
+
+ /// fs class property extension overload
+ member this.Prop with get(a:int) = ""
+
+ type OwnCode.FSStruct with
/// fs struct extension method
member this.ExtentionMethod() = 100
@@ -2307,6 +2377,9 @@ query."
let rnd = new System.Random()
rnd.DiceValue(*Marker11*) |>ignore
rnd.NextDice(*Marker12*)() |>ignore
+ rnd.NextDice(*Marker13*)(true) |>ignore
+ rnd.Next(*Marker14*)(true) |>ignore
+
module BCLStruct =
open BCLExtensions
@@ -2315,20 +2388,31 @@ query."
cki.ExtentionProperty(*Marker22*) |>ignore
module OwnClass =
+ open OwnCode
open OwnCodeExtensions
let rnd = new FSClass()
rnd.ExtentionMethod(*Marker31*) |>ignore
rnd.ExtentionProperty(*Marker32*) |>ignore
+ rnd.Method(*Marker33*)("") |>ignore
+ rnd.Method(*Marker34*)(6) |>ignore
+ rnd.Prop(*Marker35*)("") |>ignore
+ rnd.Prop(*Marker36*)(6) |>ignore
module OwnStruct =
+ open OwnCode
open OwnCodeExtensions
let cki = new FSStruct(100)
cki.ExtentionMethod(*Marker41*) |>ignore
cki.ExtentionProperty(*Marker42*) |>ignore"""
- this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker11*)", "System.Random.DiceValue: unit -> int")
+
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker11*)", "property System.Random.DiceValue: int")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker11*)", "BCL class Extension property")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker12*)", "member System.Random.NextDice : unit -> int")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker12*)", "BCL class Extension method")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker13*)", "member System.Random.NextDice : a:bool -> int")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker13*)", "new BCL class Extension method with overload")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker14*)", "member System.Random.Next : a:bool -> int")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker14*)", "existing BCL class Extension method with overload")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker21*)", "member System.ConsoleKeyInfo.ExtentionMethod : unit -> int")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker21*)", "BCL struct extension method")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker22*)", "System.ConsoleKeyInfo.ExtentionProperty: string")
@@ -2337,6 +2421,14 @@ query."
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker31*)", "fs class extension method")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker32*)", "FSClass.ExtentionProperty: string")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker32*)", "fs class extension property")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker33*)", "member FSClass.Method : a:string -> string")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker33*)", "fs class method original")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker34*)", "member FSClass.Method : a:int -> string")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker34*)", "fs class method extension overload")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker35*)", "property FSClass.Prop: string -> string")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker35*)", "fs class property original")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker36*)", "property FSClass.Prop: int -> string")
+ this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker36*)", "fs class property extension overload")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker41*)", "member FSStruct.ExtentionMethod : unit -> int")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker41*)", "fs struct extension method")
this.AssertQuickInfoContainsAtStartOfMarker (fileContent, "(*Marker42*)", "FSStruct.ExtentionProperty: string")
diff --git a/src/fsharp/unittests/Tests.LanguageService.Script.fs b/src/fsharp/unittests/Tests.LanguageService.Script.fs
index 697891e..a28c196 100755
--- a/src/fsharp/unittests/Tests.LanguageService.Script.fs
+++ b/src/fsharp/unittests/Tests.LanguageService.Script.fs
@@ -291,6 +291,40 @@ type ScriptTests() as this =
]
TakeCoffeeBreak(this.VS)
VerifyErrorListContainedExpetedStr("MyNamespace",project)
+
+ [<Test>]
+ member public this.``Fsx.HashLoad.Conditionals``() =
+ use _guard = this.UsingNewVS()
+ let solution = this.CreateSolution()
+ let project = CreateProject(solution,"testproject")
+ let fs = AddFileFromText(project,"File1.fs",
+ ["module InDifferentFS"
+ "#if INTERACTIVE"
+ "let x = 1"
+ "#else"
+ "let y = 2"
+ "#endif"
+ "#if DEBUG"
+ "let A = 3"
+ "#else"
+ "let B = 4"
+ "#endif"
+ ])
+
+ let fsx = AddFileFromText(project,"File2.fsx",
+ [
+ "#load \"File1.fs\""
+ "InDifferentFS."
+ ])
+ let fsx = OpenFile(project,"File2.fsx")
+
+ MoveCursorToEndOfMarker(fsx, "InDifferentFS.")
+ let completion = AutoCompleteAtCursor fsx
+ let completion = completion |> Array.map (fun (name, _, _, _) -> name) |> set
+ Assert.AreEqual(Set.count completion, 2, "Expected 2 elements in the completion list")
+ Assert.IsTrue(completion.Contains "x", "Completion list should contain x because INTERACTIVE is defined")
+ Assert.IsTrue(completion.Contains "B", "Completion list should contain B because DEBUG is not defined")
+
/// FEATURE: Removing a #r into a file will cause it to no longer be seen by intellisense.
[<Test>]
@@ -315,6 +349,8 @@ type ScriptTests() as this =
TakeCoffeeBreak(this.VS)
VerifyErrorListContainedExpetedStr("Transactions",project)
gpatcc.AssertExactly(notAA[file], notAA[file], true (* expectNuke, because dependent DLL set changed *))
+
+
// Corecursive load to existing property.
[<Test>]
@@ -1264,10 +1300,10 @@ type ScriptTests() as this =
(project, @"
<ItemGroup>
<!-- Subtle: You need this reference to compile but not to get language service -->
- <Reference Include=""FSharp.Compiler.Interactive.Settings, Version=4.3.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"">
+ <Reference Include=""FSharp.Compiler.Interactive.Settings, Version=4.3.1.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"">
<SpecificVersion>True</SpecificVersion>
</Reference>
- <Reference Include=""FSharp.Compiler, Version=4.3.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"">
+ <Reference Include=""FSharp.Compiler, Version=4.3.1.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"">
<SpecificVersion>True</SpecificVersion>
</Reference>
</ItemGroup>")
diff --git a/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs b/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs
index 4590789..52d109a 100755
--- a/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs
+++ b/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs
@@ -525,9 +525,9 @@ type Miscellaneous() =
let project = TheTests.CreateProject(file, "false", cnn, sp)
use project = project
let values = project.BuildActionConverter.GetStandardValues()
- let list = values |> Seq.cast |> Seq.map (fun (ba : BuildAction)-> ba.Name) |> Seq.toList |> List.sort
- let expected = ["Compile"; "Content"; "EmbeddedResource"; "None"; "MyBuildAction"; "MyBuildAction3"] |> List.sort
- if list <> expected then
+ let list = values |> Seq.cast |> Seq.map (fun (ba : BuildAction)-> ba.Name) |> Seq.toList
+ let expected = ["Compile"; "Content"; "EmbeddedResource"; "None"; "MyBuildAction"; "MyBuildAction3"]
+ if expected |> List.forall (fun i -> List.exists ((=)i) list) |> not then
let s0 = sprintf "%A" expected
let s1 = sprintf "%A" list
Assert.Fail(s0 + "<>" + s1)
diff --git a/src/fsharp/unittests/Tests.ProjectSystem.References.fs b/src/fsharp/unittests/Tests.ProjectSystem.References.fs
index 14317d8..ef57f95 100755
--- a/src/fsharp/unittests/Tests.ProjectSystem.References.fs
+++ b/src/fsharp/unittests/Tests.ProjectSystem.References.fs
@@ -282,8 +282,47 @@ type References() =
[])
finally
File.Delete(copy)
+
+ [<Test>]
+ member public this.``ReferenceResolution.NonFxAssembly.SeveralCandidates``() =
+ let fsharp4300, fsharp4310 =
+ let root = Path.Combine(FSharpSDKHelper.FSharpReferenceAssembliesLocation, FSharpSDKHelper.NETFramework, FSharpSDKHelper.v40)
+ Path.Combine(root, "4.3.0.0", "FSharp.Core.dll"),Path.Combine(root, "4.3.1.0", "FSharp.Core.dll")
+
+ this.ReferenceResolutionHelper
+ (
+ AddReferenceDialogTab.DotNetTab,
+ fsharp4300,
+ @"<Reference Include=""FSharp.Core, Version=4\.3\.0\.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"" />",
+ "v4.5",
+ []
+ )
+ this.ReferenceResolutionHelper
+ (
+ AddReferenceDialogTab.DotNetTab,
+ fsharp4310,
+ @"<Reference Include=""FSharp.Core, Version=4\.3\.1\.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a"" />",
+ "v4.5",
+ []
+ )
+ this.ReferenceResolutionHelper
+ (
+ AddReferenceDialogTab.BrowseTab,
+ fsharp4300,
+ @"4\.3\.0\.0\\FSharp\.Core\.dll</HintPath>",
+ "v4.5",
+ []
+ )
+ this.ReferenceResolutionHelper
+ (
+ AddReferenceDialogTab.BrowseTab,
+ fsharp4310,
+ @"4\.3\.1\.0\\FSharp\.Core\.dll</HintPath>",
+ "v4.5",
+ []
+ )
-
+
[<Test>]
member public this.``ReferenceResolution.Bug4423.NonFxAssembly.NetTab``() =
this.ReferenceResolutionHelper(AddReferenceDialogTab.DotNetTab,
@@ -324,6 +363,70 @@ type References() =
finally
File.Delete(copy)
+ [<Test>]
+ member public this.``ReferenceResolution.Bug650591.AutomationReference.Add.FullPath``() =
+ let invoker =
+ {
+ new Microsoft.Internal.VisualStudio.Shell.Interop.IVsInvokerPrivate with
+ member this.Invoke(invokable) = invokable.Invoke()
+ }
+ let log =
+ {
+ new Microsoft.VisualStudio.Shell.Interop.IVsActivityLog with
+ member this.LogEntry(_, _, _) = VSConstants.S_OK
+ member this.LogEntryGuid(_, _, _, _) = VSConstants.S_OK
+ member this.LogEntryGuidHr(_, _, _, _, _) = VSConstants.S_OK
+ member this.LogEntryGuidHrPath(_, _, _, _, _, _) = VSConstants.S_OK
+ member this.LogEntryGuidPath(_, _, _, _, _) = VSConstants.S_OK
+ member this.LogEntryHr(_, _, _, _) = VSConstants.S_OK
+ member this.LogEntryHrPath(_, _, _, _, _) = VSConstants.S_OK
+ member this.LogEntryPath(_, _, _, _) = VSConstants.S_OK
+ }
+ let mocks =
+ [
+ typeof<Microsoft.Internal.VisualStudio.Shell.Interop.SVsUIThreadInvokerPrivate>.GUID, box invoker
+ typeof<Microsoft.VisualStudio.Shell.Interop.SVsActivityLog>.GUID, box log
+ ] |> dict
+ let mockProvider =
+ {
+ new Microsoft.VisualStudio.OLE.Interop.IServiceProvider with
+ member this.QueryService(guidService, riid, punk) =
+ match mocks.TryGetValue guidService with
+ | true, v ->
+ punk <- System.Runtime.InteropServices.Marshal.GetIUnknownForObject(v)
+ VSConstants.S_OK
+ | _ ->
+ punk <- IntPtr.Zero
+ VSConstants.E_NOINTERFACE
+ }
+
+ let _ = Microsoft.VisualStudio.Shell.ServiceProvider.CreateFromSetSite(mockProvider)
+ let envDte80RefAssemPath = Path.Combine(Net20AssemExPathOnThisMachine(), "EnvDTE80.dll")
+ let dirName = Path.GetTempPath()
+ let copy = Path.Combine(dirName, "EnvDTE80.dll")
+ try
+ File.Copy(envDte80RefAssemPath, copy, true)
+ this.MakeProjectAndDo
+ (
+ ["DoesNotMatter.fs"],
+ [],
+ "",
+ fun proj ->
+ let refContainer = GetReferenceContainerNode(proj)
+ let automationRefs = refContainer.Object :?> Automation.OAReferences
+ automationRefs.Add(copy) |> ignore
+ SaveProject(proj)
+ let fsprojFileText = File.ReadAllText(proj.FileName)
+ printfn "%s" fsprojFileText
+ let expectedFsProj =
+ @"<Reference Include=""EnvDTE80"">"
+ + @"\s*<HintPath>\.\.\\EnvDTE80.dll</HintPath>"
+ + @"\s*</Reference>"
+ TheTests.HelpfulAssertMatches '<' expectedFsProj fsprojFileText
+ )
+ finally
+ File.Delete(copy)
+
/// Create a dummy project named 'Test', build it, and then call k with the full path to the resulting exe
member public this.CreateDummyTestProjectBuildItAndDo(k : string -> unit) =
this.MakeProjectAndDo(["foo.fs"], [], "", (fun project ->
@@ -344,9 +447,9 @@ type References() =
let expectedFsprojRegex = @"<Reference Include=""Test"">"
+ @"\s*<HintPath>Test.exe</HintPath>" // in this directory
+ @"\s*</Reference>"
- this.MakeProjectAndDo(["bar.fs"], [], "", "v3.5", (fun project ->
+ this.MakeProjectAndDo(["bar.fs"], [], "", null, (fun project ->
let exeCopy = Path.Combine(project.ProjectFolder, "Test.exe")
- File.Copy(exe, exeCopy, true)
+ File.Copy(exe, exeCopy, true)
Assert.IsTrue(File.Exists exeCopy, "failed to build exe")
let selectorData = new VSCOMPONENTSELECTORDATA(``type`` = VSCOMPONENTTYPE.VSCOMPONENTTYPE_File, bstrFile = exeCopy)
let refContainer = GetReferenceContainerNode(project)
@@ -381,7 +484,7 @@ type References() =
let expectedFsprojRegex = @"<Reference Include=""Test"">"
+ @"\s*<HintPath>\.\.\\.*?</HintPath>" // the point is, some path start with "..\", since both projects are rooted somewhere in the temp directory (where unit tests create them)
+ @"\s*</Reference>"
- this.MakeProjectAndDo(["bar.fs"], [], "", "v3.5", (fun project ->
+ this.MakeProjectAndDo(["bar.fs"], [], "", null, (fun project ->
let selectorData = new VSCOMPONENTSELECTORDATA(``type`` = VSCOMPONENTTYPE.VSCOMPONENTTYPE_File, bstrFile = exe)
let refContainer = GetReferenceContainerNode(project)
refContainer.AddReferenceFromSelectorData(selectorData) |> Assert.IsNotNull
diff --git a/src/fsharp/unittests/Tests.TypeProvidersImpl.fs b/src/fsharp/unittests/Tests.TypeProvidersImpl.fs
index 4b71502..6aa7af5 100755
--- a/src/fsharp/unittests/Tests.TypeProvidersImpl.fs
+++ b/src/fsharp/unittests/Tests.TypeProvidersImpl.fs
@@ -62,7 +62,7 @@ type TypeProviderImplTests() =
"Attempting to download metadata from 'http://bing.com/' using WS-Metadata Exchange or DISCO."
"Microsoft (R) Service Model Metadata Tool"
"[Microsoft (R) Windows (R) Communication Foundation, Version 4.0.30319.17360]"
- "Copyright (c) Microsoft Corporation. Apache 2.0 License."
+ "Copyright (c) Microsoft Corporation. All rights reserved."
""
""
""
diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs
index 7106767..91de41e 100755
--- a/src/fsharp/vs/IncrementalBuild.fs
+++ b/src/fsharp/vs/IncrementalBuild.fs
@@ -1195,7 +1195,7 @@ module internal IncrementalFSharpBuild =
// the import of a set of framework DLLs into F# CCUs. That is, the F# CCUs that result from a set of DLLs (including
// FSharp.Core.dll andb mscorlib.dll) must be logically invariant of all the other compiler configuration parameters.
let key = (frameworkDLLsKey,
- tcConfig.mscorlibAssemblyName,
+ tcConfig.primaryAssembly.Name,
tcConfig.ClrRoot,
tcConfig.fsharpBinariesDir)
match frameworkTcImportsCache.TryGet key with
@@ -1356,7 +1356,7 @@ module internal IncrementalFSharpBuild =
try
IncrementalBuilderEventsMRU.Add(IBEParsed filename)
- let result = ParseOneInputFile(tcConfig,lexResourceManager,[],filename ,isLastCompiland,errorLogger,(*retryLocked*)true)
+ let result = ParseOneInputFile(tcConfig,lexResourceManager, [], filename ,isLastCompiland,errorLogger,(*retryLocked*)true)
Trace.PrintLine("FSharpBackgroundBuildVerbose", fun _ -> sprintf "done.")
result,sourceRange,filename,errorLogger.GetErrors ()
with exn ->
@@ -1674,7 +1674,7 @@ module internal IncrementalFSharpBuild =
/// Create a type-check configuration
let tcConfigB =
let defaultFSharpBinariesDir = Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler.Value
-
+
// see also fsc.fs:runFromCommandLineToImportingAssemblies(), as there are many similarities to where the PS creates a tcConfigB
let tcConfigB =
TcConfigBuilder.CreateNew(defaultFSharpBinariesDir, implicitIncludeDir=projectDirectory,
@@ -1686,6 +1686,10 @@ module internal IncrementalFSharpBuild =
<- if useScriptResolutionRules
then MSBuildResolver.DesigntimeLike
else MSBuildResolver.CompileTimeLike
+
+ tcConfigB.conditionalCompilationDefines <-
+ let define = if useScriptResolutionRules then "INTERACTIVE" else "COMPILED"
+ define::tcConfigB.conditionalCompilationDefines
// Apply command-line arguments.
try
diff --git a/src/fsharp/vs/IncrementalBuild.fsi b/src/fsharp/vs/IncrementalBuild.fsi
index 3b6553e..c7eab84 100755
--- a/src/fsharp/vs/IncrementalBuild.fsi
+++ b/src/fsharp/vs/IncrementalBuild.fsi
@@ -8,11 +8,11 @@ open Microsoft.FSharp.Compiler.Build
[<RequireQualifiedAccess>]
-type (* internal *) Severity =
+type internal Severity =
| Warning
| Error
-type (* internal *) ErrorInfo =
+type internal ErrorInfo =
{ FileName:string
StartLine:int
EndLine:int
@@ -21,12 +21,12 @@ type (* internal *) ErrorInfo =
Severity:Severity
Message:string
Subcategory:string }
- static member internal CreateFromExceptionAndAdjustEof : PhasedError * bool * bool * range * (int*int) -> ErrorInfo
- static member internal CreateFromException : PhasedError * bool * bool * range -> ErrorInfo
+ static member CreateFromExceptionAndAdjustEof : PhasedError * bool * bool * range * (int*int) -> ErrorInfo
+ static member CreateFromException : PhasedError * bool * bool * range -> ErrorInfo
// implementation details used by other code in the compiler
[<Sealed>]
-type (* internal *) ErrorScope =
+type internal ErrorScope =
interface System.IDisposable
new : unit -> ErrorScope
member ErrorsAndWarnings : ErrorInfo list
diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/vs/ServiceDeclarations.fs
index 427609c..4658c07 100755
--- a/src/fsharp/vs/ServiceDeclarations.fs
+++ b/src/fsharp/vs/ServiceDeclarations.fs
@@ -43,7 +43,6 @@ open Microsoft.FSharp.Compiler.Infos
open Microsoft.FSharp.Compiler.Nameres
open ItemDescriptionIcons
-
module EnvMisc2 =
#if SILVERLIGHT
let GetEnvInteger e dflt = dflt
@@ -69,13 +68,13 @@ type IPartialEqualityComparer<'T> =
type iDeclarationSet = int
/// Describe a comment as either a block of text or a file+signature reference into an intellidoc file.
-type (* internal *) XmlComment =
+type internal XmlComment =
| XmlCommentNone
| XmlCommentText of string
| XmlCommentSignature of (*File and Signature*) string * string
/// A single data tip display element
-type (* internal *) DataTipElement =
+type internal DataTipElement =
| DataTipElementNone
/// A single type, method, etc with comment.
| DataTipElement of (* text *) string * XmlComment
@@ -87,7 +86,7 @@ type (* internal *) DataTipElement =
/// Information for building a data tip box.
//
// Note: this type does not hold any handles to compiler data structure.
-type (* internal *) DataTipText =
+type internal DataTipText =
/// A list of data tip elements to display.
| DataTipText of DataTipElement list
@@ -152,7 +151,7 @@ module internal ItemDescriptionsImpl =
let rangeOfPropInfo (pinfo:PropInfo) =
match pinfo with
#if EXTENSIONTYPING
- | ProvidedProp(_,pi,_,_) -> definitionLocationOfProvidedItem pi
+ | ProvidedProp(_,pi,_) -> definitionLocationOfProvidedItem pi
#endif
| _ -> pinfo.ArbitraryValRef |> Option.map (fun v -> v.Range)
@@ -166,7 +165,7 @@ module internal ItemDescriptionsImpl =
let rangeOfEventInfo (einfo:EventInfo) =
match einfo with
#if EXTENSIONTYPING
- | ProvidedEvent (_,_,ei,_) -> definitionLocationOfProvidedItem ei
+ | ProvidedEvent (_,ei,_) -> definitionLocationOfProvidedItem ei
#endif
| _ -> einfo.ArbitraryValRef |> Option.map (fun v -> v.Range)
@@ -219,18 +218,13 @@ module internal ItemDescriptionsImpl =
| Item.ArgName _ -> None
| _ -> None
- /// Work out the likely source file for an item
+ /// Work out the source file for an item and fix it up relative to the CCU if it is relative.
let fileNameOfItem (g:TcGlobals) qualProjectDir (m:range) h =
let file = m.FileName
dprintf "file stored in metadata is '%s'\n" file
if not (FileSystem.IsPathRootedShim file) then
- match (ccuOfItem g h) with
+ match ccuOfItem g h with
| Some ccu ->
-
- // Note: For F# library DLLs, the code in build.ml fixes uo the SourceCodeDirectory (compileTimeWorkingDir)
- // to be defaultFSharpBinariesDir\..\lib\<library-name>, i.e. the location of the source for the
- // file in the F# installation location
-
Path.Combine(ccu.SourceCodeDirectory, file)
| None ->
match qualProjectDir with
@@ -318,35 +312,25 @@ module internal ItemDescriptionsImpl =
let GetXmlDocSigOfMethInfo (infoReader:InfoReader) m (minfo:MethInfo) =
let amap = infoReader.amap
match minfo with
- | FSMeth (g,typ,vref,_) ->
- let tcref = tcrefOfAppTy g typ
- GetXmlDocSigOfValRef g tcref vref
+ | FSMeth (g,_,vref,_) ->
+ GetXmlDocSigOfValRef g minfo.DeclaringEntityRef vref
| ILMeth (g,ilminfo,_) ->
- let tinfo,isExt,mdef,fmtps=
- match ilminfo with
- | ILMethInfo(tinfo,isExt,mdef,fmtps) -> Some tinfo,isExt,mdef,fmtps
- | ILFSMethInfo(_,_,isExt,mdef) -> None,isExt,mdef,[]
-
- let actualTypeName,tcref =
- match tinfo,isExt with
- | _,Some ext -> ext.FullName, Import.ImportILTypeRef amap m ext
- | Some tinfo,None -> tinfo.ILTypeRef.FullName, tinfo.TyconRef
- | _ -> failwith "cannot happen"
-
+ let actualTypeName = ilminfo.DeclaringTyconRef.CompiledRepresentationForNamedType.FullName
+ let fmtps = ilminfo.FormalMethodTypars
let genArity = if fmtps.Length=0 then "" else sprintf "``%d" fmtps.Length
- match metaInfoOfEntityRef infoReader m tcref with
+ match metaInfoOfEntityRef infoReader m ilminfo.DeclaringTyconRef with
| None -> XmlCommentNone
| Some (ccuFileName,formalTypars,formalTypeInfo) ->
- let filminfo = ILMethInfo(formalTypeInfo,isExt,mdef,fmtps)
+ let filminfo = ILMethInfo(g,formalTypeInfo.ToType,None,ilminfo.RawMetadata,fmtps)
let args =
- match isExt with
- | Some _ -> filminfo.GetRawArgTypes(amap,m,minfo.FormalMethodInst)
- | None -> filminfo.GetParamTypes(amap,m,minfo.FormalMethodInst)
+ match ilminfo.IsILExtensionMethod with
+ | true -> filminfo.GetRawArgTypes(amap,m,minfo.FormalMethodInst)
+ | false -> filminfo.GetParamTypes(amap,m,minfo.FormalMethodInst)
// http://msdn.microsoft.com/en-us/library/fsbx0t7x.aspx
// If the name of the item itself has periods, they are replaced by the hash-sign ('#'). It is assumed that no item has a hash-sign directly in its name. For example, the fully qualified name of the String constructor would be "System.String.#ctor".
- let normalizedName = mdef.Name.Replace(".","#")
+ let normalizedName = ilminfo.ILName.Replace(".","#")
XmlCommentSignature (ccuFileName,"M:"+actualTypeName+"."+normalizedName+genArity+XmlDocArgsEnc g (formalTypars,fmtps) args)
| DefaultStructCtor _ -> XmlCommentNone
@@ -521,14 +505,14 @@ module internal ItemDescriptionsImpl =
| Wrap(Item.ILField(ILFieldInfo(_, fld1))), Wrap(Item.ILField(ILFieldInfo(_, fld2))) ->
fld1 === fld2 // reference equality on the object identity of the AbstractIL metadata blobs for the fields
| Wrap(Item.CustomOperation (_,_,Some minfo1)), Wrap(Item.CustomOperation (_,_,Some minfo2)) ->
- Infos.MethInfosUseIdenticalDefinitions () minfo1 minfo2
+ MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2
| Wrap(Item.TypeVar nm1), Wrap(Item.TypeVar nm2) ->
(nm1 = nm2)
| Wrap(Item.ModuleOrNamespaces(modref1 :: _)), Wrap(Item.ModuleOrNamespaces(modref2 :: _)) -> fullDisplayTextOfModRef modref1 = fullDisplayTextOfModRef modref2
| Wrap(Item.SetterArg(id1,_)), Wrap(Item.SetterArg(id2,_)) -> (id1.idRange, id1.idText) = (id2.idRange, id2.idText)
| Wrap(Item.MethodGroup(_, meths1)), Wrap(Item.MethodGroup(_, meths2)) ->
Seq.zip meths1 meths2 |> Seq.forall (fun (minfo1, minfo2) ->
- Infos.MethInfosUseIdenticalDefinitions () minfo1 minfo2)
+ MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2)
| Wrap(Item.Value vref1 | Item.CustomBuilder (_,vref1)), Wrap(Item.Value vref2 | Item.CustomBuilder (_,vref2)) -> valRefEq g vref1 vref2
| Wrap(Item.ActivePatternCase(APElemRef(_apinfo1, vref1, idx1))), Wrap(Item.ActivePatternCase(APElemRef(_apinfo2, vref2, idx2))) ->
idx1 = idx2 && valRefEq g vref1 vref2
@@ -536,11 +520,11 @@ module internal ItemDescriptionsImpl =
| Wrap(Item.RecdField(RecdFieldInfo(_, RFRef(tcref1, n1)))), Wrap(Item.RecdField(RecdFieldInfo(_, RFRef(tcref2, n2)))) ->
(tyconRefEq g tcref1 tcref2) && (n1 = n2) // there is no direct function as in the previous case
| Wrap(Item.Property(_, pi1s)), Wrap(Item.Property(_, pi2s)) ->
- List.zip pi1s pi2s |> List.forall(fun (pi1, pi2) -> Infos.PropInfosUseIdenticalDefinitions pi1 pi2)
- | Wrap(Item.Event(evt1)), Wrap(Item.Event(evt2)) -> Infos.EventInfosUseIdenticalDefintions evt1 evt2
+ List.zip pi1s pi2s |> List.forall(fun (pi1, pi2) -> PropInfo.PropInfosUseIdenticalDefinitions pi1 pi2)
+ | Wrap(Item.Event(evt1)), Wrap(Item.Event(evt2)) -> EventInfo.EventInfosUseIdenticalDefintions evt1 evt2
| Wrap(Item.CtorGroup(_, meths1)), Wrap(Item.CtorGroup(_, meths2)) ->
Seq.zip meths1 meths2
- |> Seq.forall (fun (minfo1, minfo2) -> Infos.MethInfosUseIdenticalDefinitions () minfo1 minfo2)
+ |> Seq.forall (fun (minfo1, minfo2) -> MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2)
| _ -> false)
member x.GetHashCode item =
@@ -554,19 +538,19 @@ module internal ItemDescriptionsImpl =
| Wrap(Item.ILField(ILFieldInfo(_, fld))) ->
System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode fld // hash on the object identity of the AbstractIL metadata blob for the field
| Wrap(Item.TypeVar nm) -> hash nm
- | Wrap(Item.CustomOperation (_,_,Some minfo)) -> Infos.GetMethInfoHashCode minfo
+ | Wrap(Item.CustomOperation (_,_,Some minfo)) -> minfo.ComputeHashCode()
| Wrap(Item.CustomOperation (_,_,None)) -> 1
| Wrap(Item.ModuleOrNamespaces(modref :: _)) -> hash (fullDisplayTextOfModRef modref)
| Wrap(Item.SetterArg(id,_)) -> hash (id.idRange, id.idText)
- | Wrap(Item.MethodGroup(_, meths)) -> meths |> List.fold (fun st a -> st + (Infos.GetMethInfoHashCode(a))) 0
- | Wrap(Item.CtorGroup(name, meths)) -> name.GetHashCode() + (meths |> List.fold (fun st a -> st + (Infos.GetMethInfoHashCode(a))) 0)
+ | Wrap(Item.MethodGroup(_, meths)) -> meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0
+ | Wrap(Item.CtorGroup(name, meths)) -> name.GetHashCode() + (meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0)
| Wrap(Item.Value vref | Item.CustomBuilder (_,vref)) -> hash vref.LogicalName
| Wrap(Item.ActivePatternCase(APElemRef(_apinfo, vref, idx))) -> hash (vref.LogicalName, idx)
| Wrap(Item.ExnCase(tcref)) -> hash tcref.Stamp
| Wrap(Item.UnionCase(UnionCaseInfo(_, UCRef(tcref, n)))) -> hash(tcref.Stamp, n)
| Wrap(Item.RecdField(RecdFieldInfo(_, RFRef(tcref, n)))) -> hash(tcref.Stamp, n)
- | Wrap(Item.Event evt) -> Infos.GetEventInfoHashCode(evt)
- | Wrap(Item.Property(_name, pis)) -> hash (pis |> List.map Infos.GetPropInfoHashCode)
+ | Wrap(Item.Event evt) -> evt.ComputeHashCode()
+ | Wrap(Item.Property(_name, pis)) -> hash (pis |> List.map (fun pi -> pi.ComputeHashCode()))
| _ -> failwith "unreachable") }
// Remove items containing the same module references
@@ -614,6 +598,9 @@ module internal ItemDescriptionsImpl =
let amap = infoReader.amap
let denv = SimplerDisplayEnv denv isDeclInfo
match d with
+ | Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(_, vref, _)) }) ->
+ // operator with solution
+ FormatItemDescriptionToDataTipElement isDeclInfo infoReader m denv (Item.Value vref)
| Item.Value vref | Item.CustomBuilder (_,vref) ->
let text =
bufs (fun os ->
@@ -633,14 +620,17 @@ module internal ItemDescriptionsImpl =
let uc = ucinfo.UnionCase
let rty = generalizedTyconRef ucinfo.TyconRef
let recd = uc.RecdFields
- let ty = if isNil recd then rty else (mkTupledTy g (recd |> List.map (fun rfld -> rfld.FormalType))) --> rty
let text =
bufs (fun os ->
bprintf os "%s " (FSComp.SR.typeInfoUnionCase())
NicePrint.outputTyconRef denv os ucinfo.TyconRef
bprintf os ".%s: "
(DecompileOpName uc.Id.idText)
- NicePrint.outputTy denv os ty)
+ if not (isNil recd) then
+ NicePrint.outputUnionCases denv os recd
+ os.Append (" -> ") |> ignore
+ NicePrint.outputTy denv os rty )
+
let xml = GetXmlComment (if (tyconRefUsesLocalXmlDoc g.compilingFslib ucinfo.TyconRef) then uc.XmlDoc else XmlDoc [||]) infoReader m d
DataTipElement(text, xml)
@@ -707,7 +697,7 @@ module internal ItemDescriptionsImpl =
let dataTip = bufs (fun os ->
bprintf os "%s " (FSComp.SR.typeInfoField())
NicePrint.outputILTypeRef denv os finfo.ILTypeRef
- bprintf os "%s" finfo.FieldName;
+ bprintf os ".%s" finfo.FieldName;
match finfo.LiteralValue with
| None -> ()
| Some v ->
@@ -743,7 +733,6 @@ module internal ItemDescriptionsImpl =
let _, rty, _ = PrettyTypes.PrettifyTypes1 g rty
let text =
bufs (fun os ->
- // REVIEW: use _cxs here
bprintf os "%s " (FSComp.SR.typeInfoProperty())
NicePrint.outputTyconRef denv os (tcrefOfAppTy g pinfo.EnclosingType)
bprintf os ".%s: " pinfo.PropertyName
@@ -962,16 +951,11 @@ module internal ItemDescriptionsImpl =
| ParentNone -> None
| ILMeth (_,minfo,_) ->
- let tcref,isExt,mdef = match minfo with ILMethInfo(tinfo,isExt,mdef,_) -> tinfo.TyconRef,isExt,mdef | ILFSMethInfo(tcref,_,isExt,mdef) -> tcref,isExt,mdef
- let typeString =
- // Extension methods cannot appear in generic classes, so we do not need any ticks
- match isExt with
- | None -> tcref |> ticksAndArgCountTextOfTyconRef
- | Some iltyperef -> iltyperef.Name
+ let typeString = minfo.DeclaringTyconRef |> ticksAndArgCountTextOfTyconRef
let paramString =
- let nGenericParams = mdef.GenericParams.Length
+ let nGenericParams = minfo.RawMetadata.GenericParams.Length
if nGenericParams > 0 then "``"+(nGenericParams.ToString()) else ""
- sprintf "%s.%s%s" typeString mdef.Name paramString |> Some
+ sprintf "%s.%s%s" typeString minfo.RawMetadata.Name paramString |> Some
| DefaultStructCtor _ -> None
#if EXTENSIONTYPING
@@ -1076,7 +1060,7 @@ module internal ItemDescriptionsImpl =
(tcref |> ticksAndArgCountTextOfTyconRef) + ".#ctor"|> Some
| ParentNone -> None
| (ILMeth (_,minfo,_)) :: _ ->
- let tcref = match minfo with ILMethInfo(tinfo,_,_,_) -> tinfo.TyconRef | ILFSMethInfo(tcref,_,_,_) -> tcref
+ let tcref = minfo.DeclaringTyconRef
(tcref |> ticksAndArgCountTextOfTyconRef)+".#ctor" |> Some
| (DefaultStructCtor (g,typ) :: _) ->
let tcref = tcrefOfAppTy g typ
@@ -1291,7 +1275,7 @@ type DeclarationSet(declarations: Declaration[]) =
// Put type ctors after types, sorted by #typars. RemoveDuplicateItems will remove DefaultStructCtors if a type is also reported with this name
| Item.CtorGroup (_, (cinfo :: _)) -> 1000 + 10 * (tcrefOfAppTy g cinfo.EnclosingType).TyparsNoRange.Length
| _ -> 0
- (DisplayNameOfItem g d,n))
+ (d.DisplayName g,n))
// Remove all duplicates. We've put the types first, so this removes the DelegateCtor and DefaultStructCtor's.
let items = items |> RemoveDuplicateItems g
@@ -1299,7 +1283,7 @@ type DeclarationSet(declarations: Declaration[]) =
if verbose then dprintf "service.ml: mkDecls: %d found groups after filtering\n" (List.length items);
// Group by display name
- let items = items |> List.groupBy (fun d -> DisplayNameOfItem g d)
+ let items = items |> List.groupBy (fun d -> d.DisplayName g)
// Filter out operators (and list)
let items =
diff --git a/src/fsharp/vs/ServiceDeclarations.fsi b/src/fsharp/vs/ServiceDeclarations.fsi
index b90ced2..51cd4d4 100755
--- a/src/fsharp/vs/ServiceDeclarations.fsi
+++ b/src/fsharp/vs/ServiceDeclarations.fsi
@@ -25,11 +25,10 @@ open Microsoft.FSharp.Compiler.Nameres
open Microsoft.FSharp.Compiler.Tast
open Microsoft.FSharp.Compiler.Tastops
-
/// Describe a comment as either a block of text or a file+signature reference into an intellidoc file.
//
// Note: instances of this type do not hold any references to any compiler resources.
-type (* internal *) XmlComment =
+type internal XmlComment =
| XmlCommentNone
| XmlCommentText of string
| XmlCommentSignature of (*File:*) string * (*Signature:*)string
@@ -37,7 +36,7 @@ type (* internal *) XmlComment =
/// A single data tip display element
//
// Note: instances of this type do not hold any references to any compiler resources.
-type (* internal *) DataTipElement =
+type internal DataTipElement =
| DataTipElementNone
/// A single type, method, etc with comment.
| DataTipElement of (* text *) string * XmlComment
@@ -49,20 +48,20 @@ type (* internal *) DataTipElement =
/// Information for building a data tip box.
//
// Note: instances of this type do not hold any references to any compiler resources.
-type (* internal *) DataTipText =
+type internal DataTipText =
/// A list of data tip elements to display.
| DataTipText of DataTipElement list
[<Sealed>]
// Note: this type holds a weak reference to compiler resources.
-type (* internal *) Declaration =
+type internal Declaration =
member Name : string
member DescriptionText : DataTipText
member Glyph : int
[<Sealed>]
// Note: this type holds a weak reference to compiler resources.
-type (* internal *) DeclarationSet =
+type internal DeclarationSet =
member Items : Declaration[]
// Implementation details used by other code in the compiler
diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs
index f75f149..9b1bb8e 100755
--- a/src/fsharp/vs/ServiceLexing.fs
+++ b/src/fsharp/vs/ServiceLexing.fs
@@ -539,11 +539,12 @@ type SingleLineTokenState =
/// Split a line into tokens and attach information about the tokens. This information is used by Visual Studio.
[<Sealed>]
-type (* internal *) LineTokenizer(lexbuf: UnicodeLexing.Lexbuf,
- maxLength: int option,
- filename : string,
- lexArgsLightOn : lexargs,
- lexArgsLightOff : lexargs) =
+type internal LineTokenizer(lexbuf: UnicodeLexing.Lexbuf,
+ maxLength: int option,
+ filename : string,
+ lexArgsLightOn : lexargs,
+ lexArgsLightOff : lexargs
+ ) =
let skip = false // don't skip whitespace in the lexer
diff --git a/src/fsharp/vs/ServiceLexing.fsi b/src/fsharp/vs/ServiceLexing.fsi
index b2eb049..3d9a151 100755
--- a/src/fsharp/vs/ServiceLexing.fsi
+++ b/src/fsharp/vs/ServiceLexing.fsi
@@ -20,7 +20,7 @@ open Microsoft.FSharp.Compiler.Range
open System.Collections.Generic
/// Represents encoded information for the end-of-line continutation of lexing
-type (* internal *) LexState = int64
+type internal LexState = int64
type ColorState =
| Token = 1
@@ -42,12 +42,12 @@ type ColorState =
/// A line/column pair
-type (* internal *) Position = int * int
+type internal Position = int * int
/// A start-position/end-position pair
-type (* internal *) Range = Position * Position
+type internal Range = Position * Position
-type (* internal *) TokenColorKind =
+type internal TokenColorKind =
| Default = 0
| Text = 0
| Keyword = 1
@@ -63,7 +63,7 @@ type (* internal *) TokenColorKind =
| TypeName = 11
#endif
-type (* internal *) TriggerClass =
+type internal TriggerClass =
| None = 0x00000000
| MemberSelect = 0x00000001
| MatchBraces = 0x00000002
@@ -73,7 +73,7 @@ type (* internal *) TriggerClass =
| ParamNext = 0x00000020
| ParamEnd = 0x00000040
-type (* internal *) TokenCharKind =
+type internal TokenCharKind =
| Default = 0x00000000
| Text = 0x00000000
| Keyword = 0x00000001
@@ -87,7 +87,7 @@ type (* internal *) TokenCharKind =
| Comment = 0x0000000A
/// Information about a particular token from the tokenizer
-type (* internal *) TokenInformation =
+type internal TokenInformation =
{ /// Left column of the token.
LeftColumn:int
/// Right column of the token.
@@ -111,7 +111,7 @@ type (* internal *) TokenInformation =
/// A new lexState is also returned. An IDE-plugin should in general cache the lexState
/// values for each line of the edited code.
[<Sealed>]
-type (* internal *) LineTokenizer =
+type internal LineTokenizer =
/// Scan one token from the line
member ScanToken : lexState:LexState -> TokenInformation option * LexState
static member ColorStateOfLexState : LexState -> ColorState
@@ -120,7 +120,7 @@ type (* internal *) LineTokenizer =
/// Tokenizer for a source file. Holds some expensive-to-compute resources at the scope of the file.
[<Sealed>]
-type (* internal *) SourceTokenizer =
+type internal SourceTokenizer =
new : conditionalDefines:string list * fileName:string -> SourceTokenizer
member CreateLineTokenizer : lineText:string -> LineTokenizer
member CreateBufferTokenizer : bufferFiller:(char[] * int * int -> int) -> LineTokenizer
diff --git a/src/fsharp/vs/ServiceParseTreeWalk.fs b/src/fsharp/vs/ServiceParseTreeWalk.fs
index 5032ded..4026edd 100755
--- a/src/fsharp/vs/ServiceParseTreeWalk.fs
+++ b/src/fsharp/vs/ServiceParseTreeWalk.fs
@@ -373,11 +373,15 @@ module internal AstTraversal =
|> pick expr
| SynExpr.DotIndexedGet(synExpr, synExprList, _range, _range2) ->
[yield dive synExpr synExpr.Range traverseSynExpr
- yield! synExprList |> List.map (fun x -> dive x x.Range traverseSynExpr)]
+ for synExpr in synExprList do
+ for x in synExpr.Exprs do
+ yield dive x x.Range traverseSynExpr]
|> pick expr
| SynExpr.DotIndexedSet(synExpr, synExprList, synExpr2, _, _range, _range2) ->
[yield dive synExpr synExpr.Range traverseSynExpr
- yield! synExprList |> List.map (fun x -> dive x x.Range traverseSynExpr)
+ for synExpr in synExprList do
+ for x in synExpr.Exprs do
+ yield dive x x.Range traverseSynExpr
yield dive synExpr2 synExpr2.Range traverseSynExpr]
|> pick expr
| SynExpr.JoinIn(synExpr1, _range, synExpr2, _range2) ->
diff --git a/src/fsharp/vs/ServiceUntypedParse.fs b/src/fsharp/vs/ServiceUntypedParse.fs
index a7d8608..c0c9ff5 100755
--- a/src/fsharp/vs/ServiceUntypedParse.fs
+++ b/src/fsharp/vs/ServiceUntypedParse.fs
@@ -97,15 +97,15 @@ type internal UntypedParseResults =
}
[<Sealed>]
-type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
+type internal UntypedParseInfo(parsed:UntypedParseResults) =
- member internal scope.ParseTree =
+ member scope.ParseTree =
match parsed with
| { Input=x } -> x
- member internal scope.Results = parsed
+ member scope.Results = parsed
- member internal scope.FindNoteworthyParamInfoLocations(line,col) =
+ member scope.FindNoteworthyParamInfoLocations(line,col) =
match parsed with
| { Input=Some(input) } ->
// Why don't we traverse the AST under a syncop? We don't need to, because the AST is an _immutable_ DU of DUs of ints and strings and whatnot. And a SyncOp really does slow it down in practice.
@@ -151,7 +151,7 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
let isFunction =
isSome memFlagsOpt ||
match synPat with
- | SynPat.LongIdent (_,_,_,args,_,_) when nonNil args -> true
+ | SynPat.LongIdent (_,_,_, SynConstructorArgs.Pats args,_,_) when nonNil args -> true
| _ -> false
if not isFunction then
yield! walkBindSeqPt spInfo
@@ -163,7 +163,7 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
and walkMatchClauses cl =
[ for (Clause(_,whenExpr,e,_,_)) in cl do
match whenExpr with Some e -> yield! walkExpr false e | _ -> ()
- yield! walkExpr true e; ]
+ yield! walkExpr true e ]
and walkExprOpt (spAlways:bool) eOpt = [ match eOpt with Some e -> yield! walkExpr spAlways e | _ -> () ]
@@ -218,8 +218,8 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
| SynExpr.DotSet (e1,_,e2,_)
| SynExpr.LibraryOnlyUnionCaseFieldSet (e1,_,_,e2,_)
| SynExpr.App (_,_,e1,e2,_) ->
- yield! walkExpr false e1;
- yield! walkExpr false e2;
+ yield! walkExpr false e1
+ yield! walkExpr false e2
| SynExpr.ArrayOrList (_,es,_)
| SynExpr.Tuple (es,_,_) ->
@@ -230,40 +230,40 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
yield! walkExprs (List.map (fun (_, v, _) -> v) fs |> List.choose id)
| SynExpr.ObjExpr (_,_,bs,is,_,_) ->
- yield! walkBinds bs ;
+ yield! walkBinds bs
for (InterfaceImpl(_,bs,_)) in is do yield! walkBinds bs
| SynExpr.While (spWhile,e1,e2,_) ->
yield! walkWhileSeqPt spWhile
- yield! walkExpr false e1;
- yield! walkExpr true e2;
+ yield! walkExpr false e1
+ yield! walkExpr true e2
| SynExpr.JoinIn(e1, _range, e2, _range2) ->
- yield! walkExpr false e1;
- yield! walkExpr false e2;
+ yield! walkExpr false e1
+ yield! walkExpr false e2
| SynExpr.For (spFor,_,e1,_,e2,e3,_) ->
yield! walkForSeqPt spFor
- yield! walkExpr false e1;
- yield! walkExpr true e2;
- yield! walkExpr true e3;
+ yield! walkExpr false e1
+ yield! walkExpr true e2
+ yield! walkExpr true e3
| SynExpr.ForEach (spFor,_,_,_,e1,e2,_) ->
yield! walkForSeqPt spFor
- yield! walkExpr false e1;
- yield! walkExpr true e2;
+ yield! walkExpr false e1
+ yield! walkExpr true e2
| SynExpr.MatchLambda(_isExnMatch,_argm,cl,spBind,_wholem) ->
yield! walkBindSeqPt spBind
for (Clause(_,whenExpr,e,_,_)) in cl do
yield! walkExprOpt false whenExpr
- yield! walkExpr true e;
+ yield! walkExpr true e
| SynExpr.Lambda (_,_,_,e,_) ->
- yield! walkExpr true e;
+ yield! walkExpr true e
| SynExpr.Match (spBind,e,cl,_,_) ->
yield! walkBindSeqPt spBind
- yield! walkExpr false e;
+ yield! walkExpr false e
for (Clause(_,whenExpr,e,_,_)) in cl do
yield! walkExprOpt false whenExpr
- yield! walkExpr true e;
+ yield! walkExpr true e
| SynExpr.LetOrUse (_,_,bs,e,_) ->
- yield! walkBinds bs ;
- yield! walkExpr true e;
+ yield! walkBinds bs
+ yield! walkExpr true e
| SynExpr.TryWith (e,_,cl,_,_,spTry,spWith) ->
yield! walkTrySeqPt spTry
@@ -285,17 +285,16 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) =
yield! walkExpr true e2
yield! walkExprOpt true e3opt
| SynExpr.DotIndexedGet (e1,es,_,_) ->
- yield! walkExpr false e1;
- yield! walkExprs es;
-
+ yield! walkExpr false e1
+ yield! walkExprs [ for e in es do yield! e.Exprs ]
| SynExpr.DotIndexedSet (e1,es,e2,_,_,_) ->
- yield! walkExpr false e1;
- yield! walkExprs es;
- yield! walkExpr false e2;
+ yield! walkExpr false e1
+ yield! walkExprs [ for e in es do yield! e.Exprs ]
+ yield! walkExpr false e2
| SynExpr.DotNamedIndexedPropertySet (e1,_,e2,e3,_) ->
- yield! walkExpr false e1;
- yield! walkExpr false e2;
- yield! walkExpr false e3;
+ yield! walkExpr false e1
+ yield! walkExpr false e2
+ yield! walkExpr false e3
| SynExpr.LetOrUseBang (spBind,_,_,_,e1,e2,_) ->
yield! walkBindSeqPt spBind
diff --git a/src/fsharp/vs/ServiceUntypedParse.fsi b/src/fsharp/vs/ServiceUntypedParse.fsi
index 9e12d60..5c8dba3 100755
--- a/src/fsharp/vs/ServiceUntypedParse.fsi
+++ b/src/fsharp/vs/ServiceUntypedParse.fsi
@@ -35,7 +35,7 @@ type internal UntypedParseResults =
}
[<Sealed>]
-type (* internal *) UntypedParseInfo =
+type internal UntypedParseInfo =
member internal ParseTree : Ast.ParsedInput option
/// Notable parse info for ParameterInfo at a given location
member internal FindNoteworthyParamInfoLocations : line:int * col:int -> NoteworthyParamInfoLocations option
@@ -56,8 +56,6 @@ module internal SourceFile =
/// Whether or not this file should be a single-file project
val MustBeSingleFileProject : string -> bool
-
-
type internal CompletionPath = string list * string option // plid * residue
type internal InheritanceContext =
diff --git a/src/fsharp/vs/SimpleServices.fs b/src/fsharp/vs/SimpleServices.fs
index a1be9f6..9de32f0 100755
--- a/src/fsharp/vs/SimpleServices.fs
+++ b/src/fsharp/vs/SimpleServices.fs
@@ -85,6 +85,10 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices
async { let! items = results.GetDeclarations(Some info, (line, col), source.[line], (names, residue), hasChangedSinceLastTypeCheck)
return [| for i in items.Items -> Declaration(i.Name, (fun () -> formatTip i.DescriptionText xmlCommentRetriever)) |] }
+ member x.GetRawDeclarations(line, col, names, residue, formatter:DataTipText->string[]) =
+ async { let! items = results.GetDeclarations(Some info, (line, col), source.[line], (names, residue), hasChangedSinceLastTypeCheck)
+ return [| for i in items.Items -> i.Name, (fun() -> formatter i.DescriptionText), i.Glyph |] }
+
/// Get the Visual Studio F1-help keyword for the item at the given position
member x.GetF1Keyword(line, col, names) =
results.GetF1Keyword((line, col), source.[line], names)
@@ -94,6 +98,9 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices
let tip = results.GetDataTipText((line, col), source.[line], names, identToken)
formatTip tip xmlCommentRetriever
+ member x.GetRawDataTipText(line, col, names) =
+ results.GetDataTipText((line, col), source.[line], names, identToken)
+
/// Get the location of the declaration at the given position
member x.GetDeclarationLocation(line: int, col: int, names, isDecl) =
results.GetDeclarationLocation((line, col), source.[line], names, identToken, isDecl)
@@ -167,14 +174,16 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices
member x.ErrorSinkImpl(exn) = errorSink false exn
member x.ErrorCount = errors |> Seq.filter (fun e -> e.Severity = Severity.Error) |> Seq.length }
- let createErrorLogger _ = errorLogger
-
+ let loggerProvider =
+ { new ErrorLoggerProvider() with
+ member log.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter) = errorLogger }
+
let result =
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse)
use unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger)
let exiter = { new Exiter with member x.Exit n = raise StopProcessing }
try
- mainCompile (argv, true, exiter, createErrorLogger);
+ typecheckAndCompile (argv, true, exiter, loggerProvider);
0
with e ->
stopProcessingRecovery e Range.range0
@@ -213,7 +222,7 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices
(ilGlobals ,
Microsoft.FSharp.Compiler.AbstractIL.ILRuntimeWriter.emEnv0,
assemblyBuilder,moduleBuilder,
- ilxMainModule,
+ { ilxMainModule with Resources=Microsoft.FSharp.Compiler.AbstractIL.IL.mkILResources [] },
debugInfo,
(fun s ->
match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathFromAssemblyRef s with
diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs
index 67da736..5f36b04 100755
--- a/src/fsharp/vs/service.fs
+++ b/src/fsharp/vs/service.fs
@@ -87,11 +87,19 @@ module internal Params =
let denv = denv.SetOpenPaths([])
// now printing will see a .NET-like canonical representation, that is good for sorting overloads into a reasonable order (see bug 94520)
NicePrint.stringOfTy denv strippedType
+
let ParamOfRecdField g denv f =
{ Name = f.rfield_id.idText
CanonicalTypeTextForSorting = printCanonicalizedTypeName g denv f.rfield_type
Display = NicePrint.prettyStringOfTy denv f.rfield_type
Description = "" }
+
+ let ParamOfUnionCaseField g denv isGenerated (i : int) f =
+ let initial = ParamOfRecdField g denv f
+ if isGenerated i f then initial
+ else
+ { initial with Display = NicePrint.stringOfParamData denv (ParamData(false, false, NotOptional, (Some initial.Name), f.rfield_type)) }
+
let ParamOfParamData g denv (ParamData(_isParamArrayArg,_isOutArg,_optArgInfo,nmOpt,pty) as paramData) =
{ Name = match nmOpt with None -> "" | Some pn -> pn
CanonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty
@@ -127,10 +135,6 @@ module internal Params =
Description = "" })
let ParamsOfTypes g denv args rtau =
- (*let arg,rtau = destFunTy rtau
- let args = tryDestTupleTy arg *)
-
- // Review, use tpcsL here
let ptausL, _ = NicePrint.layoutPrettifiedTypes denv (args@[rtau])
let argsL,_ = List.frontAndBack ptausL
let mkParam (tau,tyL) =
@@ -186,17 +190,20 @@ module internal Params =
// This is good enough as we don't provide ways to display info for the second curried argument
let paramDatas =
argInfo
- |> List.map ParamNameAndTypeOfArgInfo
+ |> List.map ParamNameAndType.FromArgInfo
|> List.map (fun (ParamNameAndType(nm,pty)) -> ParamData(false, false, NotOptional, nm, pty))
ParamsOfParamDatas g denv paramDatas returnTy
- | Item.UnionCase(ucr) -> ucr.UnionCase.RecdFields |> List.map (ParamOfRecdField g denv)
+ | Item.UnionCase(ucr) ->
+ match ucr.UnionCase.RecdFields with
+ | [f] -> [ParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField -1 f]
+ | fs -> fs |> List.mapi (ParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField)
| Item.ActivePatternCase(apref) ->
let v = apref.ActivePatternVal
let _,tau = v.TypeScheme
let args, _ = stripFunTy denv.g tau
ParamsOfTypes g denv args tau
| Item.ExnCase(ecref) ->
- ecref |> recdFieldsOfExnDefRef |> List.map (ParamOfRecdField g denv)
+ ecref |> recdFieldsOfExnDefRef |> List.mapi (ParamOfUnionCaseField g denv NicePrint.isGeneratedExceptionField)
| Item.Property(_,pinfo :: _) ->
let paramDatas = pinfo.GetParamDatas(amap,m)
let rty = pinfo.GetPropertyType(amap,m)
@@ -251,7 +258,7 @@ module internal Params =
/// A single method for Intellisense completion
[<NoEquality; NoComparison>]
// Note: instances of this type do not hold any references to any compiler resources.
-type (* internal *) Method =
+type internal Method =
{
Description: DataTipText
Type: string
@@ -262,7 +269,7 @@ type (* internal *) Method =
/// A table of methods for Intellisense completion
//
-// Note: this type does not hold any references to any compiler resources, nor does evaluating any of the properties execute any
+// Note: this type does not hold any strong references to any compiler resources, nor does evaluating any of the properties execute any
// code on the compiler thread.
[<Sealed>]
type MethodOverloads( name: string, unsortedMethods: Method[] ) =
@@ -279,11 +286,10 @@ type MethodOverloads( name: string, unsortedMethods: Method[] ) =
member x.Name = name
member x.Methods = methods
- static member Create(infoReader:InfoReader,m,denv,items) =
+ static member Create(infoReader:InfoReader,m,denv,items:Item list) =
let g = infoReader.g
- if verbose then dprintf "mkMethods: %d items on input\n" (List.length items)
if isNil items then new MethodOverloads("", [| |]) else
- let name = DisplayNameOfItem g items.Head
+ let name = items.Head.DisplayName g
let getOverloadsForItem item =
match methodOverloadsCache.TryGetValue item with
| true, overloads -> overloads
@@ -316,9 +322,6 @@ type MethodOverloads( name: string, unsortedMethods: Method[] ) =
| Item.CustomBuilder _ -> []
| _ -> []
- if verbose then
- dprintf "mkMethods: %d items after filtering for methodness\n" (List.length items)
-
let methods =
items |> Array.ofList |> Array.map (fun item ->
{ Description= DataTipText [FormatDescriptionOfItem true infoReader m denv item]
@@ -337,7 +340,7 @@ type MethodOverloads( name: string, unsortedMethods: Method[] ) =
//--------------------------------------------------------------------------
[<RequireQualifiedAccess>]
-type (* internal *) FindDeclFailureReason =
+type internal FindDeclFailureReason =
// generic reason: no particular information about error
| Unknown
// source code file is not available
@@ -348,7 +351,7 @@ type (* internal *) FindDeclFailureReason =
| ProvidedMember of string
[<NoEquality; NoComparison>]
-type (* internal *) FindDeclResult =
+type internal FindDeclResult =
/// declaration not found + reason
| DeclNotFound of FindDeclFailureReason
/// found declaration; return (position-in-file, name-of-file)
@@ -359,7 +362,7 @@ type (* internal *) FindDeclResult =
/// (Depending on the kind of the items, we may stop processing or continue to find better items)
[<RequireQualifiedAccess>]
[<NoEquality; NoComparison>]
-type (* internal *) NameResResult =
+type internal NameResResult =
| Members of (Item list * DisplayEnv * range)
| Cancel of DisplayEnv * range
| Empty
@@ -400,7 +403,7 @@ type CapturedNameResolution(p:pos, i:Item, io:ItemOccurence, de:DisplayEnv, nre:
[<Sealed>]
type TypeCheckInfo
(/// Information corresponding to miscellaneous command-line options (--define, etc).
- sTcConfig: Build.TcConfig,
+ _sTcConfig: Build.TcConfig,
g: Env.TcGlobals,
/// AssemblyName -> IL-Module
amap: Import.ImportMap,
@@ -738,9 +741,9 @@ type TypeCheckInfo
let f denv item = try f denv item with _ -> false
// Return only items with the specified name
- let filterDeclItemsByResidue residue items =
+ let filterDeclItemsByResidue residue (items: Item list) =
items |> List.filter (fun item ->
- let n1 = DisplayNameOfItem g item
+ let n1 = item.DisplayName g
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "\nn1 = <<<%s>>>\nn2 = <<<%s>>>\n" n1 residue)
if not (f denv item) then false
else
@@ -1120,18 +1123,23 @@ type TypeCheckInfo
match GetDeclItemsForNamesAtPosition (None,Some(names), None, line, lineStr, idx, ResolveTypeNamesToCtors,ResolveOverloads.Yes, fun _ -> false) with
| None
| Some ([], _, _) -> FindDeclResult.DeclNotFound FindDeclFailureReason.Unknown
- | Some (h :: _ , _, _) ->
- let h' =
- match h with
- | Item.MethodGroup (_, (ILMeth (_,ilinfo,_)) :: _) // rangeOfItem, ccuOfItem don't work on IL methods or fields; we'll be okay, though, looking up the method's *type* instead because they've the same CCU / source file
- | Item.CtorGroup (_, (ILMeth (_,ilinfo,_)) :: _) ->
- let ty = match ilinfo with ILMethInfo (typeInfo,_,_,_) -> typeInfo.ToType | ILFSMethInfo (t,_,_,_) -> TType_app(t,[])
- Item.Types ("", [ ty ])
+ | Some (item :: _ , _, _) ->
+
+ // For IL-based entities, switch to a different item. This is because
+ // rangeOfItem, ccuOfItem don't work on IL methods or fields.
+ //
+ // Later comment: to be honest, they aren't going to work on these new items either.
+ // This is probably old code from when we supported 'go to definition' generating IL metadata.
+ let item =
+ match item with
+ | Item.MethodGroup (_, (ILMeth (_,ilinfo,_)) :: _)
+ | Item.CtorGroup (_, (ILMeth (_,ilinfo,_)) :: _) -> Item.Types ("", [ ilinfo.ApparentEnclosingType ])
| Item.ILField (ILFieldInfo (typeInfo, _)) -> Item.Types ("", [ typeInfo.ToType ])
- | _ -> h
+ | Item.ImplicitOp(_, {contents = Some(TraitConstraintSln.FSMethSln(_, vref, _))}) -> Item.Value(vref)
+ | _ -> item
- let fail defaultReason h =
- match h with
+ let fail defaultReason =
+ match item with
#if EXTENSIONTYPING
| Params.ItemIsTypeWithStaticArguments g (tcref) -> FindDeclResult.DeclNotFound (FindDeclFailureReason.ProvidedType(tcref.DisplayName))
| Item.CtorGroup(name, ProvidedMeth(_)::_)
@@ -1142,16 +1150,16 @@ type TypeCheckInfo
#endif
| _ -> FindDeclResult.DeclNotFound defaultReason
- match rangeOfItem g isDecl h' with
- | None -> fail FindDeclFailureReason.Unknown h'
- | Some m ->
- if verbose then dprintf "tcConfig.fsharpBinariesDir = '%s'\n" sTcConfig.fsharpBinariesDir
+ match rangeOfItem g isDecl item with
+ | None -> fail FindDeclFailureReason.Unknown
+ | Some itemRange ->
- let filename = fileNameOfItem g (Some sProjectDir) m h'
+ let filename = fileNameOfItem g (Some sProjectDir) itemRange item
if FileSystem.SafeExists filename then
- FindDeclResult.DeclFound ((m.StartLine - 1, m.StartColumn), filename)
+ FindDeclResult.DeclFound ((itemRange.StartLine - 1, itemRange.StartColumn), filename)
else
- fail FindDeclFailureReason.NoSourceCode h' // provided items may have TypeProviderDefinitionLocationAttribute that binds them to some location
+ fail FindDeclFailureReason.NoSourceCode // provided items may have TypeProviderDefinitionLocationAttribute that binds them to some location
+
| _ -> FindDeclResult.DeclNotFound FindDeclFailureReason.Unknown
@@ -1275,7 +1283,6 @@ module internal Parser =
// Errors on while parsing project arguments
let parseResult =
- if verbose then dprintf "Parsing, text = \n<<<\n%s\n>>>\n" source
// If we're editing a script then we define INTERACTIVE otherwise COMPILED. Since this parsing for intellisense we always
// define EDITING
@@ -1544,7 +1551,7 @@ module internal Parser =
ReportUnexpectedException(e)
reraise()
-type UnresolvedReferencesSet =
+type internal UnresolvedReferencesSet =
val private set : System.Collections.Generic.HashSet<Build.UnresolvedAssemblyReference>
new(unresolved) = {set = System.Collections.Generic.HashSet(unresolved, HashIdentity.Structural)}
@@ -1738,16 +1745,16 @@ module internal DebuggerEnvironment =
[<NoComparison>]
-type (* internal *) TypeCheckAnswer =
+type internal TypeCheckAnswer =
| NoAntecedant
| Aborted
| TypeCheckSucceeded of TypeCheckResults
/// This file has become eligible to be re-typechecked.
-type (* internal *) NotifyFileTypeCheckStateIsDirty = NotifyFileTypeCheckStateIsDirty of (string -> unit)
+type internal NotifyFileTypeCheckStateIsDirty = NotifyFileTypeCheckStateIsDirty of (string -> unit)
// Identical to _VSFILECHANGEFLAGS in vsshell.idl
-type (* internal *) DependencyChangeCode =
+type internal DependencyChangeCode =
| NoChange = 0x00000000
| FileChanged = 0x00000001
| TimeChanged = 0x00000002
@@ -1757,7 +1764,7 @@ type (* internal *) DependencyChangeCode =
/// Callback that indicates whether a requested result has become obsolete.
[<NoComparison;NoEquality>]
-type (* internal *) IsResultObsolete =
+type internal IsResultObsolete =
| IsResultObsolete of (unit->bool)
@@ -2161,7 +2168,7 @@ open Microsoft.FSharp.Compiler.Infos
open Microsoft.FSharp.Compiler
open System.Text
-type (* internal *) typDumper(dumpTarget:Microsoft.FSharp.Compiler.Tast.TType) =
+type internal typDumper(dumpTarget:Microsoft.FSharp.Compiler.Tast.TType) =
override self.ToString() =
match !global_g with
| Some g ->
diff --git a/src/fsharp/vs/service.fsi b/src/fsharp/vs/service.fsi
index 0a5a0d8..6c85034 100755
--- a/src/fsharp/vs/service.fsi
+++ b/src/fsharp/vs/service.fsi
@@ -20,7 +20,7 @@ open Microsoft.FSharp.Compiler
open Microsoft.FSharp.Compiler.Range
open System.Collections.Generic
-type (* internal *) Param =
+type internal Param =
{ Name: string
CanonicalTypeTextForSorting: string
Display: string
@@ -28,7 +28,7 @@ type (* internal *) Param =
[<NoEquality; NoComparison>]
// Note: this type does not hold any handles to compiler data structure.
-type (* internal *) Method =
+type internal Method =
{ Description : DataTipText
Type: string
Parameters: Param[]
@@ -37,12 +37,12 @@ type (* internal *) Method =
[<Sealed>]
// Note: this type does not hold any handles to compiler data structure. All data has been pre-formatted.
-type (* internal *) MethodOverloads =
+type internal MethodOverloads =
member Name: string
member Methods: Method[]
[<RequireQualifiedAccess>]
-type (* internal *) FindDeclFailureReason =
+type internal FindDeclFailureReason =
// generic reason: no particular information about error
| Unknown
// source code file is not available
@@ -53,19 +53,19 @@ type (* internal *) FindDeclFailureReason =
| ProvidedMember of string
[<NoEquality; NoComparison>]
-type (* internal *) FindDeclResult =
+type internal FindDeclResult =
/// declaration not found + reason
| DeclNotFound of FindDeclFailureReason
/// found declaration; return (position-in-file, name-of-file)
| DeclFound of Position * string
-type (* internal *) Names = string list
-type (* internal *) NamesWithResidue = Names * string
+type internal Names = string list
+type internal NamesWithResidue = Names * string
[<Sealed>]
/// A handle to the results of TypeCheckSource.
/// A live object of this type keeps the background corresponding background builder (and type providers) alive (through reference-counting)
-type (* internal *) TypeCheckResults =
+type internal TypeCheckResults =
/// The errors returned by parsing a source file
member Errors : ErrorInfo[]
@@ -88,10 +88,10 @@ type (* internal *) TypeCheckResults =
/// wraps the set of unresolved references providing implementations of Equals\GetHashCode
/// of this objects of this type can be used as parts of types with generated Equals\GetHashCode
/// i.e. records or DUs
-type (* internal *) UnresolvedReferencesSet = class end
+type internal UnresolvedReferencesSet = class end
/// A set of key information for the language service's internal caches of project/script build information for a particular source file
-type (* internal *) CheckOptions =
+type internal CheckOptions =
{
// Note that this may not reduce to just the project directory, because there may be two projects in the same directory.
ProjectFileName: string
@@ -128,10 +128,10 @@ module internal DebuggerEnvironment =
/// This file has become eligible to be re-typechecked.
/// This notifies the language service that it needs to set the dirty flag on files whose typecheck antecedents have changed.
-type (* internal *) NotifyFileTypeCheckStateIsDirty = NotifyFileTypeCheckStateIsDirty of (string -> unit)
+type internal NotifyFileTypeCheckStateIsDirty = NotifyFileTypeCheckStateIsDirty of (string -> unit)
/// Identical to _VSFILECHANGEFLAGS in vsshell.idl
-type (* internal *) DependencyChangeCode =
+type internal DependencyChangeCode =
| NoChange = 0x0
| FileChanged = 0x00000001
| TimeChanged = 0x00000002
@@ -140,19 +140,19 @@ type (* internal *) DependencyChangeCode =
/// Callback that indicates whether a requested result has become obsolete.
[<NoComparison;NoEquality>]
-type (* internal *) IsResultObsolete =
+type internal IsResultObsolete =
| IsResultObsolete of (unit->bool)
/// The result of calling TypeCheckResult including the possibility of abort and background compiler not caught up.
[<NoComparison>]
-type (* internal *) TypeCheckAnswer =
+type internal TypeCheckAnswer =
| NoAntecedant
| Aborted // because result was obsolete
| TypeCheckSucceeded of TypeCheckResults
[<Sealed>]
[<AutoSerializable(false)>]
-type (* internal *) InteractiveChecker =
+type internal InteractiveChecker =
/// Create an instance of an InteractiveChecker. Currently resources are not reclaimed.
static member Create : NotifyFileTypeCheckStateIsDirty -> InteractiveChecker
@@ -172,7 +172,6 @@ type (* internal *) InteractiveChecker =
member TypeCheckSource : parsed: UntypedParseInfo * filename: string * fileversion: int * source: string * options: CheckOptions * isResultObsolete: IsResultObsolete * textSnapshotInfo: obj -> TypeCheckAnswer
/// For a given script file, get the CheckOptions implied by the #load closure
- /// We keep this around for now as this is the API entry point expected by the MonoDevelop 3.0 support
member GetCheckOptionsFromScriptRoot : filename : string * source : string * loadedTimestamp : System.DateTime -> CheckOptions
/// For a given script file, get the CheckOptions implied by the #load closure. Optional 'otherFlags'
diff --git a/src/ilx/cu_erase.fs b/src/ilx/cu_erase.fs
index 31ab2cd..25c33bd 100755
--- a/src/ilx/cu_erase.fs
+++ b/src/ilx/cu_erase.fs
@@ -447,7 +447,7 @@ let rec convInstr cenv (tmps: ILLocalsAllocator) inplab outlab instr =
[ AI_dup;
I_brcmp (BI_brfalse,outlab, internal1) ]);
mkBasicBlock2 (internal1,
- [ mkMscorlibExnNewobj cenv.ilg "System.InvalidCastException";
+ [ mkPrimaryAssemblyExnNewobj cenv.ilg "System.InvalidCastException";
I_throw ]);
] ))
else
@@ -846,7 +846,7 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (
emptyILCustomAttrs,
ILTypeInit.BeforeField)
[ { debugProxyTypeDef with IsSpecialName=true } ],
- ( [mkDebuggerTypeProxyAttribute cenv.ilg debugProxyTy] @ cud.cudDebugDisplayAttributes)
+ ( [cenv.ilg.mkDebuggerTypeProxyAttribute debugProxyTy] @ cud.cudDebugDisplayAttributes)
let altTypeDef =
let basicFields =
diff --git a/src/utils/CompilerLocationUtils.fs b/src/utils/CompilerLocationUtils.fs
index 717bd32..cf321bb 100755
--- a/src/utils/CompilerLocationUtils.fs
+++ b/src/utils/CompilerLocationUtils.fs
@@ -41,6 +41,18 @@ module internal FSharpEnvironment =
| s -> Some(s)
with _ -> None
+ // The F# team version number. This version number is used for
+ // - the F# version number reported by the fsc.exe and fsi.exe banners in the CTP release
+ // - the F# version number printed in the HTML documentation generator
+ // - the .NET DLL version number for all VS2008 DLLs
+ // - the VS2008 registry key, written by the VS2008 installer
+ // HKEY_LOCAL_MACHINE\Software\Microsoft\.NETFramework\AssemblyFolders\Microsoft.FSharp-" + FSharpTeamVersionNumber
+ // Also
+ // - for Beta2, the language revision number indicated on the F# language spec
+ //
+ // It is NOT the version number listed on FSharp.Core.dll
+ let FSharpTeamVersionNumber = "2.0.0.0"
+
[<DllImport("Advapi32.dll", CharSet = CharSet.Unicode, BestFitMapping = false)>]
extern uint32 RegOpenKeyExW(UIntPtr _hKey, string _lpSubKey, uint32 _ulOptions, int _samDesired, UIntPtr & _phkResult);
@@ -203,11 +215,10 @@ module internal FSharpEnvironment =
// Note: If the keys below change, be sure to update code in:
// Property pages (ApplicationPropPage.vb)
+ let key20 = @"Software\Microsoft\.NETFramework\AssemblyFolders\Microsoft.FSharp-" + FSharpTeamVersionNumber
#if FX_ATLEAST_45
- let key20 = @"Software\Microsoft\FSharp\3.0\Runtime\v2.0"
- let key40 = @"Software\Microsoft\FSharp\3.0\Runtime\v4.0"
+ let key40 = @"Software\Microsoft\FSharp\3.1\Runtime\v4.0"
#else
- let key20 = @"Software\Microsoft\FSharp\2.0\Runtime\v2.0"
let key40 = @"Software\Microsoft\FSharp\2.0\Runtime\v4.0"
#endif
let key1,key2 =
diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs
index e5c8a0f..306ae76 100755
--- a/src/utils/TaggedCollections.fs
+++ b/src/utils/TaggedCollections.fs
@@ -631,26 +631,26 @@ namespace Internal.Utilities.Collections.Tagged
static member Intersection((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) : Set<'T,'ComparerTag> =
match b.Tree with
- | SetEmpty -> b (* A INTER 0 = 0 *)
+ | SetEmpty -> b // A INTER 0 = 0
| _ ->
match a.Tree with
- | SetEmpty -> a (* 0 INTER B = 0 *)
+ | SetEmpty -> a // 0 INTER B = 0
| _ -> SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a
static member Union(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> =
match b.Tree with
- | SetEmpty -> a (* A U 0 = A *)
+ | SetEmpty -> a // A U 0 = A
| _ ->
match a.Tree with
- | SetEmpty -> b (* 0 U B = B *)
+ | SetEmpty -> b // 0 U B = B
| _ -> SetTree.union a.Comparer a.Tree b.Tree |> refresh a
static member Difference(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> =
match a.Tree with
- | SetEmpty -> a (* 0 - B = 0 *)
+ | SetEmpty -> a // 0 - B = 0
| _ ->
match b.Tree with
- | SetEmpty -> a (* A - 0 = A *)
+ | SetEmpty -> a // A - 0 = A
| _ -> SetTree.diff a.Comparer a.Tree b.Tree |> refresh a
static member Equality(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) =
@@ -759,26 +759,26 @@ namespace Internal.Utilities.Collections.Tagged
let rebalance t1 k v t2 =
let t1h = height t1
- if height t2 > t1h + 2 then (* right is heavier than left *)
+ if height t2 > t1h + 2 then // right is heavier than left
match t2 with
| MapNode(t2k,t2v,t2l,t2r,_) ->
- (* one of the nodes must have height > height t1 + 1 *)
- if height t2l > t1h + 1 then (* balance left: combination *)
+ // one of the nodes must have height > height t1 + 1
+ if height t2l > t1h + 1 then // balance left: combination
match t2l with
| MapNode(t2lk,t2lv,t2ll,t2lr,_) ->
mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r)
| _ -> failwith "rebalance"
- else (* rotate left *)
+ else // rotate left
mk (mk t1 k v t2l) t2k t2v t2r
| _ -> failwith "rebalance"
else
let t2h = height t2
- if t1h > t2h + 2 then (* left is heavier than right *)
+ if t1h > t2h + 2 then // left is heavier than right
match t1 with
| MapNode(t1k,t1v,t1l,t1r,_) ->
- (* one of the nodes must have height > height t2 + 1 *)
+ // one of the nodes must have height > height t2 + 1
if height t1r > t2h + 1 then
- (* balance right: combination *)
+ // balance right: combination
match t1r with
| MapNode(t1rk,t1rv,t1rl,t1rr,_) ->
mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2)
diff --git a/src/utils/prim-lexing.fs b/src/utils/prim-lexing.fs
index b34b199..daeb991 100755
--- a/src/utils/prim-lexing.fs
+++ b/src/utils/prim-lexing.fs
@@ -21,7 +21,7 @@ namespace Internal.Utilities.Text.Lexing
// REVIEW: This type showed up on a parsing-intensive performance measurement.
// REVIEW: Consider whether it can be smaller or can be a struct.
- type (* internal *) Position =
+ type internal Position =
{ /// The file name index for the position, use fileOfFileIndex in range.fs to decode
posFileIndex: int;
/// The line number for the position
@@ -70,7 +70,7 @@ namespace Internal.Utilities.Text.Lexing
type internal LexBufferFiller<'Char> = (LexBuffer<'Char> -> unit)
and [<Sealed>]
- (* internal *) LexBuffer<'Char>(filler: LexBufferFiller<'Char>) =
+ internal LexBuffer<'Char>(filler: LexBufferFiller<'Char>) =
let context = new Dictionary<string,obj>(1)
let mutable buffer=[||];
/// number of valid charactes beyond bufferScanStart
diff --git a/src/utils/prim-lexing.fsi b/src/utils/prim-lexing.fsi
index 2d0782b..ac37550 100755
--- a/src/utils/prim-lexing.fsi
+++ b/src/utils/prim-lexing.fsi
@@ -20,7 +20,7 @@ open Microsoft.FSharp.Control
/// Position information stored for lexing tokens
[<Sealed>]
-type (* internal *) Position =
+type internal Position =
interface System.IComparable
/// The file index for the file associated with the input stream, use fileOfFileIndex in range.fs to decode
member FileIndex : int
@@ -56,7 +56,7 @@ type (* internal *) Position =
[<Sealed>]
/// Input buffers consumed by lexers generated by <c>fslex.exe </c>
-type (* internal *) LexBuffer<'Char> =
+type internal LexBuffer<'Char> =
/// The start position for the lexeme
member StartPos: Position with get,set
/// The end position for the lexeme
diff --git a/src/utils/sformat.fs b/src/utils/sformat.fs
index 83ca4cb..dbb2d0b 100755
--- a/src/utils/sformat.fs
+++ b/src/utils/sformat.fs
@@ -59,6 +59,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat
open Microsoft.FSharp.Collections
open Microsoft.FSharp.Primitives.Basics
+#if FX_RESHAPED_REFLECTION
+ open PrimReflectionAdapters
+ open ReflectionAdapters
+#endif
+
/// A joint, between 2 layouts, is either:
/// - unbreakable, or
/// - breakable, and if broken the second block has a given indentation.
@@ -207,9 +212,9 @@ namespace Microsoft.FSharp.Text.StructuredFormat
let rec consume n z =
if stopShort z then [wordL "..."] else
match project z with
- | None -> [] (* exhaused input *)
- | Some (x,z) -> if n<=0 then [wordL "..."] (* hit print_length limit *)
- else itemL x :: consume (n-1) z (* cons recursive... *)
+ | None -> [] // exhaused input
+ | Some (x,z) -> if n<=0 then [wordL "..."] // hit print_length limit
+ else itemL x :: consume (n-1) z // cons recursive...
consume maxLength z
let unfoldL itemL project z maxLength = boundedUnfoldL itemL project (fun _ -> false) z maxLength
@@ -231,7 +236,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat
#endif
#endif
FormatProvider: System.IFormatProvider;
+#if FX_RESHAPED_REFLECTION
+ ShowNonPublic : bool
+#else
BindingFlags: System.Reflection.BindingFlags
+#endif
PrintWidth : int;
PrintDepth : int;
PrintLength : int;
@@ -248,7 +257,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat
#endif
#endif
AttributeProcessor= (fun _ _ _ -> ());
+#if FX_RESHAPED_REFLECTION
+ ShowNonPublic = false
+#else
BindingFlags = System.Reflection.BindingFlags.Public;
+#endif
FloatingPointFormat = "g10";
PrintWidth = 80 ;
PrintDepth = 100 ;
@@ -301,18 +314,31 @@ namespace Microsoft.FSharp.Text.StructuredFormat
props |> Array.toList |> List.map (fun (p:PropertyInfo) -> p.Name, p.PropertyType)
let getTypeInfoOfType (bindingFlags:BindingFlags) (typ:Type) =
+#if FX_RESHAPED_REFLECTION
+ let showNonPublic = isNonPublicFlag bindingFlags
+#endif
if FSharpType.IsTuple(typ) then TypeInfo.TupleType (FSharpType.GetTupleElements(typ) |> Array.toList)
elif FSharpType.IsFunction(typ) then let ty1,ty2 = FSharpType.GetFunctionElements typ in TypeInfo.FunctionType( ty1,ty2)
+#if FX_RESHAPED_REFLECTION
+ elif FSharpType.IsUnion(typ, showNonPublic) then
+ let cases = FSharpType.GetUnionCases(typ, showNonPublic)
+#else
elif FSharpType.IsUnion(typ,bindingFlags) then
let cases = FSharpType.GetUnionCases(typ,bindingFlags)
+#endif
match cases with
| [| |] -> TypeInfo.ObjectType(typ)
| _ ->
TypeInfo.SumType(cases |> Array.toList |> List.map (fun case ->
let flds = case.GetFields()
case.Name,recdDescOfProps(flds)))
+#if FX_RESHAPED_REFLECTION
+ elif FSharpType.IsRecord(typ, showNonPublic) then
+ let flds = FSharpType.GetRecordFields(typ, showNonPublic)
+#else
elif FSharpType.IsRecord(typ,bindingFlags) then
let flds = FSharpType.GetRecordFields(typ,bindingFlags)
+#endif
TypeInfo.RecordType(recdDescOfProps(flds))
else
TypeInfo.ObjectType(typ)
@@ -332,10 +358,13 @@ namespace Microsoft.FSharp.Text.StructuredFormat
| ObjectValue of obj
module Value =
-
+
// Analyze an object to see if it the representation
// of an F# value.
let GetValueInfoOfObject (bindingFlags:BindingFlags) (obj : obj) =
+#if FX_RESHAPED_REFLECTION
+ let showNonPublic = isNonPublicFlag bindingFlags
+#endif
match obj with
| null -> ObjectValue(obj)
| _ ->
@@ -356,20 +385,34 @@ namespace Microsoft.FSharp.Text.StructuredFormat
// the type are the actual fields of the type. Again,
// we should be reading attributes here that indicate the
// true structure of the type, e.g. the order of the fields.
+#if FX_RESHAPED_REFLECTION
+ elif FSharpType.IsUnion(reprty, showNonPublic) then
+ let tag,vals = FSharpValue.GetUnionFields (obj,reprty, showNonPublic)
+#else
elif FSharpType.IsUnion(reprty,bindingFlags) then
let tag,vals = FSharpValue.GetUnionFields (obj,reprty,bindingFlags)
+#endif
let props = tag.GetFields()
let pvals = (props,vals) ||> Array.map2 (fun prop v -> prop.Name,v)
ConstructorValue(tag.Name, Array.toList pvals)
-
+#if FX_RESHAPED_REFLECTION
+ elif FSharpType.IsExceptionRepresentation(reprty, showNonPublic) then
+ let props = FSharpType.GetExceptionFields(reprty, showNonPublic)
+ let vals = FSharpValue.GetExceptionFields(obj, showNonPublic)
+#else
elif FSharpType.IsExceptionRepresentation(reprty,bindingFlags) then
let props = FSharpType.GetExceptionFields(reprty,bindingFlags)
let vals = FSharpValue.GetExceptionFields(obj,bindingFlags)
+#endif
let pvals = (props,vals) ||> Array.map2 (fun prop v -> prop.Name,v)
ExceptionValue(reprty, pvals |> Array.toList)
-
+#if FX_RESHAPED_REFLECTION
+ elif FSharpType.IsRecord(reprty, showNonPublic) then
+ let props = FSharpType.GetRecordFields(reprty, showNonPublic)
+#else
elif FSharpType.IsRecord(reprty,bindingFlags) then
let props = FSharpType.GetRecordFields(reprty,bindingFlags)
+#endif
RecordValue(props |> Array.map (fun prop -> prop.Name, prop.GetValue(obj,null)) |> Array.toList)
else
ObjectValue(obj)
@@ -404,8 +447,14 @@ namespace Microsoft.FSharp.Text.StructuredFormat
let typeUsesSystemObjectToString (typ:System.Type) =
#if FX_ATLEAST_PORTABLE
- try let methInfo = typ.GetMethod("ToString",[| |])
+ try
+#if FX_RESHAPED_REFLECTION
+ let methInfo = typ.GetRuntimeMethod("ToString",[| |])
+ methInfo.DeclaringType = typeof<System.Object>
+#else
+ let methInfo = typ.GetMethod("ToString",[| |])
methInfo.DeclaringType = typeof<System.Object>
+#endif
with e -> false
#else
try let methInfo = typ.GetMethod("ToString",BindingFlags.Public ||| BindingFlags.Instance,null,[| |],null)
@@ -676,12 +725,13 @@ namespace Microsoft.FSharp.Text.StructuredFormat
let braceL xs = (leftL "{") ^^ xs ^^ (rightL "}")
braceL (aboveListL (List.map itemL nameXs))
- let makeRecordHorizontalL nameXs = (* This is a more compact rendering of records - and is more like tuples *)
+ // This is a more compact rendering of records - and is more like tuples
+ let makeRecordHorizontalL nameXs =
let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL "=")) -- xL
let braceL xs = (leftL "{") ^^ xs ^^ (rightL "}")
braceL (sepListL (rightL ";") (List.map itemL nameXs))
- let makeRecordL nameXs = makeRecordVerticalL nameXs (* REVIEW: switch to makeRecordHorizontalL ? *)
+ let makeRecordL nameXs = makeRecordVerticalL nameXs
let makePropertiesL nameXs =
let itemL (name,v) =
@@ -713,8 +763,8 @@ namespace Microsoft.FSharp.Text.StructuredFormat
let getProperty (obj: obj) name =
let ty = obj.GetType()
#if FX_ATLEAST_PORTABLE
- let meth = ty.GetMethod(name, (BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic))
- meth.Invoke(obj,[||])
+ let prop = ty.GetProperty(name, (BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic))
+ prop.GetValue(obj,[||])
#else
#if FX_NO_CULTURE_INFO_ARGS
ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, [| |])
@@ -792,12 +842,12 @@ namespace Microsoft.FSharp.Text.StructuredFormat
// Roughly count the "nodes" printed, e.g. leaf items and inner nodes, but not every bracket and comma.
let size = ref opts.PrintSize
let exceededPrintSize() = !size<=0
- let countNodes n = if !size > 0 then size := !size - n else () (* no need to keep decrementing (and avoid wrap around) *)
+ let countNodes n = if !size > 0 then size := !size - n else () // no need to keep decrementing (and avoid wrap around)
let stopShort _ = exceededPrintSize() // for unfoldL
// Recursive descent
- let rec objL depthLim prec (x:obj) = polyL bindingFlags objWithReprL ShowAll depthLim prec x (* showMode for inner expr *)
- and sameObjL depthLim prec (x:obj) = polyL bindingFlags objWithReprL showMode depthLim prec x (* showMode preserved *)
+ let rec objL depthLim prec (x:obj) = polyL bindingFlags objWithReprL ShowAll depthLim prec x // showMode for inner expr
+ and sameObjL depthLim prec (x:obj) = polyL bindingFlags objWithReprL showMode depthLim prec x // showMode preserved
and objWithReprL showMode depthLim prec (info:ValueInfo) (x:obj) (* x could be null *) =
try
@@ -851,7 +901,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat
//
| :? string as s -> sepL s
| _ -> sameObjL (depthLim-1) Precedence.BracketIfTuple alternativeObj
- countNodes 0 (* 0 means we do not count the preText and postText *)
+ countNodes 0 // 0 means we do not count the preText and postText
Some (leftL preText ^^ alternativeObjL ^^ rightL postText)
with _ ->
None
@@ -903,7 +953,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat
(name,objL depthLim Precedence.BracketIfTuple x)
makeRecordL (List.map itemL items)
- | ConstructorValue (constr,recd) when (* x is List<T>. Note: "null" is never a valid list value. *)
+ | ConstructorValue (constr,recd) when // x is List<T>. Note: "null" is never a valid list value.
x<>null && Type.IsListType (x.GetType()) ->
match constr with
| "Cons" ->
@@ -920,7 +970,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat
(wordL nm)
| ConstructorValue(nm,recd) ->
- countNodes 1 (* e.g. Some (Some (Some (Some 2))) should count for 5 *)
+ countNodes 1 // e.g. Some (Some (Some (Some 2))) should count for 5
(wordL nm --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic)
| ExceptionValue(ty,recd) ->
@@ -1039,13 +1089,23 @@ namespace Microsoft.FSharp.Text.StructuredFormat
#else
let props = ty.GetProperties(BindingFlags.GetField ||| BindingFlags.Instance ||| BindingFlags.Public)
#endif
+ let props =
+ props |> Array.filter (fun pi ->
+ // check if property is annotated with System.Diagnostics.DebuggerBrowsable(Never).
+ // Its evaluation may have unexpected side effects and\or block printing.
+ match Seq.toArray (pi.GetCustomAttributes(typeof<System.Diagnostics.DebuggerBrowsableAttribute>, false)) with
+ | [|:? System.Diagnostics.DebuggerBrowsableAttribute as attr |] -> attr.State <> System.Diagnostics.DebuggerBrowsableState.Never
+ | _ -> true
+ )
+
// massively reign in deep printing of properties
let nDepth = depthLim/10
#if FX_ATLEAST_PORTABLE
System.Array.Sort((props),{ new System.Collections.Generic.IComparer<PropertyInfo> with member this.Compare(p1,p2) = compare (p1.Name) (p2.Name) } );
#else
System.Array.Sort((props:>System.Array),{ new System.Collections.IComparer with member this.Compare(p1,p2) = compare ((p1 :?> PropertyInfo).Name) ((p2 :?> PropertyInfo).Name) } );
-#endif
+#endif
+
if props.Length = 0 || (nDepth <= 0) then basicL
else basicL ---
(props
@@ -1158,7 +1218,12 @@ namespace Microsoft.FSharp.Text.StructuredFormat
let any_to_string x = layout_as_string FormatOptions.Default x
#if RUNTIME
+#if FX_RESHAPED_REFLECTION
+ let internal anyToStringForPrintf opts (showNonPublicMembers : bool) x =
+ let bindingFlags = ReflectionUtils.toBindingFlags showNonPublicMembers
+#else
let internal anyToStringForPrintf opts (bindingFlags:BindingFlags) x =
+#endif
x |> anyL ShowAll bindingFlags opts |> layout_to_string opts
#endif
diff --git a/src/utils/sformat.fsi b/src/utils/sformat.fsi
index 8491c03..b5bed4e 100755
--- a/src/utils/sformat.fsi
+++ b/src/utils/sformat.fsi
@@ -228,7 +228,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat
#endif
#endif
FormatProvider: System.IFormatProvider
+#if FX_RESHAPED_REFLECTION
+ ShowNonPublic : bool
+#else
BindingFlags: System.Reflection.BindingFlags
+#endif
PrintWidth : int
PrintDepth : int
PrintLength : int
@@ -267,7 +271,12 @@ namespace Microsoft.FSharp.Text.StructuredFormat
val output_any: writer:TextWriter -> value:'T -> unit
#if RUNTIME // FSharp.Core.dll: Most functions aren't needed in FSharp.Core.dll, but we add one entry for printf
+
+#if FX_RESHAPED_REFLECTION
+ val anyToStringForPrintf: options:FormatOptions -> showNonPublicMembers : bool -> value:'T -> string
+#else
val anyToStringForPrintf: options:FormatOptions -> bindingFlags:System.Reflection.BindingFlags -> value:'T -> string
+#endif
#else
val any_to_layout : options:FormatOptions -> value:'T -> Layout
val squash_layout : options:FormatOptions -> layout:Layout -> Layout
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-cli-apps/packages/fsharp.git
More information about the Pkg-cli-apps-commits
mailing list