diff --git a/CHANGES.txt b/CHANGES.txt new file mode 100644 index 0000000000..7437c03ddd --- /dev/null +++ b/CHANGES.txt @@ -0,0 +1,20 @@ + +HEAD + * Added tests + + * Merged F# 3.1 open source release + + * Fixed build logic for F# 3.1 + +3.0.30 + * Partial fix for allowing F# 3.1 projects to compile using xbuild (also + requires xbuild fix) + + * Remove a multitude of links in xbuild directories in favour of targets + files which include the canonical targets + +3.0.29 + + * Proper DESTDIR support (very useful for making custom deb/rpm packages) + + diff --git a/FSharp.Compiler.Editor.nuspec b/FSharp.Compiler.Editor.nuspec new file mode 100644 index 0000000000..a3e0c29495 --- /dev/null +++ b/FSharp.Compiler.Editor.nuspec @@ -0,0 +1,23 @@ + + + + FSharp.Compiler.Editor + 1.0.9 + F# Compiler Editor + Dave Thomas, Anh-Dung Phan + + http://opensource.org/licenses/Apache-2.0 + https://github.com/fsharp/FSharp.Compiler.Service + false + The compiler editor assembly for creating refactoring and editing tools for F# programming language + This fork of the F# compiler contains minor modifications in visibility to allow refactoring, editing, and other tools to have access to the full F# AST and parser. + Reintegration with FSharp31 source + Copyright 2013 + fsharp compiler editing refactoring + + + + + + + \ No newline at end of file diff --git a/Makefile.in b/Makefile.in index be25c99dcb..36c5bdd20e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1,6 +1,6 @@ include $(topsrcdir)config.make -all clean install do-proto do-final do-2-1 install-2-1 clean-2-0 clean-2-1 clean-4-0: +all clean install build build-proto: $(MAKE) -C src/fsharp $@ dist: diff --git a/README.md b/README.md index 8a40b2b6f8..5767da6e00 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,93 @@ +FSharp.Compiler.Service +======================= + +Modified clone of F# compiler exposing additional functionality for editing clients and embedding F# as a service. + +## FSharp.Compiler.Editor + +At the moment, the main component is `FSharp.Compiler.Editor.dll`. +It contains minor modifications in visibility to allow refactoring editing +and other tools to have access to the full F# AST and parser. The main aim is to have a stable and +documented fork of the main compiler that allows various tools to share this common code. + +This repo should be _identical_ to 'fsharp' except: + + - Changes for building FSharp.Compiler.Editor.dll, notably + - Change the assembly name + - Only build FSharp.Compiler.Editor.dll + - No bootstrap or proto compiler is used - an installed F# compiler is assumed + + - Files for publishing the nuget package for FSharp.Compiler.Editor + + - Changes to compiler source code to expose new functionality + + - Additions to compiler source code which improve the API for the use of F# editing clients + + - Additions to compiler source code which add new functionality used by all F# editing clients + + - These additions to this README.md + + - Additions to the LICENCE file to record contributors, changes etc. + +If language or compiler addiitons are committed to fsharp/fsharp, they should be merged into this repo and a new nuget +package released. + +###Nuget +There is currently a [nuget package](https://nuget.org/packages/FSharp.Compiler.Editor/) that you can install as follows: + +Using the nuget package manager in windows: +``` +PM> Install-Package FSharp.Compiler.Editor +``` +Or from the nuget console on Osx etc: +``` +nuget install FSharp.Compiler.Editor +``` + +###Building +If you want to build this yourself then you can follow these instructions: + +``` +git clone https://github.com/fsharp/FSharp.Compiler.Editor +cd FSharp.Compiler.Editor +``` + +Now follow the build instructions below. +####Linux +``` +./autogen.sh +make +``` +####Osx +``` +./autogen.sh --prefix=/Library/Frameworks/Mono.framework/Versions/Current/ +make +``` + +###Windows + +``` +.\build.bat +``` + +The output will be located at `lib/release/4.0/FSharp.Compiler.Editor.dll` + +###Clients + +The known tools that use this component are: + +* [Fantomas](https://github.com/dungpa/fantomas) +* [Fsharp-Refactor](https://github.com/Lewix/fsharp-refactor) +* [FSharpbinding](https://github.com/fsharp/fsharpbinding) + +If you modify this component it is polite to check that these tools all build after your modifications. + + +============================================================================================= +Original README from F# Compiler begins below +============================================================================================= + + This is the F# compiler, core library and core tools (open source edition). It uses the Apache 2.0 license. The `master` branch is for the latest version of F# (currently F# 3.0). @@ -201,5 +291,4 @@ You can then go to the relevant directory and run `build.bat` and `run.bat`. F# compiler sources dropped by Microsoft are available from [fsharppowerpack.codeplex.com](http://fsharppowerpack.codeplex.com). -Uses bootstrapping libraries, tools and F# compiler. The `lib/bootstrap/X.0` directories contain mono-built libraries, compiler and tools that can be used to bootstrap a build. You can also supply your own via the `--with-bootstrap` option. - +Uses bootstrapping libraries, tools and F# compiler. The `lib/bootstrap/X.0` directories contain mono-built libraries, compiler and tools that can be used to bootstrap a build. You can also supply your own via the `--with-bootstrap` option. \ No newline at end of file diff --git a/build.bat b/build.bat index 60fa42c64e..8ead95fec7 100644 --- a/build.bat +++ b/build.bat @@ -7,14 +7,11 @@ if %PROCESSOR_ARCHITECTURE%==x86 ( ) ::Clean -del /F /S /Q lib\proto del /F /S /Q lib\release ::Build pushd . cd .\src set ABS_PATH=%CD% -%MSBUILD% %ABS_PATH%/fsharp-proto-build.proj -%MSBUILD% %ABS_PATH%/fsharp-library-build.proj /p:TargetFramework=net40 /p:Configuration=Release -%MSBUILD% %ABS_PATH%/fsharp-compiler-build.proj /p:TargetFramework=net40 /p:Configuration=Release +%MSBUILD% "%ABS_PATH%\fsharp-compiler-build.proj" /p:TargetFramework=net40 /p:Configuration=Release popd diff --git a/config.make.in b/config.make.in index 54498c6a3e..68c920d76e 100644 --- a/config.make.in +++ b/config.make.in @@ -9,7 +9,7 @@ monogacdir := @MONOGACDIR@ monogacdir20 := @MONOGACDIR20@ -#This is where to find MonoTouch of MonoAndroid, for "make do-2-1" +#This is where to find MonoTouch of MonoAndroid, for "make build-monodroid" # #For now this is hardwired, it should be optionally detected by configure.ac monogacdir21 := @abs_top_srcdir@/dependencies/mono/2.1 @@ -18,125 +18,48 @@ monogacdir35 := @MONOGACDIR35@ monogacdir40 := @MONOGACDIR40@ gacdir := ${libdir}mono -gacdir20 := ${gacdir}/2.0 -gacdir40 := ${gacdir}/4.0 tooldir := $(topdir)lib/bootstrap/4.0/ +monoopts = @mono_gc_options@ MONO_OPTIONS += @mono_gc_options@ +TargetFramework = net40 CONFIG = release +Configuration = Release DISTVERSION = 201011 +outsuffix = $(TargetFramework) + +ifeq (x-$(TargetFramework),x-net20) +VERSION = 2.3.1.0 +TARGET = 2.0 +endif + +ifeq (x-$(TargetFramework),x-net40) +VERSION = 4.3.1.0 +TARGET = 4.0 +outsuffix = . +endif + +ifeq (x-$(TargetFramework),x-monodroid) +VERSION = 2.3.98.1 +TARGET = monodroid +endif + + +ifeq (x-$(TargetFramework),x-monotouch) +VERSION = 2.3.99.1 +TARGET = monotouch +endif -VERSION_2_0 = 2.3.0.0 -VERSION_2_1 = 2.3.1.0 -VERSION_4_0 = 4.3.0.0 -TARGET_2_0 = 2.0 -TARGET_2_1 = 2.1 -TARGET_4_0 = 4.0 DELAY_SIGN_TOKEN = b03f5f7f11d50a3a SIGN_TOKEN = f536804aa0eb945b bootstrapdir = $(bootstrap)/4.0/ tmpdir = .libs/$(CONFIG)/ objdir = $(tmpdir)$(TARGET)/ -protodir = $(builddir)/lib/proto/4.0/ -outdir = $(builddir)lib/$(CONFIG)/$(TARGET)/ - -FSSRGEN = $(tooldir)../2.0/fssrgen.exe -FSLEX = $(tooldir)../2.0/fslex.exe -FSYACC = $(tooldir)../2.0/fsyacc.exe - - -FLAGS = \ - --doc:$(objdir)$(NAME).xml \ - --version:$(VERSION) \ - --debug:pdbonly \ - --optimize+ \ - --mlcompatibility \ - --noframework \ - --fullpaths \ - --times \ - --nowarn:9 - -DELAY_SIGN_FLAGS = \ - --define:STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY \ - --delaysign+ \ - --keyfile:$(topdir)msfinal.pub - -SIGN_FLAGS = \ - --define:STRONG_NAME_FSHARP_COMPILER_WITH_TEST_KEY \ - --keyfile:$(topdir)/src/fsharp/test.snk - -DEFINES_GENERAL = \ - --define:TRACE \ - --define:CROSS_PLATFORM_COMPILER - -ifeq ($(CONFIG),debug) -DEFINES_DEBUG = \ - --define:CODE_ANALYSIS \ - --define:DEBUG -else -DEFINES_DEBUG = -endif - -DEFINES_2_0 = \ - $(DEFINES_GENERAL) \ - $(DEFINES_DEBUG) \ - --define:FX_NO_STRUCTURAL_EQUALITY \ - --define:FX_NO_IOBSERVABLE \ - --define:FX_NO_TUPLE \ - --define:FX_ATLEAST_35 \ - --define:FX_NO_LAZY \ - --define:FX_NO_CANCELLATIONTOKEN_CLASSES \ - --define:FX_NO_MONITOR_REPORTS_LOCKTAKEN \ - --define:FX_NO_TPL_PARALLEL \ - --define:FX_NO_CUSTOMATTRIBUTEDATA \ - --define:FX_NO_TASK \ - --define:FX_NO_BIGINT - -DEFINES_2_1 = \ - $(DEFINES_GENERAL) \ - $(DEFINES_DEBUG) \ - --define:FX_NO_STRUCTURAL_EQUALITY \ - --define:FX_NO_CUSTOMATTRIBUTEDATA \ - --define:FX_NO_BIGINT_CULTURE_PARSE \ - --define:FX_ATLEAST_40 \ - --define:FX_ATLEAST_35 \ - --define:FX_ATLEAST_LINQ \ - --define:FX_NO_BIGINT - -DEFINES_4_0 = \ - $(DEFINES_GENERAL) \ - $(DEFINES_DEBUG) \ - --define:FX_NO_BIGINT_CULTURE_PARSE \ - --define:FX_ATLEAST_40 \ - --define:FX_ATLEAST_35 \ - --define:FX_ATLEAST_LINQ - -REFERENCES_2_0 = \ - -r:$(monogacdirXX)/Microsoft.Build.Engine.dll \ - -r:$(monogacdirXX)/Microsoft.Build.Framework.dll \ - -r:$(monogacdir35)/Microsoft.Build.Tasks.v3.5.dll \ - -r:$(monogacdir35)/Microsoft.Build.Utilities.v3.5.dll \ - -r:$(monogacdirXX)/mscorlib.dll \ - -r:$(monogacdirXX)/System.Core.dll \ - -r:$(monogacdirXX)/System.dll - -REFERENCES_2_1 = \ - -r:$(monogacdir21)/mscorlib.dll \ - -r:$(monogacdir21)/System.Core.dll \ - -r:$(monogacdir21)/System.dll - -REFERENCES_4_0 = \ - -r:$(monogacdirXX)/Microsoft.Build.Engine.dll \ - -r:$(monogacdirXX)/Microsoft.Build.Framework.dll \ - -r:$(monogacdirXX)/Microsoft.Build.Tasks.v4.0.dll \ - -r:$(monogacdirXX)/Microsoft.Build.Utilities.v4.0.dll \ - -r:$(monogacdirXX)/mscorlib.dll \ - -r:$(monogacdirXX)/System.Core.dll \ - -r:$(monogacdirXX)/System.dll \ - -r:$(monogacdirXX)/System.Numerics.dll +protodir = $(builddir)/lib/proto +outdir = $(builddir)lib/$(CONFIG)/$(outsuffix)/ INSTALL = $(SHELL) $(topdir)install-sh INSTALL_DATA = $(INSTALL) -c -m 644 diff --git a/configure.ac b/configure.ac index f74f7f80fa..e6d5da596f 100644 --- a/configure.ac +++ b/configure.ac @@ -102,8 +102,9 @@ src/fsharp/FSharp.Data.TypeProviders/Makefile src/fsharp/fsi/Makefile src/fsharp/fsiAnyCpu/Makefile src/fsharp/policy.2.0.FSharp.Core/Makefile -src/fsharp/policy.4.0.FSharp.Core/Makefile src/fsharp/policy.2.3.FSharp.Core/Makefile +src/fsharp/policy.3.3.FSharp.Core/Makefile +src/fsharp/policy.4.0.FSharp.Core/Makefile src/fsharp/policy.4.3.FSharp.Core/Makefile ]) AC_OUTPUT diff --git a/lib/bootstrap/2.0/FSharp.SRGen.targets b/lib/bootstrap/2.0/FSharp.SRGen.targets index 81cae8a1e0..f80e70ef86 100755 --- a/lib/bootstrap/2.0/FSharp.SRGen.targets +++ b/lib/bootstrap/2.0/FSharp.SRGen.targets @@ -13,6 +13,10 @@ Copyright (C) Microsoft Corporation. Apache 2.0 License. + + ProcessFsSrGen;$(PrepareForBuildDependsOn) + + ProcessFsSrGen;$(BuildDependsOn) diff --git a/lib/bootstrap/4.0/Microsoft.FSharp-proto.targets b/lib/bootstrap/4.0/Microsoft.FSharp-proto.targets new file mode 100644 index 0000000000..34cd68ae10 --- /dev/null +++ b/lib/bootstrap/4.0/Microsoft.FSharp-proto.targets @@ -0,0 +1,194 @@ + + + + + + + + + + + $(MSBuildExtensionsPath32)\FSharp\1.0\ + + $(FSharpTargetsDir)\Microsoft.FSharp-proto.targets + $(MSBuildAllProjects);$(FSharpTargetsFullPath) + .fs + F# + $(Optimize) + + RootNamespace + + + + + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + + + + + + + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + <_DebugSymbolsIntermediatePathTemporary Include="$(PdbFile)"/> + + <_DebugSymbolsIntermediatePath Include="@(_DebugSymbolsIntermediatePathTemporary->'%(RootDir)%(Directory)%(Filename).pdb')"/> + + + + _ComputeNonExistentFileProperty + + + + + + + + + + + + + <_CoreCompileResourceInputs Remove="@(_CoreCompileResourceInputs)" /> + + + + + + + + diff --git a/lib/bootstrap/4.0/Microsoft.FSharp.targets b/lib/bootstrap/4.0/Microsoft.FSharp.targets new file mode 100644 index 0000000000..32507166ed --- /dev/null +++ b/lib/bootstrap/4.0/Microsoft.FSharp.targets @@ -0,0 +1,256 @@ + + + + + + + + + + + true + true + + + + + + $(MSBuildAllProjects);$(MSBuildThisFileFullPath) + .fs + F# + Managed + $(Optimize) + Software\Microsoft\Microsoft SDKs\$(TargetFrameworkIdentifier) + + RootNamespace + false + $(Prefer32Bit) + + + + + + + + + false + true + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + + <_DebugSymbolsIntermediatePathTemporary Include="$(PdbFile)"/> + + <_DebugSymbolsIntermediatePath Include="@(_DebugSymbolsIntermediatePathTemporary->'%(RootDir)%(Directory)%(Filename).pdb')"/> + + + + + + + + + + + + + + + + + + + <_CoreCompileResourceInputs Remove="@(_CoreCompileResourceInputs)" /> + + + + + + + + + + diff --git a/src/FSharpSource.targets b/src/FSharpSource.targets index 3412b07702..04f8709a6d 100755 --- a/src/FSharpSource.targets +++ b/src/FSharpSource.targets @@ -8,8 +8,6 @@ true net40 - - 4.0 $(FSharpSourcesRoot)\..\lib\bootstrap\4.0 true $(OtherFlags) --times @@ -19,15 +17,31 @@ - $(FSharpSourcesRoot)\source-build-version - $(FSharpSourcesRoot)\source-build-version-2.3.0.0 - $(FSharpSourcesRoot)\source-build-version-4.3.0.0 - $(FSharpSourcesRoot)\source-build-version-2.3.5.0 - $(FSharpSourcesRoot)\source-build-version-2.3.5.0 - + 2.9.9.999 + + 4.3.1.0 + + 2.3.1.0 + 2.3.5.1 + 2.3.6.1 + 2.3.98.1 + 2.3.99.1 + 3.3.1.0 + + + + 2.3.0.0 + 4.3.0.0 + 2.3.5.0 + 2.3.6.0 + 2.3.98.0 + 2.3.99.0 + + $(OtherFlags) --version:$(AssemblyVersion) + @@ -78,6 +92,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do true DEBUG;NO_STRONG_NAMES;$(DefineConstants) + $(DefineConstants);FX_ATLEAST_45 proto @@ -90,7 +105,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do v2.0 - 2.0 + $(TargetFramework) $(DefineConstants);FX_NO_STRUCTURAL_EQUALITY $(DefineConstants);FX_NO_CANCELLATIONTOKEN_CLASSES $(DefineConstants);FX_NO_TASK @@ -105,8 +120,13 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do - v4.0 - 4.0 + v4.0 + + . + + + $(TargetFramework) + $(DefineConstants);FX_ATLEAST_45 $(DefineConstants);FX_ATLEAST_40 $(DefineConstants);FX_ATLEAST_35 $(DefineConstants);BE_SECURITY_TRANSPARENT @@ -119,9 +139,9 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do - + v2.1 - 2.1 + $(TargetFramework) $(DefineConstants);FX_NO_STRUCTURAL_EQUALITY $(DefineConstants);FX_NO_CUSTOMATTRIBUTEDATA $(DefineConstants);FX_NO_BIGINT_CULTURE_PARSE @@ -135,7 +155,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do v2.1 - 2.1monotouch + $(TargetFramework) $(DefineConstants);FX_NO_STRUCTURAL_EQUALITY $(DefineConstants);FX_NO_CUSTOMATTRIBUTEDATA $(DefineConstants);FX_NO_BIGINT_CULTURE_PARSE @@ -285,7 +305,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do v3.0 - sl3 + $(TargetFramework) $(DefineConstants);SILVERLIGHT $(DefineConstants);FX_NO_CANCELLATIONTOKEN_CLASSES $(DefineConstants);FX_NO_TASK @@ -364,7 +384,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do $(DefineConstants);FX_ATLEAST_LINQ Silverlight v4.0 - sl4 + $(TargetFramework) v4.0 @@ -561,7 +581,7 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do v3.5 - 3.5 + $(TargetFramework) CompactFramework $(DefineConstants);FX_ATLEAST_COMPACT_FRAMEWORK_35 $(DefineConstants);FX_NO_CANCELLATIONTOKEN_CLASSES @@ -653,6 +673,11 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do false + + + fsharp30\$(TargetFrameworkOutputDirectory) + + obj\$(ConfigurationOutputDirectory)\$(TargetFrameworkOutputDirectory)\ @@ -666,28 +691,51 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do - $(FSharpSourcesRoot)\..\lib\proto\$(protoCLIDir) + + $(FSharpSourcesRoot)\..\lib\$(ConfigurationOutputDirectory)\$(TargetFrameworkOutputDirectory) - + + + + + + + + + + + + + @@ -712,17 +760,9 @@ Some other NuGET monikers to support in the future, see http://docs.nuget.org/do Text="Configuration '$(Configuration)' is not one of the supported configurations: Debug, Release, Proto" Condition="'$(Configuration)'!='Release' and '$(Configuration)'!='Debug' and '$(Configuration)'!='Proto'"/> + Text="Portable profile '$(TargetFramework)' is not yet supported" + Condition="'$(TargetFramework)' == 'portable-windows8+net45'"/> + diff --git a/src/absil/il.fs b/src/absil/il.fs index 06a3ea9d6b..bc7e62e7c9 100755 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -10,7 +10,7 @@ // You must not remove this notice, or any other, from this software. //---------------------------------------------------------------------------- -module internal Microsoft.FSharp.Compiler.AbstractIL.IL +module (*internal*) Microsoft.FSharp.Compiler.AbstractIL.IL #nowarn "49" #nowarn "343" // The type 'ILAssemblyRef' implements 'System.IComparable' explicitly but provides no corresponding override for 'Object.Equals'. @@ -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 [] | 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 [] @@ -2384,123 +2395,182 @@ let destILArrTy ty = match ty with ILType.Array(shape,ty) -> (shape,ty) | _ -> f // Sigs of special types built-in // -------------------------------------------------------------------- +[] let tname_Object = "System.Object" +[] let tname_String = "System.String" +[] let tname_StringBuilder = "System.Text.StringBuilder" +[] let tname_AsyncCallback = "System.AsyncCallback" +[] let tname_IAsyncResult = "System.IAsyncResult" +[] let tname_IComparable = "System.IComparable" +[] let tname_Exception = "System.Exception" +[] let tname_Type = "System.Type" +[] let tname_Missing = "System.Reflection.Missing" +[] let tname_Activator = "System.Activator" +[] let tname_SerializationInfo = "System.Runtime.Serialization.SerializationInfo" +[] let tname_StreamingContext = "System.Runtime.Serialization.StreamingContext" +[] let tname_SecurityPermissionAttribute = "System.Security.Permissions.SecurityPermissionAttribute" +[] let tname_Delegate = "System.Delegate" +[] let tname_ValueType = "System.ValueType" +[] let tname_TypedReference = "System.TypedReference" +[] let tname_Enum = "System.Enum" +[] let tname_MulticastDelegate = "System.MulticastDelegate" +[] let tname_Array = "System.Array" - +[] let tname_Int64 = "System.Int64" +[] let tname_UInt64 = "System.UInt64" +[] let tname_Int32 = "System.Int32" +[] let tname_UInt32 = "System.UInt32" +[] let tname_Int16 = "System.Int16" +[] let tname_UInt16 = "System.UInt16" +[] let tname_SByte = "System.SByte" +[] let tname_Byte = "System.Byte" +[] let tname_Single = "System.Single" +[] let tname_Double = "System.Double" +[] let tname_Bool = "System.Boolean" +[] let tname_Char = "System.Char" +[] let tname_IntPtr = "System.IntPtr" +[] let tname_UIntPtr = "System.UIntPtr" +[] let tname_RuntimeArgumentHandle = "System.RuntimeArgumentHandle" +[] let tname_RuntimeTypeHandle = "System.RuntimeTypeHandle" +[] let tname_RuntimeMethodHandle = "System.RuntimeMethodHandle" +[] 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 + abstract SystemLinqExpressionsScopeRef : Lazy + abstract SystemCollectionsScopeRef : Lazy + abstract SystemReflectionScopeRef : Lazy + abstract SystemDiagnosticsDebugScopeRef : Lazy + abstract ScopeRef : ILScopeRef + [] type ILGlobals = - { mscorlibScopeRef: ILScopeRef; - mscorlibAssemblyName: string; + { traits : IPrimaryAssemblyTraits + primaryAssemblyName : string noDebugData: bool; - generateDebugBrowsableData: 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 + 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() = "" let mkNormalCall mspec = I_call (Normalcall, mspec, None) @@ -2531,100 +2601,115 @@ let tname_CompilerGeneratedAttribute = "System.Runtime.CompilerServices.Compiler let tname_DebuggableAttribute = "System.Diagnostics.DebuggableAttribute" -let mkILGlobals mscorlibScopeRef mscorlibAssemblyNameOpt (noDebugData,generateDebugBrowsableData) = - 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 @@ -2669,128 +2754,126 @@ let mkILGlobals mscorlibScopeRef mscorlibAssemblyNameOpt (noDebugData,generateDe 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 - ; generateDebugBrowsableData =generateDebugBrowsableData - ; 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, true) 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 @@ -4211,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" @@ -4297,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 |] @@ -4336,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) +[] let tname_DebuggerNonUserCodeAttribute = "System.Diagnostics.DebuggerNonUserCodeAttribute" +[] let tname_DebuggableAttribute_DebuggingModes = "DebuggingModes" +[] let tname_DebuggerHiddenAttribute = "System.Diagnostics.DebuggerHiddenAttribute" +[] let tname_DebuggerDisplayAttribute = "System.Diagnostics.DebuggerDisplayAttribute" +[] let tname_DebuggerTypeProxyAttribute = "System.Diagnostics.DebuggerTypeProxyAttribute" +[] let tname_DebuggerStepThroughAttribute = "System.Diagnostics.DebuggerStepThroughAttribute" +[] let tname_DebuggerBrowsableAttribute = "System.Diagnostics.DebuggerBrowsableAttribute" +[] 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) = @@ -4386,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 @@ -4397,9 +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) = - if ilg.generateDebugBrowsableData then mkILCustomAttrs (attrs.AsList @ [mkDebuggerBrowsableNeverAttribute ilg]) - else attrs +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} @@ -4417,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 @@ -4677,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 d3e323bcae..62323b5069 100755 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -8,10 +8,9 @@ // // 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 +module (*internal*) Microsoft.FSharp.Compiler.AbstractIL.IL open Internal.Utilities open System.Collections.Generic @@ -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 [] 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 [] 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 + abstract SystemLinqExpressionsScopeRef : Lazy + abstract SystemCollectionsScopeRef : Lazy + abstract SystemReflectionScopeRef : Lazy + abstract SystemDiagnosticsDebugScopeRef : Lazy + abstract ScopeRef : ILScopeRef + // ==================================================================== // PART 2 // @@ -1670,16 +1693,15 @@ 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. [] type ILGlobals = - { mscorlibScopeRef: ILScopeRef - mscorlibAssemblyName: string + { + traits : IPrimaryAssemblyTraits + primaryAssemblyName: string noDebugData: bool - generateDebugBrowsableData: bool tref_Object: ILTypeRef tspec_Object: ILTypeSpec typ_Object: ILType @@ -1691,13 +1713,13 @@ type ILGlobals = typ_IComparable: ILType tref_Type: ILTypeRef typ_Type: ILType - typ_Missing: ILType + typ_Missing: Lazy 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 @@ -1728,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 @@ -1744,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 : mscorlibScopeRef:ILScopeRef -> mscorlibAssemblyNameOpt:string option -> noDebugData:bool * generateDebugBrowsableData: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 ) /// must come first. This function puts it first, and creates it in the returned list as an empty typedef if it @@ -2172,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 709cc839fc..ceca10c9b6 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 3b7bfb5fe2..17b6d22946 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. -[] -type LayeredMapState<'Key,'Value when 'Key : equality and 'Key : comparison> = - /// Collapsible(entries, size) - | Collapsible of list>> * 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. -[] -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. -[] -type LayeredMultiMapState<'Key,'Value when 'Key : equality and 'Key : comparison> = - /// Collapsible(entries, size) - | Collapsible of list>> * int - /// Collapsed(frontMap, backingDict) - | Collapsed of (MultiMap<'Key,'Value> * Dictionary<'Key,'Value list>) - -/// Immutable map collection, with explicit flattening to a backing dictionary -[] -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@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[], - ('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[]>, - 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@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@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 [] -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 [] 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 71545cc2e0..934a686a11 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 0f009582d9..fdc64db944 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 01ca3b5067..bd4035fb00 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 55969dbfbe..c459e18e0d 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 28aeaa2541..e496c47b6e 100755 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -414,7 +414,8 @@ type emEnv = emLocals : LocalBuilder[]; emLabels : Zmap; emTyvars : Type[] list; // stack - emEntryPts : (TypeBuilder * string) list } + emEntryPts : (TypeBuilder * string) list + delayedFieldInits : (unit -> unit) list} let orderILTypeRef = ComparisonIdentity.Structural let orderILMethodRef = ComparisonIdentity.Structural @@ -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. @@ -926,6 +930,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 @@ -1660,7 +1666,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)); @@ -1768,8 +1790,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 @@ -2031,6 +2053,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) @@ -2060,7 +2088,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) @@ -2136,4 +2164,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 c809a74546..d3870f3970 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 * [] source : byte[] -> unit + abstract SetCheckSum : algorithmId : System.Guid * checkSumSize : int * [] checkSum : byte [] -> unit // Struct used to retrieve info on the debug output [] @@ -1023,7 +1023,6 @@ type ISymUnmanagedWriter2 = isect : int * offset : int -> unit - type PdbWriter = { symWriter : ISymUnmanagedWriter2 } type PdbDocumentWriter = { symDocWriter : ISymUnmanagedDocumentWriter } (* pointer to pDocumentWriter COM object *) @@ -1071,7 +1070,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 +1089,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 +1114,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 writer.symWriter.DefineDocument(url, &corSymLanguageTypeFSharp, &corSymLanguageVendorMicrosoft, &corSymDocumentTypeText, &docWriter) + setCheckSum (url, docWriter) { symDocWriter = docWriter } let pdbOpenMethod (writer:PdbWriter) (methodToken:int32) = diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 4ec4ebe1a1..1046cf5651 100755 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -910,7 +910,7 @@ type TypeDefTableKey = TdKey of string list (* enclosing *) * string (* type nam [] type cenv = - { mscorlib: ILScopeRef; + { primaryAssembly: ILScopeRef; ilg: ILGlobals; emitTailcalls: bool; showTimes: bool; @@ -1583,8 +1583,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 +1640,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 +1790,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 +2759,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 +2832,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 +2865,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 +2884,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 +3002,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 +3090,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 +3117,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 +3149,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 +3176,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 +3219,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 +3238,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 +3277,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 +3334,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 +3467,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 +3476,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 +3916,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 +4023,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 +4033,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 +4522,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 +4600,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 +4610,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, true)) + 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 bc17084855..62a20039b9 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 5248c174ee..03d7337e2e 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 0aa0fbd4be..ea8f4c5c71 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 ec92ae03d3..b7fdccf6e3 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 7084bc4942..4713d22681 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/all-vs2012.sln b/src/all-vs2012.sln index d883996fa0..3f5362be57 100755 --- a/src/all-vs2012.sln +++ b/src/all-vs2012.sln @@ -1,4 +1,3 @@ - Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 2012 Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{D78E3B57-DAD1-4FE1-9DC8-84F7847B0C77}" @@ -13,8 +12,6 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Fsc", "fsharp\Fsc\Fsc.fspro EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler", "fsharp\FSharp.Compiler\FSharp.Compiler.fsproj", "{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}" EndProject -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler.Silverlight", "fsharp\FSharp.Compiler.Silverlight\FSharp.Compiler.Silverlight.fsproj", "{A90A57BE-C2BD-4CB9-87DC-C0D18820FF6B}" -EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Core", "fsharp\FSharp.Core\FSharp.Core.fsproj", "{DED3BBD7-53F4-428A-8C9F-27968E768605}" EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Build", "fsharp\FSharp.Build\FSharp.Build.fsproj", "{702A7979-BCF9-4C41-853E-3ADFC9897890}" @@ -35,44 +32,28 @@ Global Release|Any CPU = Release|Any CPU EndGlobalSection GlobalSection(ProjectConfigurationPlatforms) = postSolution - {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.Build.0 = Debug|Any CPU - {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Release|Any CPU.ActiveCfg = Release|Any CPU - {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Release|Any CPU.Build.0 = Release|Any CPU - {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.Build.0 = Debug|Any CPU - {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.ActiveCfg = Release|Any CPU - {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.Build.0 = Release|Any CPU - {702A7979-BCF9-4C41-853E-3ADFC9897890}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {702A7979-BCF9-4C41-853E-3ADFC9897890}.Debug|Any CPU.Build.0 = Debug|Any CPU - {702A7979-BCF9-4C41-853E-3ADFC9897890}.Release|Any CPU.ActiveCfg = Release|Any CPU - {702A7979-BCF9-4C41-853E-3ADFC9897890}.Release|Any CPU.Build.0 = Release|Any CPU - {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.Build.0 = Debug|Any CPU - {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.ActiveCfg = Release|Any CPU - {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.Build.0 = Release|Any CPU - {A90A57BE-C2BD-4CB9-87DC-C0D18820FF6B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {A90A57BE-C2BD-4CB9-87DC-C0D18820FF6B}.Release|Any CPU.ActiveCfg = Release|Any CPU - {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Debug|Any CPU.Build.0 = Debug|Any CPU - {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|Any CPU.ActiveCfg = Release|Any CPU - {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|Any CPU.Build.0 = Release|Any CPU - {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.Build.0 = Debug|Any CPU - {D0E98C0D-490B-4C61-9329-0862F6E87645}.Release|Any CPU.ActiveCfg = Release|Any CPU - {D0E98C0D-490B-4C61-9329-0862F6E87645}.Release|Any CPU.Build.0 = Release|Any CPU - {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Debug|Any CPU.Build.0 = Debug|Any CPU - {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Release|Any CPU.ActiveCfg = Release|Any CPU - {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Release|Any CPU.Build.0 = Release|Any CPU - {DED3BBD7-53F4-428A-8C9F-27968E768605}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {DED3BBD7-53F4-428A-8C9F-27968E768605}.Debug|Any CPU.Build.0 = Debug|Any CPU - {DED3BBD7-53F4-428A-8C9F-27968E768605}.Release|Any CPU.ActiveCfg = Release|Any CPU - {DED3BBD7-53F4-428A-8C9F-27968E768605}.Release|Any CPU.Build.0 = Release|Any CPU + {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Debug|Any CPU.ActiveCfg = Debug|x86 + {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|Any CPU.ActiveCfg = Release|x86 + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.ActiveCfg = Debug|x86 + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Release|Any CPU.ActiveCfg = Release|x86 + {DED3BBD7-53F4-428A-8C9F-27968E768605}.Debug|Any CPU.ActiveCfg = Debug|x86 + {DED3BBD7-53F4-428A-8C9F-27968E768605}.Release|Any CPU.ActiveCfg = Release|x86 + {702A7979-BCF9-4C41-853E-3ADFC9897890}.Debug|Any CPU.ActiveCfg = Debug|x86 + {702A7979-BCF9-4C41-853E-3ADFC9897890}.Release|Any CPU.ActiveCfg = Release|x86 {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Debug|Any CPU.Build.0 = Debug|Any CPU {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Release|Any CPU.ActiveCfg = Release|Any CPU {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Release|Any CPU.Build.0 = Release|Any CPU + {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.ActiveCfg = Debug|x86 + {D0E98C0D-490B-4C61-9329-0862F6E87645}.Release|Any CPU.ActiveCfg = Release|x86 + {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.ActiveCfg = Debug|x86 + {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.ActiveCfg = Release|x86 + {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Debug|Any CPU.ActiveCfg = Debug|x86 + {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Release|Any CPU.ActiveCfg = Release|x86 + {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.Build.0 = Debug|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.ActiveCfg = Release|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/src/all-vs2013.sln b/src/all-vs2013.sln new file mode 100644 index 0000000000..7400bcec7d --- /dev/null +++ b/src/all-vs2013.sln @@ -0,0 +1,63 @@ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2013 +VisualStudioVersion = 12.0.21005.1 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{D78E3B57-DAD1-4FE1-9DC8-84F7847B0C77}" + ProjectSection(SolutionItems) = preProject + fsharp-compiler-build.proj = fsharp-compiler-build.proj + fsharp-proto-build.proj = fsharp-proto-build.proj + root.traversal.targets = root.traversal.targets + source-build-version = source-build-version + EndProjectSection +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Fsc", "fsharp\Fsc\Fsc.fsproj", "{C94C257C-3C0A-4858-B5D8-D746498D1F08}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler", "fsharp\FSharp.Compiler\FSharp.Compiler.fsproj", "{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Core", "fsharp\FSharp.Core\FSharp.Core.fsproj", "{DED3BBD7-53F4-428A-8C9F-27968E768605}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Build", "fsharp\FSharp.Build\FSharp.Build.fsproj", "{702A7979-BCF9-4C41-853E-3ADFC9897890}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Unittests", "fsharp\unittests\Unittests.fsproj", "{EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Fsi", "fsharp\fsi\Fsi.fsproj", "{D0E98C0D-490B-4C61-9329-0862F6E87645}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler.Interactive.Settings", "fsharp\FSharp.Compiler.Interactive.Settings\FSharp.Compiler.Interactive.Settings.fsproj", "{649FA588-F02E-457C-9FCF-87E46407481E}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler.Server.Shared", "fsharp\FSharp.Compiler.Server.Shared\FSharp.Compiler.Server.Shared.fsproj", "{D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Core.Unittests", "fsharp\FSharp.Core.Unittests\FSharp.Core.Unittests.fsproj", "{88E2D422-6852-46E3-A740-83E391DC7973}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Release|Any CPU = Release|Any CPU + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Debug|Any CPU.ActiveCfg = Debug|x86 + {C94C257C-3C0A-4858-B5D8-D746498D1F08}.Release|Any CPU.ActiveCfg = Release|x86 + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Debug|Any CPU.ActiveCfg = Debug|x86 + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}.Release|Any CPU.ActiveCfg = Release|x86 + {DED3BBD7-53F4-428A-8C9F-27968E768605}.Debug|Any CPU.ActiveCfg = Debug|x86 + {DED3BBD7-53F4-428A-8C9F-27968E768605}.Release|Any CPU.ActiveCfg = Release|x86 + {702A7979-BCF9-4C41-853E-3ADFC9897890}.Debug|Any CPU.ActiveCfg = Debug|x86 + {702A7979-BCF9-4C41-853E-3ADFC9897890}.Release|Any CPU.ActiveCfg = Release|x86 + {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Debug|Any CPU.Build.0 = Debug|Any CPU + {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Release|Any CPU.ActiveCfg = Release|Any CPU + {EE85AAB7-CDA0-4C4E-BDA0-A64DDDD13E3F}.Release|Any CPU.Build.0 = Release|Any CPU + {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.ActiveCfg = Debug|x86 + {D0E98C0D-490B-4C61-9329-0862F6E87645}.Release|Any CPU.ActiveCfg = Release|x86 + {649FA588-F02E-457C-9FCF-87E46407481E}.Debug|Any CPU.ActiveCfg = Debug|x86 + {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.ActiveCfg = Release|x86 + {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Debug|Any CPU.ActiveCfg = Debug|x86 + {D5870CF0-ED51-4CBC-B3D7-6F56DA84AC06}.Release|Any CPU.ActiveCfg = Release|x86 + {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Debug|Any CPU.Build.0 = Debug|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.ActiveCfg = Release|Any CPU + {88E2D422-6852-46E3-A740-83E391DC7973}.Release|Any CPU.Build.0 = Release|Any CPU + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/src/fsharp-compiler-build.proj b/src/fsharp-compiler-build.proj index 8750037920..c2ceb46493 100755 --- a/src/fsharp-compiler-build.proj +++ b/src/fsharp-compiler-build.proj @@ -8,19 +8,10 @@ net40 - - - - - - - - - diff --git a/src/fsharp-compiler-unittests-build.proj b/src/fsharp-compiler-unittests-build.proj index 1f626ab822..c5d2a9f6e0 100755 --- a/src/fsharp-compiler-unittests-build.proj +++ b/src/fsharp-compiler-unittests-build.proj @@ -11,9 +11,7 @@ + '$(TargetFramework)' == 'net40'"> diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index baedfcbecb..b50450c568 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -10,7 +10,7 @@ // You must not remove this notice, or any other, from this software. //---------------------------------------------------------------------------- -module internal Microsoft.FSharp.Compiler.ErrorLogger +module (*internal*) Microsoft.FSharp.Compiler.ErrorLogger open Internal.Utilities @@ -239,6 +239,9 @@ 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 ErrorOrWarningNumbers : int list + default this.ErrorOrWarningNumbers = [] let DiscardErrorsLogger = { new ErrorLogger("DiscardErrorsLogger") with diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 86f36a2aee..274fba7208 100755 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -18,7 +18,7 @@ buildUnexpectedTypeArgs,"The non-generic type '%s' does not expect any type argu 203,buildInvalidWarningNumber,"Invalid warning number '%s'" 204,buildInvalidVersionString,"Invalid version string '%s'" 205,buildInvalidVersionFile,"Invalid version file '%s'" -buildProductName,"F# Compiler for F# 3.0 %s" +buildProductName,"F# Compiler for F# 3.1 %s" 206,buildProblemWithFilename,"Problem with filename '%s': %s" 207,buildNoInputsSpecified,"No inputs specified" 208,buildMismatchOutputExtension,"The output name extension doesn't match the options used. If '-a' or '--target:library' is used the output file name must end with '.dll', if '--target:module' is used the output extension must be '.netmodule', otherwise '.exe'." @@ -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 ' 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'. 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 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 ..." @@ -1328,3 +1323,9 @@ descriptionUnavailable,"(description unavailable...)" 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." +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 [] attribute will be ignored." diff --git a/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj b/src/fsharp/FSharp.Build-proto/FSharp.Build-proto.fsproj index 860d6232ac..3562310196 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 @@ - $(MSBuildProjectDirectory)\..\.. diff --git a/src/fsharp/FSharp.Build-proto/Makefile.in b/src/fsharp/FSharp.Build-proto/Makefile.in index 60a0463dc7..89d3f27dd5 100644 --- a/src/fsharp/FSharp.Build-proto/Makefile.in +++ b/src/fsharp/FSharp.Build-proto/Makefile.in @@ -5,36 +5,8 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -CONFIG=proto - -FSC=$(bootstrapdir)fsc.exe - -FLAGS += --target:library - -DEFINES += \ - --define:BUILDING_WITH_LKG - -REFERENCES += \ - -r:$(bootstrapdir)FSharp.Core.dll - -sources= \ - $(tmpdir)FSBuild.fs \ - ../../utils/CompilerLocationUtils.fs \ - ../FSharp.Build/CreateFSharpManifestResourceName.fsi \ - ../FSharp.Build/CreateFSharpManifestResourceName.fs \ - ../FSharp.Build/Fsc.fsi \ - ../FSharp.Build/Fsc.fs - -RESOURCES = \ - $(tmpdir)FSBuild.resources - -$(tmpdir)FSBuild.fs $(tmpdir)FSBuild.resources: ../FSharp.Build/FSBuild.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSBuild.fs $(tmpdir)FSBuild.resx - resgen $(tmpdir)FSBuild.resx $(tmpdir)FSBuild.resources - -do-proto: do-4-0 - -clean: clean-4-0 +build-proto: + MONO_ENV_OPTIONS=$(monoopts) xbuild /p:Configuration=Proto include $(topdir)/src/fsharp/targets.make diff --git a/src/fsharp/FSharp.Build/FSharp.Build.fsproj b/src/fsharp/FSharp.Build/FSharp.Build.fsproj index beaa2db3d8..1057a5d154 100644 --- a/src/fsharp/FSharp.Build/FSharp.Build.fsproj +++ b/src/fsharp/FSharp.Build/FSharp.Build.fsproj @@ -1,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False @@ -33,19 +20,29 @@ FSBuild.txt - assemblyinfo.FSharp.Build.dll.fs + Utilities/assemblyinfo.FSharp.Build.dll.fs - CompilerLocationUtils.fs + Utilities/CompilerLocationUtils.fs + + + BuildTasks/Fsc.fsi + + + BuildTasks/Fsc.fs + + + BuildTasks/CreateFSharpManifestResourceName.fsi + + + BuildTasks/CreateFSharpManifestResourceName.fs - - - - + Microsoft.FSharp.Targets PreserveNewest + Microsoft.Portable.FSharp.Targets PreserveNewest @@ -54,9 +51,10 @@ - - - + + + + {DED3BBD7-53F4-428A-8C9F-27968E768605} FSharp.Core diff --git a/src/fsharp/FSharp.Build/Fsc.fs b/src/fsharp/FSharp.Build/Fsc.fs index a5d70449db..857b8eb19d 100755 --- a/src/fsharp/FSharp.Build/Fsc.fs +++ b/src/fsharp/FSharp.Build/Fsc.fs @@ -154,6 +154,8 @@ type [ + + + + + + + + + + + + + + + + true + true + + + + + + $(MSBuildAllProjects);$(MSBuildThisFileFullPath) + .fs + F# + Managed + $(Optimize) + Software\Microsoft\Microsoft SDKs\$(TargetFrameworkIdentifier) + + RootNamespace + false + $(Prefer32Bit) + + + + + + + + + false + true + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <_Temporary Remove="@(_Temporary)" /> + + + + + + + + + + <_DebugSymbolsIntermediatePathTemporary Include="$(PdbFile)"/> + + <_DebugSymbolsIntermediatePath Include="@(_DebugSymbolsIntermediatePathTemporary->'%(RootDir)%(Directory)%(Filename).pdb')"/> + + + + + + + + + + + + + + + + + + + <_CoreCompileResourceInputs Remove="@(_CoreCompileResourceInputs)" /> + + + + + + + + + + diff --git a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj index 9fe60a4fe9..a098976925 100644 --- a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj +++ b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj @@ -13,9 +13,6 @@ $(MSBuildProjectDirectory)\..\.. Proto - 10.0.0 - 2.0 - False diff --git a/src/fsharp/FSharp.Compiler-proto/Makefile.in b/src/fsharp/FSharp.Compiler-proto/Makefile.in index ee92d99dca..fc325f20ef 100644 --- a/src/fsharp/FSharp.Compiler-proto/Makefile.in +++ b/src/fsharp/FSharp.Compiler-proto/Makefile.in @@ -5,185 +5,7 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -CONFIG=proto - -FSC=$(bootstrapdir)fsc.exe - -FLAGS += --target:library - -DEFINES += \ - --define:BUILDING_WITH_LKG \ - --define:BUILDING_PROTO \ - --define:COMPILER \ - --define:NO_STRONG_NAMES \ - --define:INCLUDE_METADATA_READER \ - --define:INCLUDE_METADATA_WRITER - -REFERENCES += \ - -r:$(bootstrapdir)FSharp.Core.dll \ - -r:$(monogacdirXX)/System.Windows.Forms.dll - - -sources = \ - $(tmpdir)FSComp.fs \ - ../../assemblyinfo/assemblyinfo.FSharp.Compiler.dll.fs \ - ../../utils/sformat.fsi \ - ../../utils/sformat.fs \ - ../sr.fsi \ - ../sr.fs \ - ../../utils/prim-lexing.fsi \ - ../../utils/prim-lexing.fs \ - ../../utils/prim-parsing.fsi \ - ../../utils/prim-parsing.fs \ - ../../utils/resizearray.fsi \ - ../../utils/resizearray.fs \ - ../../utils/HashMultiMap.fsi \ - ../../utils/HashMultiMap.fs \ - ../../utils/TaggedCollections.fsi \ - ../../utils/TaggedCollections.fs \ - ../FlatList.fs \ - ../../absil/illib.fs \ - ../../utils/filename.fsi \ - ../../utils/filename.fs \ - ../../absil/zmap.fsi \ - ../../absil/zmap.fs \ - ../../absil/zset.fsi \ - ../../absil/zset.fs \ - ../../absil/bytes.fsi \ - ../../absil/bytes.fs \ - ../../absil/ildiag.fsi \ - ../../absil/ildiag.fs \ - ../ReferenceResolution.fs \ - ../../absil/il.fsi \ - ../../absil/il.fs \ - ../../absil/ilx.fsi \ - ../../absil/ilx.fs \ - ../../absil/ilascii.fsi \ - ../../absil/ilascii.fs \ - ../../absil/ilprint.fsi \ - ../../absil/ilprint.fs \ - ../../absil/ilmorph.fsi \ - ../../absil/ilmorph.fs \ - ../../absil/ilsupp.fsi \ - ../../absil/ilsupp.fs \ - $(tmpdir)ilpars.fs \ - $(tmpdir)illex.fs \ - ../../absil/ilbinary.fsi \ - ../../absil/ilbinary.fs \ - ../lib.fs \ - ../range.fsi \ - ../range.fs \ - ../ErrorLogger.fs \ - ../InternalCollections.fsi \ - ../InternalCollections.fs \ - ../../absil/ilread.fsi \ - ../../absil/ilread.fs \ - ../../absil/ilwrite.fsi \ - ../../absil/ilwrite.fs \ - ../../absil/ilreflect.fs \ - ../../utils/CompilerLocationUtils.fs \ - ../PrettyNaming.fs \ - ../../ilx/ilxsettings.fs \ - ../../ilx/pubclo.fsi \ - ../../ilx/pubclo.fs \ - ../../ilx/cu_erase.fsi \ - ../../ilx/cu_erase.fs \ - ../InternalFileSystemUtils.fsi \ - ../InternalFileSystemUtils.fs \ - ../unilex.fsi \ - ../unilex.fs \ - ../layout.fsi \ - ../layout.fs \ - ../ast.fs \ - $(tmpdir)pars.fs \ - ../lexhelp.fsi \ - ../lexhelp.fs \ - $(tmpdir)lex.fs \ - ../sreflect.fsi \ - ../sreflect.fs \ - ../QueueList.fs \ - ../tast.fs \ - ../env.fs \ - ../tastops.fsi \ - ../tastops.fs \ - ../pickle.fsi \ - ../pickle.fs \ - ../lexfilter.fs \ - ../import.fsi \ - ../import.fs \ - ../infos.fs \ - ../NicePrint.fs \ - ../augment.fsi \ - ../augment.fs \ - ../typrelns.fs \ - ../patcompile.fsi \ - ../patcompile.fs \ - ../outcome.fsi \ - ../outcome.fs \ - ../csolve.fsi \ - ../csolve.fs \ - ../formats.fsi \ - ../formats.fs \ - ../nameres.fsi \ - ../nameres.fs \ - ../unsolved.fs \ - ../creflect.fsi \ - ../creflect.fs \ - ../check.fsi \ - ../check.fs \ - ../tc.fsi \ - ../tc.fs \ - ../opt.fsi \ - ../opt.fs \ - ../detuple.fsi \ - ../detuple.fs \ - ../tlr.fsi \ - ../tlr.fs \ - ../lowertop.fs \ - ../ilxgen.fsi \ - ../ilxgen.fs \ - ../TraceCall.fs \ - ../build.fsi \ - ../build.fs \ - ../fscopts.fsi \ - ../fscopts.fs \ - ../vs/IncrementalBuild.fsi \ - ../vs/IncrementalBuild.fs \ - ../fsc.fs - -RESOURCES= \ - $(tmpdir)FSStrings.resources \ - $(tmpdir)FSComp.resources - -$(tmpdir)FSComp.fs $(tmpdir)FSComp.resources: ../FSComp.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSComp.fs $(tmpdir)FSComp.resx - resgen $(tmpdir)FSComp.resx $(tmpdir)FSComp.resources - -$(tmpdir)FSStrings.resources: ../FSStrings.resx - resgen $< $@ - -$(tmpdir)lex.fs: ../lex.fsl - mono $(MONO_OPTIONS) $(FSLEX) $< -o $@ --lexlib Internal.Utilities.Text.Lexing --unicode - @-mkdir -p ../FSharp.Compiler/.libs/ - cp -p $(tmpdir)lex.fs* ../FSharp.Compiler/.libs/ - -$(tmpdir)illex.fs: ../../absil/illex.fsl - mono $(MONO_OPTIONS) $(FSLEX) $< -o $@ --lexlib Internal.Utilities.Text.Lexing --unicode - @-mkdir -p ../FSharp.Compiler/.libs/ - cp -p $(tmpdir)illex.fs* ../FSharp.Compiler/.libs/ - -$(tmpdir)pars.fs: ../pars.fsy - mono $(MONO_OPTIONS) $(FSYACC) $< -o $@ --internal --open Microsoft.FSharp.Compiler --module Microsoft.FSharp.Compiler.Parser --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing | tee $@.report | grep "time" - @-mkdir -p ../FSharp.Compiler/.libs/ - cp -p $(tmpdir)pars.fs* ../FSharp.Compiler/.libs/ - -$(tmpdir)ilpars.fs: ../../absil/ilpars.fsy - mono $(MONO_OPTIONS) $(FSYACC) $< -o $@ --internal --module Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing | tee $@.report | grep "time" - @-mkdir -p ../FSharp.Compiler/.libs/ - cp -p $(tmpdir)ilpars.fs* ../FSharp.Compiler/.libs/ - -do-proto: do-4-0 - -clean: clean-4-0 +build-proto: + MONO_ENV_OPTIONS=$(monoopts) xbuild /p:Configuration=Proto include $(topdir)/src/fsharp/targets.make 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 93a11b4b96..f57bb95dc1 100644 --- 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,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False @@ -35,16 +22,16 @@ FSInteractiveSettings.txt - assemblyinfo.FSharp.Compiler.Interactive.Settings.dll.fs + Utilities/assemblyinfo.FSharp.Compiler.Interactive.Settings.dll.fs + + + Utilities/fsiattrs.fs - fsiaux.fsi + InteractiveSettings/fsiaux.fsi - fsiaux.fs - - - fsiattrs.fs + InteractiveSettings/fsiaux.fs diff --git a/src/fsharp/FSharp.Compiler.Interactive.Settings/Makefile.in b/src/fsharp/FSharp.Compiler.Interactive.Settings/Makefile.in index fed3f5d425..5254a08f89 100644 --- a/src/fsharp/FSharp.Compiler.Interactive.Settings/Makefile.in +++ b/src/fsharp/FSharp.Compiler.Interactive.Settings/Makefile.in @@ -6,29 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --target:library - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:Mono.Security.dll - -sources = \ - ../../assemblyinfo/assemblyinfo.FSharp.Compiler.Interactive.Settings.dll.fs \ - ../fsiaux.fsi \ - ../fsiaux.fs \ - ../fsiattrs.fs - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-lib-4 install-lib-4-5 +install: install-lib install-lib-net45 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 1e905ae19d..fbceeb9e36 100644 --- 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,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False diff --git a/src/fsharp/FSharp.Compiler.Server.Shared/Makefile.in b/src/fsharp/FSharp.Compiler.Server.Shared/Makefile.in index 2678437354..e48bee4458 100644 --- a/src/fsharp/FSharp.Compiler.Server.Shared/Makefile.in +++ b/src/fsharp/FSharp.Compiler.Server.Shared/Makefile.in @@ -6,28 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --target:library - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:System.Runtime.Remoting.dll \ - -r:Mono.Security.dll - -sources = \ - ../../assemblyinfo/assemblyinfo.FSharp.Compiler.Server.Shared.dll.fs \ - ../fsiserver/fsiserver.fs - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-lib-4 install-lib-4-5 +install: install-lib install-lib-net45 diff --git a/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj b/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj index 0342bc13e6..3cc18d4be9 100644 --- a/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj +++ b/src/fsharp/FSharp.Compiler.Silverlight/FSharp.Compiler.Silverlight.fsproj @@ -3,9 +3,6 @@ $(MSBuildProjectDirectory)\..\.. sl5-compiler - 10.0.0 - 2.0 - False @@ -475,9 +472,11 @@ fsi.fs + diff --git a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj index 676bcf8613..7e774ff411 100644 --- a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj +++ b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj @@ -1,31 +1,19 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False Debug AnyCPU Library - FSharp.Compiler + FSharp.Compiler.Editor EXTENSIONTYPING;COMPILER;INCLUDE_METADATA_READER;INCLUDE_METADATA_WRITER;EXTENSIBLE_DUMPER;TYPE_PROVIDER_SECURITY;$(DefineConstants) $(NoWarn);44;62;9 {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3} true + v4.5 0x06800000 $(OtherFlags) /warnon:1182 @@ -33,204 +21,207 @@ + + assemblyinfo.FSharp.Compiler.dll.fs + FSComp.txt FSStrings.resx - - assemblyinfo.FSharp.Compiler.dll.fs - - - --lexlib Internal.Utilities.Text.Lexing - lex.fsl - - - --lexlib Internal.Utilities.Text.Lexing - illex.fsl - - - Microsoft.FSharp.Compiler.Parser - Microsoft.FSharp.Compiler - --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing - pars.fsy - - - Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser - Microsoft.FSharp.Compiler.AbstractIL - --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing - ilpars.fsy - - - ExtensibleDumper.fsi - - - ExtensibleDumper.fs - - sformat.fsi + ErrorText/sformat.fsi - sformat.fs + ErrorText/sformat.fs - sr.fsi + ErrorText/sr.fsi - sr.fs + ErrorText/sr.fs - prim-lexing.fsi + LexYaccRuntime/prim-lexing.fsi - prim-lexing.fs + LexYaccRuntime/prim-lexing.fs - prim-parsing.fsi + LexYaccRuntime/prim-parsing.fsi - prim-parsing.fs + LexYaccRuntime/prim-parsing.fs + + + Utilities/ExtensibleDumper.fsi + + + Utilities/ExtensibleDumper.fs - resizearray.fsi + Utilities/resizearray.fsi - resizearray.fs + Utilities/resizearray.fs - HashMultiMap.fsi + Utilities/HashMultiMap.fsi - HashMultiMap.fs + Utilities/HashMultiMap.fs - TaggedCollections.fsi + Utilities/TaggedCollections.fsi - TaggedCollections.fs + Utilities/TaggedCollections.fs - FlatList.fs + Utilities/FlatList.fs - illib.fs + Utilities/illib.fs - filename.fsi + Utilities/filename.fsi - filename.fs + Utilities/filename.fs - zmap.fsi + Utilities/zmap.fsi - zmap.fs + Utilities/zmap.fs - zset.fsi + Utilities/zset.fsi - zset.fs + Utilities/zset.fs - bytes.fsi + Utilities/bytes.fsi - bytes.fs + Utilities/bytes.fs - ildiag.fsi + Utilities/ildiag.fsi - ildiag.fs + Utilities/ildiag.fs + + + Utilities/InternalCollections.fsi + + + Utilities/InternalCollections.fs + + + Utilities/QueueList.fs + + + Utilities/lib.fs + + + Utilities/InternalFileSystemUtils.fsi + + + Utilities/InternalFileSystemUtils.fs + + + Utilities/TraceCall.fsi + + + Utilities/TraceCall.fs + + + ErrorLogging/range.fsi + + + ErrorLogging/range.fs + + + ErrorLogging/ErrorLogger.fs ReferenceResolution.fs + + --lexlib Internal.Utilities.Text.Lexing + AbsIL/illex.fsl + + + Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser + Microsoft.FSharp.Compiler.AbstractIL + --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + AbsIL/ilpars.fsy + - il.fsi + AbsIL/il.fsi - il.fs + AbsIL/il.fs - ilx.fsi + AbsIL/ilx.fsi - ilx.fs + AbsIL/ilx.fs - ilascii.fsi + AbsIL/ilascii.fsi - ilascii.fs + AbsIL/ilascii.fs - ilprint.fsi + AbsIL/ilprint.fsi - ilprint.fs + AbsIL/ilprint.fs - ilmorph.fsi + AbsIL/ilmorph.fsi - ilmorph.fs + AbsIL/ilmorph.fs - ilsupp.fsi + AbsIL/ilsupp.fsi - ilsupp.fs + AbsIL/ilsupp.fs - - - - ilbinary.fsi - - - ilbinary.fs + + AbsIL/ilpars.fs - - lib.fs + + AbsIL/illex.fs - - range.fsi - - - range.fs - - - ErrorLogger.fs - - - tainted.fsi - - - tainted.fs - - - InternalCollections.fsi + + AbsIL/ilbinary.fsi - - InternalCollections.fs + + AbsIL/ilbinary.fs - ilread.fsi + AbsIL/ilread.fsi - ilread.fs + AbsIL/ilread.fs - ilwrite.fsi + AbsIL/ilwrite.fsi - ilwrite.fs + AbsIL/ilwrite.fs - ilreflect.fs + AbsIL/ilreflect.fs CompilerLocationUtils.fs @@ -239,262 +230,269 @@ PrettyNaming.fs - ilxsettings.fs + ILXErase/ilxsettings.fs - pubclo.fsi + ILXErase/pubclo.fsi - pubclo.fs + ILXErase/pubclo.fs - cu_erase.fsi + ILXErase/cu_erase.fsi - cu_erase.fs - - - InternalFileSystemUtils.fsi - - - InternalFileSystemUtils.fs + ILXErase/cu_erase.fs + + --lexlib Internal.Utilities.Text.Lexing + ParserAndUntypedAST/lex.fsl + + + Microsoft.FSharp.Compiler.Parser + Microsoft.FSharp.Compiler + --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ParserAndUntypedAST/pars.fsy + - unilex.fsi + ParserAndUntypedAST/unilex.fsi - unilex.fs + ParserAndUntypedAST/unilex.fs - layout.fsi + ParserAndUntypedAST/layout.fsi - layout.fs + ParserAndUntypedAST/layout.fs - ast.fs + ParserAndUntypedAST/ast.fs - - est.fsi - - - est.fs + + ParserAndUntypedAST/pars.fs - - lexhelp.fsi + ParserAndUntypedAST/lexhelp.fsi - lexhelp.fs + ParserAndUntypedAST/lexhelp.fs + + + ParserAndUntypedAST/lex.fs + + + ParserAndUntypedAST/lexfilter.fs + + + TypedAST/tainted.fsi + + + TypedAST/tainted.fs + + + TypedAST/est.fsi + + + TypedAST/est.fs - - sreflect.fsi + TypedAST/sreflect.fsi - sreflect.fs - - - QueueList.fs + TypedAST/sreflect.fs - tast.fs + TypedAST/tast.fs - env.fs + TypedAST/env.fs - tastops.fsi + TypedAST/tastops.fsi - tastops.fs + TypedAST/tastops.fs - pickle.fsi + TypedAST/pickle.fsi - pickle.fs - - - lexfilter.fs + TypedAST/pickle.fs - import.fsi + Logic/import.fsi - import.fs + Logic/import.fs - infos.fs + Logic/infos.fs - NicePrint.fs + Logic/NicePrint.fs - augment.fsi + Logic/augment.fsi - augment.fs + Logic/augment.fs - outcome.fsi + Logic/outcome.fsi - outcome.fs + Logic/outcome.fs - nameres.fsi + Logic/nameres.fsi - nameres.fs + Logic/nameres.fs - typrelns.fs + Logic/typrelns.fs - patcompile.fsi + Logic/patcompile.fsi - patcompile.fs + Logic/patcompile.fs - csolve.fsi + Logic/csolve.fsi - csolve.fs + Logic/csolve.fs - formats.fsi + Logic/formats.fsi - formats.fs + Logic/formats.fs - unsolved.fs + Logic/unsolved.fs - creflect.fsi + Logic/creflect.fsi - creflect.fs + Logic/creflect.fs - check.fsi + Logic/check.fsi - check.fs + Logic/check.fs - tc.fsi + Logic/tc.fsi - tc.fs + Logic/tc.fs - opt.fsi + Optimize/opt.fsi - opt.fs + Optimize/opt.fs - detuple.fsi + Optimize/detuple.fsi - detuple.fs + Optimize/detuple.fs - tlr.fsi + Optimize/tlr.fsi - tlr.fs + Optimize/tlr.fs - lowertop.fs + Optimize/lowertop.fs - ilxgen.fsi + CodeGen/ilxgen.fsi - ilxgen.fs - - - TraceCall.fsi - - - TraceCall.fs + CodeGen/ilxgen.fs - build.fsi + Driver/build.fsi - build.fs + Driver/build.fs - fscopts.fsi + Driver/fscopts.fsi - fscopts.fs + Driver/fscopts.fs - IncrementalBuild.fsi + Driver/IncrementalBuild.fsi - IncrementalBuild.fs + Driver/IncrementalBuild.fs - fsc.fs + Driver/fsc.fs - Reactor.fsi + Service/Reactor.fsi - Reactor.fs + Service/Reactor.fs - ServiceLexing.fsi + Service/ServiceLexing.fsi - ServiceLexing.fs + Service/ServiceLexing.fs - ServiceConstants.fs + Service/ServiceConstants.fs - ServiceParseTreeWalk.fs + Service/ServiceParseTreeWalk.fs - ServiceNavigation.fsi + Service/ServiceNavigation.fsi - ServiceNavigation.fs + Service/ServiceNavigation.fs - ServiceParamInfoLocations.fsi + Service/ServiceParamInfoLocations.fsi - ServiceParamInfoLocations.fs + Service/ServiceParamInfoLocations.fs - ServiceUntypedParse.fsi + Service/ServiceUntypedParse.fsi - ServiceUntypedParse.fs + Service/ServiceUntypedParse.fs - ServiceDeclarations.fsi + Service/ServiceDeclarations.fsi - ServiceDeclarations.fs + Service/ServiceDeclarations.fs - service.fsi + Service/service.fsi - service.fs + Service/service.fs + @@ -505,14 +503,11 @@ - - - - - - {DED3BBD7-53F4-428A-8C9F-27968E768605} - FSharp.Core - + + + + + diff --git a/src/fsharp/FSharp.Compiler/Makefile.in b/src/fsharp/FSharp.Compiler/Makefile.in index 67b850f173..311a75b5ec 100644 --- a/src/fsharp/FSharp.Compiler/Makefile.in +++ b/src/fsharp/FSharp.Compiler/Makefile.in @@ -6,203 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --target:library - -DEFINES += \ - --define:COMPILER \ - --define:INCLUDE_METADATA_READER \ - --define:INCLUDE_METADATA_WRITER - -DEFINES_4_0 += \ - --define:EXTENSIONTYPING - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:$(monogacdirXX)/System.Drawing.dll \ - -r:$(monogacdirXX)/System.Windows.Forms.dll - - -sources = \ - $(tmpdir)FSComp.fs \ - ../../assemblyinfo/assemblyinfo.FSharp.Compiler.dll.fs \ - ../../utils/sformat.fsi \ - ../../utils/sformat.fs \ - ../sr.fsi \ - ../sr.fs \ - ../../utils/prim-lexing.fsi \ - ../../utils/prim-lexing.fs \ - ../../utils/prim-parsing.fsi \ - ../../utils/prim-parsing.fs \ - ../../utils/resizearray.fsi \ - ../../utils/resizearray.fs \ - ../../utils/HashMultiMap.fsi \ - ../../utils/HashMultiMap.fs \ - ../../utils/TaggedCollections.fsi \ - ../../utils/TaggedCollections.fs \ - ../FlatList.fs \ - ../../absil/illib.fs \ - ../../utils/filename.fsi \ - ../../utils/filename.fs \ - ../../absil/zmap.fsi \ - ../../absil/zmap.fs \ - ../../absil/zset.fsi \ - ../../absil/zset.fs \ - ../../absil/bytes.fsi \ - ../../absil/bytes.fs \ - ../../absil/ildiag.fsi \ - ../../absil/ildiag.fs \ - ../ReferenceResolution.fs \ - ../../absil/il.fsi \ - ../../absil/il.fs \ - ../../absil/ilx.fsi \ - ../../absil/ilx.fs \ - ../../absil/ilascii.fsi \ - ../../absil/ilascii.fs \ - ../../absil/ilprint.fsi \ - ../../absil/ilprint.fs \ - ../../absil/ilmorph.fsi \ - ../../absil/ilmorph.fs \ - ../../absil/ilsupp.fsi \ - ../../absil/ilsupp.fs \ - $(tmpdir)ilpars.fs \ - $(tmpdir)illex.fs \ - ../../absil/ilbinary.fsi \ - ../../absil/ilbinary.fs \ - ../lib.fs \ - ../range.fsi \ - ../range.fs \ - ../ErrorLogger.fs \ - ../tainted.fsi \ - ../tainted.fs \ - ../InternalCollections.fsi \ - ../InternalCollections.fs \ - ../../absil/ilread.fsi \ - ../../absil/ilread.fs \ - ../../absil/ilwrite.fsi \ - ../../absil/ilwrite.fs \ - ../../absil/ilreflect.fs \ - ../../utils/CompilerLocationUtils.fs \ - ../PrettyNaming.fs \ - ../../ilx/ilxsettings.fs \ - ../../ilx/pubclo.fsi \ - ../../ilx/pubclo.fs \ - ../../ilx/cu_erase.fsi \ - ../../ilx/cu_erase.fs \ - ../InternalFileSystemUtils.fsi \ - ../InternalFileSystemUtils.fs \ - ../unilex.fsi \ - ../unilex.fs \ - ../layout.fsi \ - ../layout.fs \ - ../ast.fs \ - ../est.fsi \ - ../est.fs \ - $(tmpdir)pars.fs \ - ../lexhelp.fsi \ - ../lexhelp.fs \ - $(tmpdir)lex.fs \ - ../sreflect.fsi \ - ../sreflect.fs \ - ../QueueList.fs \ - ../tast.fs \ - ../env.fs \ - ../tastops.fsi \ - ../tastops.fs \ - ../pickle.fsi \ - ../pickle.fs \ - ../lexfilter.fs \ - ../import.fsi \ - ../import.fs \ - ../infos.fs \ - ../NicePrint.fs \ - ../augment.fsi \ - ../augment.fs \ - ../typrelns.fs \ - ../patcompile.fsi \ - ../patcompile.fs \ - ../outcome.fsi \ - ../outcome.fs \ - ../csolve.fsi \ - ../csolve.fs \ - ../formats.fsi \ - ../formats.fs \ - ../nameres.fsi \ - ../nameres.fs \ - ../unsolved.fs \ - ../creflect.fsi \ - ../creflect.fs \ - ../check.fsi \ - ../check.fs \ - ../tc.fsi \ - ../tc.fs \ - ../opt.fsi \ - ../opt.fs \ - ../detuple.fsi \ - ../detuple.fs \ - ../tlr.fsi \ - ../tlr.fs \ - ../lowertop.fs \ - ../ilxgen.fsi \ - ../ilxgen.fs \ - ../TraceCall.fs \ - ../build.fsi \ - ../build.fs \ - ../fscopts.fsi \ - ../fscopts.fs \ - ../vs/IncrementalBuild.fsi \ - ../vs/IncrementalBuild.fs \ - ../vs/Reactor.fsi \ - ../vs/Reactor.fs \ - ../vs/ServiceLexing.fsi \ - ../vs/ServiceLexing.fs \ - ../vs/ServiceConstants.fs \ - ../vs/ServiceParseTreeWalk.fs \ - ../vs/ServiceNavigation.fsi \ - ../vs/ServiceNavigation.fs \ - ../vs/ServiceParamInfoLocations.fsi \ - ../vs/ServiceParamInfoLocations.fs \ - ../vs/ServiceUntypedParse.fsi \ - ../vs/ServiceUntypedParse.fs \ - ../vs/ServiceDeclarations.fsi \ - ../vs/ServiceDeclarations.fs \ - ../vs/service.fsi \ - ../vs/service.fs \ - ../fsc.fs - -RESOURCES= \ - $(tmpdir)FSStrings.resources \ - $(tmpdir)FSComp.resources - -$(tmpdir)FSComp.fs $(tmpdir)FSComp.resources: ../FSComp.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSComp.fs $(tmpdir)FSComp.resx - resgen $(tmpdir)FSComp.resx $(tmpdir)FSComp.resources - -$(tmpdir)FSStrings.resources: ../FSStrings.resx - resgen $< $@ - -$(tmpdir)lex.fs: ../lex.fsl - mono $(MONO_OPTIONS) $(FSLEX) $< -o $@ --lexlib Internal.Utilities.Text.Lexing --unicode - -$(tmpdir)illex.fs: ../../absil/illex.fsl - mono $(MONO_OPTIONS) $(FSLEX) $< -o $@ --lexlib Internal.Utilities.Text.Lexing --unicode - -$(tmpdir)pars.fs: ../pars.fsy - mono $(MONO_OPTIONS) $(FSYACC) $< -o $@ --internal --open Microsoft.FSharp.Compiler --module Microsoft.FSharp.Compiler.Parser --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing | tee $@.report | grep "time" - -$(tmpdir)ilpars.fs: ../../absil/ilpars.fsy - mono $(MONO_OPTIONS) $(FSYACC) $< -o $@ --internal --module Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing | tee $@.report | grep "time" - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-lib-4 install-lib-4-5 +install: install-lib install-lib-net45 diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj index 9eb8be852e..f565508f2d 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj @@ -2,8 +2,6 @@ $(MSBuildProjectDirectory)\..\.. - 10.0.0 - False @@ -12,10 +10,10 @@ 2.0 true true - {88E2D422-6852-46E3-A740-83E391DC7973} Library FSharp.Core.Unittests SystematicUnitTests + {88e2d422-6852-46e3-a740-83e391dc7973} false false @@ -41,6 +39,12 @@ False + + + + {DED3BBD7-53F4-428A-8C9F-27968E768605} + FSharp.Core + @@ -48,6 +52,10 @@ + + + + {DED3BBD7-53F4-428A-8C9F-27968E768605} diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.2.0.fs index 3451ce37f6..b2d4547670 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.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.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 c820170bfd..c1d1d6dde5 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[System.Int32]) 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.Int32], T[,,,]) @@ -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 a318a8d472..b5902bf002 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[System.Int32]) 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.Int32], T[,,,]) @@ -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 d3ec6792b8..a9bbb7cf77 100755 --- a/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs +++ b/src/fsharp/FSharp.Core.Unittests/TypeForwarding.fs @@ -16,15 +16,20 @@ type TypeForwardingModule() = [] member this.TypeForwarding() = let currentRuntimeVersion = System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion() + let currentFSharpCoreTargetRuntime = typeof.Assembly.ImageRuntimeVersion let tupleAssemblyName = typeof>.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/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index e758e7b935..2108613d2f 100644 --- a/src/fsharp/FSharp.Core/FSharp.Core.fsproj +++ b/src/fsharp/FSharp.Core/FSharp.Core.fsproj @@ -1,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False @@ -32,7 +19,8 @@ true v2.0 $(OtherFlags) --warnon:1182 --compiling-fslib --optimize --maxerrors:20 --extraoptimizationloops:1 - $(OtherFlags) --compiling-fslib-20:"$(SystemRoot)\Microsoft.NET\Framework\v4.0.30319\mscorlib.dll" + $(OtherFlags) --compiling-fslib-20:"$(SystemRoot)\Microsoft.NET\Framework\v4.0.30319\mscorlib.dll" + $(OtherFlags) --compiling-fslib-20:"$(MonoLibDir40)/mscorlib.dll" $(OtherFlags) --compiling-fslib-40 @@ -43,166 +31,166 @@ FSCore.resx - prim-types-prelude.fsi + Primitives/prim-types-prelude.fsi - prim-types-prelude.fs + Primitives/prim-types-prelude.fs - SR.fs + Primitives/SR.fs - prim-types.fsi + Primitives/prim-types.fsi - prim-types.fs + Primitives/prim-types.fs - local.fsi + Collections/local.fsi - local.fs + Collections/local.fs - array2.fsi + Collections/array2.fsi - array2.fs + Collections/array2.fs - option.fsi + Collections/option.fsi - option.fs + Collections/option.fs - collections.fsi + Collections/collections.fsi - collections.fs + Collections/collections.fs - seq.fsi + Collections/seq.fsi - seq.fs + Collections/seq.fs - string.fsi + Collections/string.fsi - string.fs + Collections/string.fs - list.fsi + Collections/list.fsi - list.fs + Collections/list.fs - array.fsi + Collections/array.fsi - array.fs + Collections/array.fs - array3.fsi + Collections/array3.fsi - array3.fs + Collections/array3.fs - map.fsi + Collections/map.fsi - map.fs + Collections/map.fs - set.fsi + Collections/set.fsi - set.fs + Collections/set.fs - reflect.fsi + Reflection/reflect.fsi - reflect.fs + Reflection/reflect.fs - event.fsi + Event/event.fsi - event.fs + Event/event.fs - sformat.fsi + Printf/sformat.fsi - sformat.fs + Printf/sformat.fs - printf.fsi + Printf/printf.fsi - printf.fs + Printf/printf.fs - quotations.fsi + Quotations/quotations.fsi - quotations.fs + Quotations/quotations.fs - nativeptr.fsi + NativeInterop/nativeptr.fsi - nativeptr.fs + NativeInterop/nativeptr.fs - control.fsi + Async/control.fsi - control.fs + Async/control.fs - Linq.fsi + Queries/Linq.fsi - Linq.fs + Queries/Linq.fs - MutableTuple.fs + Queries/MutableTuple.fs - QueryExtensions.fs + Queries/QueryExtensions.fs - Query.fsi + Queries/Query.fsi - Query.fs + Queries/Query.fs - SI.fs + Units/SI.fs - n.fsi + Numerics/n.fsi - n.fs + Numerics/n.fs - z.fsi + Numerics/z.fsi - z.fs + Numerics/z.fs - fslib-extra-pervasives.fsi + Extras/fslib-extra-pervasives.fsi - fslib-extra-pervasives.fs + Extras/fslib-extra-pervasives.fs assemblyinfo.FSharp.Core.dll.fs @@ -212,12 +200,13 @@ - + + - + - + diff --git a/src/fsharp/FSharp.Core/Linq.fs b/src/fsharp/FSharp.Core/Linq.fs index 47622ba77f..bd1f0c477b 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>.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 to IEnumerable) 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 then + let tyargs = [| vP.Type |] + typedefof>, 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>.MakeGenericType tyargs + typedefof>, tyargs #else - let tyargs = [| v.Type; body.Type |] - let bodyP = ConvExprToLinqInContext env body - let convType = typedefof>.MakeGenericType tyargs + typedefof>, tyargs #endif + let convType = lambdaTy.MakeGenericType tyargs let convDelegate = Expression.Lambda(convType, bodyP, [| vP |]) |> asExpr Expression.Call(typeof,"ToFSharpFunc", tyargs,[| convDelegate |]) |> asExpr diff --git a/src/fsharp/FSharp.Core/Makefile.in b/src/fsharp/FSharp.Core/Makefile.in index b05173688b..c6dd33d3b2 100644 --- a/src/fsharp/FSharp.Core/Makefile.in +++ b/src/fsharp/FSharp.Core/Makefile.in @@ -7,106 +7,8 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS_2_0 += \ - $(DELAY_SIGN_FLAGS) \ - --compiling-fslib \ - --nowarn:75,1204 \ - --target:library \ - --compiling-fslib-20:$(monogacdir40)/mscorlib.dll \ - --extraoptimizationloops:1 - -FLAGS_2_1 += \ - $(DELAY_SIGN_FLAGS) \ - --compiling-fslib \ - --nowarn:75,1204 \ - --target:library \ - --extraoptimizationloops:1 - -FLAGS_4_0 += \ - $(DELAY_SIGN_FLAGS) \ - --compiling-fslib \ - --nowarn:75,1204 \ - --target:library \ - --compiling-fslib-40 \ - --define:BE_SECURITY_TRANSPARENT \ - --define:QUERIES_IN_FSLIB \ - --define:PUT_TYPE_PROVIDERS_IN_FSCORE \ - --extraoptimizationloops:1 - -DEFINES += \ - --define:RUNTIME - -sources = \ - prim-types-prelude.fsi \ - prim-types-prelude.fs \ - SR.fs \ - prim-types.fsi \ - prim-types.fs \ - local.fsi \ - local.fs \ - array2.fsi \ - array2.fs \ - option.fsi \ - option.fs \ - collections.fsi \ - collections.fs \ - seq.fsi \ - seq.fs \ - string.fsi \ - string.fs \ - list.fsi \ - list.fs \ - array.fsi \ - array.fs \ - array3.fsi \ - array3.fs \ - map.fsi \ - map.fs \ - set.fsi \ - set.fs \ - reflect.fsi \ - reflect.fs \ - event.fsi \ - event.fs \ - math/n.fsi \ - math/n.fs \ - math/z.fsi \ - math/z.fs \ - ../../utils/sformat.fsi \ - ../../utils/sformat.fs \ - printf.fsi \ - printf.fs \ - quotations.fsi \ - quotations.fs \ - nativeptr.fsi \ - nativeptr.fs \ - control.fsi \ - control.fs \ - Linq.fsi \ - Linq.fs \ - MutableTuple.fs \ - QueryExtensions.fs \ - Query.fsi \ - Query.fs \ - SI.fs \ - fslib-extra-pervasives.fsi \ - fslib-extra-pervasives.fs \ - ../../assemblyinfo/assemblyinfo.FSharp.Core.dll.fs - -RESOURCES = \ - $(tmpdir)FSCore.resources - -$(tmpdir)FSCore.resources: FSCore.resx - resgen $< $@ - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 do-2-0 do-2-1 - -clean: clean-4-0 clean-2-0 clean-2-1 - -install: install-lib-4 install-lib-4-5 install-lib-2 install-lib-2-1 +install: install-lib install-lib-net45 diff --git a/src/fsharp/FSharp.Core/Query.fs b/src/fsharp/FSharp.Core/Query.fs index 69752f5aab..b1b8f5be74 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>) = [] 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>) : 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>) : IQueryable<'T> = ForwardDeclarations.Query.Execute q + member this.Run q = this.RunQueryAsQueryable q + +namespace Microsoft.FSharp.Linq.QueryRunExtensions + + open Microsoft.FSharp.Core + + [] + module LowPriority = + type Microsoft.FSharp.Linq.QueryBuilder with + [] + member this.Run (q: Microsoft.FSharp.Quotations.Expr<'T>) = this.RunQueryAsValue q + + [] + module HighPriority = + type Microsoft.FSharp.Linq.QueryBuilder with + [] + member this.Run (q: Microsoft.FSharp.Quotations.Expr>) = 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 [] module Query = @@ -940,10 +997,11 @@ module Query = | MacroReduction reduced -> Some (walk reduced) | _ -> None) - - let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof.GetMethod("Run").MethodHandle) - let (|CallQueryBuilderRunValue|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.LowPriority").GetMethod("RunQueryAsValue").MethodHandle) - let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (typeof.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.HighPriority").GetMethod("RunQueryAsEnumerable").MethodHandle) + let (|CallQueryBuilderRunQueryable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b :QueryBuilder, v) -> b.Run(v))) + // (typeof.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.Assembly.GetType("Microsoft.FSharp.Linq.QueryRunExtensions.HighPriority").GetMethod("RunQueryAsEnumerable").MethodHandle) + let (|CallQueryBuilderRunEnumerable|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b : QueryBuilder, v : Expr> ) -> b.Run(v))) // type annotations here help overload resolution let (|CallQueryBuilderFor|_|) : Quotations.Expr -> _ = (|SpecificCallToMethod|_|) (methodhandleof (fun (b:QueryBuilder,source:QuerySource,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>) : 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>) : IQueryable<'T> = Query.QueryExecute q - member this.Run q = this.RunQueryAsQueryable q - - - -namespace Microsoft.FSharp.Linq.QueryRunExtensions - - open Microsoft.FSharp.Core - - [] - module LowPriority = - type Microsoft.FSharp.Linq.QueryBuilder with - [] - member this.Run (q: Microsoft.FSharp.Quotations.Expr<'T>) = this.RunQueryAsValue q - - [] - module HighPriority = - type Microsoft.FSharp.Linq.QueryBuilder with - [] - member this.Run (q: Microsoft.FSharp.Quotations.Expr>) = 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 6ebbbff2af..1038f4064c 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 a90ecb40a7..e09caba29f 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 737c0f560e..64b925aae2 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 @@ -465,6 +472,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 + + [] + 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 + + [] + 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 @@ -865,8 +900,6 @@ namespace Microsoft.FSharp.Control bindA p1 (fun () -> p2) - - open AsyncBuilderImpl [] @@ -1295,9 +1328,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) -> @@ -1347,7 +1382,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) @@ -1360,27 +1396,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 @@ -1395,6 +1425,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>(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(continuation), TaskContinuationOptions.None) |> ignore |> fake +#endif + #if FX_NO_REGISTERED_WAIT_HANDLES [] [] @@ -1405,8 +1463,12 @@ namespace Microsoft.FSharp.Control member this.IsCompleted = #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 @@ -1420,6 +1482,13 @@ namespace Microsoft.FSharp.Control static member StartImmediate(a:Async,?cancellationToken) : unit = Async.StartWithContinuations(a,id,raise,ignore,?cancellationToken=cancellationToken) +#if FSHARP_CORE_NETCORE_PORTABLE + static member Sleep(dueTime : int) : Async = + // 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 = unprotectedPrimitiveWithResync (fun ({ aux = aux } as args) -> let timer = ref (None : Timer option) @@ -1463,6 +1532,7 @@ namespace Microsoft.FSharp.Control | exn -> aux.econt exn ) +#endif static member AwaitWaitHandle(waitHandle:WaitHandle,?millisecondsTimeout:int) = let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite @@ -1523,7 +1593,6 @@ namespace Microsoft.FSharp.Control #endif // 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 ( @@ -1531,7 +1600,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, @@ -1827,7 +1896,7 @@ namespace Microsoft.FSharp.Control resultCell.RegisterResult(res,reuseThread=true) |> unfake) and del = #if FX_ATLEAST_PORTABLE - let invokeMeth = (typeof>).GetMethod("Invoke", System.Reflection.BindingFlags.NonPublic ||| System.Reflection.BindingFlags.Public ||| System.Reflection.BindingFlags.Instance) + let invokeMeth = (typeof>).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 @@ -1906,18 +1975,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>(continuation), TaskContinuationOptions.None) |> ignore |> fake - ) + static member AwaitTask (task:Task<'T>) : Async<'T> = + protectedPrimitiveWithResync (fun args -> + TaskHelpers.continueWith(task, args) + ) #endif module CommonExtensions = @@ -1930,7 +1991,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 [] // give the extension member a 'nice', unmangled compiled name, unique within this module member stream.AsyncRead(count) = @@ -1947,7 +2015,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 585aa97e53..16e827e333 100644 --- 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 02bddcb91e..1ae53eb17e 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 9972f8de2a..c62d6c93e5 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 [] type SealedAttribute(value:bool) = @@ -392,6 +390,27 @@ namespace Microsoft.FSharp.Core [] type int16<[] 'Measure> = int16 [] type int64<[] '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 [] // 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,false) + let mappingAttrs = ty.GetCustomAttributes(typeof, false) if mappingAttrs.Length = 0 then TypeNullnessSemantics_NullIsExtraValue elif ty.Equals(typeof) then TypeNullnessSemantics_NullTrueValue - elif typeof.IsAssignableFrom(ty) then + elif typeof.IsAssignableFrom(ty) then TypeNullnessSemantics_NullIsExtraValue - elif ty.GetCustomAttributes(typeof,false).Length > 0 then + elif ty.GetCustomAttributes(typeof, false).Length > 0 then TypeNullnessSemantics_NullIsExtraValue else - let reprAttrs = ty.GetCustomAttributes(typeof,false) + let reprAttrs = ty.GetCustomAttributes(typeof, 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 @@ -4631,6 +4661,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))) @@ -4911,82 +4944,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) [] @@ -5409,6 +5474,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 + [] 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 e92f3b81e3..9387675744 100755 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -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 /// The result of the operation. val inline (>>>) : value:^T -> shift:int32 -> ^T when ^T : (static member (>>>) : ^T * int32 -> ^T) and default ^T : int - /// Overloaded logical-NOT operator + /// Overloaded bitwise-NOT operator /// The input value. /// The result of the operation. val inline (~~~) : value:^T -> ^T when ^T : (static member (~~~) : ^T -> ^T) and default ^T : int - /// Overloaded prefix=plus operator + /// Overloaded prefix-plus operator /// The input value. /// The result of the operation. val inline (~+) : value:^T -> ^T when ^T : (static member (~+) : ^T -> ^T) and default ^T : int @@ -2671,7 +2685,7 @@ namespace Microsoft.FSharp.Core /// The source array. val inline SetArraySlice : target:'T[] -> start:int option -> finish:int option -> source:'T[] -> unit - /// Gets a slice of an array + /// Gets a region slice of an array /// The source array. /// The start index of the first dimension. /// The end index of the first dimension. @@ -2680,7 +2694,23 @@ namespace Microsoft.FSharp.Core /// The two dimensional sub array from the input indices. val GetArraySlice2D : source:'T[,] -> start1:int option -> finish1:int option -> start2:int option -> finish2:int option -> 'T[,] - /// Sets a slice of an array + /// Gets a vector slice of a 2D array. The index of the first dimension is fixed. + /// The source array. + /// The index of the first dimension. + /// The start index of the second dimension. + /// The end index of the second dimension. + /// The sub array from the input indices. + val inline GetArraySlice2DFixed1 : source:'T[,] -> index1:int -> start2:int option -> finish2:int option -> 'T[] + + /// Gets a vector slice of a 2D array. The index of the second dimension is fixed. + /// The source array. + /// The start index of the first dimension. + /// The end index of the first dimension. + /// The fixed index of the second dimension. + /// The sub array from the input indices. + val inline GetArraySlice2DFixed2 : source:'T[,] -> start1:int option -> finish1:int option -> index2: int -> 'T[] + + /// Sets a region slice of an array /// The target array. /// The start index of the first dimension. /// The end index of the first dimension. @@ -2689,6 +2719,22 @@ namespace Microsoft.FSharp.Core /// The source array. val SetArraySlice2D : target:'T[,] -> start1:int option -> finish1:int option -> start2:int option -> finish2:int option -> source:'T[,] -> unit + /// Sets a vector slice of a 2D array. The index of the first dimension is fixed. + /// The target array. + /// The index of the first dimension. + /// The start index of the second dimension. + /// The end index of the second dimension. + /// The source array. + val inline SetArraySlice2DFixed1 : target:'T[,] -> index1:int -> start2:int option -> finish2:int option -> source:'T[] -> unit + + /// Sets a vector slice of a 2D array. The index of the second dimension is fixed. + /// The target array. + /// The start index of the first dimension. + /// The end index of the first dimension. + /// The index of the second dimension. + /// The source array. + val inline SetArraySlice2DFixed2 : target:'T[,] -> start1:int option -> finish1:int option -> index2:int -> source:'T[] -> unit + /// Gets a slice of an array /// The source array. /// The start index of the first dimension. diff --git a/src/fsharp/FSharp.Core/printf.fs b/src/fsharp/FSharp.Core/printf.fs index ad06604fbf..4396858875 100755 --- a/src/fsharp/FSharp.Core/printf.fs +++ b/src/fsharp/FSharp.Core/printf.fs @@ -11,619 +11,1370 @@ 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 + + [] + 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 + [] + let StarValue = -1 + /// Used for width and precision to denote that corresponding value was omitted in format string + [] + let NotSpecifiedValue = -2 + + [] + [] + 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 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) + + let findNextFormatSpecifier (s : string) i = + let rec go i (buf : Text.StringBuilder) = + if i >= s.Length then + s.Length, buf.ToString() + else + let c = s.[i] + if c = '%' then + if i + 1 < s.Length then + let _, i1 = parseFlags s (i + 1) + let w, i2 = parseWidth s i1 + let p, i3 = parsePrecision s i2 + let typeChar, i4 = parseTypeChar s i3 + // shortcut for the simpliest case + // if typeChar is not % or it has star as width\precision - resort to long path + if typeChar = '%' && not (w = StarValue || p = StarValue) then + buf.Append('%') |> ignore + go i4 buf + else + i, buf.ToString() + else + raise (ArgumentException("Missing format specifier")) + else + buf.Append(c) |> ignore + go (i + 1) buf + go i (Text.StringBuilder()) + + /// Abstracts generated printer from the details of particular environment: how to write text, how to produce results etc... + [] + 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 + + [] + 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 + /// + + + ... + + 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 PercentStarFinal1(s1 : string, s2 : string) = + (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (_star1 : int) -> + let env = env() + env.Write s1 + env.Write("%") + 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() + ) + ) + + /// Handles case when '%*.*%' is used at the end of string + static member PercentStarFinal2(s1 : string, s2 : string) = + (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (_star1 : int) (_star2 : int) -> + let env = env() + env.Write s1 + env.Write("%") + 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 + ) + ) + + /// Handles case when '%*%' is used in the middle of the string so it needs to be chained to another printing block + static member PercentStarChained1<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (_star1 : int) -> + let env() = + let env = env() + env.Write s1 + env.Write("%") + 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 + ) + ) + + /// Handles case when '%*.*%' is used in the middle of the string so it needs to be chained to another printing block + static member PercentStarChained2<'Tail>(s1 : string, next : PrintfFactory<'State, 'Residue, 'Result,'Tail>) = + (fun (env : unit -> PrintfEnv<'State, 'Residue, 'Result>) -> + (fun (_star1 : int) (_star2 : int) -> + let env() = + let env = env() + env.Write s1 + env.Write("%") + 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 + + [] + 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 + + 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) - type buf = System.Text.StringBuilder - - let stringOfChar (c:char) = System.Char.ToString(c) - let stringOfInt (i:int) = i.ToString() - - [] - 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 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, ' ') - 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 + /// 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 len = numDigits + (outputSignAndLeftSpace(outputChar,info,(n >= 0L),width,numDigits) ) + /// 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 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 |]) + /// 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 + + /// 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 -> "" | 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 -> "" + | _ -> 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 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 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, "ty === typeof") + basicWithPadding spec boolToString + | 's' -> + System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") + basicWithPadding spec stringToSafeString + | 'c' -> + System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") + basicWithPadding spec (fun (c : char) -> c.ToString()) + | 'M' -> + System.Diagnostics.Debug.Assert(ty === typeof, "ty === typeof") + 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.GetMethod("GenericToString", NonPublicStatics) + let mi = mi.MakeGenericMethod(ty) + mi.Invoke(null, [| box spec |]) + | 'O' -> + let mi = typeof.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 + + [] + 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 -> "" | _ -> 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 DEBUG + if _mi = null then + ignore (System.Diagnostics.Debugger.Launch()) +#else + () +#endif - let opts = match precision with None -> opts | Some w -> { opts with PrintSize = w } - let txt = - match xobj with - | 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>.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>.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 mi = + let n = if spec.IsStarWidth = spec.IsStarPrecision then 2 else 1 + let prefix = if spec.TypeChar = '%' then "PercentStarChained" else "StarChained" + let name = prefix + (string n) + typeof>.GetMethod(name, NonPublicStatics) + + verifyMethodInfoWasTaken mi + + let argTypes, args = + if spec.TypeChar = '%' then + [| retTy |], [| box prefix; tail |] + else + let argTy = argTys.[argTys.Length - 2] + let conv = getValueConverter argTy spec + [| argTy; retTy |], [| box prefix; box conv; tail |] + + let mi = mi.MakeGenericMethod argTypes + mi.Invoke(null, args) + + let buildSpecialFinal(spec : FormatSpecifier, argTys : Type[], prefix : string, suffix : string) = + if spec.TypeChar = 'a' then + let mi = typeof>.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>.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 mi = + let n = if spec.IsStarWidth = spec.IsStarPrecision then 2 else 1 + let prefix = if spec.TypeChar = '%' then "PercentStarFinal" else "StarFinal" + let name = prefix + (string n) + typeof>.GetMethod(name, NonPublicStatics) + + verifyMethodInfoWasTaken mi + + let mi, args = + if spec.TypeChar = '%' then + mi, [| box prefix; box suffix |] + else + let argTy = argTys.[argTys.Length - 2] + let mi = mi.MakeGenericMethod(argTy) + let conv = getValueConverter argTy spec + mi, [| box prefix; box conv; box suffix |] + + mi.Invoke(null, args) + + let buildPlainFinal(args : obj[], argTypes : Type[]) = + let mi = typeof>.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>.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, suffix = FormatString.findNextFormatSpecifier s 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 + + let n = if spec.TypeChar = '%' then n - 1 else n + + System.Diagnostics.Debug.Assert(n <> 0, "n <> 0") + + 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, prefix = FormatString.findNextFormatSpecifier s 0 + if prefixPos = s.Length then + box (fun (env : unit -> PrintfEnv<'S, 'Re, 'Res>) -> + let env = env() + env.Write prefix + env.Finalize() + ) + else + let n = parseFromFormatSpecifier prefix s funcTy prefixPos + + if n = ContinuationOnStack || n = 0 then + builderStack.PopValueUnsafe() else - match fmt.[i] with - | '%' -> - let i = i+1 - capture1 fmt i args ty capture - | _ -> - capture args ty (i+1) + 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>() + static let getOrAddFunc = Func<_, _>(generate) +#else + static let mutable map = Dictionary>() +#endif - (unbox (capture [] (typeof<'a>) 0) : 'a) + 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 + let v = +#if DEBUG + try + generate(key) + with + e -> raise (ArgumentException("PRINTF::" + key, e)) +#else + generate(key) +#endif + map.Add(key, v) + v + ) +#endif + + [] +#if FX_NO_THREAD_STATIC +#else + [] +#endif + 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(()) + + 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(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(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 [] -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 + [] + 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 - [] - 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 [] 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 - [] - 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<_, _, _> + ) + [] - let kfprintf f os fmt = kprintf_imperative f (os :> TextWriter) (fun c -> ignore (os.Write(c))) fmt - - [] - let sprintf fmt = ksprintf (fun x -> x) fmt - - [] - let failwithf fmt = ksprintf failwith fmt + let kfprintf f os fmt = + doPrintf fmt (fun _ -> + TextWriterPrintfEnv(f, os) :> PrintfEnv<_, _, _> + ) [] - let bprintf buf fmt = kbprintf (fun _ -> ()) buf fmt + let bprintf buf fmt = kbprintf ignore buf fmt [] - let fprintf (os: TextWriter) fmt = kfprintf (fun _ -> ()) os fmt + let fprintf (os: System.IO.TextWriter) fmt = kfprintf ignore os fmt [] - let fprintfn (os: TextWriter) fmt = kfprintf (fun _ -> os.WriteLine()) os fmt + let fprintfn (os: System.IO.TextWriter) fmt = kfprintf (fun _ -> os.WriteLine()) os fmt + + [] + 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 + [] let printf fmt = fprintf (!outWriter) fmt @@ -648,6 +1399,4 @@ module Printf = [] 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 e2b3022fd5..c4c213c8de 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) 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. + [] + 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) + // 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) = 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)) - | 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)) + | 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 [] 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() 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 [] 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 406ffe2268..6a160ed5b2 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 = + + [] + 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 + + [] + 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.Equals ty then TypeCode.Int32 + elif typeof.Equals ty then TypeCode.Int64 + elif typeof.Equals ty then TypeCode.Byte + elif ty = typeof then TypeCode.SByte + elif ty = typeof then TypeCode.Int16 + elif ty = typeof then TypeCode.UInt16 + elif ty = typeof then TypeCode.UInt32 + elif ty = typeof then TypeCode.UInt64 + elif ty = typeof then TypeCode.Single + elif ty = typeof then TypeCode.Double + elif ty = typeof 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,false)) - let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) - let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = findCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) + let tryFindCompilationMappingAttributeFromType (typ:Type) = tryFindCompilationMappingAttribute ( typ.GetCustomAttributes(typeof, false)) + let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = tryFindCompilationMappingAttribute (info.GetCustomAttributes(typeof, false)) + let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = findCompilationMappingAttribute (info.GetCustomAttributes(typeof, false)) #else let cmaName = typeof.FullName let assemblyName = typeof.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, 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 [] 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 6ce9de9794..db0824d6dd 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. type FSharpValue = - /// Creates an instance of a record type. - /// - /// Assumes the given input is a record type. - /// The type of record to make. - /// The array of values to initialize the record. - /// Optional binding flags for the record. - /// Thrown when the input type is not a record type. - /// The created record. - static member MakeRecord: recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj - /// Reads a field from a record value. /// /// Assumes the given input is a record value. If not, ArgumentException is raised. @@ -77,16 +67,6 @@ type FSharpValue = /// Thrown when the input type is not a record type. /// The field from the record. static member GetRecordField: record:obj * info:PropertyInfo -> obj - - /// Reads all the fields from a record value. - /// - /// Assumes the given input is a record value. If not, ArgumentException is raised. - /// The record object. - /// Optional binding flags for the record. - /// Thrown when the input type is not a record type. - /// The array of fields from the record. - static member GetRecordFields: record:obj * ?bindingFlags:BindingFlags -> obj[] - /// 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 = /// A function to read the specified field from the record. static member PreComputeRecordFieldReader : info:PropertyInfo -> (obj -> obj) +#if FX_RESHAPED_REFLECTION +#else + /// Creates an instance of a record type. + /// + /// Assumes the given input is a record type. + /// The type of record to make. + /// The array of values to initialize the record. + /// Optional binding flags for the record. + /// Thrown when the input type is not a record type. + /// The created record. + static member MakeRecord: recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj + + /// Reads all the fields from a record value. + /// + /// Assumes the given input is a record value. If not, ArgumentException is raised. + /// The record object. + /// Optional binding flags for the record. + /// Thrown when the input type is not a record type. + /// The array of fields from the record. + static member GetRecordFields: record:obj * ?bindingFlags:BindingFlags -> obj[] + /// 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. @@ -115,8 +116,6 @@ type FSharpValue = /// Thrown when the input type is not a record type. /// An optimized reader for the given record type. static member PreComputeRecordReader : recordType:Type * ?bindingFlags:BindingFlags -> (obj -> obj[]) - - /// Precompute a function for constructing a record value. /// /// Assumes the given type is a RecordType. @@ -191,6 +190,16 @@ type FSharpValue = /// The description of the constructor of the given union case. static member PreComputeUnionConstructorInfo: unionCase:UnionCaseInfo * ?bindingFlags:BindingFlags -> MethodInfo + /// Reads all the fields from a value built using an instance of an F# exception declaration + /// + /// Assumes the given input is an F# exception value. If not, ArgumentException is raised. + /// The exception instance. + /// Optional binding flags. + /// Thrown when the input type is not an F# exception. + /// The fields from the given exception. + static member GetExceptionFields: exn:obj * ?bindingFlags:BindingFlags -> obj[] +#endif + /// Creates an instance of a tuple type /// /// Assumes at least one element is given. If not, ArgumentException is raised. @@ -260,20 +269,12 @@ type FSharpValue = /// A typed function from the given dynamic implementation. static member MakeFunction : functionType:Type * implementation:(obj -> obj) -> obj - /// Reads all the fields from a value built using an instance of an F# exception declaration - /// - /// Assumes the given input is an F# exception value. If not, ArgumentException is raised. - /// The exception instance. - /// Optional binding flags. - /// Thrown when the input type is not an F# exception. - /// The fields from the given exception. - static member GetExceptionFields: exn:obj * ?bindingFlags:BindingFlags -> obj[] - - [] /// Contains operations associated with constructing and analyzing F# types such as records, unions and tuples type FSharpType = +#if FX_RESHAPED_REFLECTION +#else /// Reads all the fields from a record value, in declaration order /// /// Assumes the given input is a record value. If not, ArgumentException is raised. @@ -291,6 +292,36 @@ type FSharpType = /// An array of descriptions of the cases of the given union type. static member GetUnionCases: unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo[] + + /// Return true if the typ is a representation of an F# record type + /// The type to check. + /// Optional binding flags. + /// True if the type check succeeds. + static member IsRecord: typ:Type * ?bindingFlags:BindingFlags -> bool + + /// Returns true if the typ is a representation of an F# union type or the runtime type of a value of that type + /// The type to check. + /// Optional binding flags. + /// True if the type check succeeds. + static member IsUnion: typ:Type * ?bindingFlags:BindingFlags -> bool + + /// Reads all the fields from an F# exception declaration, in declaration order + /// + /// Assumes exceptionType is an exception representation type. If not, ArgumentException is raised. + /// The exception type to read. + /// Optional binding flags. + /// Thrown if the given type is not an exception. + /// An array containing the PropertyInfo of each field in the exception. + static member GetExceptionFields: exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo[] + + /// Returns true if the typ is a representation of an F# exception declaration + /// The type to check. + /// Optional binding flags. + /// True if the type check is an F# exception. + static member IsExceptionRepresentation: exceptionType:Type * ?bindingFlags:BindingFlags -> bool + +#endif + /// Returns a System.Type representing the F# function type with the given domain and range /// The input type of the function. /// The output type of the function. @@ -317,17 +348,6 @@ type FSharpType = /// True if the type check succeeds. static member IsModule: typ:Type -> bool - /// Return true if the typ is a representation of an F# record type - /// The type to check. - /// Optional binding flags. - /// True if the type check succeeds. - static member IsRecord: typ:Type * ?bindingFlags:BindingFlags -> bool - - /// Returns true if the typ is a representation of an F# union type or the runtime type of a value of that type - /// The type to check. - /// Optional binding flags. - /// True if the type check succeeds. - static member IsUnion: typ:Type * ?bindingFlags:BindingFlags -> bool /// Gets the tuple elements from the representation of an F# tuple type. /// The input tuple type. @@ -339,24 +359,258 @@ type FSharpType = /// A tuple of the domain and range types of the input function. static member GetFunctionElements : functionType:Type -> Type * Type - /// Reads all the fields from an F# exception declaration, in declaration order - /// - /// Assumes exceptionType is an exception representation type. If not, ArgumentException is raised. - /// The exception type to read. - /// Optional binding flags. - /// Thrown if the given type is not an exception. - /// An array containing the PropertyInfo of each field in the exception. - static member GetExceptionFields: exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo[] +[] +module FSharpReflectionExtensions = + type FSharpValue with + /// Creates an instance of a record type. + /// + /// Assumes the given input is a record type. + /// The type of record to make. + /// The array of values to initialize the record. + /// Optional flags that denotes accessibility of the private representation. + /// Thrown when the input type is not a record type. + /// The created record. + static member MakeRecord: recordType:Type * values:obj [] * ?allowAccessToPrivateRepresentation : bool -> obj + /// Reads all the fields from a record value. + /// + /// Assumes the given input is a record value. If not, ArgumentException is raised. + /// The record object. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not a record type. + /// The array of fields from the record. + static member GetRecordFields: record:obj * ?allowAccessToPrivateRepresentation : bool -> obj[] + + /// 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. + /// + /// 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. + /// The type of record to read. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not a record type. + /// An optimized reader for the given record type. + static member PreComputeRecordReader : recordType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj -> obj[]) + /// Precompute a function for constructing a record value. + /// + /// Assumes the given type is a RecordType. + /// If not, ArgumentException is raised during pre-computation. + /// The type of record to construct. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not a record type. + /// A function to construct records of the given type. + static member PreComputeRecordConstructor : recordType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj[] -> obj) + + /// Get a ConstructorInfo for a record type + /// The record type. + /// Optional flag that denotes accessibility of the private representation. + /// A ConstructorInfo for the given record type. + static member PreComputeRecordConstructorInfo: recordType:Type * ?allowAccessToPrivateRepresentation : bool-> ConstructorInfo + + /// Create a union case value. + /// The description of the union case to create. + /// The array of arguments to construct the given case. + /// Optional flag that denotes accessibility of the private representation. + /// The constructed union case. + static member MakeUnion: unionCase:UnionCaseInfo * args:obj [] * ?allowAccessToPrivateRepresentation : bool-> obj + + /// Identify the union case and its fields for an object + /// + /// 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'. + /// The input union case. + /// The union type containing the value. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not a union case value. + /// The description of the union case and its fields. + static member GetUnionFields: value:obj * unionType:Type * ?allowAccessToPrivateRepresentation : bool -> UnionCaseInfo * obj [] + + /// Assumes the given type is a union type. + /// If not, ArgumentException is raised during pre-computation. + /// + /// 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. + /// The type of union to optimize reading. + /// Optional flag that denotes accessibility of the private representation. + /// An optimized function to read the tags of the given union type. + static member PreComputeUnionTagReader : unionType:Type * ?allowAccessToPrivateRepresentation : bool -> (obj -> int) + + /// Precompute a property or static method for reading an integer representing the case tag of a union type. + /// The type of union to read. + /// Optional flag that denotes accessibility of the private representation. + /// The description of the union case reader. + static member PreComputeUnionTagMemberInfo : unionType:Type * ?allowAccessToPrivateRepresentation : bool -> MemberInfo + + /// Precomputes a function for reading all the fields for a particular discriminator case of a union type + /// + /// Using the computed function will typically be faster than executing a corresponding call to GetFields + /// The description of the union case to read. + /// Optional flag that denotes accessibility of the private representation. + /// A function to for reading the fields of the given union case. + static member PreComputeUnionReader : unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> (obj -> obj[]) + + /// Precomputes a function for constructing a discriminated union value for a particular union case. + /// The description of the union case. + /// Optional flag that denotes accessibility of the private representation. + /// A function for constructing values of the given union case. + static member PreComputeUnionConstructor : unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> (obj[] -> obj) + + /// A method that constructs objects of the given case + /// The description of the union case. + /// Optional flag that denotes accessibility of the private representation. + /// The description of the constructor of the given union case. + static member PreComputeUnionConstructorInfo: unionCase:UnionCaseInfo * ?allowAccessToPrivateRepresentation : bool -> MethodInfo + + /// Reads all the fields from a value built using an instance of an F# exception declaration + /// + /// Assumes the given input is an F# exception value. If not, ArgumentException is raised. + /// The exception instance. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not an F# exception. + /// The fields from the given exception. + static member GetExceptionFields: exn:obj * ?allowAccessToPrivateRepresentation : bool -> obj[] + + type FSharpType with + /// Reads all the fields from a record value, in declaration order + /// + /// Assumes the given input is a record value. If not, ArgumentException is raised. + /// The input record type. + /// Optional flag that denotes accessibility of the private representation. + /// An array of descriptions of the properties of the record type. + static member GetRecordFields: recordType:Type * ?allowAccessToPrivateRepresentation : bool -> PropertyInfo[] + + /// Gets the cases of a union type. + /// + /// Assumes the given type is a union type. If not, ArgumentException is raised during pre-computation. + /// The input union type. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown when the input type is not a union type. + /// An array of descriptions of the cases of the given union type. + static member GetUnionCases: unionType:Type * ?allowAccessToPrivateRepresentation : bool -> UnionCaseInfo[] + + + /// Return true if the typ is a representation of an F# record type + /// The type to check. + /// Optional flag that denotes accessibility of the private representation. + /// True if the type check succeeds. + static member IsRecord: typ:Type * ?allowAccessToPrivateRepresentation : bool -> bool + + /// Returns true if the typ is a representation of an F# union type or the runtime type of a value of that type + /// The type to check. + /// Optional flag that denotes accessibility of the private representation. + /// True if the type check succeeds. + static member IsUnion: typ:Type * ?allowAccessToPrivateRepresentation : bool -> bool + + /// Reads all the fields from an F# exception declaration, in declaration order + /// + /// Assumes exceptionType is an exception representation type. If not, ArgumentException is raised. + /// The exception type to read. + /// Optional flag that denotes accessibility of the private representation. + /// Thrown if the given type is not an exception. + /// An array containing the PropertyInfo of each field in the exception. + static member GetExceptionFields: exceptionType:Type * ?allowAccessToPrivateRepresentation : bool -> PropertyInfo[] + + /// Returns true if the typ is a representation of an F# exception declaration + /// The type to check. + /// Optional flag that denotes accessibility of the private representation. + /// True if the type check is an F# exception. + static member IsExceptionRepresentation: exceptionType:Type * ?allowAccessToPrivateRepresentation : bool -> bool + +#if FX_RESHAPED_REFLECTION + +namespace Microsoft.FSharp.Core - /// Returns true if the typ is a representation of an F# exception declaration - /// The type to check. - /// Optional binding flags. - /// True if the type check is an F# exception. - static member IsExceptionRepresentation: exceptionType:Type * ?bindingFlags:BindingFlags -> bool +open System +open System.Reflection + +module internal ReflectionAdapters = + + [] + 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 + + [] + 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 -[] -type DynamicFunction<'T1,'T2> = - inherit FSharpFunc 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 2ec7a32ef0..8237c89306 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/Makefile.in b/src/fsharp/FSharp.Data.TypeProviders/Makefile.in index 9167054e34..44c79bfcda 100644 --- a/src/fsharp/FSharp.Data.TypeProviders/Makefile.in +++ b/src/fsharp/FSharp.Data.TypeProviders/Makefile.in @@ -6,45 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --target:library \ - --define:TPEMIT_INTERNAL_AND_MINIMAL_FOR_TYPE_CONTAINERS - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:System.Xml.dll \ - -r:System.Configuration.dll \ - -r:System.ServiceModel.dll \ - -r:System.Xml.Linq.dll \ - -r:System.Core.dll \ - -r:System.Data.dll - -sources = \ - $(tmpdir)FSData.fs \ - ../../assemblyinfo/assemblyinfo.FSharp.Data.TypeProviders.dll.fs \ - Util.fsi Util.fs \ - TypeProviderEmit.fsi TypeProviderEmit.fs \ - TypeProvidersImpl.fs \ - TypeProviders.fs - -RESOURCES= \ - $(tmpdir)FSData.resources - -$(tmpdir)FSData.fs $(tmpdir)FSData.resources: FSData.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSData.fs $(tmpdir)FSData.resx - resgen $(tmpdir)FSData.resx $(tmpdir)FSData.resources - - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-lib-4 install-lib-4-5 +install: install-lib install-lib-net45 diff --git a/src/fsharp/FSharp.Data.TypeProviders/Util.fsi b/src/fsharp/FSharp.Data.TypeProviders/Util.fsi index 1994d785c5..bc4e1b5ac5 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 0c2a89920c..b33acee8d6 100755 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -1,14 +1,4 @@ - $(MSBuildProjectDirectory)\..\.. diff --git a/src/fsharp/Fsc-proto/Makefile.in b/src/fsharp/Fsc-proto/Makefile.in index 81deb1a169..c58224d526 100644 --- a/src/fsharp/Fsc-proto/Makefile.in +++ b/src/fsharp/Fsc-proto/Makefile.in @@ -5,30 +5,8 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -CONFIG=proto - -FSC=$(bootstrapdir)fsc.exe - -FLAGS += --target:exe - -DEFINES += \ - --define:BUILDING_PROTO \ - --define:BUILDING_WITH_LKG \ - --define:COMPILER \ - --define:NO_STRONG_NAMES - -REFERENCES += \ - -r:$(bootstrapdir)FSharp.Core.dll \ - -r:$(outdir)FSharp.Compiler-proto.dll \ - -r:$(monogacdirXX)/System.Runtime.Remoting.dll \ - -r:$(monogacdirXX)/System.Windows.Forms.dll - -sources = \ - ../fscmain.fs - -do-proto: do-4-0 $(protodir)FSharp.Core.dll - -clean: clean-4-0 +build-proto: $(protodir)FSharp.Core.dll + MONO_ENV_OPTIONS=$(monoopts) xbuild /p:Configuration=Proto include $(topdir)/src/fsharp/targets.make diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index 584460c79d..9c77566d3b 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -1,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False @@ -37,12 +24,13 @@ - assemblyinfo.fsc.exe.fs + Resources/assemblyinfo.fsc.exe.fs - fscmain.fs + Driver/fscmain.fs + Driver/fsc.exe.config PreserveNewest diff --git a/src/fsharp/Fsc/Makefile.in b/src/fsharp/Fsc/Makefile.in index 8497cf04ee..284a18b6c2 100644 --- a/src/fsharp/Fsc/Makefile.in +++ b/src/fsharp/Fsc/Makefile.in @@ -24,11 +24,7 @@ sources = \ include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-bin-4 install-lib-4-5 +install: install-bin diff --git a/src/fsharp/Fsc/fsc.exe.config b/src/fsharp/Fsc/fsc.exe.config index 694b0fff19..cf4b939b67 100644 --- a/src/fsharp/Fsc/fsc.exe.config +++ b/src/fsharp/Fsc/fsc.exe.config @@ -4,22 +4,15 @@ - - - - - + + + + + + + + + diff --git a/src/fsharp/InternalFileSystemUtils.fs b/src/fsharp/InternalFileSystemUtils.fs index 3a4384c018..1f1b8c8b5e 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 65acd27289..cf718bd2ec 100755 --- a/src/fsharp/InternalFileSystemUtils.fsi +++ b/src/fsharp/InternalFileSystemUtils.fsi @@ -12,6 +12,10 @@ namespace Internal.Utilities.FileSystem + [] + type internal File = + static member SafeExists : filename:string -> bool + [] type internal Path = static member IsInvalidDirectory : path:string -> bool diff --git a/src/fsharp/Makefile.in b/src/fsharp/Makefile.in index 68552febc8..e26c401f79 100644 --- a/src/fsharp/Makefile.in +++ b/src/fsharp/Makefile.in @@ -1,19 +1,19 @@ # Make the proto using the bootstrap, then make the final compiler using the proto -# We call MAKE sequentially because we don't want do-final to explicitly depend on do-proto, +# We call MAKE sequentially because we don't want build-final to explicitly depend on build-proto, # as that causes a complete recompilation of both proto and final everytime you touch the # compiler sources. all: - $(MAKE) do-proto - $(MAKE) do-final + $(MAKE) build-proto + $(MAKE) build -do-proto: - $(MAKE) -C FSharp.Build-proto $@ - $(MAKE) -C FSharp.Compiler-proto $@ - $(MAKE) -C Fsc-proto $@ +build-proto: + $(MAKE) -C FSharp.Build-proto Configuration=proto $@ + $(MAKE) -C FSharp.Compiler-proto Configuration=proto $@ + $(MAKE) -C Fsc-proto Configuration=proto $@ -do-final install: - $(MAKE) -C FSharp.Core $@ +build clean install: + $(MAKE) -C FSharp.Core TargetFramework=net40 $@ $(MAKE) -C FSharp.Build $@ $(MAKE) -C FSharp.Compiler $@ $(MAKE) -C Fsc $@ @@ -25,31 +25,21 @@ do-final install: $(MAKE) -C policy.2.0.FSharp.Core $@ $(MAKE) -C policy.4.0.FSharp.Core $@ $(MAKE) -C policy.2.3.FSharp.Core $@ + $(MAKE) -C policy.3.3.FSharp.Core $@ $(MAKE) -C policy.4.3.FSharp.Core $@ - -clean clean-2-0 clean-4-0: - $(MAKE) -C FSharp.Build-proto $@ - $(MAKE) -C FSharp.Compiler-proto $@ - $(MAKE) -C Fsc-proto $@ - $(MAKE) -C FSharp.Core $@ - $(MAKE) -C FSharp.Build $@ - $(MAKE) -C FSharp.Compiler $@ - $(MAKE) -C Fsc $@ - $(MAKE) -C FSharp.Compiler.Interactive.Settings $@ - $(MAKE) -C FSharp.Compiler.Server.Shared $@ - $(MAKE) -C FSharp.Data.TypeProviders $@ - $(MAKE) -C fsi $@ - $(MAKE) -C fsiAnyCpu $@ - $(MAKE) -C policy.2.0.FSharp.Core $@ - $(MAKE) -C policy.4.0.FSharp.Core $@ - $(MAKE) -C policy.2.3.FSharp.Core $@ - $(MAKE) -C policy.4.3.FSharp.Core $@ - -clean-2-1 do-2-1: - $(MAKE) -C FSharp.Core $@ - -install-2-1: do-2-1 - $(MAKE) -C FSharp.Core $@ + $(MAKE) -C policy.2.0.FSharp.Core TargetFramework=net20 $@ + $(MAKE) -C policy.2.3.FSharp.Core TargetFramework=net20 $@ + $(MAKE) -C FSharp.Core TargetFramework=net20 $@ + $(MAKE) -C FSharp.Core TargetFramework=monodroid $@ + $(MAKE) -C FSharp.Core TargetFramework=monotouch $@ + +# Add these to build portable FSharp.Core on Mac +# - Requires Mono 3.2.4 or greater +# - Requires $(MSBuildExtensionsPath32)\Microsoft\Portable\v4.0\Microsoft.Portable.Common.targets +# - Requires PCL assemblies + +#$(MAKE) -C FSharp.Core TargetFramework=portable-net45+sl5+win8 $@ +#$(MAKE) -C FSharp.Core TargetFramework=portable-net4+sl4+wp71+win8 $@ diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 8f2690a693..61cd758eae 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 = 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/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index ca43b8f4b3..4cc5c82249 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -15,7 +15,7 @@ /// Anything to do with special names of identifiers and other lexical rules -module internal Microsoft.FSharp.Compiler.PrettyNaming +module (*internal*) Microsoft.FSharp.Compiler.PrettyNaming open Internal.Utilities open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal diff --git a/src/fsharp/ReferenceResolution.fs b/src/fsharp/ReferenceResolution.fs index 88fd4c92a9..639749a429 100644 --- a/src/fsharp/ReferenceResolution.fs +++ b/src/fsharp/ReferenceResolution.fs @@ -1,4 +1,4 @@ -namespace Viz +namespace Viz /// This type exists to have a concrete 'Target' type for a DebuggerVisualizerAttribute. /// Ideally it would be out in its own assembly, but then the compiler would need to take a dependency on that assembly, so instead we @@ -27,6 +27,8 @@ module internal MSBuildResolver = type ResolutionEnvironment = CompileTimeLike | RuntimeLike | DesigntimeLike #if SILVERLIGHT + let HighestInstalledNetFrameworkVersionMajorMinor() = + 4,"v5.0" #else open System open System.Reflection @@ -64,17 +66,107 @@ 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. GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch + [] + let private Net10 = "v1.0" + [] + let private Net11 = "v1.1" + [] + let private Net20 = "v2.0" + [] + let private Net30 = "v3.0" + [] + let private Net35 = "v3.5" + [] + let private Net40 = "v4.0" + [] + let private Net45 = "v4.5" + [] + let private Net451 = "v4.5.1" + + let SupportedNetFrameworkVersions = set [ Net20; Net30; Net35; Net40; Net45; Net451; (*SL only*) "v5.0" ] + +#if CROSS_PLATFORM_COMPILER + // Mono doesn't have GetPathToDotNetFramework. In this case we simply don't search this extra directory. + // When the x-plat compiler is run on Mono this is ok since implementation assembly folder is the same as the target framework folder. + // When the x-plat compiler is run on Windows/.NET this will curently cause slightly divergent behaviour. + let GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch _v = [] +#else + let GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch v = + 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] + | _ -> [] +#endif + +#if CROSS_PLATFORM_COMPILER + // GetPathToDotNetFrameworkReferenceAssemblies is not available on Mono. + // We currently use the old values that the F# 2.0 compiler assumed. + // When the x-plat compiler is run on Mono this is ok since the asemblies are all in the framework folder + // When the x-plat compiler is run on Windows/.NET this will curently cause slightly divergent behaviour this directory + // may not be the same as the Microsoft compiler in all cases. + let DeriveTargetFrameworkDirectoriesFor40Plus(version) = + match version with + | Net40 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.0"]) + | Net45 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.5"]) + | Net451 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.5"]) + | _ -> [] +#else + 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 + | Net45 -> Some TargetDotNetFrameworkVersion.Version45 + | Net451 -> Some TargetDotNetFrameworkVersion.Version451 + | _ -> 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 -> [] +#endif + + /// 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 CROSS_PLATFORM_COMPILER + // Mono doesn't have GetPathToDotNetFramework + 4, Net40 +#else + 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. +#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 @@ -82,14 +174,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))) @@ -188,9 +278,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 @@ -252,7 +341,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}"] @ + GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch 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 58aea2baf2..2110873397 100644 --- 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 + 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 481ece0a5a..4bdff51c42 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() + 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() 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 ) = - 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, box vsTargetFrameworkAssemblies40, false) sp.AddService(typeof, box vsFrameworkMultiTargeting, false) sp, ccn + let MakeMockServiceProviderAndConfigChangeNotifier45() = + let sp, ccn = MakeMockServiceProviderAndConfigChangeNotifierNoTargetFrameworkAssembliesService() + sp.AddService(typeof, box vsTargetFrameworkAssemblies45, false) + sp.AddService(typeof, 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 f5f8ae3522..1a52df4f22 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -10,7 +10,7 @@ // You must not remove this notice, or any other, from this software. //---------------------------------------------------------------------------- -module internal Microsoft.FSharp.Compiler.Ast +module (*internal*) Microsoft.FSharp.Compiler.Ast open System.Collections.Generic open Internal.Utilities @@ -606,12 +606,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 @@ -879,6 +879,14 @@ and mkRange m.FileName start e | SynExpr.Ident id -> id.idRange + +and + [] + 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 [] SynSimplePat = @@ -924,6 +932,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 [] SynPat = @@ -934,7 +945,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 @@ -1532,15 +1543,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()' @@ -1588,7 +1600,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. @@ -1675,7 +1687,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 @@ -1685,11 +1698,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 @@ -1697,9 +1711,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 //------------------------------------------------------------------------ @@ -1725,20 +1740,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 @@ -1940,12 +1968,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 @@ -2071,29 +2099,29 @@ type LexBuffer<'Char> with member lexbuf.LexemeRange = mkSynRange lexbuf.StartPos lexbuf.EndPos /// Get the range corresponding to the result of a grammar rule while it is being reduced -let lhs (parseState: IParseState) = +let internal lhs (parseState: IParseState) = let p1 = parseState.ResultStartPosition let p2 = parseState.ResultEndPosition mkSynRange p1 p2 /// Get the range covering two of the r.h.s. symbols of a grammar rule while it is being reduced -let rhs2 (parseState: IParseState) i j = +let internal rhs2 (parseState: IParseState) i j = let p1 = parseState.InputStartPosition i let p2 = parseState.InputEndPosition j mkSynRange p1 p2 /// Get the range corresponding to one of the r.h.s. symbols of a grammar rule while it is being reduced -let rhs parseState i = rhs2 parseState i i +let internal rhs parseState i = rhs2 parseState i i type IParseState with - member x.GetSynArgNameGenerator() = + member internal x.GetSynArgNameGenerator() = let key = "SynArgNameGenerator" let bls = x.LexBuffer.BufferLocalStore if not (bls.ContainsKey key) then bls.[key] <- box (SynArgNameGenerator()) bls.[key] :?> SynArgNameGenerator - member x.ResetSynArgNameGenerator() = x.GetSynArgNameGenerator().Reset() + member internal x.ResetSynArgNameGenerator() = x.GetSynArgNameGenerator().Reset() /// XmlDoc F# lexer/parser state, held in the BufferLocalStore for the lexer. @@ -2250,10 +2278,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 bb359e231d..3c28fbaadf 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 @@ -1395,9 +1395,10 @@ let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,err | 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) - | ErrorStyle.GccErrors -> 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) + | ErrorStyle.GccErrors -> Printf.bprintf os "%s:%d:%d: " (file.Replace('/',System.IO.Path.DirectorySeparatorChar)) m.StartLine (m.StartColumn + 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: @@ -1405,7 +1406,6 @@ let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,err 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) - match err.Exception with | ReportedError _ -> dprintf "Unexpected ReportedError" (* this should actually never happen *) @@ -1451,7 +1451,6 @@ let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,err ) #endif | x -> report x - let OutputErrorOrWarningContext prefix fileLineFn os err = match RangeOfError err with | None -> () @@ -1472,9 +1471,23 @@ let OutputErrorOrWarningContext prefix fileLineFn os err = //---------------------------------------------------------------------------- let GetFSharpCoreLibraryName () = "FSharp.Core" + #if SILVERLIGHT +let GetFSharpCoreReferenceUsedByCompiler(useMonoResolution) = GetFSharpCoreLibraryName() let GetFsiLibraryName () = "FSharp.Compiler.Silverlight" #else +type internal TypeInThisAssembly = class end +let GetFSharpCoreReferenceUsedByCompiler(useMonoResolution) = + // On Mono, there is no good reference resolution + if useMonoResolution then + GetFSharpCoreLibraryName()+".dll" + else + let fsCoreName = GetFSharpCoreLibraryName() + typeof.Assembly.GetReferencedAssemblies() + |> Array.pick (fun name -> + if name.Name = fsCoreName then Some(name.ToString()) + else None + ) let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings" #endif @@ -1488,10 +1501,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" @@ -1519,10 +1532,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" @@ -1530,12 +1543,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" @@ -1543,13 +1555,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"] @@ -1563,39 +1576,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 //---------------------------------------------------------------------------- @@ -1694,8 +1684,140 @@ type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * Assem type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted 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 list; +#endif + FSharpOptimizationData : Microsoft.FSharp.Control.Lazy> } + +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; @@ -1834,7 +1956,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 } @@ -1845,7 +1975,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; @@ -1960,6 +2090,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 @@ -1974,7 +2105,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) @@ -1994,17 +2129,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 @@ -2099,13 +2239,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, true) + | 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 @@ -2133,7 +2275,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 @@ -2161,12 +2303,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 //-------------------------------------------------------------------------- @@ -2201,22 +2343,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(data.useMonoResolution)), 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 @@ -2239,7 +2388,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, @@ -2247,18 +2397,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 @@ -2283,7 +2433,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)) @@ -2297,9 +2447,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 @@ -2417,6 +2567,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) @@ -2528,7 +2683,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 +2890,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 +2955,8 @@ 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.ErrorOrWarningNumbers = errorLogger.ErrorOrWarningNumbers let GetErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) = (ErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) :> ErrorLogger) @@ -2969,7 +3125,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 +3268,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 +3412,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 list; -#endif - FSharpOptimizationData : Microsoft.FSharp.Control.Lazy> } - -type AvailableImportedAssembly = - | ResolvedImportedAssembly of ImportedAssembly - | UnresolvedImportedAssembly of string - let availableToOptionalCcu = function | ResolvedCcu(ccu) -> Some(ccu) | UnresolvedCcu _ -> None @@ -3456,8 +3586,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 +3615,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 +3681,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 +3821,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 +3936,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 +4051,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 +4063,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 +4120,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 @@ -4117,25 +4259,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 generateDebugBrowsableData = - ccuHasType sysCcu.FSharpViewOfMetadata ["System";"Diagnostics"] "DebuggerBrowsableAttribute" && - ccuHasType sysCcu.FSharpViewOfMetadata ["System";"Diagnostics"] "DebuggerBrowsableState" - - let ilGlobals = mkILGlobals sysCcu.FSharpViewOfMetadata.ILScopeRef (Some tcConfig.mscorlibAssemblyName) (tcConfig.noDebugData, generateDebugBrowsableData) + 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()) @@ -4182,7 +4324,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 -> () } @@ -4195,14 +4337,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 @@ -4751,7 +4893,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 fdee3cf359..f93cd92543 100755 --- a/src/fsharp/build.fsi +++ b/src/fsharp/build.fsi @@ -87,13 +87,13 @@ 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 - //---------------------------------------------------------------------------- // Options and configuration //-------------------------------------------------------------------------- @@ -139,6 +139,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 @@ -186,7 +192,7 @@ type VersionFlag = type TcConfigBuilder = - { mutable mscorlibAssemblyName: string; + { mutable primaryAssembly : PrimaryAssembly; mutable autoResolveOpenDirectivesToDlls: bool; mutable noFeedback: bool; mutable stackReserveSize: int32 option; @@ -307,8 +313,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 @@ -324,7 +341,7 @@ type TcConfigBuilder = [] // Immutable TcConfig type TcConfig = - member mscorlibAssemblyName: string; + member primaryAssembly: PrimaryAssembly member autoResolveOpenDirectivesToDlls: bool; member noFeedback: bool; member stackReserveSize: int32 option; @@ -346,7 +363,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; @@ -455,6 +471,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 @@ -630,8 +651,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 b50e186aa5..286d7d3b62 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' 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 78435419f5..443d7bf588 100755 --- a/src/fsharp/creflect.fs +++ b/src/fsharp/creflect.fs @@ -51,7 +51,8 @@ type cenv = typeSplices: ResizeArray ; // Accumulate the expression splices into here exprSplices: ResizeArray - 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 4dc71f0cab..6a88855345 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(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) // 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 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, 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 list) + (calledMethGroup:CalledMeth 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 b49f27af77..dd199cd2e4 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 val CanonicalizeRelevantMemberConstraints : ConstraintSolverEnv -> int -> OptionalTrace -> Typars -> OperationResult val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> bool -> int * int -> AccessorDomain -> Typrelns.CalledMeth list -> bool -> TType option -> Typrelns.CalledMeth option * OperationResult -val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> Typrelns.CalledMeth list -> TType -> OperationResult +val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> Typrelns.CalledMeth list -> TType -> OperationResult 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 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 a156f4a7c1..2462367d38 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 629062d866..fd7879f8d1 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 18721a66b8..d8d3105822 100755 --- a/src/fsharp/est.fs +++ b/src/fsharp/est.fs @@ -39,7 +39,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 @@ -257,19 +257,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 @@ -671,6 +669,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 50a3e0c71d..451c6e657f 100755 --- a/src/fsharp/est.fsi +++ b/src/fsharp/est.fsi @@ -34,7 +34,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 [] @@ -232,6 +232,7 @@ module internal ExtensionTyping = member IsOut : bool member IsOptional : bool member RawDefaultValue : obj + member HasDefaultValue : bool interface IProvidedCustomAttributeProvider and [] diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index e52bc1877e..956d90b8af 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,26 @@ open Microsoft.FSharp.Compiler.ExtensionTyping // Reporting - warnings, errors //---------------------------------------------------------------------------- -/// Create an error logger that counts and prints errors +/// Create an error logger that counts and prints errors let ErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exiter) = let errors = ref 0 + let errorOrWarnings = ref [] { new ErrorLogger("ErrorLoggerThatQuitsAfterMaxErrors") with member x.ErrorSinkImpl(err) = if !errors >= tcConfigB.maxErrors then DoWithErrorColor true (fun () -> Printf.eprintfn "%s" (FSComp.SR.fscTooManyErrors())) +#if SQM_SUPPORT + SqmLoggerWithConfigBuilder tcConfigB !errorOrWarnings +#endif exiter.Exit 1 DoWithErrorColor false (fun () -> (writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,false)) err; stderr.WriteLine())); incr errors + errorOrWarnings := (GetErrorNumber err) :: !errorOrWarnings match err.Exception with | InternalError _ @@ -105,7 +112,9 @@ let ErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exit 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; + errorOrWarnings := (GetErrorNumber err) :: !errorOrWarnings stderr.WriteLine()) + override x.ErrorOrWarningNumbers = !errorOrWarnings member x.ErrorCount = !errors } let ErrorLoggerInitial (tcConfigB:TcConfigBuilder, exiter : Exiter) = ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter) @@ -120,12 +129,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.ErrorOrWarningNumbers +#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) = 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) = @@ -144,7 +158,8 @@ type DelayAndForwardErrorLogger(exiter : Exiter) = member x.ForwardDelayedErrorsAndWarnings(tcConfigB:TcConfigBuilder) = let errorLogger = ErrorLoggerInitial(tcConfigB, exiter) x.ForwardDelayedErrorsAndWarnings(errorLogger) - member x.FullErrorCount = !errors + member x.FullErrorCount = !errors + override x.ErrorOrWarningNumbers = delayed |> Seq.map (fun (err,_) -> GetErrorNumber err) |> Seq.toList /// Check for .fsx and, if present, compute the load closure for of #loaded files. let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexResourceManager) = @@ -173,7 +188,7 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexR let closure = LoadClosure.ComputeClosureOfSourceFiles(tcConfig,[filename,rangeStartup],CodeContext.Compilation,lexResourceManager=lexResourceManager,useDefaultScriptingReferences=false) // Record the references from the analysis of the script. The full resolutions are recorded as the corresponding #I paths used to resolve them // are local to the scripts and not added to the tcConfigB (they are added to localized clones of the tcConfigB). - let references = closure.References |> List.map snd |> List.concat |> List.filter (fun r->r.originalReference.Range<>range0) + let references = closure.References |> List.map snd |> List.concat |> List.filter (fun r->r.originalReference.Range<>range0 && r.originalReference.Range<>rangeStartup) references |> List.iter (fun r-> tcConfigB.AddReferencedAssemblyByPath(r.originalReference.Range,r.resolvedPath)) closure.NoWarns |> List.map(fun (n,ms)->ms|>List.map(fun m->m,n)) |> List.concat |> List.iter tcConfigB.TurnWarningOff closure.SourceFiles |> List.map fst |> List.iter AddIfNotPresent @@ -187,8 +202,12 @@ 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.ErrorOrWarningNumbers +#endif + exiter.Exit 1 // 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. @@ -202,10 +221,10 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : setProcessThreadLocals : TcConfigBuilder -> unit, displayBannerIfNeeded : TcConfigBuilder -> unit, optimizeForMemory : bool, - exiter : Exiter, - createErrorLogger: (TcConfigBuilder -> ErrorLogger)) + exiter : Exiter) : 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) @@ -264,9 +283,13 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : with e -> errorRecovery e rangeStartup +#if SQM_SUPPORT + SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers +#endif delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB) exiter.Exit 1 - + + tcConfigB.sqmNumOfSourceFiles <- sourceFiles.Length tcConfigB.conditionalCompilationDefines <- "COMPILED" :: tcConfigB.conditionalCompilationDefines displayBannerIfNeeded tcConfigB @@ -276,11 +299,17 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : tcConfigB.DecideNames sourceFiles with e -> errorRecovery e rangeStartup +#if SQM_SUPPORT + SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers +#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.ErrorOrWarningNumbers +#endif delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB) exiter.Exit 1 @@ -289,12 +318,13 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : try TcConfig.Create(tcConfigB,validate=false) with e -> +#if SQM_SUPPORT + SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers +#endif delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB) exiter.Exit 1 - - // Create the real errorLogger now we know the --vserrors flag - let errorLogger = createErrorLogger tcConfigB + let errorLogger = ErrorLoggerThatQuitsAfterMaxErrors(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) @@ -304,7 +334,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 = @@ -344,10 +374,14 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : ) with e -> errorRecoveryNoRange e +#if SQM_SUPPORT + SqmLoggerWithConfig tcConfig errorLogger.ErrorOrWarningNumbers +#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") @@ -361,7 +395,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI : tcGlobals,tcImports if not tcConfig.continueAfterParseFailure then - abortOnError(errorLogger, exiter) + abortOnError(errorLogger, tcConfig, exiter) if tcConfig.importAllReferencesOnly then exiter.Exit 0 @@ -375,7 +409,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) @@ -388,7 +422,7 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB defaultFSharpBinariesDir : string, directoryBuildingFrom : string, exiter : Exiter) = - let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)) + let tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger = getTcImportsFromCommandLine(Some displayPSTypeProviderSecurityDialogBlockingUI, argv, defaultFSharpBinariesDir, directoryBuildingFrom, None, (fun _ -> ()), (fun tcConfigB -> @@ -402,8 +436,8 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB tcConfigB.framework<-false ), true, // optimizeForMemory - want small memory footprint in VS - exiter, - createErrorLogger) + exiter) + // 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) @@ -567,6 +601,7 @@ let getModuleFileName() = let defaultFSharpBinariesDir = Filename.directoryName (getModuleFileName()) #endif + let outpath outfile extn = String.concat "." (["out"; Filename.chopExtension (Filename.fileNameOfPath outfile); extn]) @@ -583,7 +618,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..."; @@ -604,7 +639,10 @@ let EncodeInterfaceData(tcConfig:TcConfig,tcGlobals,exportRemapping,generatedCcu else [],[] with e -> - errorRecoveryNoRange e; + errorRecoveryNoRange e +#if SQM_SUPPORT + SqmLoggerWithConfig tcConfig _errorLogger.ErrorOrWarningNumbers +#endif exiter.Exit 1 @@ -955,12 +993,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 = @@ -1129,13 +1167,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 @@ -1154,6 +1191,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 @@ -1201,10 +1239,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) ] @@ -1285,8 +1323,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,false) ; + 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 @@ -1307,7 +1345,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 = @@ -1608,11 +1646,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 @@ -1641,7 +1685,7 @@ module FileWriter = try ILBinaryWriter.WriteILBinary outfile - { mscorlib=ilGlobals.mscorlibScopeRef; + { ilg = ilGlobals pdbfile=pdbfile; emitTailcalls= tcConfig.emitTailcalls; showTimes=tcConfig.showTimes; @@ -1671,7 +1715,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.ErrorOrWarningNumbers +#endif exiter.Exit 1 let WriteStatsFile (tcConfig:TcConfig,outfile) = @@ -1739,7 +1786,7 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig) tcGlobals topAttrs = [] type Args<'a> = Args of 'a -let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) = +let main1(argv,bannerAlreadyPrinted,exiter:Exiter) = // See Bug 735819 let lcidFromCodePage = @@ -1780,8 +1827,7 @@ let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) = Microsoft.FSharp.Compiler.Fscopts.DisplayBannerText tcConfigB ), false, // optimizeForMemory - fsc.exe can use as much memory as it likes to try to compile as fast as possible - exiter, - createErrorLogger + exiter ) if tcConfig.typeCheckOnly then exiter.Exit 0 @@ -1789,7 +1835,7 @@ let main1(argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) = 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 @@ -1845,7 +1891,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"; @@ -1858,10 +1904,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)) @@ -1932,7 +1978,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) @@ -1945,7 +1991,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) @@ -1953,15 +1999,21 @@ 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.ErrorOrWarningNumbers +#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 pdbfile = pdbfile |> Option.map Path.GetFullPath match dynamicAssemblyCreator with | None -> FileWriter.EmitIL (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo,exiter) | Some da -> da (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo); @@ -1969,23 +2021,28 @@ 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.ErrorOrWarningNumbers #endif +#endif + ReportTime tcConfig "Exiting" -let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter,createErrorLogger) = +let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter) = // Don's note: "GC of intermediate data is really, really important here" - main1 (argv,bannerAlreadyPrinted,exiter,createErrorLogger) + main1 (argv,bannerAlreadyPrinted,exiter) |> main2 |> main2b |> main2c |> main3 |> main4 -#endif //NO_COMPILER_BACKEND +#endif // NO_COMPILER_BACKEND diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi index e450e19cec..ed04f128e8 100755 --- a/src/fsharp/fsc.fsi +++ b/src/fsharp/fsc.fsi @@ -9,6 +9,6 @@ val internal runFromCommandLineToImportingAssemblies : (string -> unit) * string #if NO_COMPILER_BACKEND #else /// fsc.exe calls this -val mainCompile : argv : string[] * bannerAlreadyPrinted : bool * exiter : Exiter * createErrorLogger:(TcConfigBuilder -> ErrorLogger) -> unit +val mainCompile : argv : string[] * bannerAlreadyPrinted : bool * exiter : Exiter -> unit -#endif \ No newline at end of file +#endif diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs index bd472e84db..b542174922 100755 --- a/src/fsharp/fscmain.fs +++ b/src/fsharp/fscmain.fs @@ -17,7 +17,7 @@ open System.IO open System.Text open System.Reflection open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.IL // runningOnMono open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Driver @@ -29,6 +29,9 @@ open System.Runtime.CompilerServices type TypeInThisAssembly() = member x.Dummy = 1 +[] +do () + /// Collect the output from the stdout and stderr streams, character by character, /// recording the console color used along the way. type OutputCollector() = @@ -39,9 +42,6 @@ type OutputCollector() = lock output (fun () -> output.Add (isOut, (try Some System.Console.ForegroundColor with _ -> None) ,c)) member x.Encoding = Encoding.UTF8 } - do ignore outWriter - do System.Console.SetOut (outWriter true) - do System.Console.SetError (outWriter false) member x.GetTextAndClear() = lock output (fun () -> let res = output.ToArray() in output.Clear(); res) /// Implement the optional resident compilation service @@ -54,7 +54,7 @@ module FSharpResidentCompiler = open System.Runtime.Remoting.Lifetime /// The compilation server, which runs in the server process. Accessed by clients using .NET remoting. - type FSharpCompilationServer() = + type FSharpCompilationServer(exiter:Exiter) = inherit MarshalByRefObject() static let onWindows = @@ -83,10 +83,7 @@ module FSharpResidentCompiler = let exitCode = try Environment.CurrentDirectory <- pwd - // Install the right exiter so we can catch "StopProcessing" without exiting the server - let exiter = { new Exiter with member x.Exit n = raise StopProcessing } - 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 -> @@ -133,10 +130,10 @@ module FSharpResidentCompiler = lease.RenewOnCallTime <- TimeSpan.FromDays(1.0); box lease - static member RunServer() = + static member RunServer(exiter:Exiter) = progress := !progress || condition "FSHARP_SERVER_PROGRESS" if !progress then printfn "server: initializing server object" - let server = new FSharpCompilationServer() + let server = new FSharpCompilationServer(exiter) let chan = new Ipc.IpcChannel(channelName) ChannelServices.RegisterChannel(chan,false); RemotingServices.Marshal(server,serverName) |> ignore @@ -273,50 +270,52 @@ module FSharpResidentCompiler = | None -> None -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.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 - FSharpResidentCompiler.FSharpCompilationServer.RunServer() +let runMain 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 fscServerExe = typeof.Assembly.Location + let exitCodeOpt = FSharpResidentCompiler.FSharpCompilationServer.TryCompileUsingServer (fscServerExe, argv) + match exitCodeOpt with + | Some exitCode -> exitCode + | None -> + mainCompile (argv, true, QuitProcessExiter) 0 - - else - let exiter = QuitProcessExiter - let createErrorLogger = (fun tcConfigB -> ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)) - mainCompile (argv, false, QuitProcessExiter, createErrorLogger) - 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 -[] -do () [] 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); + runMain(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 74852b068f..af2cd79ffe 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,10 +459,11 @@ 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("gccerrors", tagNone, OptionUnit (fun () -> tcConfigB.errorStyle <- ErrorStyle.GccErrors), 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) @@ -481,7 +490,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); @@ -914,7 +923,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 @@ -1010,6 +1019,7 @@ let DoWithErrorColor isWarn f = ignoreFailureOnMono1_1_16 (fun () -> Console.ForegroundColor <- c) #endif + diff --git a/src/fsharp/fsi/FSIstrings.txt b/src/fsharp/fsi/FSIstrings.txt index 6cedefd063..d9a03587dd 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,10 +41,11 @@ 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" fsiUnexpectedThreadAbortException,"- Unexpected ThreadAbortException (Ctrl-C) during event handling: Trying to restart..." fsiFailedToResolveAssembly,"Failed to resolve assembly '%s'" fsiBindingSessionTo,"Binding session to '%s'..." -fsiProductName,"F# Interactive for F# 3.0 %s" +fsiProductName,"F# Interactive for F# 3.1 %s" diff --git a/src/fsharp/fsi/Fsi.fsproj b/src/fsharp/fsi/Fsi.fsproj index 563e4c95c3..df9d9c8565 100644 --- a/src/fsharp/fsi/Fsi.fsproj +++ b/src/fsharp/fsi/Fsi.fsproj @@ -1,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False @@ -41,19 +28,19 @@ FSIstrings.txt - assemblyinfo.fsi.exe.fs + Utilities/assemblyinfo.fsi.exe.fs - InternalCollections.fsi + Utilities/InternalCollections.fsi - InternalCollections.fs + Utilities/InternalCollections.fs - console.fs + Console/console.fs - fsi.fs + InteractiveSession/fsi.fs fsimain.fs diff --git a/src/fsharp/fsi/Makefile.in b/src/fsharp/fsi/Makefile.in index 99d9b7b6f0..6b28d3e158 100644 --- a/src/fsharp/fsi/Makefile.in +++ b/src/fsharp/fsi/Makefile.in @@ -6,43 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --target:exe - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:$(outdir)FSharp.Compiler.dll \ - -r:$(outdir)FSharp.Compiler.Interactive.Settings.dll \ - -r:$(outdir)FSharp.Compiler.Server.Shared.dll \ - -r:$(monogacdirXX)/System.Windows.Forms.dll \ - -r:$(monogacdirXX)/System.Drawing.dll - -sources = \ - $(tmpdir)FSIstrings.fs \ - ../../assemblyinfo/assemblyinfo.fsi.exe.fs \ - ../InternalCollections.fsi \ - ../InternalCollections.fs \ - console.fs \ - fsi.fs \ - fsimain.fs - -RESOURCES = \ - $(tmpdir)FSIstrings.resources - -$(tmpdir)FSIstrings.fs $(tmpdir)FSIstrings.resources: FSIstrings.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSIstrings.fs $(tmpdir)FSIstrings.resx - resgen $(tmpdir)FSIstrings.resx $(tmpdir)FSIstrings.resources - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-bin-4 install-lib-4-5 +install: install-bin diff --git a/src/fsharp/fsi/console.fs b/src/fsharp/fsi/console.fs index fb530f3c30..3622833542 100755 --- a/src/fsharp/fsi/console.fs +++ b/src/fsharp/fsi/console.fs @@ -444,11 +444,7 @@ type internal ReadLineConsole() = change() // Control-d | (ConsoleModifiers.Control, '\004') -> - if (input.Length = 0) then - raise <| new System.IO.EndOfStreamException() - else - delete (); - change() + exit 0 //quit | _ -> // Note: If KeyChar=0, the not a proper char, e.g. it could be part of a multi key-press character, // e.g. e-acute is ' and e with the French (Belgium) IME and US Intl KB. diff --git a/src/fsharp/fsi/fsi.exe.config b/src/fsharp/fsi/fsi.exe.config index 694b0fff19..cf4b939b67 100755 --- a/src/fsharp/fsi/fsi.exe.config +++ b/src/fsharp/fsi/fsi.exe.config @@ -4,22 +4,15 @@ - - - - - + + + + + + + + + diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs old mode 100644 new mode 100755 index 82fee53e63..dea1f6ad96 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -84,7 +84,21 @@ open System.Runtime.CompilerServices [] do () #endif + module internal 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>.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) @@ -130,15 +144,12 @@ type internal 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 internal FsiValuePrinterMode = | PrintExpr @@ -239,17 +250,14 @@ type internal FsiValuePrinter(ilGlobals, generateDebugInfo, resolvePath, outWrit // This will be more significant when we print values other then 'it' // try - let ass = typeof.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 + 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 + anyToLayoutCall.AnyToLayout(opts, x) with | :? ThreadAbortException -> Layout.wordL "" | e -> @@ -558,6 +566,7 @@ type internal FsiCommandLineOptions(argv: string[], tcConfigB, fsiConsoleOutput: (* 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())) ]); ] @@ -1189,7 +1198,7 @@ type internal 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 @@ -1495,7 +1504,7 @@ module internal MagicAssemblyResolution = | None -> #endif - // 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) @@ -1712,7 +1721,10 @@ type internal FsiInteractionProcessor | 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),_) -> @@ -2448,12 +2460,66 @@ type FsiEvaluationSession (argv:string[], inReader:TextReader, outWriter:TextWri 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() ) @@ -2474,7 +2540,7 @@ type FsiEvaluationSession (argv:string[], inReader:TextReader, outWriter:TextWri // 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 @@ -2484,7 +2550,7 @@ type FsiEvaluationSession (argv:string[], inReader:TextReader, outWriter:TextWri () // 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 @@ -2517,9 +2583,35 @@ type FsiEvaluationSession (argv:string[], inReader:TextReader, outWriter:TextWri // 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 /// Defines a read-only input stream used to feed content to the hosted F# Interactive dynamic compiler. [] @@ -2541,7 +2633,6 @@ type CompilerInputStream() = let ret = Array.zeroCreate lengthToRead for i in 0 .. lengthToRead - 1 do ret.[i] <- readQueue.Dequeue() - Some ret else None) @@ -2611,3 +2702,5 @@ type CompilerOutputStream() = System.Text.Encoding.UTF8.GetString(bytes, 0, n) else "") + +#endif // SILVERLIGHT diff --git a/src/fsharp/fsi/fsimain.fs b/src/fsharp/fsi/fsimain.fs index 010da785d2..7cf6034ad8 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 [] [] -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/fsiAnyCpu/FsiAnyCPU.fsproj b/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj index ce1b64f0d8..e5699c53e0 100644 --- a/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj +++ b/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj @@ -1,20 +1,7 @@ - $(MSBuildProjectDirectory)\..\.. - 10.0.0 - 2.0 - False diff --git a/src/fsharp/fsiAnyCpu/Makefile.in b/src/fsharp/fsiAnyCpu/Makefile.in index 943cb8b49d..510fa953ec 100644 --- a/src/fsharp/fsiAnyCpu/Makefile.in +++ b/src/fsharp/fsiAnyCpu/Makefile.in @@ -6,44 +6,9 @@ srcdir := @abs_srcdir@/ include @abs_top_builddir@/config.make -FSC=$(protodir)fsc-proto.exe - -FLAGS += \ - $(SIGN_FLAGS) \ - --platform:anycpu \ - --target:exe - -REFERENCES += \ - -r:$(outdir)FSharp.Core.dll \ - -r:$(outdir)FSharp.Compiler.dll \ - -r:$(outdir)FSharp.Compiler.Interactive.Settings.dll \ - -r:$(outdir)FSharp.Compiler.Server.Shared.dll \ - -r:$(monogacdirXX)/System.Windows.Forms.dll \ - -r:$(monogacdirXX)/System.Drawing.dll - -sources = \ - $(tmpdir)FSIstrings.fs \ - ../../assemblyinfo/assemblyinfo.fsi.exe.fs \ - ../InternalCollections.fsi \ - ../InternalCollections.fs \ - ../fsi/console.fs \ - ../fsi/fsi.fs \ - ../fsi/fsimain.fs - -RESOURCES = \ - $(tmpdir)FSIstrings.resources - -$(tmpdir)FSIstrings.fs $(tmpdir)FSIstrings.resources: ../fsi/FSIstrings.txt - mono $(MONO_OPTIONS) $(FSSRGEN) $< $(tmpdir)FSIstrings.fs $(tmpdir)FSIstrings.resx - resgen $(tmpdir)FSIstrings.resx $(tmpdir)FSIstrings.resources - include $(topdir)/src/fsharp/targets.make -do-final: do-4-0 - -clean: clean-4-0 - -install: install-bin-4 install-lib-4-5 +install: install-bin diff --git a/src/fsharp/fsiAnyCpu/fsiAnyCPU.exe.config b/src/fsharp/fsiAnyCpu/fsiAnyCPU.exe.config index 694b0fff19..cf4b939b67 100755 --- a/src/fsharp/fsiAnyCpu/fsiAnyCPU.exe.config +++ b/src/fsharp/fsiAnyCpu/fsiAnyCPU.exe.config @@ -4,22 +4,15 @@ - - - - - + + + + + + + + + diff --git a/src/fsharp/ilxgen.fs b/src/fsharp/ilxgen.fs index 52a2108360..3b380bcdc9 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,9 +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 = - if cenv.g.ilg.generateDebugBrowsableData then mkILCustomAttrs [ mkDebuggerBrowsableNeverAttribute cenv.g.ilg ] - else emptyILCustomAttrs } + 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); @@ -1720,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) -> @@ -2530,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 @@ -2565,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) @@ -4182,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 @@ -4765,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 @@ -4784,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") @@ -4806,14 +4808,10 @@ and GenBindAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) = let ilFieldDef = { ilFieldDef with - CustomAttrs = - if cenv.g.ilg.generateDebugBrowsableData then - mkILCustomAttrs (ilAttribs @ [ mkDebuggerBrowsableNeverAttribute cenv.g.ilg ]) - else - mkILCustomAttrs ilAttribs } + CustomAttrs = mkILCustomAttrs (ilAttribs @ [ cenv.g.ilg.mkDebuggerBrowsableNeverAttribute() ]) } + [ (fspec.EnclosingTypeRef, ilFieldDef) ] - let ilTypeRefForProperty = ilTyForProperty.TypeRef for (tref,ilFieldDef) in ilFieldDefs do @@ -5236,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 @@ -5314,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 @@ -5441,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; @@ -5710,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' calls + // Detect 'typeof' calls | TypeOfExpr g ty, _ -> ILAttribElem.Type (Some (GenType amap x.Range g eenv.tyenv ty)) // Detect 'typedefof' 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 @@ -6246,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 @@ -6265,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 = @@ -6342,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 @@ -6359,8 +6367,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let extraAttribs = match tyconRepr with - | TRecdRepr _ when not useGenuineField && cenv.g.ilg.generateDebugBrowsableData -> - [ 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 @@ -6751,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 = @@ -6801,12 +6817,7 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) = mkILGenericClass (ilTypeName,access,[],cenv.g.ilg.typ_Exception, interfaces, -#if BE_SECURITY_TRANSPARENT - (ignore(getObjectDataMethodForSerialization); - mkILMethods ([ilCtorDef] @ ilMethodDefsForComparison @ ilCtorDefNoArgs @ [ ilCtorDefForSerialziation ] @ ilMethodDefsForProperties)), -#else - mkILMethods ([ilCtorDef] @ ilMethodDefsForComparison @ ilCtorDefNoArgs @ [ getObjectDataMethodForSerialization; ilCtorDefForSerialziation ] @ ilMethodDefsForProperties), -#endif + mkILMethods ([ilCtorDef] @ ilMethodDefsForComparison @ ilCtorDefNoArgs @ serializationRelatedMembers @ ilMethodDefsForProperties), mkILFields ilFieldDefs, emptyILTypeDefs, mkILProperties ilPropertyDefs, @@ -6829,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(); @@ -7029,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() diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index f3c3deb775..331bb6a61c 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) = @@ -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 40d4c410e9..204eaf7815 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 -> CcuThunk -val internal ImportILAssemblyTypeForwarders : (unit -> ImportMap) * range * ILExportedTypesAndForwarders -> Lazy> +val internal ImportILAssemblyTypeForwarders : (unit -> ImportMap) * range * ILExportedTypesAndForwarders -> Map<(string array * string), Lazy> diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 3e58111c26..b8465ac3a1 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. -[] -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) = + let returnType = + if mi.PUntaint((fun mi -> mi.IsConstructor),m) then + mi.PApply((fun mi -> mi.DeclaringType),m) + else mi.Coerce(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) -[] -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 + +[] +/// 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) + [] +/// 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) = +//------------------------------------------------------------------------- +// 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) = + 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 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) m = +/// Try to get an arbitrary ProvidedMethodInfo associated with a property. +let ArbitraryMethodInfoOfPropertyInfo (pi:Tainted) 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) 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. +[] +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. [] 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,64 +705,54 @@ 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 * Import.ImportMap * range + | ProvidedMeth of Import.ImportMap * Tainted * 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 + // 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.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 * Import.ImportMap * range + | ProvidedField of Import.ImportMap * Tainted * 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 * Import.ImportMap * range + | ProvidedProp of Import.ImportMap * Tainted * 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 [] 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*option + 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 * range + | ProvidedEvent of Import.ImportMap * Tainted * 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*option, 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) = - let returnType = - if mi.PUntaint((fun mi -> mi.IsConstructor),m) then - mi.PApply((fun mi -> mi.DeclaringType),m) - else mi.Coerce(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.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 6b59e97f13..805abde23d 100755 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -10,10 +10,8 @@ // 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 +module (*internal*) Microsoft.FSharp.Compiler.Lexhelp open System.Text open Internal.Utilities @@ -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 0b02fb8028..189c29b00c 100755 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -9,10 +9,8 @@ // 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 +module (*internal*) Microsoft.FSharp.Compiler.Lexhelp open Internal.Utilities open Internal.Utilities.Text @@ -72,6 +70,6 @@ exception internal IndentationProblem of string * Range.range module Keywords = val internal KeywordOrIdentifierToken : lexargs -> UnicodeLexing.Lexbuf -> string -> Parser.token val internal IdentifierToken : lexargs -> UnicodeLexing.Lexbuf -> string -> Parser.token - val internal QuoteIdentifierIfNeeded : string -> string + val (*internal*) QuoteIdentifierIfNeeded : string -> string val mutable internal permitFsharpKeywords : bool val keywordNames : string list diff --git a/src/fsharp/lowertop.fs b/src/fsharp/lowertop.fs index f3969e89f5..7b50aef23e 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 0ee42cca1c..fcc86d6013 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 = 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' [] +/// 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 [] 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 [] +/// 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 /// Extension members by type and name - eExtensionMembers: TyconRefMultiMap + eIndexedExtensionMembers: TyconRefMultiMap + + /// 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.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) = 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) = 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 [] [] +/// 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 = [] +/// 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. 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. 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) (byAccessNames: LayeredMultiMap) = if IsMangledGenericName nm then @@ -787,19 +895,23 @@ let LookupTypeNameNoArity nm (byDemangledNameAndArity: LayeredMap Option.toList - +/// A flag which indicates if direct references to generated provided types are allowed. Normally these +/// are disallowed. [] 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 [] 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@ctorInfos))) + success (resInfo,Item.MakeCtorGroup ((tcrefOfAppTy g typ).LogicalName, (defaultStructCtorInfo@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@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@extensionMethInfos),rest) - - //success (resInfo,MakeMethGroup (nm,minfos),rest) + let extensionMethInfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ + success (resInfo,Item.MakeMethGroup (nm,minfos@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 - // - // 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 +// +// 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 [] 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 de2996ea3c..bd57d563a2 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 + [] +/// Information about an extension member held in the name resolution environment type ExtensionMember [] +/// The environment of information used to resolve names type NameResolutionEnv = - {eDisplayEnv: DisplayEnv; - eUnqualifiedItems: LayeredMap; - ePatItems: NameMap; - eModulesAndNamespaces: NameMultiMap; - eFullyQualifiedModulesAndNamespaces: NameMultiMap; - eFieldLabels: NameMultiMap; - eTyconsByAccessNames: LayeredMultiMap; - eFullyQualifiedTyconsByAccessNames: LayeredMultiMap; - eTyconsByDemangledNameAndArity: LayeredMap; - eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap; - eExtensionMembers: TyconRefMultiMap; - eTypars: NameMap;} + {eDisplayEnv: DisplayEnv + eUnqualifiedItems: LayeredMap + ePatItems: NameMap + eModulesAndNamespaces: NameMultiMap + eFullyQualifiedModulesAndNamespaces: NameMultiMap + eFieldLabels: NameMultiMap + eTyconsByAccessNames: LayeredMultiMap + eFullyQualifiedTyconsByAccessNames: LayeredMultiMap + eTyconsByDemangledNameAndArity: LayeredMap + eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap + eIndexedExtensionMembers: TyconRefMultiMap + eUnindexedExtensionMembers: ExtensionMember list + eTypars: NameMap } static member Empty : g:TcGlobals -> NameResolutionEnv member DisplayEnv : DisplayEnv member FindUnqualifiedItem : string -> Item @@ -105,8 +107,6 @@ type FullyQualifiedFlag = [] 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 [] 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 -> string option * AccessorDomain -> FindMemberFlag -> range -> TType -> PropInfo list -val internal AllMethInfosOfTypeInScope : InfoReader -> TyconRefMultiMap -> 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 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 d72585e1aa..3f2b83515a 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 f2fa10eb4a..fef20309e0 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(...) */ diff --git a/src/fsharp/patcompile.fs b/src/fsharp/patcompile.fs index 84ba328237..a5cdeeb566 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/policy.2.0.FSharp.Core/Makefile.in b/src/fsharp/policy.2.0.FSharp.Core/Makefile.in index 5c7b4d6610..29d9b35716 100644 --- a/src/fsharp/policy.2.0.FSharp.Core/Makefile.in +++ b/src/fsharp/policy.2.0.FSharp.Core/Makefile.in @@ -8,22 +8,20 @@ include @abs_top_builddir@/config.make include $(topdir)/src/fsharp/targets.make -#override the method to build the assembly +# override the targets to build the assembly -$(objdir)$(TARGET_2_0)/policy.2.0.FSharp.Core.dll: policy.2.0.FSharp.Core.dll.config +$(outdir)/$(NAME).dll: $(NAME).dll.config @mkdir -p $(@D) - cp policy.2.0.FSharp.Core.dll.config $(@D) - al /link:policy.2.0.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_2_0) + cp $(NAME).dll.config $(@D) + al /link:$(NAME).dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub -$(objdir)$(TARGET_4_0)/policy.2.0.FSharp.Core.dll: policy.2.0.FSharp.Core.dll.config - @mkdir -p $(@D) - cp policy.2.0.FSharp.Core.dll.config $(@D) - al /link:policy.2.0.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_4_0) +build: + $(MAKE) $(outdir)/$(NAME).dll -do-final: do-2-0 do-4-0 +clean: + -rm -f $(outdir)/$(NAME).dll -clean: clean-2-0 clean-4-0 +install: install-lib -install: install-lib-2 install-lib-4 diff --git a/src/fsharp/policy.2.0.FSharp.Core/policy.2.0.FSharp.Core.dll.config b/src/fsharp/policy.2.0.FSharp.Core/policy.2.0.FSharp.Core.dll.config index 0ed33620de..14bf6512e8 100644 --- a/src/fsharp/policy.2.0.FSharp.Core/policy.2.0.FSharp.Core.dll.config +++ b/src/fsharp/policy.2.0.FSharp.Core/policy.2.0.FSharp.Core.dll.config @@ -4,13 +4,13 @@ - + - + diff --git a/src/fsharp/policy.2.3.FSharp.Core/Makefile.in b/src/fsharp/policy.2.3.FSharp.Core/Makefile.in index 53c77ef526..51ece55698 100644 --- a/src/fsharp/policy.2.3.FSharp.Core/Makefile.in +++ b/src/fsharp/policy.2.3.FSharp.Core/Makefile.in @@ -8,22 +8,19 @@ include @abs_top_builddir@/config.make include $(topdir)/src/fsharp/targets.make -#override the method to build the assembly +# override the targets to build the assembly -$(objdir)$(TARGET_2_0)/policy.2.3.FSharp.Core.dll: policy.2.3.FSharp.Core.dll.config +$(outdir)/$(NAME).dll: $(NAME).dll.config @mkdir -p $(@D) - cp policy.2.3.FSharp.Core.dll.config $(@D) - al /link:policy.2.3.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_2_0) + cp $(NAME).dll.config $(@D) + al /link:$(NAME).dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub -$(objdir)$(TARGET_4_0)/policy.2.3.FSharp.Core.dll: policy.2.3.FSharp.Core.dll.config - @mkdir -p $(@D) - cp policy.2.3.FSharp.Core.dll.config $(@D) - al /link:policy.2.3.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_4_0) - -do-final: do-2-0 do-4-0 +build: + $(MAKE) $(outdir)/$(NAME).dll -clean: clean-2-0 clean-4-0 +clean: + -rm -f $(outdir)/$(NAME).dll -install: install-lib-2 install-lib-4 +install: install-lib diff --git a/src/fsharp/policy.2.3.FSharp.Core/policy.2.3.FSharp.Core.dll.config b/src/fsharp/policy.2.3.FSharp.Core/policy.2.3.FSharp.Core.dll.config index 6a65bb4351..9c66175c74 100644 --- a/src/fsharp/policy.2.3.FSharp.Core/policy.2.3.FSharp.Core.dll.config +++ b/src/fsharp/policy.2.3.FSharp.Core/policy.2.3.FSharp.Core.dll.config @@ -4,14 +4,17 @@ - + + - - + + + + diff --git a/src/fsharp/policy.3.3.FSharp.Core/Makefile.in b/src/fsharp/policy.3.3.FSharp.Core/Makefile.in new file mode 100644 index 0000000000..7b3c87c84c --- /dev/null +++ b/src/fsharp/policy.3.3.FSharp.Core/Makefile.in @@ -0,0 +1,24 @@ +NAME=policy.3.3.FSharp.Core +ASSEMBLY = $(NAME).dll +DELAY_SIGN=1 + +srcdir := @abs_srcdir@/ + +include @abs_top_builddir@/config.make + +include $(topdir)/src/fsharp/targets.make + +# override the targets to build the assembly + +$(outdir)/$(NAME).dll: $(NAME).dll.config + @mkdir -p $(@D) + cp $(NAME).dll.config $(@D) + al /link:$(NAME).dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub + +build: + $(MAKE) $(outdir)/$(NAME).dll + +clean: + -rm -f $(outdir)/$(NAME).dll + +install: install-lib diff --git a/src/fsharp/policy.3.3.FSharp.Core/policy.3.3.FSharp.Core.dll.config b/src/fsharp/policy.3.3.FSharp.Core/policy.3.3.FSharp.Core.dll.config new file mode 100644 index 0000000000..d6a18af3ac --- /dev/null +++ b/src/fsharp/policy.3.3.FSharp.Core/policy.3.3.FSharp.Core.dll.config @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/src/fsharp/policy.4.0.FSharp.Core/Makefile.in b/src/fsharp/policy.4.0.FSharp.Core/Makefile.in index 3dfe5a5031..393b9afe45 100644 --- a/src/fsharp/policy.4.0.FSharp.Core/Makefile.in +++ b/src/fsharp/policy.4.0.FSharp.Core/Makefile.in @@ -10,21 +10,15 @@ include $(topdir)/src/fsharp/targets.make # override the targets to build the assembly -$(objdir)$(TARGET_2_0)/policy.4.0.FSharp.Core.dll: policy.4.0.FSharp.Core.dll.config +$(outdir)/$(NAME).dll: $(NAME).dll.config @mkdir -p $(@D) - cp policy.4.0.FSharp.Core.dll.config $(@D) - al /link:policy.4.0.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_2_0) - -$(objdir)$(TARGET_4_0)/policy.4.0.FSharp.Core.dll: policy.4.0.FSharp.Core.dll.config - @mkdir -p $(@D) - cp policy.4.0.FSharp.Core.dll.config $(@D) - al /link:policy.4.0.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_4_0) - -do-final: do-2-0 do-4-0 - -clean: clean-2-0 clean-4-0 - -install: install-lib-2 install-lib-4 + cp $(NAME).dll.config $(@D) + al /link:$(NAME).dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub +build: + $(MAKE) $(outdir)/$(NAME).dll +clean: + -rm -f $(outdir)/$(NAME).dll +install: install-lib diff --git a/src/fsharp/policy.4.0.FSharp.Core/policy.4.0.FSharp.Core.dll.config b/src/fsharp/policy.4.0.FSharp.Core/policy.4.0.FSharp.Core.dll.config index b279a6ff94..0b6856e380 100644 --- a/src/fsharp/policy.4.0.FSharp.Core/policy.4.0.FSharp.Core.dll.config +++ b/src/fsharp/policy.4.0.FSharp.Core/policy.4.0.FSharp.Core.dll.config @@ -4,7 +4,7 @@ - + diff --git a/src/fsharp/policy.4.3.FSharp.Core/Makefile.in b/src/fsharp/policy.4.3.FSharp.Core/Makefile.in index 0ae7e6975a..51e8c2d813 100644 --- a/src/fsharp/policy.4.3.FSharp.Core/Makefile.in +++ b/src/fsharp/policy.4.3.FSharp.Core/Makefile.in @@ -10,21 +10,15 @@ include $(topdir)/src/fsharp/targets.make # override the targets to build the assembly -$(objdir)$(TARGET_2_0)/policy.4.3.FSharp.Core.dll: policy.4.3.FSharp.Core.dll.config +$(outdir)/$(NAME).dll: $(NAME).dll.config @mkdir -p $(@D) - cp policy.4.3.FSharp.Core.dll.config $(@D) - al /link:policy.4.3.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_2_0) - -$(objdir)$(TARGET_4_0)/policy.4.3.FSharp.Core.dll: policy.4.3.FSharp.Core.dll.config - @mkdir -p $(@D) - cp policy.4.3.FSharp.Core.dll.config $(@D) - al /link:policy.4.3.FSharp.Core.dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub /version:$(VERSION_4_0) - -do-final: do-2-0 do-4-0 - -clean: clean-2-0 clean-4-0 - -install: install-lib-2 install-lib-4 + cp $(NAME).dll.config $(@D) + al /link:$(NAME).dll.config /out:$@ /delaysign /keyfile:$(topdir)msfinal.pub +build: + $(MAKE) $(outdir)/$(NAME).dll +clean: + -rm -f $(outdir)/$(NAME).dll +install: install-lib diff --git a/src/fsharp/policy.4.3.FSharp.Core/policy.4.3.FSharp.Core.dll.config b/src/fsharp/policy.4.3.FSharp.Core/policy.4.3.FSharp.Core.dll.config index 436a9dcd33..3e3e956862 100644 --- a/src/fsharp/policy.4.3.FSharp.Core/policy.4.3.FSharp.Core.dll.config +++ b/src/fsharp/policy.4.3.FSharp.Core/policy.4.3.FSharp.Core.dll.config @@ -4,7 +4,7 @@ - + diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index b5c5bfe352..1094a40a56 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 a5881be39d..bb40103ffe 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 2dad17d8ab..18d424b07c 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 d4dff8c7f5..9c9b27f825 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/targets.make b/src/fsharp/targets.make index 41ba5f5d48..06ad73911d 100644 --- a/src/fsharp/targets.make +++ b/src/fsharp/targets.make @@ -1,158 +1,37 @@ SOURCES := $(patsubst $(srcdir)$(tmpdir)%,$(tmpdir)%,$(patsubst %,$(srcdir)%,$(sources))) -.PHONY: install install-bin install-bin-2 install-bin-4 install-lib +.PHONY: install install-lib-net20 install-lib-monodroid install-lib-net40 -clean-2-0: TARGET := $(TARGET_2_0) -clean-2-0: - -rm -rf $(tmpdir) - -rm -rf $(objdir) - -rm -f $(outdir)$(ASSEMBLY) - -rm -f $(outdir)$(ASSEMBLY).mdb - -rm -f $(outdir)$(NAME).xml - -rm -f $(outdir)$(NAME).sigdata - -rm -f $(outdir)$(NAME).optdata - -clean-2-1: TARGET := $(TARGET_2_1) -clean-2-1: - -rm -rf $(tmpdir) - -rm -rf $(objdir) - -rm -f $(outdir)$(ASSEMBLY) - -rm -f $(outdir)$(ASSEMBLY).mdb - -rm -f $(outdir)$(NAME).xml - -rm -f $(outdir)$(NAME).sigdata - -rm -f $(outdir)$(NAME).optdata - -clean-4-0: TARGET := $(TARGET_4_0) -clean-4-0: - -rm -rf $(tmpdir) - -rm -rf $(objdir) - -rm -f $(outdir)$(ASSEMBLY) - -rm -f $(outdir)$(ASSEMBLY).mdb - -rm -f $(outdir)$(NAME).xml - -rm -f $(outdir)$(NAME).sigdata - -rm -f $(outdir)$(NAME).optdata - -do-2-0: DEFINES += $(DEFINES_2_0) -do-2-0: REFERENCES += $(REFERENCES_2_0) -do-2-0: FLAGS += $(FLAGS_2_0) -do-2-0: TARGET := $(TARGET_2_0) -do-2-0: VERSION := $(VERSION_2_0) -do-2-0: monogacdirXX = $(monogacdir20) -do-2-0: gacdirXX = $(gacdir20) -do-2-0: $(objdir) $(objdir)$(TARGET_2_0) $(objdir)$(TARGET_4_0) $(objdir)$(TARGET_2_0)/$(ASSEMBLY) - @mkdir -p $(outdir) - @cp $(objdir)$(ASSEMBLY) $(outdir) - @if test -e $(objdir)$(ASSEMBLY).xml; then \ - cp $(objdir)$(NAME).xml $(outdir); \ - fi - @if test -e $(objdir)$(ASSEMBLY).mdb; then \ - cp $(objdir)$(ASSEMBLY).mdb $(outdir); \ - fi - @if test -e $(objdir)$(NAME).sigdata; then \ - cp $(objdir)$(NAME).sigdata $(outdir); \ - fi - @if test -e $(objdir)$(NAME).optdata; then \ - cp $(objdir)$(NAME).optdata $(outdir); \ - fi - @if test "x$(DELAY_SIGN)" = "x1"; then \ - sn -q -R $(outdir)$(ASSEMBLY) $(srcdir)../../../mono.snk; \ - fi - -do-2-1: DEFINES += $(DEFINES_2_1) -do-2-1: REFERENCES += $(REFERENCES_2_1) -do-2-1: FLAGS += $(FLAGS_2_1) -do-2-1: TARGET := $(TARGET_2_1) -do-2-1: VERSION := $(VERSION_2_1) -do-2-1: monogacdirXX = $(monogacdir20) -do-2-1: gacdirXX = $(gacdir20) -do-2-1: $(objdir) $(objdir)$(TARGET_2_1) $(objdir)$(TARGET_4_0) $(objdir)$(TARGET_2_1)/$(ASSEMBLY) - @mkdir -p $(outdir) - @cp $(objdir)$(ASSEMBLY) $(outdir) - @if test -e $(objdir)$(NAME).xml; then \ - cp $(objdir)$(NAME).xml $(outdir); \ - fi - @if test -e $(objdir)$(ASSEMBLY).mdb; then \ - cp $(objdir)$(ASSEMBLY).mdb $(outdir); \ - fi - @if test -e $(objdir)$(NAME).sigdata; then \ - cp $(objdir)$(NAME).sigdata $(outdir); \ - fi - @if test -e $(objdir)$(NAME).optdata; then \ - cp $(objdir)$(NAME).optdata $(outdir); \ - fi - @if test "x$(DELAY_SIGN)" = "x1"; then \ - sn -q -R $(outdir)$(ASSEMBLY) $(srcdir)../../../mono.snk; \ - fi - -do-4-0: DEFINES += $(DEFINES_4_0) -do-4-0: REFERENCES += $(REFERENCES_4_0) -do-4-0: FLAGS += $(FLAGS_4_0) -do-4-0: TARGET := $(TARGET_4_0) -do-4-0: VERSION := $(VERSION_4_0) -do-4-0: monogacdirXX = $(monogacdir40) -do-4-0: gacdirXX = $(gacdir40) -do-4-0: $(objdir) $(objdir)$(TARGET_2_0) $(objdir)$(TARGET_4_0) $(objdir)$(TARGET_4_0)/$(ASSEMBLY) - @mkdir -p $(outdir) - @cp $(objdir)$(ASSEMBLY) $(outdir) - @if test -e $(objdir)$(NAME).xml; then \ - cp $(objdir)$(NAME).xml $(outdir); \ - fi - @if test -e $(objdir)$(ASSEMBLY).mdb; then \ - cp $(objdir)$(ASSEMBLY).mdb $(outdir); \ - fi - @if test -e $(objdir)$(NAME).sigdata; then \ - cp $(objdir)$(NAME).sigdata $(outdir); \ - fi - @if test -e $(objdir)$(NAME).optdata; then \ - cp $(objdir)$(NAME).optdata $(outdir); \ - fi - @if test "x$(DELAY_SIGN)" = "x1"; then \ - sn -q -R $(outdir)$(ASSEMBLY) $(srcdir)../../../mono.snk; \ - fi - @if test -e Microsoft.FSharp.Targets; then \ - cp Microsoft.FSharp.Targets $(outdir)Microsoft.FSharp.Targets; \ - fi - @if test -e Microsoft.Portable.FSharp.Targets; then \ - cp Microsoft.Portable.FSharp.Targets $(outdir)Microsoft.Portable.FSharp.Targets; \ - fi - -install-lib-2: TARGET := $(TARGET_2_0) -install-lib-2: VERSION := $(VERSION_2_0) - -install-lib-2-1: TARGET := $(TARGET_2_1) -install-lib-2-1: VERSION := $(VERSION_2_1) - -install-lib-4: TARGET := $(TARGET_4_0) -install-lib-4: VERSION := $(VERSION_4_0) - -install-bin-2: TARGET := $(TARGET_2_0) -install-bin-2: VERSION := 2 - -install-bin-2-1: TARGET := $(TARGET_2_1) -install-bin-2-1: VERSION := 2.1 - -install-bin-4: TARGET := $(TARGET_4_0) +build: + MONO_ENV_OPTIONS=$(monoopts) xbuild /p:Configuration=$(Configuration) /p:TargetFramework=$(TargetFramework) /p:MonoLibDir40=$(monogacdir40) +clean: + xbuild /p:Configuration=$(Configuration) /p:TargetFramework=$(TargetFramework) /t:Clean # Install the library binaries in the GAC and the framework directory, # Install .optdata/.sigdata if they exist (they go alongside FSharp.Core) # Install the .Targets file. The XBuild targets file gets installed into the place(s) expected for standard F# project # files. For F# 2.0 project files this is -# .../Microsoft F#/v4.0/Microsoft.FSharp.Targets +# /usr/lib/mono/Microsoft F#/v4.0/Microsoft.FSharp.Targets # For F# 3.0 project files this is -# .../Microsoft SDKs/F#/3.0/Framework/v4.0/Microsoft.FSharp.Targets -# +# /usr/lib/mono/Microsoft SDKs/F#/3.0/Framework/v4.0/Microsoft.FSharp.Targets # For F# 3.1 project files this is -# .../lib/mono/xbuild/Microsoft/VisualStudio/v$(VisualStudioVersion)/FSharp/Microsoft.FSharp.Targets +# /usr/lib/mono/xbuild/Microsoft/VisualStudio/v12.0/FSharp/Microsoft.FSharp.Targets # -# xbuild sets 'VisualStudioVersion' to empty. +# Here 12.0 is 'VisualStudioVersion'. xbuild should set this to 12.0, copying MSBuild. +# +# We put the F# 3.1 targets and link the SDK DLLs for all three locations # # We put a forwarding targets file into all three locations. We also put one in # .../lib/mono/xbuild/Microsoft/VisualStudio/v12.0/FSharp/Microsoft.FSharp.Targets # since this is the correct location, and 'xbuild' may in future start setting VisualStudioVersion to this value. -install-lib-2 install-lib-2-1 install-lib-4: + +install-lib: @echo "Installing $(ASSEMBLY)" @mkdir -p $(DESTDIR)$(gacdir)/$(TARGET) + @if test "x$(DELAY_SIGN)" = "x1"; then \ + sn -q -R $(outdir)$(ASSEMBLY) $(srcdir)../../../mono.snk; \ + fi gacutil -i $(outdir)$(ASSEMBLY) -root $(DESTDIR)$(libdir) -package $(TARGET) @if test -e $(outdir)Microsoft.FSharp.Targets; then \ $(INSTALL_LIB) $(outdir)Microsoft.FSharp.Targets $(DESTDIR)$(gacdir)/$(TARGET)/; \ @@ -165,7 +44,6 @@ install-lib-2 install-lib-2-1 install-lib-4: mkdir -p $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.1/Framework/v$(TARGET)/; \ mkdir -p $(DESTDIR)$(gacdir)/xbuild/Microsoft/VisualStudio/v/FSharp/; \ mkdir -p $(DESTDIR)$(gacdir)/xbuild/Microsoft/VisualStudio/v12.0/FSharp/; \ - mkdir -p $(DESTDIR)$(gacdir)/Microsoft\ F#/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ F#/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.0/Framework/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.1/Framework/v$(TARGET)/; \ @@ -182,7 +60,6 @@ install-lib-2 install-lib-2-1 install-lib-4: mkdir -p $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.1/Framework/v$(TARGET)/; \ mkdir -p $(DESTDIR)$(gacdir)/xbuild/Microsoft/VisualStudio/v/FSharp/; \ mkdir -p $(DESTDIR)$(gacdir)/xbuild/Microsoft/VisualStudio/v12.0/FSharp/; \ - mkdir -p $(DESTDIR)$(gacdir)/Microsoft\ F#/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.Portable.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ F#/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.Portable.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.0/Framework/v$(TARGET)/; \ $(INSTALL_LIB) $(tmpdir)Microsoft.Portable.FSharp.Targets $(DESTDIR)$(gacdir)/Microsoft\ SDKs/F#/3.1/Framework/v$(TARGET)/; \ @@ -190,20 +67,22 @@ install-lib-2 install-lib-2-1 install-lib-4: $(INSTALL_LIB) $(tmpdir)Microsoft.Portable.FSharp.Targets $(DESTDIR)$(gacdir)/xbuild/Microsoft/VisualStudio/v12.0/FSharp/; \ fi @if test -e $(outdir)$(NAME).xml; then \ - $(INSTALL_LIB) $(outdir)$(NAME).xml $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN); \ + $(INSTALL_LIB) $(outdir)$(NAME).xml $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN)/; \ ln -fs ../gac/$(NAME)/$(VERSION)__$(TOKEN)/$(NAME).xml $(DESTDIR)$(gacdir)/$(TARGET)/$(NAME).xml; \ fi @if test -e $(outdir)$(NAME).sigdata; then \ - $(INSTALL_LIB) $(outdir)$(NAME).sigdata $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN); \ + $(INSTALL_LIB) $(outdir)$(NAME).sigdata $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN)/; \ ln -fs ../gac/$(NAME)/$(VERSION)__$(TOKEN)/$(NAME).sigdata $(DESTDIR)$(gacdir)/$(TARGET)/$(NAME).sigdata; \ fi @if test -e $(outdir)$(NAME).optdata; then \ - $(INSTALL_LIB) $(outdir)$(NAME).optdata $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN); \ + $(INSTALL_LIB) $(outdir)$(NAME).optdata $(DESTDIR)$(gacdir)/gac/$(NAME)/$(VERSION)__$(TOKEN)/; \ ln -fs ../gac/$(NAME)/$(VERSION)__$(TOKEN)/$(NAME).optdata $(DESTDIR)$(gacdir)/$(TARGET)/$(NAME).optdata; \ fi -install-lib-4-5: install-lib-4 - @if test -e $(DESTDIR)$(gacdir)/4.5/; then \ +# Also place some .NET 4.0 libraries into .NET 4.5 +install-lib-net45: + @if test '$(TargetFramework)' = 'net40'; then \ + if test -e $(DESTDIR)$(gacdir)/4.5/; then \ ln -fs ../4.0/$(ASSEMBLY) $(DESTDIR)$(gacdir)/4.5/$(ASSEMBLY); \ if test -e $(DESTDIR)$(gacdir)/4.0/$(ASSEMBLY).config; then \ ln -fs ../4.0/$(ASSEMBLY).config $(DESTDIR)$(gacdir)/4.5/$(ASSEMBLY).config; \ @@ -217,11 +96,12 @@ install-lib-4-5: install-lib-4 if test -e $(DESTDIR)$(gacdir)/4.0/$(NAME).optdata; then \ ln -fs ../4.0/$(NAME).optdata $(DESTDIR)$(gacdir)/4.5/$(NAME).optdata; \ fi; \ + fi \ fi # The binaries fsc.exe and fsi.exe only get installed for Mono 4.0 profile # This also installs 'fsharpc' and 'fsharpi' -install-bin-4: +install-bin: sed -e 's,[@]DIR[@],$(gacdir)/$(TARGET),g' -e 's,[@]TOOL[@],$(ASSEMBLY),g' < $(topdir)launcher > $(outdir)$(subst fs,fsharp,$(NAME))$(VERSION) chmod +x $(outdir)$(subst fs,fsharp,$(NAME))$(VERSION) @mkdir -p $(DESTDIR)$(gacdir)/$(TARGET) @@ -230,14 +110,3 @@ install-bin-4: $(INSTALL_BIN) $(outdir)$(subst fs,fsharp,$(NAME))$(VERSION) $(DESTDIR)$(bindir) -$(objdir) $(objdir)$(TARGET_2_0) $(objdir)$(TARGET_2_1) $(objdir)$(TARGET_4_0): - mkdir -p $@ - -$(objdir)$(TARGET_2_0)/$(ASSEMBLY): $(RESOURCES) $(SOURCES) - mono $(MONO_OPTIONS) $(FSC) -o:$(objdir)$(ASSEMBLY) $(REFERENCES) $(DEFINES) $(FLAGS) $(patsubst %,--resource:%,$(RESOURCES)) $(SOURCES) - -$(objdir)$(TARGET_2_1)/$(ASSEMBLY): $(RESOURCES) $(SOURCES) - mono $(MONO_OPTIONS) $(FSC) -o:$(objdir)$(ASSEMBLY) $(REFERENCES) $(DEFINES) $(FLAGS) $(patsubst %,--resource:%,$(RESOURCES)) $(SOURCES) - -$(objdir)$(TARGET_4_0)/$(ASSEMBLY): $(RESOURCES) $(SOURCES) - mono $(MONO_OPTIONS) $(FSC) -o:$(objdir)$(ASSEMBLY) $(REFERENCES) $(DEFINES) $(FLAGS) $(patsubst %,--resource:%,$(RESOURCES)) $(SOURCES) diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 62221a4fa7..490a80e088 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> +and CcuTypeForwarderTable = Map> 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 = ccu.Deref.TypeForwarders.Force() + member ccu.TypeForwarders : Map> = 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 9c5fd78263..2c4404cc01 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.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 95130e874c..a799bca70d 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 389404e615..8687f43ce7 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) (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)) = [] 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 [] 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>; + mutable postInferenceChecks: ResizeArray 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@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((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,[""])); + if newOk = NoNewTypars then error (UndefinedName(0,FSComp.SR.undefinedNameTypeParameter,id,[""])) // 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) = 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 (...) = then " 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.Sth' but also only 'MyType.' // (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 with value - result of equality operation or 2) create option using named arg syntax. + // so far we've used 1) so we cannot immediately switch to 2) since it will be a definite breaking change. + + 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(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(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() +/// Check for duplicate bindings in simple recursive patterns +and CheckRecursiveBindingIds binds = + let hashOfBinds = new Dictionary() - 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; + UnifyUnitType cenv env.DisplayEnv mBinding overallTy (Some rhsExpr') |> ignore // 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; - RepInfoTcGlobals:TcGlobals; + TakenFieldNames:Set + RepInfoTcGlobals:TcGlobals /// vals mapped to representations - ValReprs : Zmap; + ValReprs : Zmap /// vals represented as fields or members from this point on - ValsWithRepresentation : Val Zset; } + ValsWithRepresentation : Zset } 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 = | 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 = | 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 = 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 f1e1613a20..ea684cd8b2 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 -> 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 360b94080e..8fc9946b77 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 // 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 3008f3604c..5b3588ae5e 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, - availPriorOverrides: OverrideInfo list, - overrides - ) = + /// Check all implementations implement some dispatch slot. + let CheckOverridesAreAllUsedOnce(denv, g, amap, isObjExpr, reqdTy, + dispatchSlotsKeyed: NameMultiMap, + 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 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, 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) = + 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) = + 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 959fa97cc7..148747f504 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 aa2e0fd379..4bd1ae7ecc 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 605039276a..70acf871c6 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 b7b559e2fd..0890e7aa5d 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) + + [] + member this.``AutoCompletion.ObjectMethods``() = + let code = + [ + "type DU1 = DU_1" + + "[]" + "type DU2 = DU_2" + + "[]" + "type DU3 =" + " | DU_3" + " with member this.Equals(b : string) = 1" + + "[]" + "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 + [] member this.``AutoCompletion.BeforeThis``() = @@ -338,16 +384,29 @@ type AutoCompletionListTests() as this = [] member public this.``AdjacentToDot_21_Negative``() = testAutoCompleteAdjacentToDotNegative ".+." [] - 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"] [] [] member public this.``Query.CompletionInJoinOn``() = @@ -1000,7 +1059,28 @@ derived.derivedField"] [ "baseFieldPrivate"; "derivedFieldPrivate" ] // should not contain [] - 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 + + [] + member public this.``Visibility.InheritedClass.MethodsWithDiffAccessibility``() = AssertAutoCompleteContainsNoCoffeeBreak [ "type Base = val mutable baseField : int @@ -1018,6 +1098,47 @@ type Derived = [ "baseField"; "derivedField"; "derivedFieldPrivate" ] // should contain [ "baseFieldPrivate" ] // should not contain + [] + 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 + + [] + 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 + [] member public this.``Identifier.Array.AfterassertKeyword``() = AssertAutoCompleteContainsNoCoffeeBreak @@ -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") - + + [] + 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") + [] 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 1a4334474f..c612242d3f 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 6a7139d62b..1854dcf667 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) = @@ -66,7 +76,31 @@ type GotoDefinitionTests() = (GotoDefnSuccess identifier definitionCode) file result - + + [] + member this.``Operators.TopLevel``() = + this.VerifyGotoDefnSuccessForNonIdentifierAtStartOfMarker( + fileContents = """ + let (===) a b = a = b + let _ = 1 === 2 + """, + marker = "=== 2", + pos=(1,21) + ) + + [] + member this.``Operators.Member``() = + this.VerifyGotoDefnSuccessForNonIdentifierAtStartOfMarker( + fileContents = """ + type U = U + with + static member (+++) (U, U) = U + let _ = U +++ U + """, + marker = "++ U", + pos=(3,35) + ) + [] 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 bfe1c0445c..555a04598b 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"]]) + + [] + 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"]]) + + [] + 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" ]]) [] [] @@ -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"]]) - + + [] + 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"]]) + + [] + [] + 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 ------------------------------------------------ *) [] diff --git a/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs b/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs index 6878923e5e..28c2757a49 100755 --- a/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs +++ b/src/fsharp/unittests/Tests.LanguageService.QuickInfo.fs @@ -133,6 +133,36 @@ type QuickInfoTests() = expectedExactOrder = ["Enumerator"; "KeyCollection"; "ValueCollection"] ) + [] + 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")) + ) + + [] + 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")) + ) + [] member public this.``QuickInfo.OverriddenMethods``() = let source = """ @@ -700,6 +730,30 @@ type QuickInfoTests() = this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "PriorityQueue(*MarkerModule*)" expectedquickinfoPriorityQueueinModule this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "pq(*MarkerVal*)" expectedquickinfoVal this.InfoInDeclarationTestQuickInfoImplWithTrim fileContents "singleton(*MarkerLastLine*)" expectedquickinfoLastLine + + [] + 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 [] 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 697891ef17..a28c196726 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) + + [] + 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. [] @@ -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. [] @@ -1264,10 +1300,10 @@ type ScriptTests() as this = (project, @" - + True - + True ") diff --git a/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs b/src/fsharp/unittests/Tests.ProjectSystem.Miscellaneous.fs index 4590789a8b..52d109a790 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 14317d854f..ef57f9555c 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) + + [] + 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, + @"", + "v4.5", + [] + ) + this.ReferenceResolutionHelper + ( + AddReferenceDialogTab.DotNetTab, + fsharp4310, + @"", + "v4.5", + [] + ) + this.ReferenceResolutionHelper + ( + AddReferenceDialogTab.BrowseTab, + fsharp4300, + @"4\.3\.0\.0\\FSharp\.Core\.dll", + "v4.5", + [] + ) + this.ReferenceResolutionHelper + ( + AddReferenceDialogTab.BrowseTab, + fsharp4310, + @"4\.3\.1\.0\\FSharp\.Core\.dll", + "v4.5", + [] + ) - + [] member public this.``ReferenceResolution.Bug4423.NonFxAssembly.NetTab``() = this.ReferenceResolutionHelper(AddReferenceDialogTab.DotNetTab, @@ -324,6 +363,70 @@ type References() = finally File.Delete(copy) + [] + 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.GUID, box invoker + typeof.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 = + @"" + + @"\s*\.\.\\EnvDTE80.dll" + + @"\s*" + 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 = @"" + @"\s*Test.exe" // in this directory + @"\s*" - 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 = @"" + @"\s*\.\.\\.*?" // the point is, some path start with "..\", since both projects are rooted somewhere in the temp directory (where unit tests create them) + @"\s*" - 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/Unittests.fsproj b/src/fsharp/unittests/Unittests.fsproj index 5f9aed906d..7f3d51f645 100644 --- a/src/fsharp/unittests/Unittests.fsproj +++ b/src/fsharp/unittests/Unittests.fsproj @@ -2,14 +2,11 @@ $(MSBuildProjectDirectory)\..\.. - 10.0.0 - False Debug AnyCPU - 2.0 true v3.5 true diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs index 261b607f37..c65f1d1163 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(None).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 3b6553e681..c7eab844e6 100755 --- a/src/fsharp/vs/IncrementalBuild.fsi +++ b/src/fsharp/vs/IncrementalBuild.fsi @@ -8,11 +8,11 @@ open Microsoft.FSharp.Compiler.Build [] -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 [] -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 fd705b3072..85b7a349f5 100644 --- 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) @@ -222,18 +221,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\, i.e. the location of the source for the - // file in the F# installation location - Path.Combine(ccu.SourceCodeDirectory, file) | None -> match qualProjectDir with @@ -321,35 +315,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 @@ -524,14 +508,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 @@ -539,11 +523,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 = @@ -557,19 +541,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 @@ -617,6 +601,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 -> @@ -636,14 +623,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) @@ -710,7 +700,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 -> @@ -746,7 +736,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 @@ -965,16 +954,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 @@ -1079,7 +1063,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 @@ -1294,7 +1278,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 @@ -1302,7 +1286,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 b90ced22ef..91666f1114 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,26 +48,26 @@ 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 [] // 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 [] // 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 static member internal Create : infoReader:InfoReader * m:range * denv:DisplayEnv * items:Item list * syncop:((unit->unit)->unit) * checkAlive:(unit -> bool) -> DeclarationSet static member internal Error : message:string -> DeclarationSet - static member internal Empty : DeclarationSet + static member (*internal*) Empty : DeclarationSet module internal TestHooks = diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs index f75f149bb6..4e1fbc31c1 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. [] -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 b2eb049858..fa4cb94192 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. [] -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. [] -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/ServiceNavigation.fsi b/src/fsharp/vs/ServiceNavigation.fsi index 6671c4c401..824e47b9cf 100755 --- a/src/fsharp/vs/ServiceNavigation.fsi +++ b/src/fsharp/vs/ServiceNavigation.fsi @@ -18,7 +18,7 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler -type internal DeclarationItemKind = +type (*internal*) DeclarationItemKind = | NamespaceDecl | ModuleFileDecl | ExnDecl @@ -31,7 +31,7 @@ type internal DeclarationItemKind = /// Represents an item to be displayed in the navigation bar [] -type internal DeclarationItem = +type (*internal*) DeclarationItem = member Name : string member UniqueName : string member Glyph : int @@ -43,7 +43,7 @@ type internal DeclarationItem = /// Represents top-level declarations (that should be in the type drop-down) /// with nested declarations (that can be shown in the member drop-down) [] -type internal TopLevelDeclaration = +type (*internal*) TopLevelDeclaration = { Declaration : DeclarationItem Nested : DeclarationItem[] } @@ -51,7 +51,7 @@ type internal TopLevelDeclaration = /// all the members and currently selected indices. First level correspond to /// types & modules and second level are methods etc. [] -type internal NavigationItems = +type (*internal*) NavigationItems = member Declarations : TopLevelDeclaration[] // implementation details used by other code in the compiler diff --git a/src/fsharp/vs/ServiceParseTreeWalk.fs b/src/fsharp/vs/ServiceParseTreeWalk.fs index 5032ded197..c2944d3c05 100755 --- a/src/fsharp/vs/ServiceParseTreeWalk.fs +++ b/src/fsharp/vs/ServiceParseTreeWalk.fs @@ -24,7 +24,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast -module internal AstTraversal = +module (*internal*) AstTraversal = // treat ranges as though they are half-open: [,) let rangeContainsPosLeftEdgeInclusive (m1:range) p = if posEq m1.Start m1.End then @@ -139,7 +139,7 @@ module internal AstTraversal = /// traverse an implementation file walking all the way down to SynExpr or TypeAbbrev at a particular location /// - let internal Traverse(line, col, parseTree, visitor:AstVisitorBase<'T>) = + let (*internal*) Traverse(line, col, parseTree, visitor:AstVisitorBase<'T>) = let pos = Pos.fromVS line col // line was 0-based, need 1-based let pick x = pick pos line col x let rec traverseSynModuleDecl path (decl:SynModuleDecl) = @@ -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 a7d8608aae..4516de8f30 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fs +++ b/src/fsharp/vs/ServiceUntypedParse.fs @@ -71,7 +71,7 @@ type internal RecordContext = | Constructor of string // typename | New of CompletionPath -type internal CompletionContext = +type (*internal*) CompletionContext = // completion context cannot be determined due to errors | Invalid // completing something after the inherit keyword @@ -85,7 +85,7 @@ type internal CompletionContext = //---------------------------------------------------------------------------- [] -type internal UntypedParseResults = +type (*internal*) UntypedParseResults = { // Error infos Errors : ErrorInfo[] // Untyped AST @@ -97,15 +97,15 @@ type internal UntypedParseResults = } [] -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 @@ -396,7 +395,7 @@ type (* internal *) UntypedParseInfo internal (parsed:UntypedParseResults) = // This does not need to be run on the background thread scope.ValidateBreakpointLocationImpl(pos) -module internal UntypedParseInfoImpl = +module (*internal*) UntypedParseInfoImpl = let GetUntypedParseResults (upi : UntypedParseInfo) = upi.Results let GetRangeOfExprLeftOfDot(line,col,parseTreeOpt) = diff --git a/src/fsharp/vs/ServiceUntypedParse.fsi b/src/fsharp/vs/ServiceUntypedParse.fsi index 9e12d601bc..ba1cfd555b 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fsi +++ b/src/fsharp/vs/ServiceUntypedParse.fsi @@ -35,19 +35,19 @@ type internal UntypedParseResults = } [] -type (* internal *) UntypedParseInfo = - member internal ParseTree : Ast.ParsedInput option +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 /// Name of the file for which this information were created member internal FileName : string /// Get declared items and the selected item at the specified location - member internal GetNavigationItems : unit -> NavigationItems + member (*internal*) GetNavigationItems : unit -> NavigationItems /// Return the inner-most range associated with a possible breakpoint location member internal ValidateBreakpointLocation : Position -> Range option /// When these files change then the build is invalid member internal DependencyFiles : unit -> string list - internal new : parsed:UntypedParseResults -> UntypedParseInfo + (*internal*) new : parsed:UntypedParseResults -> UntypedParseInfo /// Information about F# source file names module internal SourceFile = @@ -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 = @@ -81,7 +79,7 @@ type internal CompletionContext = // implementation details used by other code in the compiler -module internal UntypedParseInfoImpl = +module (*internal*) UntypedParseInfoImpl = open Microsoft.FSharp.Compiler.Ast val GetUntypedParseResults : UntypedParseInfo -> UntypedParseResults val TryFindExpressionASTLeftOfDotLeftOfCursor : int * int * ParsedInput option -> (pos * bool) option diff --git a/src/fsharp/vs/SimpleServices.fs b/src/fsharp/vs/SimpleServices.fs index 23faa25fac..c13917ea0a 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 diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs index c76eee2c37..b0b333225c 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 [] // 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. [] type MethodOverloads( name: string, unsortedMethods: Method[] ) = @@ -281,11 +288,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 = #if FX_ATLEAST_40 match methodOverloadsCache.TryGetValue item with @@ -320,9 +326,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] @@ -343,7 +346,7 @@ type MethodOverloads( name: string, unsortedMethods: Method[] ) = //-------------------------------------------------------------------------- [] -type (* internal *) FindDeclFailureReason = +type internal FindDeclFailureReason = // generic reason: no particular information about error | Unknown // source code file is not available @@ -354,7 +357,7 @@ type (* internal *) FindDeclFailureReason = | ProvidedMember of string [] -type (* internal *) FindDeclResult = +type internal FindDeclResult = /// declaration not found + reason | DeclNotFound of FindDeclFailureReason /// found declaration; return (position-in-file, name-of-file) @@ -365,7 +368,7 @@ type (* internal *) FindDeclResult = /// (Depending on the kind of the items, we may stop processing or continue to find better items) [] [] -type (* internal *) NameResResult = +type internal NameResResult = | Members of (Item list * DisplayEnv * range) | Cancel of DisplayEnv * range | Empty @@ -406,7 +409,7 @@ type CapturedNameResolution(p:pos, i:Item, io:ItemOccurence, de:DisplayEnv, nre: [] 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, @@ -744,9 +747,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 @@ -1126,18 +1129,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(_)::_) @@ -1148,16 +1156,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 @@ -1281,7 +1289,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 @@ -1550,7 +1557,7 @@ module internal Parser = ReportUnexpectedException(e) reraise() -type UnresolvedReferencesSet = +type internal UnresolvedReferencesSet = val private set : System.Collections.Generic.HashSet new(unresolved) = {set = System.Collections.Generic.HashSet(unresolved, HashIdentity.Structural)} @@ -1744,16 +1751,16 @@ module internal DebuggerEnvironment = [] -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 @@ -1763,7 +1770,7 @@ type (* internal *) DependencyChangeCode = /// Callback that indicates whether a requested result has become obsolete. [] -type (* internal *) IsResultObsolete = +type internal IsResultObsolete = | IsResultObsolete of (unit->bool) @@ -2169,7 +2176,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 0a5a0d8585..6c850344bd 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 = [] // 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 = [] // 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[] [] -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 [] -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 [] /// 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. [] -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. [] -type (* internal *) TypeCheckAnswer = +type internal TypeCheckAnswer = | NoAntecedant | Aborted // because result was obsolete | TypeCheckSucceeded of TypeCheckResults [] [] -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 31ab2cddfe..25c33bdcae 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/source-build-version b/src/source-build-version deleted file mode 100755 index 7b9cc56c6e..0000000000 --- a/src/source-build-version +++ /dev/null @@ -1 +0,0 @@ -2.9.9.999 \ No newline at end of file diff --git a/src/source-build-version-2.3.0.0 b/src/source-build-version-2.3.0.0 deleted file mode 100755 index e7a4af9545..0000000000 --- a/src/source-build-version-2.3.0.0 +++ /dev/null @@ -1 +0,0 @@ -2.3.0.0 \ No newline at end of file diff --git a/src/source-build-version-2.3.5.0 b/src/source-build-version-2.3.5.0 deleted file mode 100755 index bb2f148bfd..0000000000 --- a/src/source-build-version-2.3.5.0 +++ /dev/null @@ -1 +0,0 @@ -2.3.5.0 \ No newline at end of file diff --git a/src/source-build-version-4.3.0.0 b/src/source-build-version-4.3.0.0 deleted file mode 100755 index 61e257ab07..0000000000 --- a/src/source-build-version-4.3.0.0 +++ /dev/null @@ -1 +0,0 @@ -4.3.0.0 \ No newline at end of file diff --git a/src/utils/CompilerLocationUtils.fs b/src/utils/CompilerLocationUtils.fs index 3a90fe8279..e6b42133c6 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" + [] extern uint32 RegOpenKeyExW(UIntPtr _hKey, string _lpSubKey, uint32 _ulOptions, int _samDesired, UIntPtr & _phkResult); @@ -239,7 +251,7 @@ module internal FSharpEnvironment = // On windows the location of the compiler is via a registry key let key20 = @"Software\Microsoft\FSharp\2.0\Runtime\v4.0" - let key40 = @"Software\Microsoft\FSharp\3.0\Runtime\v4.0" + let key40 = @"Software\Microsoft\FSharp\3.1\Runtime\v4.0" let key1,key2 = match FSharpCoreLibRunningVersion with | None -> key40,key20 @@ -307,10 +319,12 @@ module internal FSharpEnvironment = // Check if the framework version 4.5 or above is installed at the given key entry let IsNetFx45OrAboveInstalledAt subkey = + try useKey subkey (fun regkey -> match regkey with | null -> false | _ -> regkey.GetValue("Release", 0) :?> int |> (fun s -> s >= 0x50000)) // 0x50000 implies 4.5.0 + with _ -> false // Check if the framework version 4.5 or above is installed let IsNetFx45OrAboveInstalled = diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index e5c8a0f507..306ae7628b 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 b34b19991b..a3547f3476 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 [] - (* internal *) LexBuffer<'Char>(filler: LexBufferFiller<'Char>) = + (*internal*) LexBuffer<'Char>(filler: LexBufferFiller<'Char>) = let context = new Dictionary(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 2d0782b102..f0b887eccc 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 [] -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 = [] /// Input buffers consumed by lexers generated by fslex.exe -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/prim-parsing.fs b/src/utils/prim-parsing.fs index a542980103..466af17e88 100755 --- a/src/utils/prim-parsing.fs +++ b/src/utils/prim-parsing.fs @@ -22,7 +22,7 @@ exception RecoverableParseError exception Accept of obj [] -type internal IParseState(ruleStartPoss:Position[],ruleEndPoss:Position[],lhsPos:Position[],ruleValues:obj[],lexbuf:LexBuffer) = +type (*internal*) IParseState(ruleStartPoss:Position[],ruleEndPoss:Position[],lhsPos:Position[],ruleValues:obj[],lexbuf:LexBuffer) = member p.LexBuffer = lexbuf member p.InputRange n = ruleStartPoss.[n-1], ruleEndPoss.[n-1]; member p.InputStartPosition n = ruleStartPoss.[n-1] diff --git a/src/utils/prim-parsing.fsi b/src/utils/prim-parsing.fsi index 75f9558f95..6943e8d796 100755 --- a/src/utils/prim-parsing.fsi +++ b/src/utils/prim-parsing.fsi @@ -16,7 +16,7 @@ open Internal.Utilities.Text.Lexing open System.Collections.Generic [] -type internal IParseState = +type (*internal*) IParseState = /// Get the start and end position for the terminal or non-terminal at a given index matched by the production member InputRange: index:int -> Position * Position /// Get the end position for the terminal or non-terminal at a given index matched by the production diff --git a/src/utils/sformat.fs b/src/utils/sformat.fs index 83ca4cbf58..dbb2d0b14f 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 +#else + let methInfo = typ.GetMethod("ToString",[| |]) methInfo.DeclaringType = typeof +#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. Note: "null" is never a valid list value. *) + | ConstructorValue (constr,recd) when // x is List. 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, 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 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 8491c03713..b5bed4e028 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 diff --git a/tests/ChompErr.bat b/tests/ChompErr.bat new file mode 100644 index 0000000000..b7eadaac58 --- /dev/null +++ b/tests/ChompErr.bat @@ -0,0 +1,31 @@ +@if "%_echo%"=="" echo off +if /I %1 EQU 0 ( goto Skip ) + +if not defined _UNATTENDEDLOG ( goto Exit ) + +echo ERRORLEVEL=%1: in %2 >> %_UNATTENDEDLOG% +echo current directory is %CD% >> %_UNATTENDEDLOG% +:LOG_ERRORS +if "%~3"=="" ( +echo. >> %_UNATTENDEDLOG% +exit /b 0 +) +echo "%~3" >> %_UNATTENDEDLOG% +shift /3 +goto LOG_ERRORS + + +:Skip +exit /b 0 + +:Exit +echo ERRORLEVEL= %1 : in %2 +echo current directory is %CD% +:ECHO_ERRORS +if "%~3"=="" ( +echo +exit /b 1 +) +echo %~3 +shift /3 +goto ECHO_ERRORS diff --git a/tests/build-and-run.bat b/tests/build-and-run.bat new file mode 100644 index 0000000000..5fbf4e914d --- /dev/null +++ b/tests/build-and-run.bat @@ -0,0 +1,52 @@ +@if "%_echo%"=="" echo off + +setlocal +set _ScriptHome=%~dp0% + +if "%_UNATTENDEDLOG%"== "" set _UNATTENDEDLOG=%~dp0%\build-and-run.log +echo Start: >_UNATTENDEDLOG + +if exist tdirs ( + for /f %%i in (tdirs) do ( + if exist "%%i" ( + pushd %%i + echo ************************************************** + cd + cd >> %_UNATTENDEDLOG% + echo ************************************************** + call %_ScriptHome%\build-and-run.bat + if ERRORLEVEL 1 goto Exit + popd + ) + ) +) + +if NOT exist tdirs ( + if exist build.bat ( + call .\build.bat + if ERRORLEVEL 1 exit /b 1 + ) + + if exist run.bat ( + call .\run.bat + if ERRORLEVEL 1 exit /b 1 + ) + + if NOT exist build.bat ( + if NOT exist run.bat ( + echo FAILURE: build.bat and run.bat not found. Check %CD%\..\tdirs + call .\build.bat > NUL 2>&1 + if ERRORLEVEL 1 goto Error + ) + ) +) + +:Exit +endlocal + +exit /b %ERRORLEVEL% + +:Error +call %_ScriptHome%\ChompErr.bat %ERRORLEVEL% %~f0 +endlocal +exit /b %ERRORLEVEL% \ No newline at end of file diff --git a/tests/build.bat b/tests/build.bat new file mode 100644 index 0000000000..69bef2d8d0 --- /dev/null +++ b/tests/build.bat @@ -0,0 +1,37 @@ +@if "%_echo%"=="" echo off + +setlocal +set _ScriptHome=%~dp0% + +if exist tdirs ( + for /f %%i in (tdirs) do ( + if exist %%i ( + pushd %%i + echo ************************************************** + cd + echo ************************************************** + call %_ScriptHome%\build.bat + if ERRORLEVEL 1 goto Error + popd + ) + ) +) + +if NOT exist tdirs ( + if exist build.bat ( + call .\build.bat + if ERRORLEVEL 1 goto Error + ) +) + +echo Built fsharp ok. +:Ok +endlocal +exit /b 0 + +:Error +endlocal +exit /b %ERRORLEVEL% + + + diff --git a/tests/config.bat b/tests/config.bat new file mode 100644 index 0000000000..4929b12332 --- /dev/null +++ b/tests/config.bat @@ -0,0 +1,288 @@ +@if "%_echo%"=="" echo off + +set _SCRIPT_DRIVE=%~d0 +set _SCRIPT_PATH=%~p0 +set SCRIPT_ROOT=%_SCRIPT_DRIVE%%_SCRIPT_PATH% + +if not defined FSHARP_HOME set FSHARP_HOME=%SCRIPT_ROOT%..\.. + +for /f %%i in ("%FSHARP_HOME%") do set FSHARP_HOME=%%~fi + +REM Do we know where fsc.exe is? +IF DEFINED FSCBinPath goto :FSCBinPathFound +FOR /F "delims=" %%i IN ('where fsc.exe') DO IF NOT DEFINED FSCBinPath SET FSCBinPath=%%~dpi +:FSCBinPathFound + +SET CLIFLAVOUR=cli\4.5 + +if not defined FSCBinPath set FSCBinPath=%FSHARP_HOME%\Retail\%CLIFLAVOUR%\bin + +if not exist "%FSCBinPath%\fsc.exe" echo %FSCBinPath%\fsc.exe not found. Assume that this is a lab QA run machine, with product installed. +if not exist "%FSCBinPath%\fsc.exe" call :SetFSCBinPath45 + +if not exist "%FSCBinPath%\fsc.exe" echo %FSCBinPath%\fsc.exe still not found. Assume that user has added it to path somewhere + +REM strip extra file separators and make short-name in case the the location is "Program Files" (how i hate spaces in file names!) +if defined FSCBinPath for /f "delims=" %%l in ("%FSCBinPath%") do set FSCBinPath=%%~fsl + +REM add %FSCBinPath% to path only if not already there. Otherwise, the path keeps growing. +echo %path%; | find /i "%FSCBinPath%;" > NUL +if ERRORLEVEL 1 set PATH=%PATH%;%FSCBinPath% + +if "%FSDIFF%"=="" set FSDIFF=%SCRIPT_ROOT%fsharpqa\testenv\bin\%processor_architecture%\diff.exe -dew + +rem check if we're already configured, if not use the configuration from the last line of the config file +if "%fsc%"=="" ( + set csc_flags=/nologo + set fsiroot=fsi +) + +if not defined ALINK set ALINK=al.exe +if not defined CSC set CSC=csc.exe %csc_flags% + +REM SDK Dependencires. +if not defined ILDASM set ILDASM=ildasm.exe +if not defined GACUTIL set GACUTIL=gacutil.exe +if not defined PEVERIFY set PEVERIFY=peverify.exe +if not defined RESGEN set RESGEN=resgen.exe + +if "%fsiroot%" == "" ( set fsiroot=fsi) + +REM == Test strategy: if we are on a 32bit OS => use fsi.exe +REM == if we are on a 64bit OS => use fsiAnyCPU.exe +REM == This way we get coverage of both binaries without having to +REM == double the test matrix. Note that our nightly automation +REM == always cover x86 and x64... so we won't miss much. There +REM == is an implicit assumption that the CLR will do it's job +REM == to make an FSIAnyCPU.exe behave as FSI.exe on a 32bit OS. +REM == On 64 bit machines ensure that we run the 64 bit versions of tests too. +SET OSARCH=%PROCESSOR_ARCHITECTURE% +IF NOT "%PROCESSOR_ARCHITEW6432%"=="" SET OSARCH=%PROCESSOR_ARCHITEW6432% +IF "%fsiroot%"=="fsi" IF NOT "%OSARCH%"=="x86" ( + SET fsiroot=fsiAnyCPU + set FSC_BASIC_64=FSC_BASIC_64 +) + +REM --------------------------------------------------------------- +REM If we set a "--cli-version" flag anywhere in the flags then assume its v1.x +REM and generate a config file, so we end up running the test on the right version +REM of the CLR. Also modify the CORSDK used. +REM +REM Use CLR 1.1 at a minimum since 1.0 is not installed on most of my machines + +REM otherwise assume v2.0 +REM TODO: we need to update this to be v2.0 or v3.5 and nothing else. + +set fsc_flags=%fsc_flags% + +set CLR_SUPPORTS_GENERICS=true +set ILDASM=%ILDASM% +set GACUTIL=%GACUTIL% +set CLR_SUPPORTS_WINFORMS=true +set CLR_SUPPORTS_SYSTEM_WEB=true + +REM == +REM == F# v1.0 targets NetFx3.5 (i.e. NDP2.0) +REM == It is ok to hardcode the location, since this is not going to +REM == change ever. Well, if/when we target a different runtime we'll have +REM == to come and update this, but for now we MUST make sure we use the 2.0 stuff. +REM == +REM == If we run on a 64bit machine (from a 64bit command prompt!), we use the 64bit +REM == CLR, but tweaking 'Framework' to 'Framework64'. +REM == +set CORDIR=%SystemRoot%\Microsoft.NET\Framework\v2.0.50727\ + +set CORDIR40= +FOR /D %%i IN (%windir%\Microsoft.NET\Framework\v4.0.?????) do set CORDIR40=%%i +IF NOT "%CORDIR40%"=="" set CORDIR=%CORDIR40% + +REM == Use the same runtime as our architecture +REM == ASSUMPTION: This could be a good or bad thing. +IF /I NOT "%PROCESSOR_ARCHITECTURE%"=="x86" set CORDIR=%CORDIR:Framework=Framework64% + +REM == +REM == Find out path to NDP SDK (on a standard F# v1.0 run, this should be one of: +REM == - NDP2.0 SDK (NetFx2.0 SDK) +REM == - WinSDK 6.0A (VS2008) +REM == - WinSDK 6.1 (Vista WinSDK) +REM == - WinSDK 7.0A (Dev10) +REM == - WinSDK 8.0A (Dev11) +REM == - WinSDK 8.1A (Dev12) +REM == ==> we need to peverify against NET 2.0 (F# VS2008) or 4.0/4.5/4.5.1 (F# Dev12) +REM == +REM == Try Windows SDK 6.x or 7.x +@reg>NUL 2>&1 QUERY "HKLM\Software\Microsoft\Microsoft SDKs\Windows" /v CurrentInstallFolder +IF ERRORLEVEL 1 goto :TryNDPSDK20 + +IF /I "%PROCESSOR_ARCHITECTURE%"=="AMD64" ( + FOR /F "tokens=2*" %%A IN ('reg QUERY "HKLM\Software\Wow6432Node\Microsoft\Microsoft SDKs\Windows\v8.1A\WinSDK-NetFx40Tools" /v InstallationFolder') DO SET CORSDK=%%B +) ELSE ( + FOR /F "tokens=2*" %%A IN ('reg QUERY "HKLM\Software\Microsoft\Microsoft SDKs\Windows\v8.1A\WinSDK-NetFx40Tools" /v InstallationFolder') DO SET CORSDK=%%B +) + +IF "%CORSDK%"=="" FOR /F "tokens=2*" %%A IN ('reg QUERY "HKLM\Software\Microsoft\Microsoft SDKs\Windows" /v CurrentInstallFolder') DO SET CORSDK=%%BBin +IF NOT "%CORDIR40%"=="" IF EXIST "%CORSDK%\NETFX 4.0 Tools" set CORSDK=%CORSDK%\NETFX 4.0 Tools + +REM == Fix up CORSDK for 64bit platforms... +IF /I "%PROCESSOR_ARCHITECTURE%"=="AMD64" SET CORSDK=%CORSDK%\x64 +IF /I "%PROCESSOR_ARCHITECTURE%"=="IA64" SET CORSDK=%CORSDK%\IA64 +goto :DoneCORSDK + +REM == Try NDP2.0 SDK +:TryNDPSDK20 +@reg>NUL 2>&1 QUERY "HKLM\Software\Microsoft\.NETFramework" /v sdkInstallRootv2.0 +IF NOT ERRORLEVEL 0 @echo NDPSDK Not Found!&&goto :TryNDPSDK20 +FOR /F "tokens=2*" %%A IN ('reg QUERY "HKLM\Software\Microsoft\.NETFramework" /v sdkInstallRootv2.0') DO SET CORSDK=%%BBin +goto :DoneCORSDK + +:DoneCORSDK + +REM add powerpack to flags only if not already there. Otherwise, the variable can keep growing. +echo %fsc_flags% | find /i "powerpack" +if ERRORLEVEL 1 set fsc_flags=%fsc_flags% -r:System.Core.dll --nowarn:20 + +if not defined fsi_flags set fsi_flags=%fsc_flags:--define:COMPILED=% --define:INTERACTIVE --maxerrors:1 --abortonerror + +echo %fsc_flags%; | find "--define:COMPILED" > NUL || ( + set fsc_flags=%fsc_flags% --define:COMPILED +) + +if NOT "%fsc_flags:generate-config-file=X%"=="%fsc_flags%" ( + if NOT "%fsc_flags:clr-root=X%"=="%fsc_flags%" ( + set fsc_flags=%fsc_flags% --clr-root:%CORDIR% + ) +) + +if "%CORDIR%"=="unknown" set CORDIR= + +REM use short names in the path so you don't have to deal with the space in things like "Program Files" +for /f "delims=" %%I in ("%CORSDK%") do set CORSDK=%%~dfsI% +for /f "delims=" %%I in ("%CORDIR%") do set CORDIR=%%~dfsI% + +set NGEN= + +REM == +REM == Set path to C# compiler. If we are NOT on NetFx4.0, try we prefer C# 3.5 to C# 2.0 +REM == This is because we have tests that reference System.Core.dll from C# code! +REM == (e.g. fsharp\core\fsfromcs) +REM == + IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\csc.exe" SET CSC="%CORDIR%\csc.exe" %csc_flags% +IF "%CORDIR40%"=="" IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\..\V3.5\csc.exe" SET CSC="%CORDIR%\..\v3.5\csc.exe" %csc_flags% + +IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\ngen.exe" SET NGEN=%CORDIR%\ngen.exe +IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\al.exe" SET ALINK=%CORDIR%\al.exe + +REM == +REM == The logic here is: pick the latest msbuild +REM == If we are testing against NDP4.0, then don't try msbuild 3.5 +REM == +IF NOT "%CORSDK%"=="" IF EXIST "%CORSDK%\ildasm.exe" SET ILDASM=%CORSDK%\ildasm.exe +IF NOT "%CORSDK%"=="" IF EXIST "%CORSDK%\gacutil.exe" SET GACUTIL=%CORSDK%\gacutil.exe +IF NOT "%CORSDK%"=="" IF EXIST "%CORSDK%\peverify.exe" SET PEVERIFY=%CORSDK%\peverify.exe +IF NOT "%CORSDK%"=="" IF EXIST "%CORSDK%\resgen.exe" SET RESGEN=%CORSDK%\resgen.exe +IF NOT "%CORSDK%"=="" IF EXIST "%CORSDK%\al.exe" SET ALINK=%CORSDK%\al.exe + +IF NOT DEFINED FSC SET FSC=fsc.exe +IF NOT DEFINED FSI SET FSI=%fsiroot%.exe + +IF DEFINED FSCBinPath IF EXIST "%FSCBinPath%\fsc.exe" SET FSC=%FSCBinPath%\fsc.exe +IF DEFINED FSCBinPath IF EXIST "%FSCBinPath%\%fsiroot%.exe" SET FSI=%FSCBinPath%\%fsiroot%.exe + +REM == In Dev11 (layout setup), FSharp.Core.dll is not sitting next to fsc.exe +REM == so we provide an alternative location to look for it. Automation will check +REM == this value (which may or may not be defined) and decide to use it. +set FSCOREDLLPATH= +set FSCOREDLL20PATH= +call :GetFSCOREDLLPaths + +IF EXIST "%FSCBinPath%\FSharp.Core.dll" set FSCOREDLLPATH=%FSCBinPath% +set FSCOREDLLPATH=%FSCOREDLLPATH%\FSharp.Core.dll + +set FSCOREDLL20PATH=%FSCOREDLL20PATH%\FSharp.Core.dll +IF EXIST "%FSCBinPath%net20\FSharp.Core.dll" set FSCOREDLL20PATH=%FSCBinPath%net20\FSharp.Core.dll +IF EXIST "%FSCBinPath%Runtime\2.0\FSharp.Core.dll" set FSCOREDLL20PATH=%FSCBinPath%Runtime\2.0\FSharp.Core.dll + +REM == Set standard flags for invoking powershell scripts +IF NOT DEFINED PSH_FLAGS SET PSH_FLAGS=-nologo -noprofile -executionpolicy bypass + +if DEFINED _UNATTENDEDLOG exit /b 0 + +rem first see if we have got msbuild installed +if exist "%X86_PROGRAMFILES%\MSBuild\12.0\Bin\MSBuild.exe" SET MSBuildToolsPath=%X86_PROGRAMFILES%\MSBuild\12.0\Bin\ +if not "%MSBuildToolsPath%" == "" goto done_MsBuildToolsPath + + IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\msbuild.exe" SET MSBuildToolsPath=%CORDIR% +IF "%CORDIR40%"=="" IF NOT "%CORDIR%"=="" IF EXIST "%CORDIR%\..\V3.5\msbuild.exe" SET MSBuildToolsPath="%CORDIR%\..\V3.5\" + +IF NOT "%CORDIR%"=="" FOR /f %%j IN ("%MSBuildToolsPath%") do SET MSBuildToolsPath=%%~fj +:done_MsBuildToolsPath + +echo --------------------------------------------------------------- +echo Executables +echo. +echo ALINK =%ALINK% +echo CORDIR =%CORDIR% +echo CORSDK =%CORSDK% +echo CSC =%CSC% +echo csc_flags =%csc_flags% +echo FSC =%FSC% +echo fsc_flags =%fsc_flags% +echo FSCBinPath =%FSCBinPath% +echo FSCOREDLL20PATH =%FSCOREDLL20PATH% +echo FSCOREDLLPATH =%FSCOREDLLPATH% +echo FSDIFF =%FSDIFF% +echo FSI =%FSI% +echo fsi_flags =%fsi_flags% +echo GACUTIL =%GACUTIL% +echo ILDASM =%ILDASM% +echo MSBUILDTOOLSPATH =%MSBuildToolsPath% +echo NGEN =%ngen% +echo PEVERIFY =%PEVERIFY% +echo RESGEN =%RESGEN% +echo --------------------------------------------------------------- + +exit /b 0 + +REM === +REM === Find path to FSC/FSI looking up the registry +REM === Will set the FSCBinPath env variable. +REM === This if for Dev11+/NDP4.5 +REM === Works on both XP and Vista and hopefully everything else +REM === Works on 32bit and 64 bit, no matter what cmd prompt it is invoked from +REM === +:SetFSCBinPath45 + +reg>NUL 2>&1 query "HKLM\SOFTWARE\Microsoft\FSharp\3.1\Runtime\v4.0" /ve +IF ERRORLEVEL 1 goto :Try64bit +FOR /F "tokens=1-2*" %%a IN ('reg query "HKLM\SOFTWARE\Microsoft\FSharp\3.1\Runtime\v4.0" /ve') DO set FSCBinPath=%%c +IF EXIST "%FSCBinPath%" goto :EOF +FOR /F "tokens=1-3*" %%a IN ('reg query "HKLM\SOFTWARE\Microsoft\FSharp\3.1\Runtime\v4.0" /ve') DO set FSCBinPath=%%d +goto :EOF + +:Try64bit +FOR /F "tokens=1-2*" %%a IN ('reg query "HKLM\SOFTWARE\Wow6432Node\Microsoft\FSharp\3.1\Runtime\v4.0" /ve') DO set FSCBinPath=%%c +IF EXIST "%FSCBinPath%" goto :EOF +FOR /F "tokens=1-3*" %%a IN ('reg query "HKLM\SOFTWARE\Wow6432Node\Microsoft\FSharp\3.1\Runtime\v4.0" /ve') DO set FSCBinPath=%%d + +goto :EOF + +REM === +REM === Find path to FSharp.Core.dll (in Dev11, this is under Reference Assemblies\Microsoft\FSharp\3.0\Runtime\v4.0 and v2.0) +REM === in Dev12, this is under Reference Assemblies\Microsoft\FSharp\{.NETFramework|.NETCore|.NETPortable}\... +REM === +:GetFSCOREDLLPaths + +REM == Find out OS architecture, no matter what cmd prompt +SET OSARCH=%PROCESSOR_ARCHITECTURE% +IF NOT "%PROCESSOR_ARCHITEW6432%"=="" SET OSARCH=%PROCESSOR_ARCHITEW6432% + +REM == Find out path to native 'Program Files 32bit', no matter what +REM == architecture we are running on and no matter what command +REM == prompt we came from. +IF /I "%OSARCH%"=="x86" set X86_PROGRAMFILES=%ProgramFiles% +IF /I "%OSARCH%"=="IA64" set X86_PROGRAMFILES=%ProgramFiles(x86)% +IF /I "%OSARCH%"=="AMD64" set X86_PROGRAMFILES=%ProgramFiles(x86)% + +REM == Set path to v2.0 and v4.0 FSharp.Core.dll (4.0 is the default) +set FSCOREDLLPATH=%X86_PROGRAMFILES%\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.3.1.0 +set FSCOREDLL20PATH=%X86_PROGRAMFILES%\Reference Assemblies\Microsoft\FSharp\.NETFramework\v2.0\2.3.0.0 \ No newline at end of file diff --git a/tests/fsharp/DecidePEVerify.ps1 b/tests/fsharp/DecidePEVerify.ps1 new file mode 100644 index 0000000000..88676f0076 --- /dev/null +++ b/tests/fsharp/DecidePEVerify.ps1 @@ -0,0 +1,18 @@ +param( + [string] $testPath, + [string] $fscPath +) + +$errorActionPreference = 'Stop' + +if(-not (Test-Path "$testPath\dont.run.peverify")) +{ + # seed for random selection is based on build # and test area + # this ensures re-runs are predictable, but different test areas get different random choices + $seed = (dir $fscPath).VersionInfo.FileBuildPart -bxor $testPath.GetHashCode() + + # 50% chance that we will skip PEVerify step + $skipPEVerify = (Get-Random -SetSeed $seed) % 2 + + if($skipPEVerify){ 'Randomly decided not to do peverify' | out-file "$testPath\dont.run.peverify" } +} \ No newline at end of file diff --git a/tests/fsharp/PickPermutations.ps1 b/tests/fsharp/PickPermutations.ps1 new file mode 100644 index 0000000000..b31532a086 --- /dev/null +++ b/tests/fsharp/PickPermutations.ps1 @@ -0,0 +1,31 @@ +param( + [string] $testPath, # path to test directory + [string] $fscPath, # path to FSC.exe + [string] $allPermutations # space-delimited list of all permutation labels +) + +$errorActionPreference = 'Stop' + +# some permutations do not apply to all test areas +# we don't want to randomly pick a permutation which does not apply to the current test area +$specialCaseCriteria = @{ + 'FSC_HW' = (Test-Path "$testPath\test-hw.*") + 'FSC_BASIC_64' = ($env:PROCESSOR_ARCHITECTURE -eq 'AMD64') + 'GENERATED_SIGNATURE' = ((Test-Path "$testPath\test.ml") -and (-not (Test-Path "$testPath\dont.use.generated.signature"))) + 'EMPTY_SIGNATURE' = ((Test-Path "$testPath\test.ml") -and (-not (Test-Path "$testPath\dont.use.empty.signature"))) + 'EMPTY_SIGNATURE_OPT' = ((Test-Path "$testPath\test.ml") -and (-not (Test-Path "$testPath\dont.use.empty.signature"))) + 'AS_DLL' = (-not (Test-Path "$testPath\dont.compile.test.as.dll")) + 'WRAPPER_NAMESPACE' = ((Test-Path "$testPath\test.ml") -and (-not (Test-Path "$testPath\dont.use.wrapper.namespace"))) + 'WRAPPER_NAMESPACE_OPT' = ((Test-Path "$testPath\test.ml") -and (-not (Test-Path "$testPath\dont.use.wrapper.namespace"))) + 'FSI_FILE' = (-not (Test-Path "$testPath\dont.run.as.script")) + 'FSI_STDIN' = (-not (Test-Path "$testPath\dont.pipe.to.stdin")) + 'FSI_STDIN_OPT' = (-not (Test-Path "$testPath\dont.pipe.to.stdin")) + 'FSI_STDIN_GUI' = (-not (Test-Path "$testPath\dont.pipe.to.stdin")) +} + +# seed for random selection is based on build # and test area +# this ensures re-runs are predictable, but different test areas get different random choices +$seed = (dir $fscPath).VersionInfo.FileBuildPart -bxor $testPath.GetHashCode() +$permutations = ($allPermutations -split '\s+') |?{ $specialCaseCriteria[$_] -ne $false } | Get-Random -SetSeed $seed + +$permutations -join ' ' \ No newline at end of file diff --git a/tests/fsharp/core/access/build.bat b/tests/fsharp/core/access/build.bat new file mode 100644 index 0000000000..a6ff3718fe --- /dev/null +++ b/tests/fsharp/core/access/build.bat @@ -0,0 +1,6 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-build.bat + +exit /b %ERRORLEVEL% + diff --git a/tests/fsharp/core/access/run.bat b/tests/fsharp/core/access/run.bat new file mode 100644 index 0000000000..ceb0a61a54 --- /dev/null +++ b/tests/fsharp/core/access/run.bat @@ -0,0 +1,7 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-run.bat + +exit /b %ERRORLEVEL% + + diff --git a/tests/fsharp/core/access/test.fsx b/tests/fsharp/core/access/test.fsx new file mode 100644 index 0000000000..ea25ba3be9 --- /dev/null +++ b/tests/fsharp/core/access/test.fsx @@ -0,0 +1,284 @@ +// #Regression #Conformance #Accessibility #SignatureFiles #Regression #Records #Unions +#if ALL_IN_ONE +module Core_access +#endif + +#light +let failures = ref [] + +let report_failure (s : string) = + stderr.Write" NO: " + stderr.WriteLine s + failures := !failures @ [s] + +let test (s : string) b = + stderr.Write(s) + if b then stderr.WriteLine " OK" + else report_failure (s) + +(*--------------------*) + +// Test cases for bug://1562 +// Checking that generated signature can be compiled against the file. + +type internal typInternal = | AAA1 +type private typPrivate = | AAA2 +type public typPublic = | AAA3 +type typDefault = | AAA4 +type internal rrr = | AAA + +let internal ValInternal = 1212 +let private ValPrivate = 1212 +let public ValPublic = 1212 +let ValDefault = 1212 + +type MyClassFields = + val internal fieldInternal : int + val private fieldPrivate : int + val public fieldPublic : int + +type MyClassMutableFields = + val mutable internal mfieldInternal : int + val mutable private mfieldPrivate : int + val mutable public mfieldPublic : int + +type MyClassStaticMembers = + static member internal SInternal = 12 + static member private SPrivate = 12 + static member public SPublic = 12 + static member SDefault = 12 + static member internal SMInternal() = 12 + static member private SMPrivate() = 12 + static member public SMPublic() = 12 + static member SMDefault() = 12 + +type MyClassPropertiyGetters = + member internal x.InstInternal = 12 + member private x.InstPrivate = 12 + member public x.InstPublic = 12 + member x.InstDefault = 12 + +type MyClassExplicitCtors = + val v : int + internal new(x) = { v = x } + private new(x,y) = { v = x + y} + public new(x,y,z) = { v = x + y + z} + +type MyClassExplicitCtors2 = + new() = {} + internal new(x) = let v : int = x in {} + private new(x,y) = let v : int = x + y in {} + public new(x,y,z) = let v : int = x + y + z in {} + +type MyClassPropertyGetSetterMatrix = + //-- + member obj.PropGetSetInternalInternal + with internal get() = 1 + and internal set(x:int) = () + member obj.PropGetSetInternalPrivate + with internal get() = 1 + and private set(x:int) = () + member obj.PropGetSetInternalPublic + with internal get() = 1 + and public set(x:int) = () + //-- + member obj.PropGetSetPrivateInternal + with private get() = 1 + and internal set(x:int) = () + member obj.PropGetSetPrivatePrivate + with private get() = 1 + and private set(x:int) = () + member obj.PropGetSetPrivatePublic + with private get() = 1 + and public set(x:int) = () + //-- + member obj.PropGetSetPublicInternal + with public get() = 1 + and internal set(x:int) = () + member obj.PropGetSetPublicPrivate + with public get() = 1 + and private set(x:int) = () + member obj.PropGetSetPublicPublic + with public get() = 1 + and public set(x:int) = () + +type MyClassImplicitCtorInternal internal() = + member obj.Res = 12 + +type MyClassImplicitCtorPrivate private() = + member obj.Res = 12 + +module internal ModInternal = begin end +module private ModPrivate = begin end +module public ModPublic = begin end + +type recordRepInternal = internal { rfA1 : int } +type recordRepPrivate = private { rfA2 : int } +type recordRepPublic = public { rfA3 : int } + +type dtypeRepInternal = internal | AA1 | BB1 +type dtypeRepPrivate = private | AA2 | BB2 +type dtypeRepPublic = public | AA3 | BB3 + +type internal dtypeRepPublic2 = private | AA3 | BB3 +type private dtypeRepPublic3 = internal | AA3 | BB3 + +type internal dtypeRepPublic4 = + private + | AA3 + | BB3 + +module internal M = + module private PP = + type dtypeRepPublic5 = + | AA3 + | BB3 + +module private M2 = + module internal P = + let vv = 12 + + +module RestrictedRecordsAndUnionsUsingPrivateAndInternalTypes = + + module public Test1 = + + type internal Data = + { + Datum: int + } + + type public Datum = + internal + { + Thing: Data + } + + type public Datum2 = + internal | A of Data * Data | B of Data + + module public Test2 = + + type internal Data = + { + Datum: int + } + + type internal Datum = + { + Thing: Data + } + + type internal Datum2 = + | A of Data * Data | B of Data + + module public Test3 = + + type public Data = + internal + { + Datum: int + } + + type internal Datum = + { + Thing: Data + } + + type internal Datum2 = + internal | A of Data * Data | B of Data + + + module public Test4 = + + type internal Data = + { + Datum: int + } + + type public Datum = + internal + { + Thing: Data + } + + type public Datum2 = + internal | A of Data * Data | B of Data + + + module public Test5 = + + type private Data = + { + Datum: int + } + + type public Datum = + private + { + Thing: Data + } + + type public Datum2 = + private | A of Data * Data | B of Data + + + module Test6 = + module internal HelperModule = + + type public Data = + private + { + Datum: int + } + + let internal handle (data:Data): int = data.Datum + + module public Module = + + type public Data = + private + { + Thing: HelperModule.Data + } + + let public getInt (data:Data): int = HelperModule.handle data.Thing + + module Test7 = + module internal HelperModule = + + type Data = + { + Datum: int + } + + let handle (data:Data): int = data.Datum + + module Module = + + type Data = + internal + { + Thing: HelperModule.Data + } + + let getInt (data:Data): int = HelperModule.handle data.Thing + + + (*--------------------*) + + +#if ALL_IN_ONE +let RUN() = !failures +#else +let aa = + match !failures with + | [] -> + stdout.WriteLine "Test Passed" + System.IO.File.WriteAllText("test.ok","ok") + exit 0 + | _ -> + stdout.WriteLine "Test Failed" + exit 1 +#endif + diff --git a/tests/fsharp/core/apporder/build.bat b/tests/fsharp/core/apporder/build.bat new file mode 100644 index 0000000000..a6ff3718fe --- /dev/null +++ b/tests/fsharp/core/apporder/build.bat @@ -0,0 +1,6 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-build.bat + +exit /b %ERRORLEVEL% + diff --git a/tests/fsharp/core/apporder/run.bat b/tests/fsharp/core/apporder/run.bat new file mode 100644 index 0000000000..ceb0a61a54 --- /dev/null +++ b/tests/fsharp/core/apporder/run.bat @@ -0,0 +1,7 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-run.bat + +exit /b %ERRORLEVEL% + + diff --git a/tests/fsharp/core/apporder/test.fsx b/tests/fsharp/core/apporder/test.fsx new file mode 100644 index 0000000000..3af1d46a47 --- /dev/null +++ b/tests/fsharp/core/apporder/test.fsx @@ -0,0 +1,951 @@ +// #Conformance #Constants #Recursion #LetBindings #MemberDefinitions #Mutable +#if ALL_IN_ONE +module Core_apporder +#endif + +#light +let failures = ref [] + +let report_failure (s : string) = + stderr.Write" NO: " + stderr.WriteLine s + failures := !failures @ [s] + +let test s b = if b then () else report_failure(s) + +(* TEST SUITE FOR Int32 *) + +let out r (s:string) = r := !r @ [s] + +let check s v1 v2 = + if v1 = v2 then printfn "%s: OK" s + else printfn "%s: FAILED, expected %A, got %A" s v2 v1 + +module CheckMutationOfArgumentValuesInOtherArguments = + let test1232() = + let mutable cell1 = 1 + let f1 x = printfn "hello"; (fun y -> printfn "x = %A, y = %A" x y; (x,y)) + let f2 x y = printfn "x = %A, y = %A" x y; (x,y) + cell1 <- 1 // reset + let res = f1 (cell1 <- 11; cell1) cell1 + check "test1232 - test1" res (11,11) + cell1 <- 1 // reset + let res = f1 cell1 (cell1 <- 21; cell1) + check "test1232 - test2" res (1,21) + cell1 <- 1 // reset + let res = (f1 (cell1 <- 11; cell1)) cell1 + check "test1232 - test3" res (11,11) + cell1 <- 1 // reset + let res = (f1 cell1) (cell1 <- 21; cell1) + check "test1232 - test4" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test5" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test6" res (1,21) + cell1 <- 1 // reset + let res = (f2 cell1) (cell1 <- 21; cell1) + check "test1232 - test7" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test8" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test9" res (1,21) + + test1232() + + let test1233() = + let cell1 = ref 1 + let f1 x = cell1 := 4; (fun y -> printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; (x,y,!cell1)) + let f2 x y = printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; (x,y,!cell1) + cell1 := 1 + let res = f1 (cell1 := 11; !cell1) !cell1 + check "test1233 - test1" res (11,11,4) + cell1 := 1 + let res = (f1 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test2" res (11,4,4) + cell1 := 1 + let res = f1 !cell1 (cell1 := 21; !cell1) + check "test1233 - test3" res (1,21,4) + cell1 := 1 + let res = (f1 !cell1) (cell1 := 21; !cell1) + check "test1233 - test4" res (1,21,21) + cell1 := 1 + let res = f2 (cell1 := 11; !cell1) !cell1 + check "test1233 - test5" res (11,11,11) + cell1 := 1 + let res = (f2 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test6" res (11,11,11) + cell1 := 1 + let res = f2 !cell1 (cell1 := 21; !cell1) + check "test1233 - test7" res (1,21,21) + cell1 := 1 + let res = (f2 !cell1) (cell1 := 21; !cell1) + check "test1233 - test8" res (1,21,21) + + + test1233() + + let test1234() = + let mutable cell1 = 1 + let f1 x = (); (fun y -> (x,y)) + let f2 x y = (x,y) + cell1 <- 1 // reset + let res = f1 (cell1 <- 11; cell1) cell1 + check "test1234 - test1" res (11,11) + cell1 <- 1 // reset + let res = f1 cell1 (cell1 <- 21; cell1) + check "test1234 - test2" res (1,21) + cell1 <- 1 // reset + let res = (f1 (cell1 <- 11; cell1)) cell1 + check "test1234 - test3" res (11,11) + cell1 <- 1 // reset + let res = (f1 cell1) (cell1 <- 21; cell1) + check "test1234 - test4" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1234 - test5" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1234 - test6" res (1,21) + cell1 <- 1 // reset + let res = (f2 cell1) (cell1 <- 21; cell1) + check "test1234 - test7" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1234 - test8" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1234 - test9" res (1,21) + + test1234() + + let test1235() = + let cell1 = ref 1 + let f1 x = cell1 := 4; (fun y -> (* printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; *) (x,y,!cell1)) + let f2 x y = (* printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; *) (x,y,!cell1) + cell1 := 1 + let res = f1 (cell1 := 11; !cell1) !cell1 + check "test1235 - test1" res (11,11,4) + cell1 := 1 + let res = (f1 (cell1 := 11; !cell1)) !cell1 + check "test1235 - test2" res (11,4,4) + cell1 := 1 + let res = f1 !cell1 (cell1 := 21; !cell1) + check "test1235 - test3" res (1,21,4) + cell1 := 1 + let res = (f1 !cell1) (cell1 := 21; !cell1) + check "test1235 - test4" res (1,21,21) + cell1 := 1 + let res = f2 (cell1 := 11; !cell1) !cell1 + check "test1235 - test5" res (11,11,11) + cell1 := 1 + let res = (f2 (cell1 := 11; !cell1)) !cell1 + check "test1235 - test6" res (11,11,11) + cell1 := 1 + let res = f2 !cell1 (cell1 := 21; !cell1) + check "test1235 - test7" res (1,21,21) + cell1 := 1 + let res = (f2 !cell1) (cell1 := 21; !cell1) + check "test1235 - test8" res (1,21,21) + + + test1235() + + +module CheckMutationOfArgumentValuesInOtherArgumentsWithIdFunction = + let test1232() = + let mutable cell1 = 1 + let f1 x = printfn "hello"; (fun y -> printfn "x = %A, y = %A" x y; (x,y)) + let f2 x y = printfn "x = %A, y = %A" x y; (x,y) + cell1 <- 1 // reset + let res = id f1 (cell1 <- 11; cell1) cell1 + check "test1232 - test1" res (11,11) + cell1 <- 1 // reset + let res = id f1 cell1 (cell1 <- 21; cell1) + check "test1232 - test2" res (1,21) + cell1 <- 1 // reset + let res = id (f1 (cell1 <- 11; cell1)) cell1 + check "test1232 - test3" res (11,11) + cell1 <- 1 // reset + let res = id (f1 cell1) (cell1 <- 21; cell1) + check "test1232 - test4" res (1,21) + cell1 <- 1 // reset + let res = id f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test5" res (11,11) + cell1 <- 1 // reset + let res = id f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test6" res (1,21) + cell1 <- 1 // reset + let res = id (f2 cell1) (cell1 <- 21; cell1) + check "test1232 - test7" res (1,21) + cell1 <- 1 // reset + let res = id f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test8" res (11,11) + cell1 <- 1 // reset + let res = id f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test9" res (1,21) + + test1232() + + let test1233() = + let cell1 = ref 1 + let f1 x = cell1 := 4; (fun y -> printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; (x,y,!cell1)) + let f2 x y = printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; (x,y,!cell1) + cell1 := 1 + let res = id f1 (cell1 := 11; !cell1) !cell1 + check "test1233 - test1" res (11,11,4) + cell1 := 1 + let res = id (f1 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test2" res (11,4,4) + cell1 := 1 + let res = id f1 !cell1 (cell1 := 21; !cell1) + check "test1233 - test3" res (1,21,4) + cell1 := 1 + let res = id (f1 !cell1) (cell1 := 21; !cell1) + check "test1233 - test4" res (1,21,21) + cell1 := 1 + let res = id f2 (cell1 := 11; !cell1) !cell1 + check "test1233 - test5" res (11,11,11) + cell1 := 1 + let res = id (f2 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test6" res (11,11,11) + cell1 := 1 + let res = id f2 !cell1 (cell1 := 21; !cell1) + check "test1233 - test7" res (1,21,21) + cell1 := 1 + let res = id (f2 !cell1) (cell1 := 21; !cell1) + check "test1233 - test8" res (1,21,21) + + + test1233() + + let test1234() = + let mutable cell1 = 1 + let f1 x = (); (fun y -> (x,y)) + let f2 x y = (x,y) + cell1 <- 1 // reset + let res = id f1 (cell1 <- 11; cell1) cell1 + check "test1234 - test1" res (11,11) + cell1 <- 1 // reset + let res = id f1 cell1 (cell1 <- 21; cell1) + check "test1234 - test2" res (1,21) + cell1 <- 1 // reset + let res = id (f1 (cell1 <- 11; cell1)) cell1 + check "test1234 - test3" res (11,11) + cell1 <- 1 // reset + let res = id (f1 cell1) (cell1 <- 21; cell1) + check "test1234 - test4" res (1,21) + cell1 <- 1 // reset + let res = id f2 (cell1 <- 11; cell1) cell1 + check "test1234 - test5" res (11,11) + cell1 <- 1 // reset + let res = id f2 cell1 (cell1 <- 21; cell1) + check "test1234 - test6" res (1,21) + cell1 <- 1 // reset + let res = id (f2 cell1) (cell1 <- 21; cell1) + check "test1234 - test7" res (1,21) + cell1 <- 1 // reset + let res = id f2 (cell1 <- 11; cell1) cell1 + check "test1234 - test8" res (11,11) + cell1 <- 1 // reset + let res = id f2 cell1 (cell1 <- 21; cell1) + check "test1234 - test9" res (1,21) + + test1234() + + let test1235() = + let cell1 = ref 1 + let f1 x = cell1 := 4; (fun y -> (* printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; *) (x,y,!cell1)) + let f2 x y = (* printfn "x = %A, y = %A, !cell1 = %A" x y !cell1; *) (x,y,!cell1) + cell1 := 1 + let res = id f1 (cell1 := 11; !cell1) !cell1 + check "test1235 - test1" res (11,11,4) + cell1 := 1 + let res = id (f1 (cell1 := 11; !cell1)) !cell1 + check "test1235 - test2" res (11,4,4) + cell1 := 1 + let res = id f1 !cell1 (cell1 := 21; !cell1) + check "test1235 - test3" res (1,21,4) + cell1 := 1 + let res = id (f1 !cell1) (cell1 := 21; !cell1) + check "test1235 - test4" res (1,21,21) + cell1 := 1 + let res = id f2 (cell1 := 11; !cell1) !cell1 + check "test1235 - test5" res (11,11,11) + cell1 := 1 + let res = id (f2 (cell1 := 11; !cell1)) !cell1 + check "test1235 - test6" res (11,11,11) + cell1 := 1 + let res = id f2 !cell1 (cell1 := 21; !cell1) + check "test1235 - test7" res (1,21,21) + cell1 := 1 + let res = id (f2 !cell1) (cell1 := 21; !cell1) + check "test1235 - test8" res (1,21,21) + + + test1235() + +module AppTwo = + let test1() = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + f (out r "1") (out r "2") + check "(two args at a time) test1" !r ["1"; "2"; "app1"; "app2"] + + let test2() = + let r = ref [] + let f x y = out r "app1"; out r "app2" + f (out r "1") (out r "2") + check "(two args at a time) test2" !r ["1"; "2"; "app1"; "app2"] + + let test3() = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + f (out r "1") (out r "2") + check "(two args at a time) test3" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + f (out r "1") (out r "2") + obj <- f + check "(two args at a time) test1captured" !r ["1"; "2"; "app1"; "app2"] + + let test2captured() = + let r = ref [] + let f x y = out r "app1"; out r "app2" + f (out r "1") (out r "2") + obj <- f + check "(two args at a time) test2captured" !r ["1"; "2"; "app1"; "app2"] + + let test3captured() = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + f (out r "1") (out r "2") + obj <- f + check "(two args at a time) test3captured" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let test1top = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + f (out r "1") (out r "2") + fun () -> check "(two args at a time) test1top" !r ["1"; "2"; "app1"; "app2"] + + let test2top = + let r = ref [] + let f x y = out r "app1"; out r "app2" + f (out r "1") (out r "2") + fun () -> check "(two args at a time) test2top" !r ["1"; "2"; "app1"; "app2"] + + let test3top = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + f (out r "1") (out r "2") + fun () -> check "(two args at a time) test3top" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let r1 = ref [] + let f1 x = out r1 "app1"; (fun y -> out r1 "app2") + let test1mod() = + f1 (out r1 "1") (out r1 "2") + check "(two args at a time) test1mod" !r1 ["1"; "2"; "app1"; "app2"] + + let r2 = ref [] + let f2 x y = out r2 "app1"; out r2 "app2" + let test2mod() = + f2 (out r2 "1") (out r2 "2") + check "(two args at a time) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + let r3 = ref [] + let f3 = out r3 "f0"; (fun x -> out r3 "app1"; (fun y -> out r3 "app2")) + let test3mod() = + f3 (out r3 "1") (out r3 "2") + check "(two args at a time) test3mod" !r3 ["f0"; "1"; "2"; "app1"; "app2"] + + test1() + test2() + test3() + + test1captured() + test2captured() + test3captured() + + test1top() + test2top() + test3top() + + test1mod() + test2mod() + test3mod() + +module AppOne = + let test1() = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + (f (out r "1")) (out r "2") + check "(one arg at a time) test1" !r ["1"; "app1"; "2"; "app2"] + + let test2() = + let r = ref [] + let f x y = out r "app1"; out r "app2" + (f (out r "1")) (out r "2") + check "(one arg at a time) test2" !r ["1"; "2"; "app1"; "app2"] + + let test3() = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + (f (out r "1")) (out r "2") + check "(one arg at a time) test3" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + (f (out r "1")) (out r "2") + obj <- f + check "(one arg at a time) test1captured" !r ["1"; "app1"; "2"; "app2"] + + let test2captured() = + let r = ref [] + let f x y = out r "app1"; out r "app2" + (f (out r "1")) (out r "2") + obj <- f + check "(one arg at a time) test2captured" !r ["1"; "2"; "app1"; "app2"] + + let test3captured() = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + (f (out r "1")) (out r "2") + obj <- f + check "(one arg at a time) test3captured" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let test1top = + let r = ref [] + let f x = out r "app1"; (fun y -> out r "app2") + (f (out r "1")) (out r "2") + fun () -> check "(one arg at a time) test1top" !r ["1"; "app1"; "2"; "app2"] + + let test2top = + let r = ref [] + let f x y = out r "app1"; out r "app2" + (f (out r "1")) (out r "2") + fun () -> check "(one arg at a time) test2top" !r ["1"; "2"; "app1"; "app2"] + + let test3top = + let r = ref [] + let f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + (f (out r "1")) (out r "2") + fun () -> check "(one arg at a time) test3top" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let r1 = ref [] + let f1 x = out r1 "app1"; (fun y -> out r1 "app2") + let test1mod() = + (f1 (out r1 "1")) (out r1 "2") + check "(one arg at a time) test1mod" !r1 ["1"; "app1"; "2"; "app2"] + + let r2 = ref [] + let f2 x y = out r2 "app1"; out r2 "app2" + let test2mod() = + (f2 (out r2 "1")) (out r2 "2") + check "(one arg at a time) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + let r3 = ref [] + let f3 = out r3 "f0"; (fun x -> out r3 "app1"; (fun y -> out r3 "app2")) + let test3mod() = + (f3 (out r3 "1")) (out r3 "2") + check "(one arg at a time) test3mod" !r3 ["f0"; "1"; "app1"; "2"; "app2"] + + test1() + test2() + test3() + + test1captured() + test2captured() + test3captured() + + test1top() + test2top() + test3top() + + test1mod() + test2mod() + test3mod() + +module AppTwoRec = + let test1() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = f (out r "1") (out r "2") + g () + check "(two args at a time, rec) test1" !r ["1"; "2"; "app1"; "app2"] + + let test2() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = f (out r "1") (out r "2") + g () + check "(two args at a time, rec) test2" !r ["1"; "2"; "app1"; "app2"] + + let test3() = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = f (out r "1") (out r "2") + g () + check "(two args at a time, rec) test3" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = f (out r "1") (out r "2") + g () + obj <- f + check "(two args at a time, rec) test1captured" !r ["1"; "2"; "app1"; "app2"] + + let test2captured() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = f (out r "1") (out r "2") + g () + obj <- f + check "(two args at a time, rec) test2captured" !r ["1"; "2"; "app1"; "app2"] + + let test3captured() = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = f (out r "1") (out r "2") + g () + obj <- f + check "(two args at a time, rec) test3captured" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let test1top = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = f (out r "1") (out r "2") + g () + fun () -> check "(two args at a time, rec) test1top" !r ["1"; "2"; "app1"; "app2"] + + let test2top = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = f (out r "1") (out r "2") + g () + fun () -> check "(two args at a time, rec) test2top" !r ["1"; "2"; "app1"; "app2"] + + let test3top = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = f (out r "1") (out r "2") + g () + fun () -> check "(two args at a time, rec) test3top" !r ["f0"; "1"; "2"; "app1"; "app2"] + + let r1 = ref [] + let rec f1 x = out r1 "app1"; (fun y -> out r1 "app2") + and g1() = f1 (out r1 "1") (out r1 "2") + let test1mod() = + g1() + check "(two args at a time, rec) test1mod" !r1 ["1"; "2"; "app1"; "app2"] + + let r2 = ref [] + let rec f2 x y = out r2 "app1"; out r2 "app2" + and g2() = f2 (out r2 "1") (out r2 "2") + let test2mod() = + g2() + check "(two args at a time, rec) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + let r3 = ref [] + let rec f3 = out r3 "f0"; (fun x -> out r3 "app1"; (fun y -> out r3 "app2")) + and g3() = f3 (out r3 "1") (out r3 "2") + let test3mod() = + g3() + check "(two args at a time, rec) test3mod" !r3 ["f0"; "1"; "2"; "app1"; "app2"] + + test1() + test2() + test3() + + test1captured() + test2captured() + test3captured() + + test1top() + test2top() + test3top() + + test1mod() + test2mod() + test3mod() + +module AppOneRec = + let test1() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = (f (out r "1")) (out r "2") + g() + check "(one arg at a time, rec) test1" !r ["1"; "app1"; "2"; "app2"] + + let test2() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = (f (out r "1")) (out r "2") + g() + check "(one arg at a time, rec) test2" !r ["1"; "2"; "app1"; "app2"] + + let test3() = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = (f (out r "1")) (out r "2") + g() + check "(one arg at a time, rec) test3" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = (f (out r "1")) (out r "2") + g() + obj <- f + check "(one arg at a time, rec) test1captured" !r ["1"; "app1"; "2"; "app2"] + + let test2captured() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = (f (out r "1")) (out r "2") + g() + obj <- f + check "(one arg at a time, rec) test2captured" !r ["1"; "2"; "app1"; "app2"] + + let test3captured() = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = (f (out r "1")) (out r "2") + g() + obj <- f + check "(one arg at a time, rec) test3captured" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let test1top = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2") + and g() = (f (out r "1")) (out r "2") + g() + fun () -> check "(one arg at a time, rec) test1top" !r ["1"; "app1"; "2"; "app2"] + + let test2top = + let r = ref [] + let rec f x y = out r "app1"; out r "app2" + and g() = (f (out r "1")) (out r "2") + g() + fun () -> check "(one arg at a time, rec) test2top" !r ["1"; "2"; "app1"; "app2"] + + let test3top = + let r = ref [] + let rec f = out r "f0"; (fun x -> out r "app1"; (fun y -> out r "app2")) + and g() = (f (out r "1")) (out r "2") + g() + fun () -> check "(one arg at a time, rec) test3top" !r ["f0"; "1"; "app1"; "2"; "app2"] + + let r1 = ref [] + let rec f1 x = out r1 "app1"; (fun y -> out r1 "app2") + and g1() = (f1 (out r1 "1")) (out r1 "2") + let test1mod() = + g1() + check "(one arg at a time, rec) test1mod" !r1 ["1"; "app1"; "2"; "app2"] + + let r2 = ref [] + let rec f2 x y = out r2 "app1"; out r2 "app2" + and g2() = (f2 (out r2 "1")) (out r2 "2") + let test2mod() = + g2() + check "(one arg at a time, rec) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + let r3 = ref [] + let rec f3 = out r3 "f0"; (fun x -> out r3 "app1"; (fun y -> out r3 "app2")) + and g3() = (f3 (out r3 "1")) (out r3 "2") + let test3mod() = + g3() + check "(one arg at a time, rec) test3mod" !r3 ["f0"; "1"; "app1"; "2"; "app2"] + + test1() + test2() + test3() + + test1captured() + test2captured() + test3captured() + + test1top() + test2top() + test3top() + + test1mod() + test2mod() + test3mod() + +module AppTwoRecGeneric = + let test1() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = f (out r "1") (out r "2") + (g () : int) |> ignore + check "(two args at a time, rec, generic) test1" !r ["1"; "2"; "app1"; "app2"] + r := [] + (g () : string) |> ignore + check "(two args at a time, rec, generic) test1" !r ["1"; "2"; "app1"; "app2"] + + let test2() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = f (out r "1") (out r "2") + (g () : int) |> ignore + check "(two args at a time, rec, generic) test2" !r ["1"; "2"; "app1"; "app2"] + r := [] + (g () : string) |> ignore + check "(two args at a time, rec, generic) test2" !r ["1"; "2"; "app1"; "app2"] + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = f (out r "1") (out r "2") + obj <- f + (g () : int) |> ignore + check "(two args at a time, rec, generic) test1captured" !r ["1"; "2"; "app1"; "app2"] + r := [] + (g () : string) |> ignore + check "(two args at a time, rec, generic) test1captured" !r ["1"; "2"; "app1"; "app2"] + + let test2captured() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = f (out r "1") (out r "2") + g () + obj <- f + check "(two args at a time, rec, generic) test2captured" !r ["1"; "2"; "app1"; "app2"] + + let test1top = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = f (out r "1") (out r "2") + g () + fun () -> check "(two args at a time, rec, generic) test1top" !r ["1"; "2"; "app1"; "app2"] + + let test2top = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = f (out r "1") (out r "2") + g () + fun () -> check "(two args at a time, rec, generic) test2top" !r ["1"; "2"; "app1"; "app2"] + + + let r1 = ref [] + let rec f1 x = out r1 "app1"; (fun y -> out r1 "app2"; Unchecked.defaultof<'a>) + and g1() = f1 (out r1 "1") (out r1 "2") + let test1mod() = + g1() + check "(two args at a time, rec, generic) test1mod" !r1 ["1"; "2"; "app1"; "app2"] + + let r2 = ref [] + let rec f2 x y = out r2 "app1"; out r2 "app2"; Unchecked.defaultof<'a> + and g2() = f2 (out r2 "1") (out r2 "2") + let test2mod() = + g2() + check "(two args at a time, rec, generic) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + test1() + test2() + + test1captured() + test2captured() + + test1top() + test2top() + + test1mod() + test2mod() + +module AppOneRecGeneric = + let test1() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = (f (out r "1")) (out r "2") + g() + check "(one arg at a time, rec, generic) test1" !r ["1"; "app1"; "2"; "app2"] + + let test2() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = (f (out r "1")) (out r "2") + g() + check "(one arg at a time, rec) test2" !r ["1"; "2"; "app1"; "app2"] + + + let mutable obj = obj() + + let test1captured() = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = (f (out r "1")) (out r "2") + g() + obj <- f + check "(one arg at a time, rec) test1captured" !r ["1"; "app1"; "2"; "app2"] + + let test2captured() = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = (f (out r "1")) (out r "2") + g() + obj <- f + check "(one arg at a time, rec, generic) test2captured" !r ["1"; "2"; "app1"; "app2"] + + + let test1top = + let r = ref [] + let rec f x = out r "app1"; (fun y -> out r "app2"; Unchecked.defaultof<'a>) + and g() = (f (out r "1")) (out r "2") + g() + fun () -> check "(one arg at a time, rec, generic) test1top" !r ["1"; "app1"; "2"; "app2"] + + let test2top = + let r = ref [] + let rec f x y = out r "app1"; out r "app2"; Unchecked.defaultof<'a> + and g() = (f (out r "1")) (out r "2") + g() + fun () -> check "(one arg at a time, rec, generic) test2top" !r ["1"; "2"; "app1"; "app2"] + + let r1 = ref [] + let rec f1 x = out r1 "app1"; (fun y -> out r1 "app2"; Unchecked.defaultof<'a>) + and g1() = (f1 (out r1 "1")) (out r1 "2") + let test1mod() = + g1() + check "(one arg at a time, rec, generic) test1mod" !r1 ["1"; "app1"; "2"; "app2"] + + let r2 = ref [] + let rec f2 x y = out r2 "app1"; out r2 "app2"; Unchecked.defaultof<'a> + and g2() = (f2 (out r2 "1")) (out r2 "2") + let test2mod() = + g2() + check "(one arg at a time, rec, generic) test2mod" !r2 ["1"; "2"; "app1"; "app2"] + + test1() + test2() + + test1captured() + test2captured() + + test1top() + test2top() + + test1mod() + test2mod() + +module DuplicateTestsWithCondensedArgs = + module CheckMutationOfArgumentValuesInOtherArguments = + let test1232() = + let mutable cell1 = 1 + let f1 (x:System.IComparable) = printfn "hello"; (fun (y:System.IComparable) -> printfn "x = %A, y = %A" x y; ((x :?> int),(y :?> int) )) + let f2 (x:System.IComparable) (y:System.IComparable) = printfn "x = %A, y = %A" x y; ((x :?> int),(y :?> int) ) + cell1 <- 1 // reset + let res = f1 (cell1 <- 11; cell1) cell1 + check "test1232 - test1" res (11,11) + cell1 <- 1 // reset + let res = f1 cell1 (cell1 <- 21; cell1) + check "test1232 - test2" res (1,21) + cell1 <- 1 // reset + let res = (f1 (cell1 <- 11; cell1)) cell1 + check "test1232 - test3" res (11,11) + cell1 <- 1 // reset + let res = (f1 cell1) (cell1 <- 21; cell1) + check "test1232 - test4" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test5" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test6" res (1,21) + cell1 <- 1 // reset + let res = (f2 cell1) (cell1 <- 21; cell1) + check "test1232 - test7" res (1,21) + cell1 <- 1 // reset + let res = f2 (cell1 <- 11; cell1) cell1 + check "test1232 - test8" res (11,11) + cell1 <- 1 // reset + let res = f2 cell1 (cell1 <- 21; cell1) + check "test1232 - test9" res (1,21) + + test1232() + + let test1233() = + let cell1 = ref 1 + let f1 (x:System.IComparable) = cell1 := 4; printfn "hello"; (fun (y:System.IComparable) -> printfn "x = %A, y = %A" x y; ((x :?> int),(y :?> int),!cell1 )) + let f2 (x:System.IComparable) (y:System.IComparable) = printfn "x = %A, y = %A" x y; ((x :?> int),(y :?> int), !cell1 ) + cell1 := 1 + let res = f1 (cell1 := 11; !cell1) !cell1 + check "test1233 - test1" res (11,11,4) + cell1 := 1 + let res = (f1 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test2" res (11,4,4) + cell1 := 1 + let res = f1 !cell1 (cell1 := 21; !cell1) + check "test1233 - test3" res (1,21,4) + cell1 := 1 + let res = (f1 !cell1) (cell1 := 21; !cell1) + check "test1233 - test4" res (1,21,21) + cell1 := 1 + let res = f2 (cell1 := 11; !cell1) !cell1 + check "test1233 - test5" res (11,11,11) + cell1 := 1 + let res = (f2 (cell1 := 11; !cell1)) !cell1 + check "test1233 - test6" res (11,11,11) + cell1 := 1 + let res = f2 !cell1 (cell1 := 21; !cell1) + check "test1233 - test7" res (1,21,21) + cell1 := 1 + let res = (f2 !cell1) (cell1 := 21; !cell1) + check "test1233 - test8" res (1,21,21) + + + test1233() + +module MemberAppOrder = + type Foo(x:int,y:int,?z:int) = + let mutable a = 0 + let mutable b = 0 + member this.A with get() = a + and set(x) = a <- x + member this.B with get() = b + and set(x) = b <- x + member this.X = x + member this.Y = y + member this.Z = defaultArg z 99 + + let mutable state = [] + let out i = + state <- state @ [i] + i + let foo = new Foo(B=out 5, A=out 4, y=out 2, x=out 3) + check "cwkneccewi" state [3;2;5;4] + check "nvroirv" (sprintf "%d %d %d %d %d" foo.A foo.B foo.X foo.Y foo.Z) "4 5 3 2 99" + +#if ALL_IN_ONE +let RUN() = !failures +#else +let aa = + match !failures with + | [] -> + stdout.WriteLine "Test Passed" + System.IO.File.WriteAllText("test.ok","ok") + exit 0 + | _ -> + stdout.WriteLine "Test Failed" + exit 1 +#endif + + diff --git a/tests/fsharp/core/array/build.bat b/tests/fsharp/core/array/build.bat new file mode 100644 index 0000000000..7cec41ea48 --- /dev/null +++ b/tests/fsharp/core/array/build.bat @@ -0,0 +1,6 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-build.bat + + +exit /b %ERRORLEVEL% diff --git a/tests/fsharp/core/array/run.bat b/tests/fsharp/core/array/run.bat new file mode 100644 index 0000000000..74f0f70a33 --- /dev/null +++ b/tests/fsharp/core/array/run.bat @@ -0,0 +1,15 @@ +@if "%_echo%"=="" echo off + +setlocal + +call %~d0%~p0..\..\..\config.bat + +call %~d0%~p0..\..\single-test-run.bat +exit /b %ERRORLEVEL% + +:Skip +echo Skipped %~f0 +endlocal +exit /b 0 + + diff --git a/tests/fsharp/core/array/test.fsx b/tests/fsharp/core/array/test.fsx new file mode 100644 index 0000000000..5d3d21155b --- /dev/null +++ b/tests/fsharp/core/array/test.fsx @@ -0,0 +1,1336 @@ +// #Conformance #Arrays #Stress #Structs #Mutable #ControlFlow #LetBindings +#if ALL_IN_ONE +module Core_array +#endif + +#light +let failures = ref [] + +let report_failure (s : string) = + stderr.Write" NO: " + stderr.WriteLine s + failures := !failures @ [s] + +let test (s : string) b = + stderr.Write(s) + if b then stderr.WriteLine " OK" + else report_failure (s) + +let check s b1 b2 = test s (b1 = b2) + + +#if NetCore +#else +let argv = System.Environment.GetCommandLineArgs() +let SetCulture() = + if argv.Length > 2 && argv.[1] = "--culture" then begin + let cultureString = argv.[2] in + let culture = new System.Globalization.CultureInfo(cultureString) in + stdout.WriteLine ("Running under culture "+culture.ToString()+"..."); + System.Threading.Thread.CurrentThread.CurrentCulture <- culture + end + +do SetCulture() +#endif + +(* TEST SUITE FOR Array *) + +let test_make_get_set_length () = + let arr = Array.create 3 0 in + test "fewoih" (Array.get arr 0 = 0); + test "vvrew0" (Array.get arr 2 = 0); + ignore (Array.set arr 0 4); + test "vsdiuvs" (Array.get arr 0 = 4); + test "vropivrwe" (Array.length arr = 3) + +let test_const () = + let arr = [| 4;3;2 |] in + test "sdvjk2" (Array.get arr 0 = 4); + test "cedkj" (Array.get arr 2 = 2); + ignore (Array.set arr 0 4); + test "ds9023" (Array.get arr 0 = 4); + test "sdio2" (Array.length arr = 3) + +let test_const_empty () = + let arr = [| |] in + test "sdio2" (Array.length arr = 0) + +let test_map () = + let arr = Array.map (fun x -> x + 1) ( [| 4;3;2 |]) in + test "test2927: sdvjk2" (Array.get arr 0 = 5); + test "test2927: cedkj" (Array.get arr 2 = 3) + +let test_iter () = + Array.iter (fun x -> test "fuo" (x <= 4)) ( [| 4;3;2 |]) + +let test_iteri () = + let arr = [| 4;3;2 |] in + Array.iteri (fun i x -> test "fuo" (arr.[i] = x)) arr + +let test_mapi () = + let arr = [| 4;3;2 |] in + let arr2 = Array.mapi (fun i x -> test "dwqfuo" (arr.[i] = x); i + x) arr in + test "test2927: sdvjk2" (Array.get arr2 0 = 4); + test "test2927: cedkj" (Array.get arr2 2 = 4) + +let test_isEmpty () = + test "isEmpty a" (Array.isEmpty [||]) + test "isEmpty b" (Array.isEmpty <| Array.create 0 42) + test "isEmpty c" <| not (Array.isEmpty <| [| 1 |]) + test "isEmpty d" (Array.isEmpty <| Array.empty) + +let test_create () = + let arr = Array.create 10 10 + for i in 0 .. 9 do + test "test_create" (arr.[i] = 10) + +let test_concat () = + let make n = [| for i in n .. n + 9 -> i |] + let arr = [| for i in 0..+10..50 -> make i|] + test "concat a" (Array.concat arr = [|0..59|]) + + let arr2 = [| for i in 0..50 -> [||] |] + test "concat b" (Array.concat arr2 = [| |]) + + let arr3 = [| [||]; [||]; [|1; 2|]; [||] |] + test "concat c" (Array.concat arr3 = [|1; 2|]) + +let test_sub () = + test "sub a" (Array.sub [|0..100|] 10 20 = [|10..29|]) + test "sub b" (Array.sub [|0..100|] 0 101 = [|0..100|]) + test "sub c" (Array.sub [|0..100|] 0 1 = [|0|]) + test "sub d" (Array.sub [|0..100|] 0 0 = [||]) + +let test_fold2 () = + test "fold2 a" + (Array.fold2 (fun i j k -> i+j+k) 100 [|1;2;3|] [|1;2;3|] = 112) + + test "fold2_b" + (Array.fold2 (fun i j k -> i-j-k) 100 [|1;2;3|] [|1;2;3|] = 100-12) + +let test_foldBack2 () = + test "foldBack2 a" + (Array.foldBack2 (fun i j k -> i+j+k) [|1;2;3|] [|1;2;3|] 100 = 112) + + test "foldBack2_b" + (Array.foldBack2 (fun i j k -> k-i-j) [|1;2;3|] [|1;2;3|] 100 = 100-12) + +let test_scan () = + test "scan" + (Array.scan (+) 0 [|1..5|] = [|0; 1; 3; 6; 10; 15|]) + + test "scanBack" + (Array.scanBack (+) [|1..5|] 0 = [|15; 14; 12; 9; 5; 0|]) + +let test_iter2 () = + let c = ref -1 + Array.iter2 (fun x y -> incr c; test "iter2" (!c = x && !c = y)) [|0..100|] [|0..100|] + test "iter2" (!c = 100) + +let test_iteri2 () = + let c = ref 0 + Array.iteri2 (fun i j k -> c := !c+i+j+k) [|1;2;3|] [|10;20;30|] + test "iteri2" (!c = 6+60+3) + +let test_map2 () = + test "map2" + (Array.map2 (+) [|0..100|] [|0..100|] = [|0..+2..200|]) + +let test_mapi2 () = + test "mapi2 a" + (Array.mapi2 (fun i j k -> i+j+k) [|1..10|] [|1..10|] = [|2..+3..29|]) + + test "mapi2_b" + (try Array.mapi2 (fun i j k -> i+j+k) [||] [|1..10|] |> ignore; false + with _ -> true) + +let test_exists () = + test "exists a" + ([|1..100|] |> Array.exists ((=) 50)) + + test "exists b" <| not + ([|1..100|] |> Array.exists ((=) 150)) + +let test_forall () = + test "forall a" + ([|1..100|] |> Array.forall (fun x -> x < 150)) + + test "forall b" <| not + ([|1..100|] |> Array.forall (fun x -> x < 80)) + +let test_exists2 () = + test "exists2 a" <| Array.exists2 (=) + [|1; 2; 3; 4; 5; 6|] + [|2; 3; 4; 5; 6; 6|] + + test "exists2 b" <| not (Array.exists2 (=) + [|1; 2; 3; 4; 5; 6|] + [|2; 3; 4; 5; 6; 7|]) + +let test_forall2 () = + test "forall2 a" + (Array.forall2 (=) [|1..10|] [|1..10|]) + + test "forall2_b" <| not + (Array.forall2 (=) [|1;2;3;4;5|] [|1;2;3;0;5|]) + +let test_filter () = + test "filter a" + (Array.filter (fun x -> x % 2 = 0) [|0..100|] = [|0..+2..100|]) + + test "filter b" + (Array.filter (fun x -> false) [|0..100|] = [||]) + + test "filter c" + (Array.filter (fun x -> true) [|0..100|] = [|0..100|]) + + +let test_partition () = + let p1, p2 = Array.partition (fun x -> x % 2 = 0) [|0..100|] + test "partition" + (p1 = [|0..+2..100|] && p2 = [|1..+2..100|]) + +let test_choose () = + test "choose" + (Array.choose (fun x -> if x % 2 = 0 then Some (x/2) else None) [|0..100|] = [|0..50|]) + +let test_find () = + test "find a" + ([|1..100|] |> Array.find (fun x -> x > 50) = 51) + + test "find b" + (try [|1..100|] |> Array.find (fun x -> x > 180) |> ignore; false + with _ -> true) + +module Array = + let findIndexi f (array : array<_>) = + let len = array.Length + let rec go n = + if n >= len then + failwith "fail" + elif f n array.[n] then + n + else + go (n+1) + go 0 + + let tryFindIndexi f (array : array<_>) = + let len = array.Length + let rec go n = if n >= len then None elif f n array.[n] then Some n else go (n+1) + go 0 + +let test_findIndex () = + test "findIndex a" + (Array.findIndex (fun i -> i >= 4) [|0..10|] = 4) + + test "findIndex b" + (try Array.findIndex (fun i -> i >= 20) [|0..10|] |> ignore; false + with _ -> true) + + test "findIndexi a" + (Array.findIndexi (=) [|1; 2; 3; 3; 2; 1|] = 3) + + test "findIndexi b" + (try Array.findIndexi (=) [|1..10|] |> ignore; false + with _ -> true) + +let test_tryfind () = + test "tryFind" + ([|1..100|] |> Array.tryFind (fun x -> x > 50) = Some 51) + + test "tryFind b" + ([|1..100|] |> Array.tryFind (fun x -> x > 180) = None) + + test "tryfind_index a" + (Array.tryFindIndex (fun x -> x = 4) [|0..10|] = Some 4) + + test "tryfind_index b" + (Array.tryFindIndex (fun x -> x = 42) [|0..10|] = None) + + test "tryFindIndexi a" + (Array.tryFindIndexi (=) [|1;2;3;4;4;3;2;1|] = Some 4) + + test "tryFindIndexi b" + (Array.tryFindIndexi (=) [|1..10|] = None) + +let test_first () = + test "first a" + ([|1..100|] |> Array.tryPick (fun x -> if x > 50 then Some (x*x) else None) = Some (51*51)) + + test "first b" + ([|1..100|] |> Array.tryPick (fun x -> None) = None) + + test "first c" + ([||] |> Array.tryPick (fun _ -> Some 42) = None) + +let test_sort () = + + test "sort a" (Array.sort [||] = [||]) + test "sort b" (Array.sort [|1|] = [|1|]) + test "sort c" (Array.sort [|1;2|] = [|1;2|]) + test "sort d" (Array.sort [|2;1|] = [|1;2|]) + test "sort e" (Array.sort [|1..1000|] = [|1..1000|]) + test "sort f" (Array.sort [|1000..-1..1|] = [|1..1000|]) + +let test_sort_by () = + + test "Array.sortBy a" (Array.sortBy int [||] = [||]) + test "Array.sortBy b" (Array.sortBy int [|1|] = [|1|]) + test "Array.sortBy c" (Array.sortBy int [|1;2|] = [|1;2|]) + test "Array.sortBy d" (Array.sortBy int [|2;1|] = [|1;2|]) + test "Array.sortBy e" (Array.sortBy int [|1..1000|] = [|1..1000|]) + test "Array.sortBy f" (Array.sortBy int [|1000..-1..1|] = [|1..1000|]) + + let testGen s f = + test ("Array.sortBy a "+s) (Array.sortBy f [||] = [||]) + test ("Array.sortBy b "+s) (Array.sortBy f [|1|] = [|1|]) + test ("Array.sortBy c "+s) (Array.sortBy f [|1;2|] = [|1;2|]) + test ("Array.sortBy d "+s) (Array.sortBy f [|2;1|] = [|1;2|]) + test ("Array.sortBy e "+s) (Array.sortBy f [|1..1000|] = [|1..1000|]) + test ("Array.sortBy f "+s) (Array.sortBy f [|1000..-1..1|] = [|1..1000|]) + + // All these projects from integers preserve the expected key ordering for the tests in 'testGen()' + testGen "int" int + testGen "uint32" uint32 + testGen "int16" int16 + testGen "uint16" uint16 + testGen "int64" int64 + testGen "uint64" uint64 + testGen "nativeint" nativeint + testGen "unativeint" unativeint + testGen "float" float + testGen "float32" float32 + testGen "decimal" decimal + + test "Array.sortBy g" (Array.sortBy int [|"4";"2";"3";"1";"5"|] = [|"1";"2";"3";"4";"5"|]) + test "Array.sortBy h" (Array.sortBy abs [|1;-2;5;-4;0;-6;3|] = [|0;1;-2;3;-4;5;-6|]) + test "Array.sortBy i" (Array.sortBy String.length [|"a";"abcd";"ab";"";"abc"|] = [|"";"a";"ab";"abc";"abcd"|]) + + +let test_list_stableSortBy() = + for lo in 0 .. 100 do + for hi in lo .. 100 do + test (sprintf "vre9u0rejkn, lo = %d, hi = %d" lo hi) (List.sortBy snd [ for i in lo .. hi -> (i, i % 17) ] = [ for key in 0 .. 16 do for i in lo .. hi do if i % 17 = key then yield (i, i % 17) ]) + +test_list_stableSortBy() + + +[] +type Key = + | Key of int * int + interface System.IComparable with + member x.CompareTo(yobj:obj) = + match yobj with + | :? Key as y -> + let (Key(y1,y2)) = y in + let (Key(x1,x2)) = x in + compare x2 y2 + | _ -> failwith "failure" + + override x.Equals(yobj) = + match yobj with + | :? Key as y -> + let (Key(y1,y2)) = y in + let (Key(x1,x2)) = x in + x2 = y2 + | _ -> false + + override x.GetHashCode() = + let (Key(x1,x2)) = x in + hash x2 + +let test_list_stableSort() = + for lo in 0 .. 100 do + for hi in lo .. 100 do + test (sprintf "vre9u0rejkn, lo = %d, hi = %d" lo hi) (List.sort [ for i in lo .. hi -> Key(i, i % 17) ] = [ for key in 0 .. 16 do for i in lo .. hi do if i % 17 = key then yield Key(i, i % 17) ]) + +test_list_stableSort() + +let test_list_stableSortByNonIntegerKey() = + for lo in 0 .. 100 do + for hi in lo .. 100 do + test (sprintf "vre9u0rejkn, lo = %d, hi = %d" lo hi) (List.sortBy (fun (Key(a,b)) -> Key(0,b)) [ for i in lo .. hi -> Key(i, i % 17) ] = [ for key in 0 .. 16 do for i in lo .. hi do if i % 17 = key then yield Key(i, i % 17) ]) + +test_list_stableSortByNonIntegerKey() + + +let test_zip () = + test "zip" + (Array.zip [|1..10|] [|1..10|] = [|for i in 1..10 -> i, i|]) + + let unzip1, unzip2 = Array.unzip <| [|for i in 1..10 -> i, i+1|] + test "unzip" (unzip1 = [|1..10|] && unzip2 = [|2..11|]) + +let test_zip3 () = + test "zip3" + (Array.zip3 [|1..10|] [|1..10|] [|1..10|] = [|for i in 1..10 -> i, i, i|]) + + let unzip1, unzip2, unzip3 = Array.unzip3 <| [|for i in 1..10 -> i, i+1, i+2|] + test "unzip3" (unzip1 = [|1..10|] && unzip2 = [|2..11|] && unzip3 = [|3..12|]) + + +let test_rev () = + test "rev a" + (Array.rev [|0..100|] = [|100..-1 ..0|]) + + test "rev b" + (Array.rev [|1|] = [|1|]) + + test "rev c" + (Array.rev [||] = [||]) + + test "rev d" + (Array.rev [|1; 2|] = [|2; 1|]) + +let test_sum () = + test "sum a" (Array.sum [||] = 0) + test "sum b" (Array.sum [|42|] = 42) + test "sum c" (Array.sum [|42;-21|] = 21) + test "sum d" (Array.sum [|1..1000|] = (1000*1001) / 2) + test "sum e" (Array.sum [|1.;2.;3.|] = 6.) + test "sum f" (Array.sum [|1.;2.;infinity;3.|] = infinity) + +let test_sum_by () = + test "sum_by a" (Array.sumBy int [||] = 0) + test "sum_by b" (Array.sumBy int [|42|] = 42) + test "sum_by c" (Array.sumBy int [|42;-21|] = 21) + test "sum_by d" (Array.sumBy int [|1..1000|] = (1000*1001) / 2) + test "sum_by e" (Array.sumBy float [|1.;2.;3.|] = 6.) + test "sum_by f" (Array.sumBy float [|1.;2.;infinity;3.|] = infinity) + test "sum_by g" (Array.sumBy abs [|1; -2; 3; -4|] = 10) + test "sum_by h" (Array.sumBy String.length [|"abcd";"efg";"hi";"j";""|] = 10) + +let test_average () = + test "average a1" (try Array.average ([||]: float array) |> ignore; false with :? System.ArgumentException -> true) + test "average a2" (try Array.average ([||]: float32 array) |> ignore; false with :? System.ArgumentException -> true) + test "average a3" (try Array.average ([||]: decimal array) |> ignore; false with :? System.ArgumentException -> true) + test "average a4" (Array.average [|0.|] = 0.) + test "average b" (Array.average [|4.|] = 4.) + test "average c" (Array.average [|4.;6.|] = 5.) + + test "average_by a1" (try Array.averageBy id ([||]: float array) |> ignore; false with :? System.ArgumentException -> true) + test "average_by a2" (try Array.averageBy id ([||]: float32 array) |> ignore; false with :? System.ArgumentException -> true) + test "average_by a3" (try Array.averageBy id ([||]: decimal array) |> ignore; false with :? System.ArgumentException -> true) + test "average_by a4" (Array.averageBy float [|0..1000|] = 500.) + test "average_by b" (Array.averageBy (String.length >> float) [|"ab";"cdef"|] = 3.) + +let test_min () = + test "min a" (Array.min [|42|] = 42) + test "min b" (Array.min [|42;21|] = 21) + test "min c" (Array.min [|'a';'b'|] = 'a') + + test "max a" (Array.max [|42|] = 42) + test "max b" (Array.max [|42;21|] = 42) + test "max c" (Array.max [|'a';'b'|] = 'b') + +let test_min_by () = + test "min_by a" (Array.minBy int [|42|] = 42) + test "min_by b" (Array.minBy abs [|-42;-21|] = -21) + test "min_by c" (Array.minBy int [|'a';'b'|] = 'a') + + test "max_by a" (Array.maxBy int [|42|] = 42) + test "max_by b" (Array.maxBy abs [|-42;-21|] = -42) + test "max_by c" (Array.maxBy int [|'a';'b'|] = 'b') + +let test_seq () = + test "to_seq" (Array.ofSeq [1..100] = [|1..100|]) + test "to_seq" ([|1..100|] |> Array.toSeq |> Array.ofSeq = [|1..100|]) + + +let test_zero_create () = + let arr = Array.zeroCreate 3 in + ignore (Array.set arr 0 4); + ignore (Array.set arr 1 3); + ignore (Array.set arr 2 2); + test "fewoih" (Array.get arr 0 = 4); + test "vvrew0" (Array.get arr 1 = 3); + test "vvrew0" (Array.get arr 2 = 2) + +let test_zero_create_2 () = + let arr = Array.zeroCreate 0 in + test "sdio2" (Array.length arr = 0) + +let test_init () = + let arr = Array.init 4 (fun x -> x + 1) in + test "test2927: sdvjk2" (Array.get arr 0 = 1); + test "test2927: cedkj" (Array.get arr 2 = 3) + +let test_init_empty () = + let arr = Array.init 0 (fun x -> x + 1) in + test "test2927: sdvjk2" (Array.length arr = 0) + +let test_append () = + let arr = Array.append ( [| "4";"3" |]) ( [| "2" |]) in + test "test2928: sdvjk2" (Array.get arr 0 = "4"); + test "test2928: cedkj" (Array.get arr 2 = "2"); + test "test2928: cedkj" (Array.length arr = 3) + +let test_append_empty () = + let arr = Array.append ( [| |]) ( [| |]) in + test "test2928: cedkj" (Array.length arr = 0) + +let test_fill () = + let arr = [| "4";"3";"2" |] in + Array.fill arr 1 2 "1"; + test "test2929: sdvjk2" (Array.get arr 0 = "4"); + test "test2929: cedkj" (Array.get arr 2 = "1") + +let test_copy () = + let arr = [| "4";"3";"2" |] in + let arr2 = Array.copy arr in + test "test2929: sdvjk2" (Array.get arr2 0 = "4"); + test "test2929: cedkj" (Array.get arr2 2 = "2"); + test "feio" (not (LanguagePrimitives.PhysicalEquality arr arr2)) + +let test_blit () = + let arr = [| "4";"3";"2";"0" |] in + let arr2 = [| "4";"3";"-1"; "-1" |] in + Array.blit arr 1 arr2 2 2; + test "test2930: sdvjk2" (Array.get arr2 0 = "4"); + test "test2930: cedkj" (Array.get arr2 1 = "3"); + test "test2930: ceddwkj" (Array.get arr2 2 = "3"); + test "test2930: ceqwddkj" (Array.get arr2 3 = "2") + +let test_of_list () = + let arr = Array.ofList [ "4";"3";"2";"0" ] in + test "test2931: sdvjk2" (Array.get arr 0 = "4"); + test "test2931: cedkj" (Array.get arr 1 = "3"); + test "test2931: ceddwkj" (Array.get arr 2 = "2"); + test "test2931: ceqwddkj" (Array.get arr 3 = "0") + +let test_to_list () = + test "test2932" (Array.toList ( [| "4";"3";"2";"0" |]) = [ "4";"3";"2";"0" ]) + +let test_to_list_of_list () = + test "test2933" (Array.toList (Array.ofList [ "4";"3";"2";"0" ]) = [ "4";"3";"2";"0" ]) + +let test_fold_left () = + let arr = Array.ofList [ 4;3;2;1 ] in + test "test2931: sdvjk2few" (Array.fold (fun x y -> x/y) (5*4*3*2*1) arr = 5) + +let test_fold_right () = + let arr = Array.ofList [ 4;3;2;1 ] in + test "test2931: sdvjk2ew" (Array.foldBack (fun y x -> x/y) arr (6*4*3*2*1) = 6) + +let test_reduce_left () = + test "test2931: array.reduce" (Array.reduce (fun x y -> x/y) [|5*4*3*2; 4;3;2;1|] = 5) + +let test_reduce_right () = + let arr = Array.ofList [ 4;3;2;1;5 ] in + test "test2931: array.reduceBack" (Array.reduceBack (fun y x -> x/y) [|4;3;2;1; 5*4*3*2|] = 5) + + +let _ = test_make_get_set_length () +let _ = test_const () +let _ = test_const_empty () +let _ = test_map () +let _ = test_mapi () +let _ = test_iter () +let _ = test_iteri () +let _ = test_mapi () +let _ = test_isEmpty () +let _ = test_create () +let _ = test_concat () +let _ = test_sub () +let _ = test_fold2 () +let _ = test_foldBack2 () +let _ = test_scan () +let _ = test_iter2 () +let _ = test_iteri2 () +let _ = test_iter () +let _ = test_map2 () +let _ = test_mapi2 () +let _ = test_exists () +let _ = test_forall () +let _ = test_iter () +let _ = test_exists2 () +let _ = test_forall2 () +let _ = test_filter () +let _ = test_partition () +let _ = test_choose () +let _ = test_find () +let _ = test_findIndex () +let _ = test_tryfind () +let _ = test_first () +let _ = test_sort () +let _ = test_sort_by () +let _ = test_zip () +let _ = test_zip3 () +let _ = test_rev () +let _ = test_sum () +let _ = test_sum_by () +let _ = test_average () +let _ = test_min () +let _ = test_min_by () +let _ = test_seq () +let _ = test_zero_create () +let _ = test_zero_create_2 () +let _ = test_append () +let _ = test_append_empty () +let _ = test_init () +let _ = test_init_empty () +let _ = test_fill () +let _ = test_blit () +let _ = test_of_list () +let _ = test_to_list () +let _ = test_to_list_of_list () +let _ = test_copy () +let _ = test_iter () +let _ = test_iteri () +let _ = test_fold_left () +let _ = test_fold_right () +let _ = test_reduce_left () +let _ = test_reduce_right () + +module Array2Tests = begin + + let test_make_get_set_length () = + let arr = Array2D.create 3 4 0 in + test "fewoih1" (Array2D.get arr 0 0 = 0); + test "fewoih2" (Array2D.get arr 0 1 = 0); + test "vvrew03" (Array2D.get arr 2 2 = 0); + test "vvrew04" (Array2D.get arr 2 3 = 0); + ignore (Array2D.set arr 0 2 4); + test "vsdiuvs5" (Array2D.get arr 0 2 = 4); + arr.[0,2] <- 2; + test "vsdiuvs6" (arr.[0,2] = 2); + test "vropivrwe7" (Array2D.length1 arr = 3); + test "vropivrwe8" (Array2D.length2 arr = 4) + + let a = Array2D.init 10 10 (fun i j -> i,j) + let b = Array2D.init 2 2 (fun i j -> i+1,j+1) + //test "a2_sub" + // (Array2D.sub a 1 1 2 2 = b) + + Array2D.blit b 0 0 a 0 0 2 2 + //test "a2_blit" + // (Array2D.sub a 0 0 2 2 = b) + + let _ = test_make_get_set_length () + +end + +module Array3Tests = begin + + let test_make_get_set_length () = + let arr = Array3D.create 3 4 5 0 in + test "fewoih1" (Array3D.get arr 0 0 0 = 0); + test "fewoih2" (Array3D.get arr 0 1 0 = 0); + test "vvrew03" (Array3D.get arr 2 2 2 = 0); + test "vvrew04" (Array3D.get arr 2 3 4 = 0); + ignore (Array3D.set arr 0 2 3 4); + test "vsdiuvs5" (Array3D.get arr 0 2 3 = 4); + arr.[0,2,3] <- 2; + test "vsdiuvs6" (arr.[0,2,3] = 2); + arr.[0,2,3] <- 3; + test "vsdiuvs" (arr.[0,2,3] = 3); + test "vropivrwe7" (Array3D.length1 arr = 3); + test "vropivrwe8" (Array3D.length2 arr = 4); + test "vropivrwe9" (Array3D.length3 arr = 5) + + let _ = test_make_get_set_length () + +end + +module Array4Tests = begin + + let test_make_get_set_length () = + let arr = Array4D.create 3 4 5 6 0 in + arr.[0,2,3,4] <- 2; + test "vsdiuvsq" (arr.[0,2,3,4] = 2); + arr.[0,2,3,4] <- 3; + test "vsdiuvsw" (arr.[0,2,3,4] = 3); + test "vsdiuvsw" (Array4D.get arr 0 2 3 4 = 3); + Array4D.set arr 0 2 3 4 5; + test "vsdiuvsw" (Array4D.get arr 0 2 3 4 = 5); + test "vropivrwee" (Array4D.length1 arr = 3); + test "vropivrwer" (Array4D.length2 arr = 4); + test "vropivrwet" (Array4D.length3 arr = 5) + test "vropivrwey" (Array4D.length4 arr = 6) + + let test_init () = + let arr = Array4D.init 3 4 5 6 (fun i j k m -> i+j+k+m) in + test "vsdiuvs1" (arr.[0,2,3,4] = 9); + test "vsdiuvs2" (arr.[0,2,3,3] = 8); + test "vsdiuvs3" (arr.[0,0,0,0] = 0); + arr.[0,2,3,4] <- 2; + test "vsdiuvs4" (arr.[0,2,3,4] = 2); + arr.[0,2,3,4] <- 3; + test "vsdiuvs5" (arr.[0,2,3,4] = 3); + test "vropivrwe1" (Array4D.length1 arr = 3); + test "vropivrwe2" (Array4D.length2 arr = 4); + test "vropivrwe3" (Array4D.length3 arr = 5) + test "vropivrwe4" (Array4D.length4 arr = 6) + + let _ = test_make_get_set_length () + let _ = test_init () + +end + +// nb. PERF TESTING ONLY WITH v2.0 (GENERICS) +#if PERF +let test_map_perf () = + let arr1 = [| 4;3;2 |] in + let res = ref (Array.map (fun x -> x + 1) arr1) in + for i = 1 to 20000000 do + res := Array.map (fun x -> x + 1) arr1 + done; + test "test2927: sdvjk2" (Array.get !res 0 = 5) + +let _ = test_map_perf() +#endif + +module SeqCacheAllTest = + let s2 = + let count = ref 0 + let s = Seq.cache (seq { for i in 0 .. 10 -> (incr count; i) }) :> seq<_> + let test0 = (!count = 0) + let e1 = s.GetEnumerator() + let test1 = (!count = 0) + printf "test1 = %b\n" test1; + for i = 1 to 1 do (e1.MoveNext() |> ignore; e1.Current |> ignore) + let test2 = (!count = 1) + printf "test2 = %b\n" test2; + let e2 = s.GetEnumerator() + for i = 1 to 5 do (e2.MoveNext() |> ignore; e2.Current |> ignore) + let test3 = (!count = 5) + printf "test3 = %b\n" test3; + let e3 = s.GetEnumerator() + for i = 1 to 5 do (e3.MoveNext() |> ignore; e3.Current |> ignore) + let test4 = (!count = 5) + printf "test4 = %b\n" test4; + let e4 = s.GetEnumerator() + for i = 1 to 3 do (e4.MoveNext() |> ignore; e4.Current |> ignore) + let test5 = (!count = 5) + printf "test5 = %b\n" test5; + + let test6 = [ for x in s -> x ] = [ 0 .. 10 ] + printf "test6 = %b\n" test6; + for x in s do () + let test7 = (!count = 11) + let test8 = [ for x in s -> x ] = [ 0 .. 10 ] + let test9 = !count = 11 + test "test0" test0 + test "test1" test1 + test "test2" test2 + test "test3" test3 + test "test4" test4 + test "test5" test5 + test "test6" test6 + test "test7" test7 + test "test8" test8 + test "test9" test9 + +module StringSlicingTest = + let s1 = "abcdef" + test "slice1923" (s1.[*] = s1) + test "slice1923" (s1.[0..] = s1) + test "slice1924" (s1.[1..] = "bcdef") + test "slice1925" (s1.[2..] = "cdef") + test "slice1926" (s1.[5..] = "f") + test "slice1927" (s1.[6..] = "") + test "slice1928" (try s1.[7..] |> ignore; false with _ -> true) + test "slice1929" (try s1.[-1 ..] |> ignore; false with _ -> true) + test "slice1917" (s1.[..0] = "a") + test "slice1911" (s1.[..1] = "ab") + test "slice1912" (s1.[..2] = "abc") + test "slice1913" (s1.[..3] = "abcd") + test "slice1914" (s1.[..4] = "abcde") + test "slice1915" (s1.[..5] = "abcdef") + test "slice1918" (try s1.[..6] |> ignore; false with _ -> true) + test "slice1817" (s1.[1..0] = "") + test "slice1811" (s1.[1..1] = "b") + test "slice1812" (s1.[1..2] = "bc") + test "slice1813" (s1.[1..3] = "bcd") + test "slice1814" (s1.[1..4] = "bcde") + test "slice1815" (s1.[1 ..5] = "bcdef") + test "slice1818" (try s1.[1..6] |> ignore; false with _ -> true) + +module ArraySlicingTestBytes = + + let s1 = "abcdef"B + test "aslice1923" (s1.[0..] = s1) + test "aslice1924" (s1.[1..] = "bcdef"B) + test "aslice1925" (s1.[2..] = "cdef"B) + test "aslice1926" (s1.[5..] = "f"B) + test "aslice1927" (s1.[6..] = ""B) + test "aslice1928" (try s1.[7..] |> ignore; false with _ -> true) + test "aslice1929" (try s1.[-1 ..] |> ignore; false with _ -> true) + test "aslice1917" (s1.[..0] = "a"B) + test "aslice1911" (s1.[..1] = "ab"B) + test "aslice1912" (s1.[..2] = "abc"B) + test "aslice1913" (s1.[..3] = "abcd"B) + test "aslice1914" (s1.[..4] = "abcde"B) + test "aslice1915" (s1.[..5] = "abcdef"B) + test "aslice1918" (try s1.[..6] |> ignore; false with _ -> true) + test "aslice1817" (s1.[1..0] = ""B) + test "aslice1811" (s1.[1..1] = "b"B) + test "aslice1812" (s1.[1..2] = "bc"B) + test "aslice1813" (s1.[1..3] = "bcd"B) + test "aslice1814" (s1.[1..4] = "bcde"B) + test "aslice1815" (s1.[1 ..5] = "bcdef"B) + test "aslice1818" (try s1.[1..6] |> ignore; false with _ -> true) + +module ArraySlicingTestInts = + + let s1 = [| 1;2;3;4;5;6 |] + test "aslice1923" (s1.[0..] = s1) + test "aslice1924" (s1.[1..] = [| 2;3;4;5;6 |]) + test "aslice1925" (s1.[2..] = [| 3;4;5;6 |]) + test "aslice1926" (s1.[5..] = [| 6 |]) + test "aslice1927" (s1.[6..] = [| |]) + test "aslice1928" (try s1.[7..] |> ignore; false with _ -> true) + test "aslice1929" (try s1.[-1 ..] |> ignore; false with _ -> true) + test "aslice1917" (s1.[..0] = [| 1 |]) + test "aslice1911" (s1.[..1] = [| 1;2|]) + test "aslice1912" (s1.[..2] = [| 1;2;3 |]) + test "aslice1913" (s1.[..3] = [| 1;2;3;4|]) + test "aslice1914" (s1.[..4] = [| 1;2;3;4;5 |]) + test "aslice1915" (s1.[..5] = [| 1;2;3;4;5;6 |]) + test "aslice1918" (try s1.[..6] |> ignore; false with _ -> true) + test "aslice1817" (s1.[1..0] = [| |]) + test "aslice1811" (s1.[1..1] = [| 2 |]) + test "aslice1812" (s1.[1..2] = [| 2;3 |]) + test "aslice1813" (s1.[1..3] = [| 2;3;4|]) + test "aslice1814" (s1.[1..4] = [| 2;3;4;5|]) + test "aslice1815" (s1.[1 ..5] = [| 2;3;4;5;6|]) + test "aslice1818" (try s1.[1..6] |> ignore; false with _ -> true) + + +module Array2DSlicingTests = + + let array2d (arrs: 'a array array) = Array2D.init arrs.Length arrs.[0].Length (fun i j -> arrs.[i].[j]) + + let m1 = array2d [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 10.0;20.0;30.0;40.0;50.0;60.0 |] |] + test "a2slice1923" (m1.[*,*] = m1) + test "a2slice1924" (m1.[0..,*] = array2d [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 10.0;20.0;30.0;40.0;50.0;60.0 |] |]) + test "a2slice1925" (m1.[1..,*] = array2d [| //[| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 10.0;20.0;30.0;40.0;50.0;60.0 |] |]) + test "a2slice1926" (m1.[..0,*] = array2d [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + //[| 10.0;20.0;30.0;40.0;50.0;60.0 |] + |]) + test "a2slice1927" (m1.[*,0..] = array2d [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 10.0;20.0;30.0;40.0;50.0;60.0 |] + |]) + test "a2slice1928" (m1.[*,1..] = array2d [| [| 2.0;3.0;4.0;5.0;6.0 |]; + [| 20.0;30.0;40.0;50.0;60.0 |] + |]) + test "a2slice1929" (m1.[*,2..] = array2d [| [| 3.0;4.0;5.0;6.0 |]; + [| 30.0;40.0;50.0;60.0 |] + |]) + test "a2slice192a" (m1.[*,3..] = array2d [| [| 4.0;5.0;6.0 |]; + [| 40.0;50.0;60.0 |] + |]) + test "a2slice192b" (m1.[*,4..] = array2d [| [| 5.0;6.0 |]; + [| 50.0;60.0 |] + |]) + test "a2slice192c" (m1.[*,5..] = array2d [| [| 6.0 |]; + [| 60.0 |] + |]) + test "a2slice1930" (m1.[*, 0] = [| 1.0; 10.0 |]) + test "a2slice1931" (m1.[1.., 3] = [| 40.0 |]) + test "a2slice1932" (m1.[1, *] = [| 10.0;20.0;30.0;40.0;50.0;60.0 |]) + test "a2slice1933" (m1.[0, ..3] = [| 1.0;2.0;3.0;4.0 |]) + + let arr2D1 = array2d [| [| 1.; 2.; 3.; 4. |]; + [| 5.; 6.; 7.; 8. |]; + [| 9.; 10.; 11.; 12. |] |] + arr2D1.[0, *] <- [|0.; 0.; 0.; 0.|] + test "a2slice1934" (arr2D1.[0,*] = [|0.; 0.; 0.; 0.|]) + arr2D1.[*, 1] <- [|100.; 100.; 100.|] + test "a2slice1935" (arr2D1.[*,1] = [|100.; 100.; 100.|]) + test "a2slice1936" (arr2D1.[*,*] = array2d [| [| 0.; 100.; 0.; 0. |]; + [| 5.; 100.; 7.; 8. |]; + [| 9.; 100.; 11.; 12. |] |]) + +module Array3DSlicingTests = + + let array3d (arrs: 'a array array array ) = Array3D.init arrs.Length arrs.[0].Length arrs.[0].[0].Length (fun i j k -> arrs.[i].[j].[k]) + + let m1 = array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] + test "a3slice1923" (m1.[*,*,*] = m1) + test "a3slice1924" (m1.[0..,*,*] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |]) + test "a3slice1925" (m1.[0..0,*,*] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] |]) + test "a3slice1926" (m1.[1..1,*,*] = + array3d [| + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] ) + + test "a3slice1927" (m1.[*,1..1,*] = + array3d [| + [| [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] ) + test "a3slice1928" (m1.[..1,*,*] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] ) + test "a3slice1929" (m1.[*,0..0,*] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; |] |] ) + test "a3slice1930" (m1.[*,0..1,*] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] ) + test "a3slice1931" (m1.[*,*,0..0] = + array3d [| + [| [| 1.0|]; + [| 11.0|] |] + [| [| 10.0|]; + [| 100.0 |] |] |] ) + test "a3slice1932" (m1.[*,*,0..5] = + array3d [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] ) + + +module Array4DSlicingTests = + + let array4d (arrs: 'a array array array array) = Array4D.init arrs.Length arrs.[0].Length arrs.[0].[0].Length arrs.[0].[0].[0].Length (fun i j k m -> arrs.[i].[j].[k].[m]) + + let m1 = array4d + [| + [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] + [| + [| [| 19.0;29.0;39.0;49.0;59.0;69.0 |]; + [| 119.0;219.0;319.0;419.0;519.0;619.0 |] |] + [| [| 109.0;209.0;309.0;409.0;509.0;609.0 |]; + [| 1009.0;2009.0;3009.0;4009.0;5009.0;6009.0 |] |] |] + |] + test "a4slice1923" (m1.[*,*,*,*] = m1) + test "a4slice1924" (m1.[0..,*,*,*] = m1) + test "a4slice1925" (m1.[0..0,*,*,*] = + array4d + [| + [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] |] + |]) + test "a4slice1926" (m1.[1..1,*,*,*] = + array4d + [| + [| + [| [| 19.0;29.0;39.0;49.0;59.0;69.0 |]; + [| 119.0;219.0;319.0;419.0;519.0;619.0 |] |] + [| [| 109.0;209.0;309.0;409.0;509.0;609.0 |]; + [| 1009.0;2009.0;3009.0;4009.0;5009.0;6009.0 |] |] |] + |]) + + test "a4slice1927" (m1.[*,0..0,*,*] = + array4d + [| + [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; + [| 11.0;21.0;31.0;41.0;51.0;61.0 |] |] + |]; + [| + [| [| 19.0;29.0;39.0;49.0;59.0;69.0 |]; + [| 119.0;219.0;319.0;419.0;519.0;619.0 |] |] + |] + |]) + test "a4slice1928" (m1.[..1,*,*,*] = m1) + test "a4slice1929" (m1.[*,1..,*,*] = + array4d + [| + [| + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; + [| 100.0;200.0;300.0;400.0;500.0;600.0 |] |] + |]; + [| + [| [| 109.0;209.0;309.0;409.0;509.0;609.0 |]; + [| 1009.0;2009.0;3009.0;4009.0;5009.0;6009.0 |] |] + |] + |]) + test "a4slice1930" (m1.[*,0..1,*,*] = m1) + test "a4slice1931" (m1.[*,*,0..0,*] = + array4d + [| + [| + [| [| 1.0;2.0;3.0;4.0;5.0;6.0 |]; |] + [| [| 10.0;20.0;30.0;40.0;50.0;60.0 |]; |] + |]; + [| + [| [| 19.0;29.0;39.0;49.0;59.0;69.0 |]; |] + [| [| 109.0;209.0;309.0;409.0;509.0;609.0 |]; |] |] + |]) + test "a4slice1932" (m1.[*,*,*,0..5] = m1) + + test "a4slice1931" (m1.[*,*,*,0..4] = + array4d + [| + [| + [| [| 1.0;2.0;3.0;4.0;5.0 |]; + [| 11.0;21.0;31.0;41.0;51.0 |] |] + [| [| 10.0;20.0;30.0;40.0;50.0 |]; + [| 100.0;200.0;300.0;400.0;500.0 |] |] + |]; + [| + [| [| 19.0;29.0;39.0;49.0;59.0 |]; + [| 119.0;219.0;319.0;419.0;519.0 |] |] + [| [| 109.0;209.0;309.0;409.0;509.0 |]; + [| 1009.0;2009.0;3009.0;4009.0;5009.0 |] |] + |] + |]) + +module ArrayStructMutation = + module Array1D = + module Test1 = + [] + type T = + val mutable i : int + let a = Array.create 10 Unchecked.defaultof + a.[0].i <- 27 + check "wekvw0301" 27 a.[0].i + + + module Test2 = + + [] + type T = + val mutable public i : int + member public this.Set i = this.i <- i + let a = Array.create 10 Unchecked.defaultof + a.[0].Set 27 + a.[2].Set 27 + check "wekvw0302" 27 a.[0].i + check "wekvw0303" 27 a.[2].i + + module Array2D = + module Test1 = + [] + type T = + val mutable i : int + let a = Array2D.create 10 10 Unchecked.defaultof + a.[0,0].i <- 27 + check "wekvw0304" 27 a.[0,0].i + + + module Test2 = + + [] + type T = + val mutable public i : int + member public this.Set i = this.i <- i + let a = Array2D.create 10 10 Unchecked.defaultof + a.[0,0].Set 27 + a.[0,2].Set 27 + check "wekvw0305" 27 a.[0,0].i + check "wekvw0306" 27 a.[0,2].i + + + module Array3D = + module Test1 = + [] + type T = + val mutable i : int + let a = Array3D.create 10 10 10 Unchecked.defaultof + a.[0,0,0].i <- 27 + a.[0,2,3].i <- 27 + check "wekvw0307" 27 a.[0,0,0].i + check "wekvw0308" 27 a.[0,2,3].i + + + module Test2 = + + [] + type T = + val mutable public i : int + member public this.Set i = this.i <- i + let a = Array3D.create 10 10 10 Unchecked.defaultof + a.[0,0,0].Set 27 + a.[0,2,3].Set 27 + check "wekvw0309" 27 a.[0,0,0].i + check "wekvw030q" 27 a.[0,2,3].i + + module Array4D = + module Test1 = + [] + type T = + val mutable i : int + let a = Array4D.create 10 10 10 10 Unchecked.defaultof + a.[0,0,0,0].i <- 27 + a.[0,2,3,4].i <- 27 + check "wekvw030w" 27 a.[0,0,0,0].i + check "wekvw030e" 27 a.[0,2,3,4].i + + + module Test2 = + + [] + type T = + val mutable public i : int + member public this.Set i = this.i <- i + let a = Array4D.create 10 10 10 10 Unchecked.defaultof + a.[0,0,0,0].Set 27 + a.[0,2,3,4].Set 27 + check "wekvw030r" 27 a.[0,0,0,0].i + check "wekvw030t" 27 a.[0,2,3,4].i + +module LoopTests = + let loop3 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. N do + x <- x + 1 + done; + check (sprintf "clkrerev90-%A" (a,N)) x (if N < a then 0 else N - a + 1) + + + do loop3 0 10 + do loop3 0 0 + do loop3 0 -1 + do loop3 10 9 + + let loop4 a N = + let mutable x = 0 in + for i in OperatorIntrinsics.RangeInt32 a 1 N do + x <- x + 1 + done; + check (sprintf "clkrerev91-%A" (a,N)) x (if N < a then 0 else N - a + 1) + + do loop4 0 10 + do loop4 0 0 + do loop4 0 -1 + do loop4 10 9 + + let loop5 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. 2 .. (min N N) do + x <- x + 1 + done; + check (sprintf "clkrerev92-%A" (a,N)) x ((if N < a then 0 else N - a + 2) / 2) + + do loop5 0 10 + do loop5 0 0 + do loop5 0 -1 + do loop5 10 9 + + + let loop6 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. 200 .. (min N N) do + x <- x + 1 + done; + check (sprintf "clkrerev93-%A" (a,N)) x ((if N < a then 0 else N - a + 200) / 200) + + do loop6 0 10 + do loop6 0 0 + do loop6 0 -1 + do loop6 10 9 + + + let loop7 a step N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. step .. (min N N) do + x <- x + 1 + done; + check (sprintf "clkrerev95-%A" (a,step,N)) x (if step < 0 then (if a < N then 0 else (a - N + abs step) / abs step) else (if N < a then 0 else N - a + step) / step) + + do loop7 0 1 10 + do loop7 0 -1 0 + do loop7 0 2 -1 + do loop7 10 -2 9 + + let loop8 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. -1 .. (min N N) do + x <- x + 1 + done; + check (sprintf "clkrerev96-%A" (a,N)) x (abs (if a < N then 0 else (a - N + 1) / 1)) + + do loop8 0 10 + do loop8 0 0 + do loop8 0 -1 + do loop8 10 9 + +// Some more adhoc testing - the use of 'min' gives rise to a let binding in optimized code +module MoreLoopTestsWithLetBindings = + let loop3 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. (min N N) do + x <- x + 1 + done; + check (sprintf "ffclkrerev90-%A" (a,N)) x (if N < a then 0 else N - a + 1) + + + do loop3 0 10 + do loop3 0 0 + do loop3 0 -1 + do loop3 10 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do loop3 start finish + + let loop4 a N = + let mutable x = 0 in + for i in OperatorIntrinsics.RangeInt32 a 1 N do + x <- x + 1 + done; + check (sprintf "ffclkrerev91-%A" (a,N)) x (if N < a then 0 else N - a + 1) + + do loop4 0 10 + do loop4 0 0 + do loop4 0 -1 + do loop4 10 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do loop4 start finish + + let loop5 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. 2 .. (min N N) do + x <- x + 1 + done; + check (sprintf "ffclkrerev92-%A" (a,N)) x ((if N < a then 0 else N - a + 2) / 2) + + do loop5 0 10 + do loop5 0 0 + do loop5 0 -1 + do loop5 10 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do loop5 start finish + + + let loop6 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. 200 .. (min N N) do + x <- x + 1 + done; + check (sprintf "ffclkrerev93-%A" (a,N)) x ((if N < a then 0 else N - a + 200) / 200) + + do loop6 0 10 + do loop6 0 0 + do loop6 0 -1 + do loop6 10 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do loop6 start finish + + + let loop7 a step N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. step .. (min N N) do + x <- x + 1 + done; + check (sprintf "ffclkrerev95-%A" (a,step,N)) x (if step < 0 then (if a < N then 0 else (a - N + abs step) / abs step) else (if N < a then 0 else N - a + step) / step) + + do loop7 0 1 10 + do loop7 0 -1 0 + do loop7 0 2 -1 + do loop7 10 -2 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do for step in [-2; -1; 1; 2] do loop7 start step finish + + let loop8 a N = + let mutable x = 0 in + // In this loop, the types of 'a' and 'N' are not known prior to the loop + for i in (min a a) .. -1 .. (min N N) do + x <- x + 1 + done; + check (sprintf "ffclkrerev96-%A" (a,N)) x (abs (if a < N then 0 else (a - N + 1) / 1)) + + do loop8 0 10 + do loop8 0 0 + do loop8 0 -1 + do loop8 10 9 + do for start in -3 .. 3 do for finish in -3 .. 3 do loop8 start finish + +module bug872632 = + type MarkerStyle = + | None = 0 + | Square = 1 + | Circle = 2 + | Diamond = 3 + | Triangle = 4 + | Triangle1 = 10 + | Cross = 5 + | Star4 = 6 + | Star5 = 7 + | Star6 = 8 + | Star10 = 9 + + + + module Foo = + let x = [| + MarkerStyle.Circle + MarkerStyle.Cross + MarkerStyle.Star6 + MarkerStyle.Diamond + MarkerStyle.Square + MarkerStyle.Star10 + MarkerStyle.Triangle + MarkerStyle.Triangle1 + |] + + do check "bug872632" Foo.x.Length 8 + +#if Portable +#else // this overload of CreateInstance doesn't exist in portable +module bug6447 = + let a = System.Array.CreateInstance(typeof, [|1|], [|1|]) + let a1 = System.Array.CreateInstance(typeof, [|1|], [|3|]) + let a2 = System.Array.CreateInstance(typeof, [|3|], [|1|]) + + do check "bug6447_bound1" a a + do check "bug6447_bound3" a1 a1 + do check "bug6447_bound1_3" a2 a2 + do check "bug6447_a_lt_a" (Unchecked.compare a a) 0 + do check "bug6447_a_eq_a1" (Unchecked.equals a a1) false + do check "bug6447_a_lt_a1" (Unchecked.compare a a1) -1 + do check "bug6447_a_lt_a1" (Unchecked.compare a1 a) 1 + do check "bug6447_a_eq_a2" (Unchecked.equals a a2) false + do check "bug6447_a_lt_a2" (Unchecked.compare a a2) -1 + do check "bug6447_a_lt_a2" (Unchecked.compare a2 a) 1 + do check "bug6447_a1_eq_a2" (Unchecked.equals a1 a2) false + do check "bug6447_a1_gt_a2" (Unchecked.compare a2 a1) 1 + do check "bug6447_a1_lt_a2" (Unchecked.compare a1 a2) -1 + do check "bug6447_a1_lt_a2" (Unchecked.compare a2 a1) 1 + do check "bug6447_a2_eq_a1" (Unchecked.equals a2 a1) false + do check "bug6447_a2_gt_a2" (Unchecked.compare a2 a1) 1 + do check "bug6447_a2_lt_a1" (Unchecked.compare a1 a2) -1 + do check "bug6447_hash_a" (hash a) 631 + do check "bug6447_hash_a1" (hash a1) 1893 + do check "bug6447_hash_a2" (hash a2) 10727 +#endif + +#if ALL_IN_ONE +let RUN() = !failures +#else +let aa = + match !failures with + | [] -> + stdout.WriteLine "Test Passed" + System.IO.File.WriteAllText("test.ok","ok") + exit 0 + | _ -> + stdout.WriteLine "Test Failed" + exit 1 +#endif + diff --git a/tests/fsharp/core/attributes/build.bat b/tests/fsharp/core/attributes/build.bat new file mode 100644 index 0000000000..a6ff3718fe --- /dev/null +++ b/tests/fsharp/core/attributes/build.bat @@ -0,0 +1,6 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-build.bat + +exit /b %ERRORLEVEL% + diff --git a/tests/fsharp/core/attributes/cslib.cs b/tests/fsharp/core/attributes/cslib.cs new file mode 100644 index 0000000000..5ead12d04e --- /dev/null +++ b/tests/fsharp/core/attributes/cslib.cs @@ -0,0 +1,54 @@ +namespace CSharpLibrary +{ + + + public class IntArrayPropAttribute : System.Attribute + { + int[] v; + public int[] Value { set { v = value; } get { return v; } } + } + + + public class ObjArrayPropAttribute : System.Attribute + { + object[] v; + public object[] Value { set { v = value; } get { return v; } } + } + + public class AnyPropAttribute : System.Attribute + { + object v; + public object Value { set { v = value; } get { return v; } } + } + + public class IntArrayAttribute : System.Attribute + { + int[] values; + public IntArrayAttribute(int[] value) { values = value; } + public int[] Value { get { return values; } } + } + + public class ObjArrayAttribute : System.Attribute + { + object[] values; + public ObjArrayAttribute(object[] value) { values = value; } + public object[] Value { get { return values; } } + } + + + + public class AnyAttribute : System.Attribute + { + object v; + public AnyAttribute(object value) { v = value; } + public object Value { get { return v; } } + } + + [Any(new int[] { 42 })] + [IntArray(new int[] { 42 })] + [ObjArray(new object[] { 42 })] + [IntArrayProp(Value = new int[] { 42 })] + [ObjArrayProp(Value = new object[] { 42 })] + [AnyProp(Value = new int[] { 42 })] + public class TestClass { } +} diff --git a/tests/fsharp/core/attributes/cslib.dll b/tests/fsharp/core/attributes/cslib.dll new file mode 100644 index 0000000000..96482b4f85 Binary files /dev/null and b/tests/fsharp/core/attributes/cslib.dll differ diff --git a/tests/fsharp/core/attributes/dont.use.empty.signature b/tests/fsharp/core/attributes/dont.use.empty.signature new file mode 100644 index 0000000000..1eb40992dd --- /dev/null +++ b/tests/fsharp/core/attributes/dont.use.empty.signature @@ -0,0 +1 @@ +"indeed" diff --git a/tests/fsharp/core/attributes/dont.use.generated.signature b/tests/fsharp/core/attributes/dont.use.generated.signature new file mode 100644 index 0000000000..b9e931c327 --- /dev/null +++ b/tests/fsharp/core/attributes/dont.use.generated.signature @@ -0,0 +1 @@ +because parameter names and attributes may come from the signature diff --git a/tests/fsharp/core/attributes/dont.use.wrapper.namespace b/tests/fsharp/core/attributes/dont.use.wrapper.namespace new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/tests/fsharp/core/attributes/dont.use.wrapper.namespace @@ -0,0 +1 @@ + diff --git a/tests/fsharp/core/attributes/run.bat b/tests/fsharp/core/attributes/run.bat new file mode 100644 index 0000000000..ceb0a61a54 --- /dev/null +++ b/tests/fsharp/core/attributes/run.bat @@ -0,0 +1,7 @@ +@if "%_echo%"=="" echo off + +call %~d0%~p0..\..\single-test-run.bat + +exit /b %ERRORLEVEL% + + diff --git a/tests/fsharp/core/attributes/test.fsx b/tests/fsharp/core/attributes/test.fsx new file mode 100644 index 0000000000..d74304a1d0 --- /dev/null +++ b/tests/fsharp/core/attributes/test.fsx @@ -0,0 +1,1330 @@ +// #Conformance #Attributes #Interop #Regression +(*------------------------------------------------------------------------- +!* attribute tests + *------------------------------------------------------------------------- *) +#if ALL_IN_ONE +module Core_attributes +#endif +#light + +#if Portable +#else +#load "testlib.fsi" "testlib.fs" // a warning is expected here + +#r "cslib.dll" +#endif + +let failures = ref [] + +let report_failure (s : string) = + stderr.Write" NO: " + stderr.WriteLine s + failures := !failures @ [s] + +let test (s : string) b = + stderr.Write(s) + if b then stderr.WriteLine " OK" + else report_failure (s) + +let check (s:string) e r = + if r = e then stdout.WriteLine (s+": YES") + else (stdout.Write ("\n***** "+s+": FAIL: "); + printfn "Expected '%A', Got '%A'" r e + report_failure s) + +open System +open System.Diagnostics + +#if Portable +#else +(* ATTRIBUTES *) + +[] + +let main = () + +#endif + + +(* attribute on a type *) +type [< Obsolete("testing an obsolete warning is printed")>] x = X + +(* attribute on a type *) +type [] x2 = X2 + +let [] fx2 (x:x2) = () + +let fx3 (x:x2) = fx2 x + +(* attribute on a method *) +let [] myLoggingMethod x = stderr.WriteLine(x:string) + +#if Portable +#else +let [] myLoggingMethod2 x = stderr.WriteLine(x:string) +#endif + +(* attribute on a type *) +type [] y = Y + +type y2 = | [] Y | [] Z + +let y2f () = (Y,Z) + +(* attribute on a field *) +type record = + { myField1: int; + [] myField2: int; + [] myDebugField3: string } + +let recordf x = x.myField2 + +(* +#r "System.Security.dll";; +#r "System.Configuration.dll";; +open System.Configuration +type CustomSection = +class + inherit ConfigurationSection + val fileName : string + new() = {inherit ConfigurationSection(); fileName = ""} + [] + member m.FileName = m.fileName +end;; +*) + +(* attribute on a method parameter *) +(* NOT YET: let myMethod2 x ([] y) = stderr.WriteLine x *) + +(* attribute on an instance property type *) +(* NOT YET: let [] x.myDebug = x.myDebugField3 *) + +(* attribute on a return type *) +(* NOT YET: let [] myMethod3 x = x + 1 *) + +#if Portable +#else +(* BUG 428 - compile time error - on obsolete attributes *) +let f (cert:System.Security.Cryptography.X509Certificates.X509Certificate) = + let x = cert.GetName () in + () + + +open System.Threading +let test32498() = + let guiTH = new Thread(new ThreadStart(fun () -> ())) in + guiTH.ApartmentState <- ApartmentState.STA + +//let [] id x = x + +//[] let id2 x = x +#endif + + +type A = + class + [] new() = { } + [] member this.M() = () + [] static member M2() = () + end + +let ww (x: A) = () +let xx = new A() +let yy = xx.M() +let zz = A.M2() + +let checkAttributeCount s attrs n = + if Array.length attrs <> n then report_failure (sprintf "incorrect number of CAs on '%s', expected %d, got %d" s n attrs.Length) + +module CheckAttributesExist = begin + open System.Reflection + + [] + module Outer = begin + type Inner = A | B + let x = 1 + let ty = typeof + do checkAttributeCount "outer module" (ty.DeclaringType.GetCustomAttributes(typeof, false)) 1; + end +end + +module CheckNullAttributeOnString = begin + + [] + module Outer = begin + type Inner = A | B + let x = 1 + let ty = typeof + do checkAttributeCount "property f1" (ty.DeclaringType.GetCustomAttributes(typeof,false)) 1; + do match ty.DeclaringType.GetCustomAttributes(typeof,false) with + | [| (:? System.ObsoleteAttribute as ca) |] -> check "test423cwo3ne02" ca.Message null + | _ -> check "no attribute found" true false + end + + [] + module Outer2 = begin + type Inner = A | B + let x = 1 + let ty = typeof + do checkAttributeCount "property f1" (ty.DeclaringType.GetCustomAttributes(typeof,false)) 1; + do match ty.DeclaringType.GetCustomAttributes(typeof,false) with + | [| (:? System.ObsoleteAttribute as ca) |] -> check "test423cwo3ne02" ca.Message "" + | _ -> check "no attribute found" true false + end + + let v = Outer2.Inner.A + + [] + let NullLiteral : string = null + + [] + module Outer3 = begin + type Inner = A | B + let x = 1 + let ty = typeof + do checkAttributeCount "property f1" (ty.DeclaringType.GetCustomAttributes(typeof,false)) 1; + do match ty.DeclaringType.GetCustomAttributes(typeof,false) with + | [| (:? System.ObsoleteAttribute as ca) |] -> check "test423cwo3ne02" ca.Message null + | _ -> check "no attribute found" true false + end + + [] + let NullLiteral1 : string = null + + [] + let NullLiteral2 : string = NullLiteral1 + + [] + module Outer4 = begin + type Inner = A | B + let x = 1 + let ty = typeof + do checkAttributeCount "property f1" (ty.DeclaringType.GetCustomAttributes(typeof,false)) 1; + do match ty.DeclaringType.GetCustomAttributes(typeof,false) with + | [| (:? System.ObsoleteAttribute as ca) |] -> check "test423cwo3ne02" ca.Message null + | _ -> check "no attribute found" true false + end + + + +end + +open System + +/// Test the use of '|||' in attributes +[] +type BitwiseOrAttribute = class + inherit Attribute +end + +[] +type BitwiseOrAttribute2 = class + inherit Attribute +end + +[] +do () + +type dummy = Dummy +let ass = typeof.Assembly + +// Assembly attributes are currently ignored by F# Interactive, so this test +// fails. We ignore the failure. +#if COMPILED +let ca = ass.GetCustomAttributes(typeof,false) +do if Array.length ca <> 1 then failwith "could not find CA on assembly" +#endif + +[] +type y3 = Y3 + +let ca3 = typeof.GetCustomAttributes(typeof,false) +do if Array.length ca3 <> 1 then failwith "could not find CA on type" + +[] +type y4 = Y4 + +let ca4 = typeof.GetCustomAttributes(typeof,false) +do if Array.length ca4 <> 1 then failwith "could not find CA on type" + + +#if Portable +#else +open System.Runtime.InteropServices + +[] +let MoveFile ((src : string), (dst: string)) : bool = failwith "extern" +#endif + +//--------------------------------------------------------------------- +// Test we can define an attribute that accepts a named property argument + + +type DontPressThisButtonAttribute = + class + inherit System.Attribute + val v: string + val mutable someOtherField: string + member x.SomeOtherField + with get() = x.someOtherField + and set(v:string) = x.someOtherField <- v + member x.Message = x.v + new(s:string) = { inherit System.Attribute(); v=s; someOtherField="" } + end + +type [] button = Buttpon + +let ca5 = typeof