From 63c12b9739f67c0eed008c3a59bea8386fa7862c Mon Sep 17 00:00:00 2001 From: ncave Date: Tue, 31 Jan 2017 23:07:02 -0800 Subject: [PATCH] [WIP] Fable support --- .vscode/launch.json | 21 + build.fsx | 13 + global.json | 5 +- src/absil/il.fs | 33 +- src/absil/il.fsi | 2 + src/absil/ildiag.fs | 7 + src/absil/ildiag.fsi | 4 +- src/absil/illib.fs | 58 +- src/absil/ilread.fs | 375 +-- src/absil/ilread.fsi | 2 + src/absil/ilwrite.fs | 77 +- src/fsharp/CompileOps.fs | 2760 +++++++++-------- src/fsharp/CompileOps.fsi | 4 +- src/fsharp/CompileOptions.fs | 2 + src/fsharp/ConstraintSolver.fs | 7 +- src/fsharp/ErrorLogger.fs | 33 +- src/fsharp/ErrorResolutionHints.fs | 4 + src/fsharp/ExtensionTyping.fs | 8 +- src/fsharp/FSComp.txt | 2 +- .../FSharp.Compiler.Service/project.json | 2 +- src/fsharp/Fable.FCS/.gitignore | 5 + src/fsharp/Fable.FCS/Fable.FCS.fsx | 174 ++ src/fsharp/Fable.FCS/Fable.FCS.sln | 22 + src/fsharp/Fable.FCS/adapters.fs | 269 ++ src/fsharp/Fable.FCS/app.fs | 69 + src/fsharp/Fable.FCS/fableconfig.json | 24 + src/fsharp/Fable.FCS/fsstrings.fs | 968 ++++++ src/fsharp/Fable.FCS/package.json | 9 + src/fsharp/Fable.FCS/project.fsproj | 86 + src/fsharp/Fable.FCS/project.fsx | 11 + src/fsharp/Fable.FCS/project.json | 60 + src/fsharp/Fable.FCS/service_shim.fs | 860 +++++ src/fsharp/Fable.FCS/unicode.fs | 71 + src/fsharp/InfoReader.fs | 4 + src/fsharp/LexFilter.fs | 26 +- src/fsharp/MethodCalls.fs | 6 +- src/fsharp/NameResolution.fs | 29 +- src/fsharp/NicePrint.fs | 50 +- src/fsharp/Optimizer.fs | 3 +- src/fsharp/PatternMatchCompilation.fs | 5 +- src/fsharp/PostInferenceChecks.fs | 7 +- src/fsharp/PrettyNaming.fs | 10 +- src/fsharp/QuotationPickler.fs | 5 +- src/fsharp/QuotationTranslator.fs | 9 +- src/fsharp/SignatureConformance.fs | 3 + src/fsharp/TastOps.fs | 68 +- src/fsharp/TastPickle.fs | 14 +- src/fsharp/TcGlobals.fs | 7 +- src/fsharp/TypeChecker.fs | 38 +- src/fsharp/TypeRelations.fs | 6 +- src/fsharp/UnicodeLexing.fs | 6 +- src/fsharp/UnicodeLexing.fsi | 3 + src/fsharp/import.fs | 6 + src/fsharp/infos.fs | 2 +- src/fsharp/layout.fs | 8 + src/fsharp/layout.fsi | 7 + src/fsharp/lex.fsl | 59 +- src/fsharp/lexhelp.fs | 32 +- src/fsharp/lexhelp.fsi | 12 +- src/fsharp/lib.fs | 18 +- src/fsharp/pars.fsy | 12 +- src/fsharp/range.fs | 82 +- src/fsharp/range.fsi | 12 +- src/fsharp/rational.fs | 3 + src/fsharp/tast.fs | 21 +- src/fsharp/vs/Exprs.fs | 13 +- src/fsharp/vs/ServiceDeclarations.fs | 33 +- src/fsharp/vs/ServiceDeclarations.fsi | 3 + src/fsharp/vs/ServiceLexing.fs | 3 + src/fsharp/vs/ServiceUntypedParse.fs | 3 + src/fsharp/vs/SimpleServices.fs | 2 +- src/fsharp/vs/Symbols.fs | 97 +- src/fsharp/vs/Symbols.fsi | 4 +- src/ilx/EraseUnions.fs | 3 +- src/utils/HashMultiMap.fs | 44 +- src/utils/HashMultiMap.fsi | 13 +- src/utils/ResizeArray.fs | 60 + src/utils/TaggedCollections.fs | 4 +- src/utils/filename.fs | 33 +- src/utils/prim-lexing.fs | 5 +- src/utils/prim-parsing.fs | 19 +- src/utils/prim-parsing.fsi | 11 + 82 files changed, 5149 insertions(+), 1821 deletions(-) create mode 100644 .vscode/launch.json create mode 100644 src/fsharp/Fable.FCS/.gitignore create mode 100644 src/fsharp/Fable.FCS/Fable.FCS.fsx create mode 100644 src/fsharp/Fable.FCS/Fable.FCS.sln create mode 100644 src/fsharp/Fable.FCS/adapters.fs create mode 100644 src/fsharp/Fable.FCS/app.fs create mode 100644 src/fsharp/Fable.FCS/fableconfig.json create mode 100644 src/fsharp/Fable.FCS/fsstrings.fs create mode 100644 src/fsharp/Fable.FCS/package.json create mode 100644 src/fsharp/Fable.FCS/project.fsproj create mode 100644 src/fsharp/Fable.FCS/project.fsx create mode 100644 src/fsharp/Fable.FCS/project.json create mode 100644 src/fsharp/Fable.FCS/service_shim.fs create mode 100644 src/fsharp/Fable.FCS/unicode.fs diff --git a/.vscode/launch.json b/.vscode/launch.json new file mode 100644 index 0000000000..c22caf968e --- /dev/null +++ b/.vscode/launch.json @@ -0,0 +1,21 @@ +{ + // Use IntelliSense to learn about possible Node.js debug attributes. + // Hover to view descriptions of existing attributes. + // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 + "version": "0.2.0", + "configurations": [ + { + "type": "node2", + "request": "launch", + "name": "Launch Program", + "program": "${workspaceRoot}/src/fsharp/Fable.FCS/out/Fable.FCS/project.js", + "cwd": "${workspaceRoot}" + }, + { + "type": "node2", + "request": "attach", + "name": "Attach to Process", + "port": 5858 + } + ] +} \ No newline at end of file diff --git a/build.fsx b/build.fsx index 3910de4d98..02f01b04d5 100644 --- a/build.fsx +++ b/build.fsx @@ -272,14 +272,27 @@ Target "CodeGen.NetCore" (fun _ -> let fsLex fsl out = runInDir (toolDir + "fslex.exe") "%s --unicode %s -o %s" fsl lexArgs out let fsYacc fsy out m o = runInDir (toolDir + "fsyacc.exe") "%s %s %s %s %s -o %s" fsy lexArgs yaccArgs m o out +#if FABLE_COMPILER + // until a more recent version of fssrgen is released, building from source + runInDir "dotnet" "run -c Release -p /Projects/FsSrGen/src/dotnet-fssrgen ../FSComp.txt ./FSComp.fs" + runInDir "dotnet" "run -c Release -p /Projects/FsSrGen/src/dotnet-fssrgen ../fsi/FSIstrings.txt ./FSIstrings.fs" +#else runInDir "dotnet" "fssrgen ../FSComp.txt ./FSComp.fs ./FSComp.resx" runInDir "dotnet" "fssrgen ../fsi/FSIstrings.txt ./FSIstrings.fs ./FSIstrings.resx" +#endif fsLex "../lex.fsl" "lex.fs" fsLex "../pplex.fsl" "pplex.fs" fsLex "../../absil/illex.fsl" "illex.fs" fsYacc "../../absil/ilpars.fsy" "ilpars.fs" module1 open1 fsYacc "../pars.fsy" "pars.fs" module2 open2 fsYacc "../pppars.fsy" "pppars.fs" module3 open3 + +#if FABLE_COMPILER + // comments the #line directive as it is not supported by Fable + ["lex.fs"; "pplex.fs"; "illex.fs"; "ilpars.fs"; "pars.fs"; "pppars.fs"] + |> Seq.map (fun fileName -> IO.Path.Combine (workDir, fileName)) + |> RegexReplaceInFilesWithEncoding @"# (?=\d)" "//# " Text.Encoding.UTF8 +#endif ) Target "Build.NetCore" (fun _ -> diff --git a/global.json b/global.json index 6e0ba32b5d..245a03dea6 100644 --- a/global.json +++ b/global.json @@ -1,3 +1,6 @@ { - "projects": [ "src/fsharp", "tests" ] + "projects": [ "src/fsharp", "tests" ], + "sdk": { + "version": "1.0.0-preview2-003131" + } } diff --git a/src/absil/il.fs b/src/absil/il.fs index 2655a6c815..f552c8a1e7 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -8,6 +8,10 @@ module (*internal*) Microsoft.FSharp.Compiler.AbstractIL.IL open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -373,6 +377,7 @@ type ILAssemblyRef(data) = assemRefVersion=version; assemRefLocale=locale; } +#if !FABLE_COMPILER static member FromAssemblyName (aname:System.Reflection.AssemblyName) = let locale = None //match aname.CultureInfo with @@ -395,13 +400,18 @@ type ILAssemblyRef(data) = let retargetable = aname.Flags = System.Reflection.AssemblyNameFlags.Retargetable ILAssemblyRef.Create(aname.Name,None,publicKey,retargetable,version,locale) - + #endif + member aref.QualifiedName = let b = new System.Text.StringBuilder(100) let add (s:string) = (b.Append(s) |> ignore) +#if FABLE_COMPILER + let addC (s:char) = (b.Append(string s) |> ignore) +#else let addC (s:char) = (b.Append(s) |> ignore) +#endif add(aref.Name); match aref.Version with | None -> () @@ -468,7 +478,7 @@ type ILScopeRef = member scoref.QualifiedName = match scoref with | ILScopeRef.Local -> "" - | ILScopeRef.Module mref -> "module "^mref.Name + | ILScopeRef.Module mref -> "module "+mref.Name | ILScopeRef.Assembly aref when aref.Name = "mscorlib" -> "" | ILScopeRef.Assembly aref -> aref.QualifiedName @@ -3661,7 +3671,7 @@ type ILTypeSigParser(tstring : string) = // fetch the arity let arity = while (int(here()) >= (int('0'))) && (int(here()) <= ((int('9')))) && (int(peek()) >= (int('0'))) && (int(peek()) <= ((int('9')))) do step() - System.Int32.Parse(take()) + System.Convert.ToInt32(take()) // skip the '[' drop() // get the specializations @@ -3699,7 +3709,11 @@ type ILTypeSigParser(tstring : string) = yield grabScopeComponent() // culture yield grabScopeComponent() // public key token ] |> String.concat "," +#if FABLE_COMPILER + ILScopeRef.Assembly(mkSimpleAssRef scope) +#else ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(System.Reflection.AssemblyName(scope))) +#endif else ILScopeRef.Local @@ -3844,7 +3858,11 @@ let decodeILAttribData ilg (ca: ILAttribute) = pieces.[0], None let scoref = match rest with +#if FABLE_COMPILER + | Some aname -> ILScopeRef.Assembly(mkSimpleAssRef aname) +#else | Some aname -> ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(System.Reflection.AssemblyName(aname))) +#endif | None -> ilg.traits.ScopeRef let tref = mkILTyRef (scoref,unqualified_tname) @@ -4105,13 +4123,18 @@ let parseILVersion (vstr : string) = // Set the revision number to number of seconds today / 2 versionComponents.[3] <- defaultRevision.ToString() ; vstr <- System.String.Join(".",versionComponents) ; - + +#if FABLE_COMPILER + let parts = vstr.Split([|'.'|]) + let versions = Array.append (Array.map uint16 parts) [|0us;0us;0us;0us|] + (versions.[0], versions.[1], versions.[2], versions.[3]) +#else let version = System.Version(vstr) let zero32 n = if n < 0 then 0us else uint16(n) // since the minor revision will be -1 if none is specified, we need to truncate to 0 to not break existing code let minorRevision = if version.Revision = -1 then 0us else uint16(version.MinorRevision) (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision);; - +#endif let compareILVersions (a1,a2,a3,a4) ((b1,b2,b3,b4) : ILVersionInfo) = let c = compare a1 b1 diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 37a2d205e0..ad948eb296 100755 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -99,7 +99,9 @@ type ILVersionInfo = uint16 * uint16 * uint16 * uint16 [] type ILAssemblyRef = static member Create : name: string * hash: byte[] option * publicKey: PublicKey option * retargetable: bool * version: ILVersionInfo option * locale: string option -> ILAssemblyRef +#if !FABLE_COMPILER static member FromAssemblyName : System.Reflection.AssemblyName -> ILAssemblyRef +#endif member Name: string; /// The fully qualified name of the assembly reference, e.g. mscorlib, Version=1.0.3705 etc. member QualifiedName: string; diff --git a/src/absil/ildiag.fs b/src/absil/ildiag.fs index ae5fd91546..208bdb55a7 100755 --- a/src/absil/ildiag.fs +++ b/src/absil/ildiag.fs @@ -6,6 +6,12 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Internal.Utilities +#if FABLE_COMPILER +let dprintf fmt = printf fmt +let dprintfn fmt = printfn fmt +let dprintn s = printfn "%s" s +#else + let diagnosticsLog = ref (Some stdout) let setDiagnosticsChannel s = diagnosticsLog := s @@ -21,3 +27,4 @@ let dprintf (fmt: Format<_,_,_,_>) = let dprintfn (fmt: Format<_,_,_,_>) = Printf.kfprintf dflushn (match !diagnosticsLog with None -> System.IO.TextWriter.Null | Some d -> d) fmt +#endif \ No newline at end of file diff --git a/src/absil/ildiag.fsi b/src/absil/ildiag.fsi index b7aeb60341..e0b4666673 100755 --- a/src/absil/ildiag.fsi +++ b/src/absil/ildiag.fsi @@ -8,10 +8,12 @@ /// REVIEW: review if we should just switch to System.Diagnostics module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open System.IO open Microsoft.FSharp.Core.Printf +#if !FABLE_COMPILER +open System.IO val public setDiagnosticsChannel: TextWriter option -> unit +#endif val public dprintfn: TextWriterFormat<'a> -> 'a val public dprintf: TextWriterFormat<'a> -> 'a diff --git a/src/absil/illib.fs b/src/absil/illib.fs index 5d06388aa2..051c2da0d2 100755 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -8,6 +8,11 @@ open System open System.Collections open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +#endif #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters @@ -20,9 +25,10 @@ let (>>>&) (x:int32) (n:int32) = int32 (uint32 x >>> n) let notlazy v = Lazy<_>.CreateFromValue v let inline isNonNull x = not (isNull x) -let inline nonNull msg x = if isNull x then failwith ("null: " ^ msg) else x +let inline nonNull msg x = if isNull x then failwith ("null: " + msg) else x let (===) x y = LanguagePrimitives.PhysicalEquality x y +#if !FABLE_COMPILER //--------------------------------------------------------------------- // Library: ReportTime //--------------------------------------------------------------------- @@ -36,13 +42,19 @@ let reportTime = let first = match !tFirst with None -> (tFirst := Some t; t) | Some t -> t printf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr tPrev := Some t +#endif //------------------------------------------------------------------------- // Library: projections //------------------------------------------------------------------------ -[] /// An efficient lazy for inline storage in a class type. Results in fewer thunks. +#if FABLE_COMPILER +type InlineDelayInit<'T when 'T : not struct>(f: unit -> 'T) = + let store = lazy(f()) + member x.Value = store.Force() +#else +[] type InlineDelayInit<'T when 'T : not struct> = new (f: unit -> 'T) = {store = Unchecked.defaultof<'T>; func = System.Func<_>(f) } val mutable store : 'T @@ -54,6 +66,7 @@ type InlineDelayInit<'T when 'T : not struct> = let res = System.Threading.LazyInitializer.EnsureInitialized(&x.store, x.func) x.func <- Unchecked.defaultof<_> res +#endif //------------------------------------------------------------------------- // Library: projections @@ -172,7 +185,7 @@ module Option = module List = - let item n xs = List.nth xs n + let item n xs = List.item n xs #if FX_RESHAPED_REFLECTION open PrimReflectionAdapters open Microsoft.FSharp.Core.ReflectionAdapters @@ -233,7 +246,9 @@ module List = ch [] [] l let mapq (f: 'T -> 'T) inp = +#if !FABLE_COMPILER assert not (typeof<'T>.IsValueType) +#endif match inp with | [] -> inp | _ -> @@ -398,10 +413,10 @@ module String = if r = -1 then indexNotFound() else r let contains (s:string) (c:char) = - s.IndexOf(c,0,String.length s) <> -1 + s.IndexOf(c) <> -1 let order = LanguagePrimitives.FastGenericComparer - + let lowercase (s:string) = s.ToLowerInvariant() @@ -512,7 +527,8 @@ module Eventually = else forceWhile check (work()) let force e = Option.get (forceWhile (fun () -> true) e) - + +#if !FABLE_COMPILER /// Keep running the computation bit by bit until a time limit is reached. /// The runner gets called each time the computation is restarted let repeatedlyProgressUntilDoneOrTimeShareOver timeShareInMilliseconds runner e = @@ -532,6 +548,7 @@ module Eventually = loop(work()) loop(e)) runTimeShare e +#endif let rec bind k e = match e with @@ -613,13 +630,15 @@ type MemoizationTable<'T,'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer<' let table = new System.Collections.Generic.Dictionary<'T,'U>(keyComparer) member t.Apply(x) = if (match canMemoize with None -> true | Some f -> f x) then - let mutable res = Unchecked.defaultof<'U> - let ok = table.TryGetValue(x,&res) +#if FABLE_COMPILER + ( +#else + let ok, res = table.TryGetValue(x) if ok then res else lock table (fun () -> - let mutable res = Unchecked.defaultof<'U> - let ok = table.TryGetValue(x,&res) +#endif + let ok, res = table.TryGetValue(x) if ok then res else let res = compute x @@ -661,12 +680,16 @@ type LazyWithContext<'T,'ctxt> = match x.funcOrException with | null -> x.value | _ -> +#if FABLE_COMPILER + x.UnsynchronizedForce(ctxt) +#else // Enter the lock in case another thread is in the process of evaluating the result System.Threading.Monitor.Enter(x); try x.UnsynchronizedForce(ctxt) finally System.Threading.Monitor.Exit(x) +#endif member x.UnsynchronizedForce(ctxt) = match x.funcOrException with @@ -697,11 +720,11 @@ module Tables = let memoize f = let t = new Dictionary<_,_>(1000, HashIdentity.Structural) fun x -> - let mutable res = Unchecked.defaultof<_> - if t.TryGetValue(x, &res) then + let ok, res = t.TryGetValue(x) + if ok then res else - res <- f x; t.[x] <- res; res + let res = f x in t.[x] <- res; res //------------------------------------------------------------------------- // Library: Name maps @@ -808,10 +831,17 @@ type LayeredMap<'Key,'Value when 'Key : comparison> = Map<'Key,'Value> type Map<'Key,'Value when 'Key : comparison> with static member Empty : Map<'Key,'Value> = Map.empty +#if FABLE_COMPILER + member m.TryGetValue (key) = + match m.TryFind key with + | None -> false, Unchecked.defaultof<_> + | Some r -> true, r +#else member m.TryGetValue (key,res:byref<'Value>) = match m.TryFind key with | None -> false | Some r -> res <- r; true +#endif member x.Values = [ for (KeyValue(_,v)) in x -> v ] member x.AddAndMarkAsCollapsible (kvs: _[]) = (x,kvs) ||> Array.fold (fun x (KeyValue(k,v)) -> x.Add(k,v)) @@ -831,6 +861,7 @@ type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(con member x.Values = contents.Values |> List.concat static member Empty : LayeredMultiMap<'Key,'Value> = LayeredMultiMap LayeredMap.Empty +#if !FABLE_COMPILER [] module Shim = @@ -904,3 +935,4 @@ module Shim = System.Text.Encoding.GetEncoding(n) let mutable FileSystem = DefaultFileSystem() :> IFileSystem +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index fbb76f24ef..44b0db277c 100755 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -14,6 +14,7 @@ open System.IO open System.Runtime.InteropServices open System.Collections.Generic open Internal.Utilities +open Microsoft.FSharp.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal #if FX_NO_PDB_READER @@ -104,6 +105,8 @@ type BinaryFile() = abstract CountUtf8String : addr:int -> int abstract ReadUTF8String : addr: int -> string +#if !FABLE_COMPILER + /// Read from memory mapped files. module MemoryMapping = @@ -212,6 +215,7 @@ type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) = // new System.String(NativePtr.ofNativeInt (m.Addr i), 0, n, System.Text.Encoding.UTF8) //#endif +#endif //!FABLE_COMPILER //--------------------------------------------------------------------- // Read file from memory blocks @@ -764,8 +768,7 @@ let mkCacheInt32 lowMem _inbase _nm _sz = | null -> cache := new Dictionary(11) | _ -> () !cache - let mutable res = Unchecked.defaultof<_> - let ok = cache.TryGetValue(idx, &res) + let ok, res = cache.TryGetValue(idx) if ok then incr count res @@ -1029,67 +1032,63 @@ let count c = #endif -let seekReadUInt16Adv ctxt (addr: byref) = +let seekReadUInt16Adv ctxt (addr: int) = let res = seekReadUInt16 ctxt.is addr - addr <- addr + 2 - res + (res, addr + 2) //TODO: return struct tuple -let seekReadInt32Adv ctxt (addr: byref) = +let seekReadInt32Adv ctxt (addr: int) = let res = seekReadInt32 ctxt.is addr - addr <- addr+4 - res + (res, addr + 4) //TODO: return struct tuple -let seekReadUInt16AsInt32Adv ctxt (addr: byref) = +let seekReadUInt16AsInt32Adv ctxt (addr: int) = let res = seekReadUInt16AsInt32 ctxt.is addr - addr <- addr+2 - res - -let seekReadTaggedIdx f nbits big is (addr: byref) = - let tok = if big then seekReadInt32Adv is &addr else seekReadUInt16AsInt32Adv is &addr - tokToTaggedIdx f nbits tok - - -let seekReadIdx big ctxt (addr: byref) = - if big then seekReadInt32Adv ctxt &addr else seekReadUInt16AsInt32Adv ctxt &addr - -let seekReadUntaggedIdx (tab:TableName) ctxt (addr: byref) = - seekReadIdx ctxt.tableBigness.[tab.Index] ctxt &addr - - -let seekReadResolutionScopeIdx ctxt (addr: byref) = seekReadTaggedIdx mkResolutionScopeTag 2 ctxt.rsBigness ctxt &addr -let seekReadTypeDefOrRefOrSpecIdx ctxt (addr: byref) = seekReadTaggedIdx mkTypeDefOrRefOrSpecTag 2 ctxt.tdorBigness ctxt &addr -let seekReadTypeOrMethodDefIdx ctxt (addr: byref) = seekReadTaggedIdx mkTypeOrMethodDefTag 1 ctxt.tomdBigness ctxt &addr -let seekReadHasConstantIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasConstantTag 2 ctxt.hcBigness ctxt &addr -let seekReadHasCustomAttributeIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasCustomAttributeTag 5 ctxt.hcaBigness ctxt &addr -let seekReadHasFieldMarshalIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasFieldMarshalTag 1 ctxt.hfmBigness ctxt &addr -let seekReadHasDeclSecurityIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasDeclSecurityTag 2 ctxt.hdsBigness ctxt &addr -let seekReadMemberRefParentIdx ctxt (addr: byref) = seekReadTaggedIdx mkMemberRefParentTag 3 ctxt.mrpBigness ctxt &addr -let seekReadHasSemanticsIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasSemanticsTag 1 ctxt.hsBigness ctxt &addr -let seekReadMethodDefOrRefIdx ctxt (addr: byref) = seekReadTaggedIdx mkMethodDefOrRefTag 1 ctxt.mdorBigness ctxt &addr -let seekReadMemberForwardedIdx ctxt (addr: byref) = seekReadTaggedIdx mkMemberForwardedTag 1 ctxt.mfBigness ctxt &addr -let seekReadImplementationIdx ctxt (addr: byref) = seekReadTaggedIdx mkImplementationTag 2 ctxt.iBigness ctxt &addr -let seekReadCustomAttributeTypeIdx ctxt (addr: byref) = seekReadTaggedIdx mkILCustomAttributeTypeTag 3 ctxt.catBigness ctxt &addr -let seekReadStringIdx ctxt (addr: byref) = seekReadIdx ctxt.stringsBigness ctxt &addr -let seekReadGuidIdx ctxt (addr: byref) = seekReadIdx ctxt.guidsBigness ctxt &addr -let seekReadBlobIdx ctxt (addr: byref) = seekReadIdx ctxt.blobsBigness ctxt &addr + (res, addr + 2) //TODO: return struct tuple + +let seekReadTaggedIdx f nbits big is (addr: int) = + let tok, addr = if big then seekReadInt32Adv is addr else seekReadUInt16AsInt32Adv is addr + (tokToTaggedIdx f nbits tok, addr) //TODO: return struct tuple + +let seekReadIdx big ctxt (addr: int) = + if big then seekReadInt32Adv ctxt addr else seekReadUInt16AsInt32Adv ctxt addr + +let seekReadUntaggedIdx (tab:TableName) ctxt (addr: int) = + seekReadIdx ctxt.tableBigness.[tab.Index] ctxt addr + + +let seekReadResolutionScopeIdx ctxt (addr: int) = seekReadTaggedIdx mkResolutionScopeTag 2 ctxt.rsBigness ctxt addr +let seekReadTypeDefOrRefOrSpecIdx ctxt (addr: int) = seekReadTaggedIdx mkTypeDefOrRefOrSpecTag 2 ctxt.tdorBigness ctxt addr +let seekReadTypeOrMethodDefIdx ctxt (addr: int) = seekReadTaggedIdx mkTypeOrMethodDefTag 1 ctxt.tomdBigness ctxt addr +let seekReadHasConstantIdx ctxt (addr: int) = seekReadTaggedIdx mkHasConstantTag 2 ctxt.hcBigness ctxt addr +let seekReadHasCustomAttributeIdx ctxt (addr: int) = seekReadTaggedIdx mkHasCustomAttributeTag 5 ctxt.hcaBigness ctxt addr +let seekReadHasFieldMarshalIdx ctxt (addr: int) = seekReadTaggedIdx mkHasFieldMarshalTag 1 ctxt.hfmBigness ctxt addr +let seekReadHasDeclSecurityIdx ctxt (addr: int) = seekReadTaggedIdx mkHasDeclSecurityTag 2 ctxt.hdsBigness ctxt addr +let seekReadMemberRefParentIdx ctxt (addr: int) = seekReadTaggedIdx mkMemberRefParentTag 3 ctxt.mrpBigness ctxt addr +let seekReadHasSemanticsIdx ctxt (addr: int) = seekReadTaggedIdx mkHasSemanticsTag 1 ctxt.hsBigness ctxt addr +let seekReadMethodDefOrRefIdx ctxt (addr: int) = seekReadTaggedIdx mkMethodDefOrRefTag 1 ctxt.mdorBigness ctxt addr +let seekReadMemberForwardedIdx ctxt (addr: int) = seekReadTaggedIdx mkMemberForwardedTag 1 ctxt.mfBigness ctxt addr +let seekReadImplementationIdx ctxt (addr: int) = seekReadTaggedIdx mkImplementationTag 2 ctxt.iBigness ctxt addr +let seekReadCustomAttributeTypeIdx ctxt (addr: int) = seekReadTaggedIdx mkILCustomAttributeTypeTag 3 ctxt.catBigness ctxt addr +let seekReadStringIdx ctxt (addr: int) = seekReadIdx ctxt.stringsBigness ctxt addr +let seekReadGuidIdx ctxt (addr: int) = seekReadIdx ctxt.guidsBigness ctxt addr +let seekReadBlobIdx ctxt (addr: int) = seekReadIdx ctxt.blobsBigness ctxt addr let seekReadModuleRow ctxt idx = if idx = 0 then failwith "cannot read Module table row 0" - let mutable addr = ctxt.rowAddr TableNames.Module idx - let generation = seekReadUInt16Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let mvidIdx = seekReadGuidIdx ctxt &addr - let encidIdx = seekReadGuidIdx ctxt &addr - let encbaseidIdx = seekReadGuidIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Module idx + let generation,addr = seekReadUInt16Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let mvidIdx,addr = seekReadGuidIdx ctxt addr + let encidIdx,addr = seekReadGuidIdx ctxt addr + let encbaseidIdx,_addr = seekReadGuidIdx ctxt addr (generation, nameIdx, mvidIdx, encidIdx, encbaseidIdx) /// Read Table ILTypeRef. let seekReadTypeRefRow ctxt idx = count ctxt.countTypeRef - let mutable addr = ctxt.rowAddr TableNames.TypeRef idx - let scopeIdx = seekReadResolutionScopeIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.TypeRef idx + let scopeIdx,addr = seekReadResolutionScopeIdx ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let namespaceIdx,_addr = seekReadStringIdx ctxt addr (scopeIdx,nameIdx,namespaceIdx) /// Read Table ILTypeDef. @@ -1097,43 +1096,43 @@ let seekReadTypeDefRow ctxt idx = ctxt.seekReadTypeDefRow idx let seekReadTypeDefRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countTypeDef - let mutable addr = ctxt.rowAddr TableNames.TypeDef idx - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr - let extendsIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr - let fieldsIdx = seekReadUntaggedIdx TableNames.Field ctxt &addr - let methodsIdx = seekReadUntaggedIdx TableNames.Method ctxt &addr + let addr = ctxt.rowAddr TableNames.TypeDef idx + let flags,addr = seekReadInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let namespaceIdx,addr = seekReadStringIdx ctxt addr + let extendsIdx,addr = seekReadTypeDefOrRefOrSpecIdx ctxt addr + let fieldsIdx,addr = seekReadUntaggedIdx TableNames.Field ctxt addr + let methodsIdx,_addr = seekReadUntaggedIdx TableNames.Method ctxt addr (flags, nameIdx, namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) /// Read Table Field. let seekReadFieldRow ctxt idx = count ctxt.countField - let mutable addr = ctxt.rowAddr TableNames.Field idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Field idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let typeIdx,_addr = seekReadBlobIdx ctxt addr (flags,nameIdx,typeIdx) /// Read Table Method. let seekReadMethodRow ctxt idx = count ctxt.countMethod - let mutable addr = ctxt.rowAddr TableNames.Method idx - let codeRVA = seekReadInt32Adv ctxt &addr - let implflags = seekReadUInt16AsInt32Adv ctxt &addr - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr - let paramIdx = seekReadUntaggedIdx TableNames.Param ctxt &addr + let addr = ctxt.rowAddr TableNames.Method idx + let codeRVA,addr = seekReadInt32Adv ctxt addr + let implflags,addr = seekReadUInt16AsInt32Adv ctxt addr + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let typeIdx,addr = seekReadBlobIdx ctxt addr + let paramIdx,_addr = seekReadUntaggedIdx TableNames.Param ctxt addr (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) /// Read Table Param. let seekReadParamRow ctxt idx = count ctxt.countParam - let mutable addr = ctxt.rowAddr TableNames.Param idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let seq = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Param idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let seq,addr = seekReadUInt16AsInt32Adv ctxt addr + let nameIdx,_addr = seekReadStringIdx ctxt addr (flags,seq,nameIdx) /// Read Table InterfaceImpl. @@ -1141,18 +1140,18 @@ let seekReadInterfaceImplRow ctxt idx = ctxt.seekReadInterfaceImplRow idx let seekReadInterfaceImplRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countInterfaceImpl - let mutable addr = ctxt.rowAddr TableNames.InterfaceImpl idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.InterfaceImpl idx + let tidx,addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr + let intfIdx,_addr = seekReadTypeDefOrRefOrSpecIdx ctxt addr (tidx,intfIdx) /// Read Table MemberRef. let seekReadMemberRefRow ctxt idx = count ctxt.countMemberRef - let mutable addr = ctxt.rowAddr TableNames.MemberRef idx - let mrpIdx = seekReadMemberRefParentIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.MemberRef idx + let mrpIdx,addr = seekReadMemberRefParentIdx ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let typeIdx,_addr = seekReadBlobIdx ctxt addr (mrpIdx,nameIdx,typeIdx) /// Read Table Constant. @@ -1160,19 +1159,19 @@ let seekReadConstantRow ctxt idx = ctxt.seekReadConstantRow idx let seekReadConstantRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countConstant - let mutable addr = ctxt.rowAddr TableNames.Constant idx - let kind = seekReadUInt16Adv ctxt &addr - let parentIdx = seekReadHasConstantIdx ctxt &addr - let valIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Constant idx + let kind,addr = seekReadUInt16Adv ctxt addr + let parentIdx,addr = seekReadHasConstantIdx ctxt addr + let valIdx,_addr = seekReadBlobIdx ctxt addr (kind, parentIdx, valIdx) /// Read Table CustomAttribute. let seekReadCustomAttributeRow ctxt idx = count ctxt.countCustomAttribute - let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx - let parentIdx = seekReadHasCustomAttributeIdx ctxt &addr - let typeIdx = seekReadCustomAttributeTypeIdx ctxt &addr - let valIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.CustomAttribute idx + let parentIdx,addr = seekReadHasCustomAttributeIdx ctxt addr + let typeIdx,addr = seekReadCustomAttributeTypeIdx ctxt addr + let valIdx,_addr = seekReadBlobIdx ctxt addr (parentIdx, typeIdx, valIdx) /// Read Table FieldMarshal. @@ -1180,59 +1179,59 @@ let seekReadFieldMarshalRow ctxt idx = ctxt.seekReadFieldMarshalRow idx let seekReadFieldMarshalRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countFieldMarshal - let mutable addr = ctxt.rowAddr TableNames.FieldMarshal idx - let parentIdx = seekReadHasFieldMarshalIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.FieldMarshal idx + let parentIdx,addr = seekReadHasFieldMarshalIdx ctxt addr + let typeIdx,_addr = seekReadBlobIdx ctxt addr (parentIdx, typeIdx) /// Read Table Permission. let seekReadPermissionRow ctxt idx = count ctxt.countPermission - let mutable addr = ctxt.rowAddr TableNames.Permission idx - let action = seekReadUInt16Adv ctxt &addr - let parentIdx = seekReadHasDeclSecurityIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Permission idx + let action,addr = seekReadUInt16Adv ctxt addr + let parentIdx,addr = seekReadHasDeclSecurityIdx ctxt addr + let typeIdx,_addr = seekReadBlobIdx ctxt addr (action, parentIdx, typeIdx) /// Read Table ClassLayout. let seekReadClassLayoutRow ctxt idx = count ctxt.countClassLayout - let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx - let pack = seekReadUInt16Adv ctxt &addr - let size = seekReadInt32Adv ctxt &addr - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr + let addr = ctxt.rowAddr TableNames.ClassLayout idx + let pack,addr = seekReadUInt16Adv ctxt addr + let size,addr = seekReadInt32Adv ctxt addr + let tidx,_addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr (pack,size,tidx) /// Read Table FieldLayout. let seekReadFieldLayoutRow ctxt idx = count ctxt.countFieldLayout - let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx - let offset = seekReadInt32Adv ctxt &addr - let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr + let addr = ctxt.rowAddr TableNames.FieldLayout idx + let offset,addr = seekReadInt32Adv ctxt addr + let fidx,_addr = seekReadUntaggedIdx TableNames.Field ctxt addr (offset,fidx) //// Read Table StandAloneSig. let seekReadStandAloneSigRow ctxt idx = count ctxt.countStandAloneSig - let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx - let sigIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.StandAloneSig idx + let sigIdx,_addr = seekReadBlobIdx ctxt addr sigIdx /// Read Table EventMap. let seekReadEventMapRow ctxt idx = count ctxt.countEventMap - let mutable addr = ctxt.rowAddr TableNames.EventMap idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt &addr + let addr = ctxt.rowAddr TableNames.EventMap idx + let tidx,addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr + let eventsIdx,_addr = seekReadUntaggedIdx TableNames.Event ctxt addr (tidx,eventsIdx) /// Read Table Event. let seekReadEventRow ctxt idx = count ctxt.countEvent - let mutable addr = ctxt.rowAddr TableNames.Event idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Event idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let typIdx,_addr = seekReadTypeDefOrRefOrSpecIdx ctxt addr (flags,nameIdx,typIdx) /// Read Table PropertyMap. @@ -1240,18 +1239,18 @@ let seekReadPropertyMapRow ctxt idx = ctxt.seekReadPropertyMapRow idx let seekReadPropertyMapRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countPropertyMap - let mutable addr = ctxt.rowAddr TableNames.PropertyMap idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt &addr + let addr = ctxt.rowAddr TableNames.PropertyMap idx + let tidx,addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr + let propsIdx,_addr = seekReadUntaggedIdx TableNames.Property ctxt addr (tidx,propsIdx) /// Read Table Property. let seekReadPropertyRow ctxt idx = count ctxt.countProperty - let mutable addr = ctxt.rowAddr TableNames.Property idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Property idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let typIdx,_addr = seekReadBlobIdx ctxt addr (flags,nameIdx,typIdx) /// Read Table MethodSemantics. @@ -1259,111 +1258,111 @@ let seekReadMethodSemanticsRow ctxt idx = ctxt.seekReadMethodSemanticsRow idx let seekReadMethodSemanticsRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countMethodSemantics - let mutable addr = ctxt.rowAddr TableNames.MethodSemantics idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let midx = seekReadUntaggedIdx TableNames.Method ctxt &addr - let assocIdx = seekReadHasSemanticsIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.MethodSemantics idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let midx,addr = seekReadUntaggedIdx TableNames.Method ctxt addr + let assocIdx,_addr = seekReadHasSemanticsIdx ctxt addr (flags,midx,assocIdx) /// Read Table MethodImpl. let seekReadMethodImplRow ctxt idx = count ctxt.countMethodImpl - let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let mbodyIdx = seekReadMethodDefOrRefIdx ctxt &addr - let mdeclIdx = seekReadMethodDefOrRefIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.MethodImpl idx + let tidx,addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr + let mbodyIdx,addr = seekReadMethodDefOrRefIdx ctxt addr + let mdeclIdx,_addr = seekReadMethodDefOrRefIdx ctxt addr (tidx,mbodyIdx,mdeclIdx) /// Read Table ILModuleRef. let seekReadModuleRefRow ctxt idx = count ctxt.countModuleRef - let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx - let nameIdx = seekReadStringIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.ModuleRef idx + let nameIdx,_addr = seekReadStringIdx ctxt addr nameIdx /// Read Table ILTypeSpec. let seekReadTypeSpecRow ctxt idx = count ctxt.countTypeSpec - let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx - let blobIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.TypeSpec idx + let blobIdx,_addr = seekReadBlobIdx ctxt addr blobIdx /// Read Table ImplMap. let seekReadImplMapRow ctxt idx = count ctxt.countImplMap - let mutable addr = ctxt.rowAddr TableNames.ImplMap idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let forwrdedIdx = seekReadMemberForwardedIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let scopeIdx = seekReadUntaggedIdx TableNames.ModuleRef ctxt &addr + let addr = ctxt.rowAddr TableNames.ImplMap idx + let flags,addr = seekReadUInt16AsInt32Adv ctxt addr + let forwrdedIdx,addr = seekReadMemberForwardedIdx ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let scopeIdx,_addr = seekReadUntaggedIdx TableNames.ModuleRef ctxt addr (flags, forwrdedIdx, nameIdx, scopeIdx) /// Read Table FieldRVA. let seekReadFieldRVARow ctxt idx = count ctxt.countFieldRVA - let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx - let rva = seekReadInt32Adv ctxt &addr - let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr + let addr = ctxt.rowAddr TableNames.FieldRVA idx + let rva,addr = seekReadInt32Adv ctxt addr + let fidx,_addr = seekReadUntaggedIdx TableNames.Field ctxt addr (rva,fidx) /// Read Table Assembly. let seekReadAssemblyRow ctxt idx = count ctxt.countAssembly - let mutable addr = ctxt.rowAddr TableNames.Assembly idx - let hash = seekReadInt32Adv ctxt &addr - let v1 = seekReadUInt16Adv ctxt &addr - let v2 = seekReadUInt16Adv ctxt &addr - let v3 = seekReadUInt16Adv ctxt &addr - let v4 = seekReadUInt16Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let publicKeyIdx = seekReadBlobIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let localeIdx = seekReadStringIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.Assembly idx + let hash,addr = seekReadInt32Adv ctxt addr + let v1,addr = seekReadUInt16Adv ctxt addr + let v2,addr = seekReadUInt16Adv ctxt addr + let v3,addr = seekReadUInt16Adv ctxt addr + let v4,addr = seekReadUInt16Adv ctxt addr + let flags,addr = seekReadInt32Adv ctxt addr + let publicKeyIdx,addr = seekReadBlobIdx ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let localeIdx,_addr = seekReadStringIdx ctxt addr (hash,v1,v2,v3,v4,flags,publicKeyIdx, nameIdx, localeIdx) /// Read Table ILAssemblyRef. let seekReadAssemblyRefRow ctxt idx = count ctxt.countAssemblyRef - let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx - let v1 = seekReadUInt16Adv ctxt &addr - let v2 = seekReadUInt16Adv ctxt &addr - let v3 = seekReadUInt16Adv ctxt &addr - let v4 = seekReadUInt16Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let publicKeyOrTokenIdx = seekReadBlobIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let localeIdx = seekReadStringIdx ctxt &addr - let hashValueIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.AssemblyRef idx + let v1,addr = seekReadUInt16Adv ctxt addr + let v2,addr = seekReadUInt16Adv ctxt addr + let v3,addr = seekReadUInt16Adv ctxt addr + let v4,addr = seekReadUInt16Adv ctxt addr + let flags,addr = seekReadInt32Adv ctxt addr + let publicKeyOrTokenIdx,addr = seekReadBlobIdx ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let localeIdx,addr = seekReadStringIdx ctxt addr + let hashValueIdx,_addr = seekReadBlobIdx ctxt addr (v1,v2,v3,v4,flags,publicKeyOrTokenIdx, nameIdx, localeIdx,hashValueIdx) /// Read Table File. let seekReadFileRow ctxt idx = count ctxt.countFile - let mutable addr = ctxt.rowAddr TableNames.File idx - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let hashValueIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.File idx + let flags,addr = seekReadInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let hashValueIdx,_addr = seekReadBlobIdx ctxt addr (flags, nameIdx, hashValueIdx) /// Read Table ILExportedTypeOrForwarder. let seekReadExportedTypeRow ctxt idx = count ctxt.countExportedType - let mutable addr = ctxt.rowAddr TableNames.ExportedType idx - let flags = seekReadInt32Adv ctxt &addr - let tok = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr - let implIdx = seekReadImplementationIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.ExportedType idx + let flags,addr = seekReadInt32Adv ctxt addr + let tok,addr = seekReadInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let namespaceIdx,addr = seekReadStringIdx ctxt addr + let implIdx,_addr = seekReadImplementationIdx ctxt addr (flags,tok,nameIdx,namespaceIdx,implIdx) /// Read Table ManifestResource. let seekReadManifestResourceRow ctxt idx = count ctxt.countManifestResource - let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx - let offset = seekReadInt32Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let implIdx = seekReadImplementationIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.ManifestResource idx + let offset,addr = seekReadInt32Adv ctxt addr + let flags,addr = seekReadInt32Adv ctxt addr + let nameIdx,addr = seekReadStringIdx ctxt addr + let implIdx,_addr = seekReadImplementationIdx ctxt addr (offset,flags,nameIdx,implIdx) /// Read Table Nested. @@ -1371,35 +1370,35 @@ let seekReadNestedRow ctxt idx = ctxt.seekReadNestedRow idx let seekReadNestedRowUncached ctxtH idx = let ctxt = getHole ctxtH count ctxt.countNested - let mutable addr = ctxt.rowAddr TableNames.Nested idx - let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr + let addr = ctxt.rowAddr TableNames.Nested idx + let nestedIdx,addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr + let enclIdx,_addr = seekReadUntaggedIdx TableNames.TypeDef ctxt addr (nestedIdx,enclIdx) /// Read Table GenericParam. let seekReadGenericParamRow ctxt idx = count ctxt.countGenericParam - let mutable addr = ctxt.rowAddr TableNames.GenericParam idx - let seq = seekReadUInt16Adv ctxt &addr - let flags = seekReadUInt16Adv ctxt &addr - let ownerIdx = seekReadTypeOrMethodDefIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.GenericParam idx + let seq,addr = seekReadUInt16Adv ctxt addr + let flags,addr = seekReadUInt16Adv ctxt addr + let ownerIdx,addr = seekReadTypeOrMethodDefIdx ctxt addr + let nameIdx,_addr = seekReadStringIdx ctxt addr (idx,seq,flags,ownerIdx,nameIdx) // Read Table GenericParamConstraint. let seekReadGenericParamConstraintRow ctxt idx = count ctxt.countGenericParamConstraint - let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx - let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt &addr - let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.GenericParamConstraint idx + let pidx,addr = seekReadUntaggedIdx TableNames.GenericParam ctxt addr + let constraintIdx,_addr = seekReadTypeDefOrRefOrSpecIdx ctxt addr (pidx,constraintIdx) /// Read Table ILMethodSpec. let seekReadMethodSpecRow ctxt idx = count ctxt.countMethodSpec - let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx - let mdorIdx = seekReadMethodDefOrRefIdx ctxt &addr - let instIdx = seekReadBlobIdx ctxt &addr + let addr = ctxt.rowAddr TableNames.MethodSpec idx + let mdorIdx,addr = seekReadMethodDefOrRefIdx ctxt addr + let instIdx,_addr = seekReadBlobIdx ctxt addr (mdorIdx,instIdx) @@ -3943,6 +3942,8 @@ let ClosePdbReader pdb = | None -> () #endif +#if !FABLE_COMPILER + let OpenILModuleReader infile opts = try @@ -3994,6 +3995,8 @@ let OpenILModuleReaderAfterReadingAllBytes infile opts = ilModuleReaderCache.Put(key, ilModuleReader) ilModuleReader +#endif //!FABLE_COMPILER + let OpenILModuleReaderFromBytes fileNameForDebugOutput bytes opts = assert opts.pdbPath.IsNone let mc = ByteFile(bytes) diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi index ccc4c72185..4e5d9ecbd8 100755 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -50,12 +50,14 @@ type ILModuleReader = member ILAssemblyRefs : ILAssemblyRef list interface System.IDisposable +#if !FABLE_COMPILER val OpenILModuleReader: string -> ILReaderOptions -> ILModuleReader /// Open a binary reader, except first copy the entire contents of the binary into /// memory, close the file and ensure any subsequent reads happen from the in-memory store. /// PDB files may not be read with this option. val OpenILModuleReaderAfterReadingAllBytes: string -> ILReaderOptions -> ILModuleReader +#endif /// Open a binary reader based on the given bytes. val OpenILModuleReaderFromBytes: fileNameForDebugOutput:string -> assemblyContents: byte[] -> options: ILReaderOptions -> ILModuleReader diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 62196b77a3..cb9bb406d2 100755 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -458,8 +458,7 @@ type MetadataTable<'T> = #if DEBUG tbl.lookups <- tbl.lookups + 1 #endif - let mutable res = Unchecked.defaultof<_> - let ok = tbl.dict.TryGetValue(x,&res) + let ok, res = tbl.dict.TryGetValue(x) if ok then res else tbl.AddSharedEntry x @@ -762,8 +761,8 @@ let rec GetTypeRefAsTypeRefRow cenv (tref:ILTypeRef) = SharedRow [| ResolutionScope (rs1,rs2); nelem; nselem |] and GetTypeRefAsTypeRefIdx cenv tref = - let mutable res = 0 - if cenv.trefCache.TryGetValue(tref,&res) then res else + let ok, res = cenv.trefCache.TryGetValue(tref) + if ok then res else let res = FindOrAddSharedRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref) cenv.trefCache.[tref] <- res res @@ -2546,40 +2545,40 @@ let GenMethodDefAsRow cenv env midx (md: ILMethodDef) = if md.IsEntryPoint then if cenv.entrypoint <> None then failwith "duplicate entrypoint" else cenv.entrypoint <- Some (true, midx) - let codeAddr = - (match md.mdBody.Contents with - | MethodBody.IL ilmbody -> - let addr = cenv.nextCodeAddr - let (localToken, code, seqpoints, rootScope) = GenILMethodBody md.Name cenv env ilmbody - - // Now record the PDB record for this method - we write this out later. - if cenv.generatePdb then - cenv.pdbinfo.Add - { MethToken=getUncodedToken TableNames.Method midx - MethName=md.Name - LocalSignatureToken=localToken - Params= [| |] (* REVIEW *) - RootScope = rootScope - Range= - match ilmbody.SourceMarker with - | Some m when cenv.generatePdb -> - // table indexes are 1-based, document array indexes are 0-based - let doc = (cenv.documents.FindOrAddSharedEntry m.Document) - 1 - - Some ({ Document=doc - Line=m.Line - Column=m.Column }, - { Document=doc - Line=m.EndLine - Column=m.EndColumn }) - | _ -> None - SequencePoints=seqpoints } - - cenv.AddCode code - addr - | MethodBody.Native -> - failwith "cannot write body of native method - Abstract IL cannot roundtrip mixed native/managed binaries" - | _ -> 0x0000) + let codeAddr = + (match md.mdBody.Contents with + | MethodBody.IL ilmbody -> + let addr = cenv.nextCodeAddr + let (localToken, code, seqpoints, rootScope) = GenILMethodBody md.Name cenv env ilmbody + + // Now record the PDB record for this method - we write this out later. + if cenv.generatePdb then + cenv.pdbinfo.Add + { MethToken=getUncodedToken TableNames.Method midx + MethName=md.Name + LocalSignatureToken=localToken + Params= [| |] (* REVIEW *) + RootScope = rootScope + Range= + match ilmbody.SourceMarker with + | Some m when cenv.generatePdb -> + // table indexes are 1-based, document array indexes are 0-based + let doc = (cenv.documents.FindOrAddSharedEntry m.Document) - 1 + + Some ({ Document=doc + Line=m.Line + Column=m.Column }, + { Document=doc + Line=m.EndLine + Column=m.EndColumn }) + | _ -> None + SequencePoints=seqpoints } + + cenv.AddCode code + addr + | MethodBody.Native -> + failwith "cannot write body of native method - Abstract IL cannot roundtrip mixed native/managed binaries" + | _ -> 0x0000) UnsharedRow [| ULong codeAddr @@ -3543,7 +3542,7 @@ let writeBinaryAndReportMappings (outfile, ilg, pdbfile: string option, signer: reportTime showTimes "Write Started"; let isDll = modul.IsDLL - + let signer = match signer,modul.Manifest with | Some _, _ -> signer diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index aff3b1e408..7650b81df7 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -3,25 +3,29 @@ /// Coordinating compiler operations - configuration, loading initial context, reporting errors etc. module internal Microsoft.FSharp.Compiler.CompileOps +open Internal.Utilities open System open System.Text open System.IO open System.Collections.Generic open System.Runtime.CompilerServices -open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +#endif open Internal.Utilities.Text open Internal.Utilities.Collections open Internal.Utilities.Filename -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.TastPickle open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TypeChecker @@ -107,79 +111,79 @@ exception HashLoadedSourceHasIssues of (*warnings*) exn list * (*errors*) exn li exception HashLoadedScriptConsideredSource of range -let GetRangeOfError(err:PhasedError) = +let GetRangeOfError(err:PhasedError) = let rec RangeFromException = function - | ErrorFromAddingConstraint(_,err2,_) -> RangeFromException err2 + | ErrorFromAddingConstraint(_,err2,_) -> RangeFromException err2 #if EXTENSIONTYPING | ExtensionTyping.ProvidedTypeResolutionNoRange(e) -> RangeFromException e | ExtensionTyping.ProvidedTypeResolution(m,_) #endif | ReservedKeyword(_,m) | IndentationProblem(_,m) - | ErrorFromAddingTypeEquation(_,_,_,_,_,_,m) - | ErrorFromApplyingDefault(_,_,_,_,_,m) + | ErrorFromAddingTypeEquation(_,_,_,_,_,_,m) + | ErrorFromApplyingDefault(_,_,_,_,_,m) | ErrorsFromAddingSubsumptionConstraint(_,_,_,_,_,_,m) | FunctionExpected(_,_,m) | BakedInMemberConstraintName(_,m) | StandardOperatorRedefinitionWarning(_,m) | BadEventTransformation(m) | ParameterlessStructCtor(m) - | FieldNotMutable (_,_,m) - | Recursion (_,_,_,_,m) - | InvalidRuntimeCoercion(_,_,_,m) + | FieldNotMutable (_,_,m) + | Recursion (_,_,_,_,m) + | InvalidRuntimeCoercion(_,_,_,m) | IndeterminateRuntimeCoercion(_,_,_,m) | IndeterminateStaticCoercion (_,_,_,m) | StaticCoercionShouldUseBox (_,_,_,m) | CoercionTargetSealed(_,_,m) | UpcastUnnecessary(m) - | QuotationTranslator.IgnoringPartOfQuotedTermWarning (_,m) - + | QuotationTranslator.IgnoringPartOfQuotedTermWarning (_,m) + | TypeTestUnnecessary(m) | RuntimeCoercionSourceSealed(_,_,m) | OverrideDoesntOverride(_,_,_,_,_,m) - | UnionPatternsBindDifferentNames m - | UnionCaseWrongArguments (_,_,_,m) - | TypeIsImplicitlyAbstract m - | RequiredButNotSpecified (_,_,_,_,m) + | UnionPatternsBindDifferentNames m + | UnionCaseWrongArguments (_,_,_,m) + | TypeIsImplicitlyAbstract m + | RequiredButNotSpecified (_,_,_,_,m) | FunctionValueUnexpected (_,_,m) | UnitTypeExpected (_,_,_,m ) - | UseOfAddressOfOperator m - | DeprecatedThreadStaticBindingWarning(m) - | NonUniqueInferredAbstractSlot (_,_,_,_,_,m) + | UseOfAddressOfOperator m + | DeprecatedThreadStaticBindingWarning(m) + | NonUniqueInferredAbstractSlot (_,_,_,_,_,m) | DefensiveCopyWarning (_,m) - | LetRecCheckedAtRuntime m + | LetRecCheckedAtRuntime m | UpperCaseIdentifierInPattern m | NotUpperCaseConstructor m - | RecursiveUseCheckedAtRuntime (_,_,m) - | LetRecEvaluatedOutOfOrder (_,_,_,m) + | RecursiveUseCheckedAtRuntime (_,_,m) + | LetRecEvaluatedOutOfOrder (_,_,_,m) | Error (_,m) | NumberedError (_,m) - | SyntaxError (_,m) + | SyntaxError (_,m) | InternalError (_,m) | FullAbstraction(_,m) - | InterfaceNotRevealed(_,_,m) + | InterfaceNotRevealed(_,_,m) | WrappedError (_,m) | PatternMatchCompilation.MatchIncomplete (_,_,m) - | PatternMatchCompilation.RuleNeverMatched m + | PatternMatchCompilation.RuleNeverMatched m | ValNotMutable(_,_,m) - | ValNotLocal(_,_,m) - | MissingFields(_,m) + | ValNotLocal(_,_,m) + | MissingFields(_,m) | OverrideInIntrinsicAugmentation(m) - | IntfImplInIntrinsicAugmentation(m) + | IntfImplInIntrinsicAugmentation(m) | OverrideInExtrinsicAugmentation(m) - | IntfImplInExtrinsicAugmentation(m) - | ValueRestriction(_,_,_,_,m) - | LetRecUnsound (_,_,m) - | ObsoleteError (_,m) - | ObsoleteWarning (_,m) - | Experimental (_,m) + | IntfImplInExtrinsicAugmentation(m) + | ValueRestriction(_,_,_,_,m) + | LetRecUnsound (_,_,m) + | ObsoleteError (_,m) + | ObsoleteWarning (_,m) + | Experimental (_,m) | PossibleUnverifiableCode m - | UserCompilerMessage (_,_,m) - | Deprecated(_,m) - | LibraryUseOnly(m) - | FieldsFromDifferentTypes (_,_,_,m) + | UserCompilerMessage (_,_,m) + | Deprecated(_,m) + | LibraryUseOnly(m) + | FieldsFromDifferentTypes (_,_,_,m) | IndeterminateType(m) - | TyconBadArgs(_,_,_,m) -> + | TyconBadArgs(_,_,_,m) -> Some m | FieldNotContained(_,arf,_,_) -> Some arf.Range @@ -187,64 +191,66 @@ let GetRangeOfError(err:PhasedError) = | ConstrNotContained(_,aval,_,_) -> Some aval.Id.idRange | ExnconstrNotContained(_,aexnc,_,_) -> Some aexnc.Range - | VarBoundTwice(id) - | UndefinedName(_,_,id,_) -> - Some id.idRange + | VarBoundTwice(id) + | UndefinedName(_,_,id,_) -> + Some id.idRange - | Duplicate(_,_,m) - | NameClash(_,_,_,m,_,_,_) - | UnresolvedOverloading(_,_,_,m) + | Duplicate(_,_,m) + | NameClash(_,_,_,m,_,_,_) + | UnresolvedOverloading(_,_,_,m) | UnresolvedConversionOperator (_,_,_,m) - | PossibleOverload(_,_,_, m) + | PossibleOverload(_,_,_, m) | VirtualAugmentationOnNullValuedType(m) | NonVirtualAugmentationOnNullValuedType(m) | NonRigidTypar(_,_,_,_,_,m) - | ConstraintSolverTupleDiffLengths(_,_,_,m,_) - | ConstraintSolverInfiniteTypes(_,_,_,_,m,_) - | ConstraintSolverMissingConstraint(_,_,_,m,_) + | ConstraintSolverTupleDiffLengths(_,_,_,m,_) + | ConstraintSolverInfiniteTypes(_,_,_,_,m,_) + | ConstraintSolverMissingConstraint(_,_,_,m,_) | ConstraintSolverTypesNotInEqualityRelation(_,_,_,m,_) - | ConstraintSolverError(_,m,_) - | ConstraintSolverTypesNotInSubsumptionRelation(_,_,_,m,_) - | ConstraintSolverRelatedInformation(_,m,_) - | SelfRefObjCtor(_,m) -> + | ConstraintSolverError(_,m,_) + | ConstraintSolverTypesNotInSubsumptionRelation(_,_,_,m,_) + | ConstraintSolverRelatedInformation(_,m,_) + | SelfRefObjCtor(_,m) -> Some m - | NotAFunction(_,_,mfun,_) -> + | NotAFunction(_,_,mfun,_) -> Some mfun | IllegalFileNameChar(_) -> Some rangeCmdArgs - | UnresolvedReferenceError(_,m) - | UnresolvedPathReference(_,_,m) - | DeprecatedCommandLineOptionFull(_,m) - | DeprecatedCommandLineOptionForHtmlDoc(_,m) - | DeprecatedCommandLineOptionSuggestAlternative(_,_,m) - | DeprecatedCommandLineOptionNoDescription(_,m) + | UnresolvedReferenceError(_,m) + | UnresolvedPathReference(_,_,m) + | DeprecatedCommandLineOptionFull(_,m) + | DeprecatedCommandLineOptionForHtmlDoc(_,m) + | DeprecatedCommandLineOptionSuggestAlternative(_,_,m) + | DeprecatedCommandLineOptionNoDescription(_,m) | InternalCommandLineOption(_,m) | HashIncludeNotAllowedInNonScript(m) - | HashReferenceNotAllowedInNonScript(m) - | HashDirectiveNotAllowedInNonScript(m) - | FileNameNotResolved(_,_,m) - | LoadedSourceNotFoundIgnoring(_,m) - | MSBuildReferenceResolutionWarning(_,_,m) - | MSBuildReferenceResolutionError(_,_,m) - | AssemblyNotResolved(_,m) - | HashLoadedSourceHasIssues(_,_,m) - | HashLoadedScriptConsideredSource(m) -> + | HashReferenceNotAllowedInNonScript(m) + | HashDirectiveNotAllowedInNonScript(m) + | FileNameNotResolved(_,_,m) + | LoadedSourceNotFoundIgnoring(_,m) + | MSBuildReferenceResolutionWarning(_,_,m) + | MSBuildReferenceResolutionError(_,_,m) + | AssemblyNotResolved(_,m) + | HashLoadedSourceHasIssues(_,_,m) + | HashLoadedScriptConsideredSource(m) -> Some m +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> + | :? System.Reflection.TargetInvocationException as e -> RangeFromException e.InnerException +#endif #if EXTENSIONTYPING | :? TypeProviderError as e -> e.Range |> Some #endif - + | _ -> None - + RangeFromException err.Exception -let GetErrorNumber(err:PhasedError) = - let rec GetFromException(e:exn) = +let GetErrorNumber(err:PhasedError) = + let rec GetFromException(e:exn) = match e with (* DO NOT CHANGE THESE NUMBERS *) | ErrorFromAddingTypeEquation _ -> 1 @@ -261,7 +267,7 @@ let GetErrorNumber(err:PhasedError) = | IndeterminateStaticCoercion _ -> 13 | StaticCoercionShouldUseBox _ -> 14 // 15 cannot be reused - | RuntimeCoercionSourceSealed _ -> 16 + | RuntimeCoercionSourceSealed _ -> 16 | OverrideDoesntOverride _ -> 17 | UnionPatternsBindDifferentNames _ -> 18 | UnionCaseWrongArguments _ -> 19 @@ -304,7 +310,7 @@ let GetErrorNumber(err:PhasedError) = | DeprecatedThreadStaticBindingWarning _ -> 56 | Experimental _ -> 57 | IndentationProblem _ -> 58 - | CoercionTargetSealed _ -> 59 + | CoercionTargetSealed _ -> 59 | OverrideInIntrinsicAugmentation _ -> 60 | NonVirtualAugmentationOnNullValuedType _ -> 61 | UserCompilerMessage (_,n,_) -> n @@ -320,19 +326,19 @@ let GetErrorNumber(err:PhasedError) = | IndeterminateType _ -> 72 | InternalError _ -> 73 | UnresolvedReferenceNoRange _ - | UnresolvedReferenceError _ - | UnresolvedPathReferenceNoRange _ + | UnresolvedReferenceError _ + | UnresolvedPathReferenceNoRange _ | UnresolvedPathReference _ -> 74 | DeprecatedCommandLineOptionFull _ | DeprecatedCommandLineOptionForHtmlDoc _ | DeprecatedCommandLineOptionSuggestAlternative _ - | DeprecatedCommandLineOptionNoDescription _ + | DeprecatedCommandLineOptionNoDescription _ | InternalCommandLineOption _ -> 75 - | HashIncludeNotAllowedInNonScript _ - | HashReferenceNotAllowedInNonScript _ + | HashIncludeNotAllowedInNonScript _ + | HashReferenceNotAllowedInNonScript _ | HashDirectiveNotAllowedInNonScript _ -> 76 | BakedInMemberConstraintName _ -> 77 - | FileNameNotResolved _ -> 78 + | FileNameNotResolved _ -> 78 | LoadedSourceNotFoundIgnoring _ -> 79 // 80 cannot be reused | ParameterlessStructCtor _ -> 81 @@ -356,11 +362,12 @@ let GetErrorNumber(err:PhasedError) = #endif (* DO NOT CHANGE THE NUMBERS *) +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> + | :? System.Reflection.TargetInvocationException as e -> GetFromException e.InnerException - - | WrappedError(e,_) -> GetFromException e +#endif + | WrappedError(e,_) -> GetFromException e | Error ((n,_),_) -> n | Failure _ -> 192 @@ -372,68 +379,79 @@ let GetErrorNumber(err:PhasedError) = | ErrorsFromAddingSubsumptionConstraint (_,_,_,_,_,ContextInfo.DowncastUsedInsteadOfUpcast _,_) -> fst (FSComp.SR.considerUpcast("","")) | _ -> 193 GetFromException err.Exception - -let GetWarningLevel err = - match err.Exception with + +let GetWarningNumber(m,s:string) = + try + Some (int32 s) + with err -> + warning(Error(FSComp.SR.buildInvalidWarningNumber(s),m)) + None + +let GetWarningLevel err = + match err.Exception with // Level 5 warnings | RecursiveUseCheckedAtRuntime _ | LetRecEvaluatedOutOfOrder _ | DefensiveCopyWarning _ | FullAbstraction _ -> 5 - | NumberedError((n,_),_) - | Error((n,_),_) -> + | NumberedError((n,_),_) + | Error((n,_),_) -> // 1178,tcNoComparisonNeeded1,"The struct, record or union type '%s' is not structurally comparable because the type parameter %s does not satisfy the 'comparison' constraint. Consider adding the 'NoComparison' attribute to this type to clarify that the type is not comparable" - // 1178,tcNoComparisonNeeded2,"The struct, record or union type '%s' is not structurally comparable because the type '%s' does not satisfy the 'comparison' constraint. Consider adding the 'NoComparison' attribute to this type to clarify that the type is not comparable" + // 1178,tcNoComparisonNeeded2,"The struct, record or union type '%s' is not structurally comparable because the type '%s' does not satisfy the 'comparison' constraint. Consider adding the 'NoComparison' attribute to this type to clarify that the type is not comparable" // 1178,tcNoEqualityNeeded1,"The struct, record or union type '%s' does not support structural equality because the type parameter %s does not satisfy the 'equality' constraint. Consider adding the 'NoEquality' attribute to this type to clarify that the type does not support structural equality" // 1178,tcNoEqualityNeeded2,"The struct, record or union type '%s' does not support structural equality because the type '%s' does not satisfy the 'equality' constraint. Consider adding the 'NoEquality' attribute to this type to clarify that the type does not support structural equality" if (n = 1178) then 5 else 2 - // Level 2 + // Level 2 | _ -> 2 -let warningOn err level specificWarnOn = +let warningOn err level specificWarnOn = let n = GetErrorNumber err List.contains n specificWarnOn || // Some specific warnings are never on by default, i.e. unused variable warnings - match n with + match n with | 1182 -> false // chkUnusedValue - off by default | 3180 -> false // abImplicitHeapAllocation - off by default - | _ -> level >= GetWarningLevel err + | _ -> level >= GetWarningLevel err -let SplitRelatedErrors(err:PhasedError) = +let SplitRelatedErrors(err:PhasedError) = let ToPhased(e) = {Exception=e; Phase = err.Phase} let rec SplitRelatedException = function - | UnresolvedOverloading(a,overloads,b,c) -> + | UnresolvedOverloading(a,overloads,b,c) -> let related = overloads |> List.map ToPhased UnresolvedOverloading(a,[],b,c)|>ToPhased, related - | ConstraintSolverRelatedInformation(fopt,m2,e) -> + | ConstraintSolverRelatedInformation(fopt,m2,e) -> let e,related = SplitRelatedException e ConstraintSolverRelatedInformation(fopt,m2,e.Exception)|>ToPhased, related | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,specializedMessageF,m) -> let e,related = SplitRelatedException e ErrorFromAddingTypeEquation(g,denv,t1,t2,e.Exception,specializedMessageF,m)|>ToPhased, related - | ErrorFromApplyingDefault(g,denv,tp,defaultType,e,m) -> + | ErrorFromApplyingDefault(g,denv,tp,defaultType,e,m) -> let e,related = SplitRelatedException e ErrorFromApplyingDefault(g,denv,tp,defaultType,e.Exception,m)|>ToPhased, related - | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,contextInfo,m) -> + | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,contextInfo,m) -> let e,related = SplitRelatedException e ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e.Exception,contextInfo,m)|>ToPhased, related - | ErrorFromAddingConstraint(x,e,m) -> + | ErrorFromAddingConstraint(x,e,m) -> let e,related = SplitRelatedException e ErrorFromAddingConstraint(x,e.Exception,m)|>ToPhased, related - | WrappedError (e,m) -> + | WrappedError (e,m) -> let e,related = SplitRelatedException e WrappedError(e.Exception,m)|>ToPhased, related +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> + | :? System.Reflection.TargetInvocationException as e -> SplitRelatedException e.InnerException - | e -> +#endif + | e -> ToPhased(e), [] SplitRelatedException(err.Exception) let DeclareMesssage = Microsoft.FSharp.Compiler.DiagnosticMessage.DeclareResourceString +#if !FABLE_COMPILER do FSComp.SR.RunStartupValidation() +#endif let SeeAlsoE() = DeclareResourceString("SeeAlso","%s") let ConstraintSolverTupleDiffLengthsE() = DeclareResourceString("ConstraintSolverTupleDiffLengths","%d%d") let ConstraintSolverInfiniteTypesE() = DeclareResourceString("ConstraintSolverInfiniteTypes", "%s%s") @@ -586,7 +604,7 @@ let FileNameNotResolvedE() = DeclareResourceString("FileNameNotResolved","%s%s") let AssemblyNotResolvedE() = DeclareResourceString("AssemblyNotResolved","%s") let HashLoadedSourceHasIssues1E() = DeclareResourceString("HashLoadedSourceHasIssues1","") let HashLoadedSourceHasIssues2E() = DeclareResourceString("HashLoadedSourceHasIssues2","") -let HashLoadedScriptConsideredSourceE() = DeclareResourceString("HashLoadedScriptConsideredSource","") +let HashLoadedScriptConsideredSourceE() = DeclareResourceString("HashLoadedScriptConsideredSource","") let InvalidInternalsVisibleToAssemblyName1E() = DeclareResourceString("InvalidInternalsVisibleToAssemblyName1","%s%s") let InvalidInternalsVisibleToAssemblyName2E() = DeclareResourceString("InvalidInternalsVisibleToAssemblyName2","%s") let LoadedSourceNotFoundIgnoringE() = DeclareResourceString("LoadedSourceNotFoundIgnoring","%s") @@ -598,10 +616,10 @@ let getErrorString key = SR.GetString key let (|InvalidArgument|_|) (exn:exn) = match exn with :? ArgumentException as e -> Some e.Message | _ -> None let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = - let rec OutputExceptionR (os:System.Text.StringBuilder) = function - | ConstraintSolverTupleDiffLengths(_,tl1,tl2,m,m2) -> + let rec OutputExceptionR (os:System.Text.StringBuilder) = function + | ConstraintSolverTupleDiffLengths(_,tl1,tl2,m,m2) -> os.Append(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) |> ignore - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) | ConstraintSolverInfiniteTypes(contextInfo,denv,t1,t2,m,m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) @@ -615,40 +633,40 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(" " + FSComp.SR.yieldUsedInsteadOfYieldBang()) |> ignore | _ -> () - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore ) - | ConstraintSolverMissingConstraint(denv,tpr,tpc,m,m2) -> + | ConstraintSolverMissingConstraint(denv,tpr,tpc,m,m2) -> os.Append(ConstraintSolverMissingConstraintE().Format (NicePrint.stringOfTyparConstraint denv (tpr,tpc))) |> ignore - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore ) - | ConstraintSolverTypesNotInEqualityRelation(denv,(TType_measure _ as t1),(TType_measure _ as t2),m,m2) -> + | ConstraintSolverTypesNotInEqualityRelation(denv,(TType_measure _ as t1),(TType_measure _ as t2),m,m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverTypesNotInEqualityRelation1E().Format t1 t2 ) |> ignore - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) - | ConstraintSolverTypesNotInEqualityRelation(denv,t1,t2,m,m2) -> + | ConstraintSolverTypesNotInEqualityRelation(denv,t1,t2,m,m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverTypesNotInEqualityRelation2E().Format t1 t2) |> ignore - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) - | ConstraintSolverTypesNotInSubsumptionRelation(denv,t1,t2,m,m2) -> + | ConstraintSolverTypesNotInSubsumptionRelation(denv,t1,t2,m,m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, cxs= NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverTypesNotInSubsumptionRelationE().Format t2 t1 cxs) |> ignore - (if m.StartLine <> m2.StartLine then + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m2)) |> ignore) - | ConstraintSolverError(msg,m,m2) -> + | ConstraintSolverError(msg,m,m2) -> os.Append(ConstraintSolverErrorE().Format msg) |> ignore - if m.StartLine <> m2.StartLine then + if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m2)) |> ignore - | ConstraintSolverRelatedInformation(fopt,_,e) -> - match e with + | ConstraintSolverRelatedInformation(fopt,_,e) -> + match e with | ConstraintSolverError _ -> OutputExceptionR os e | _ -> () fopt |> Option.iter (Printf.bprintf os " %s") - | ErrorFromAddingTypeEquation(g,denv,t1,t2,ConstraintSolverTypesNotInEqualityRelation(_, t1', t2',_ ,_ ),contextInfo,_) + | ErrorFromAddingTypeEquation(g,denv,t1,t2,ConstraintSolverTypesNotInEqualityRelation(_, t1', t2',_ ,_ ),contextInfo,_) when typeEquiv g t1 t1' && typeEquiv g t2 t2' -> let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 @@ -662,7 +680,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore os.Append(System.Environment.NewLine + FSComp.SR.derefInsteadOfNot()) |> ignore | _ -> os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore - | ErrorFromAddingTypeEquation(_,_,_,_,((ConstraintSolverTypesNotInSubsumptionRelation _ | ConstraintSolverError _) as e), _, _) -> + | ErrorFromAddingTypeEquation(_,_,_,_,((ConstraintSolverTypesNotInSubsumptionRelation _ | ConstraintSolverError _) as e), _, _) -> OutputExceptionR os e | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,_,_) -> if not (typeEquiv g t1 t2) then ( @@ -670,14 +688,14 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = if t1<>t2 + tpcs then os.Append(ErrorFromAddingTypeEquation2E().Format t1 t2 tpcs) |> ignore ) OutputExceptionR os e - | ErrorFromApplyingDefault(_,denv,_,defaultType,e,_) -> + | ErrorFromApplyingDefault(_,denv,_,defaultType,e,_) -> let defaultType = NicePrint.minimalStringOfType denv defaultType os.Append(ErrorFromApplyingDefault1E().Format defaultType) |> ignore OutputExceptionR os e os.Append(ErrorFromApplyingDefault2E().Format) |> ignore | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,contextInfo,_) -> match contextInfo with - | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> + | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> let t1,t2,_ = NicePrint.minimalStringsOfTwoTypes denv t1 t2 if isOperator then os.Append(FSComp.SR.considerUpcastOperator(t1,t2) |> snd) |> ignore @@ -686,43 +704,43 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | _ -> if not (typeEquiv g t1 t2) then let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 - if t1 <> (t2 + tpcs) then + if t1 <> (t2 + tpcs) then os.Append(ErrorsFromAddingSubsumptionConstraintE().Format t2 t1 tpcs) |> ignore else OutputExceptionR os e else OutputExceptionR os e - | UpperCaseIdentifierInPattern(_) -> + | UpperCaseIdentifierInPattern(_) -> os.Append(UpperCaseIdentifierInPatternE().Format) |> ignore - | NotUpperCaseConstructor(_) -> + | NotUpperCaseConstructor(_) -> os.Append(NotUpperCaseConstructorE().Format) |> ignore - | ErrorFromAddingConstraint(_,e,_) -> + | ErrorFromAddingConstraint(_,e,_) -> OutputExceptionR os e #if EXTENSIONTYPING | ExtensionTyping.ProvidedTypeResolutionNoRange(e) - | ExtensionTyping.ProvidedTypeResolution(_,e) -> + | ExtensionTyping.ProvidedTypeResolution(_,e) -> OutputExceptionR os e | :? TypeProviderError as e -> os.Append(e.ContextualErrorMessage) |> ignore #endif - | UnresolvedOverloading(_,_,mtext,_) -> + | UnresolvedOverloading(_,_,mtext,_) -> os.Append(mtext) |> ignore - | UnresolvedConversionOperator(denv,fromTy,toTy,_) -> + | UnresolvedConversionOperator(denv,fromTy,toTy,_) -> let t1,t2,_tpcs = NicePrint.minimalStringsOfTwoTypes denv fromTy toTy os.Append(FSComp.SR.csTypeDoesNotSupportConversion(t1,t2)) |> ignore - | PossibleOverload(_,minfo, originalError, _) -> + | PossibleOverload(_,minfo, originalError, _) -> // print original error that describes reason why this overload was rejected let buf = new StringBuilder() OutputExceptionR buf originalError os.Append(PossibleOverloadE().Format minfo (buf.ToString())) |> ignore - //| PossibleBestOverload(_,minfo,m) -> + //| PossibleBestOverload(_,minfo,m) -> // Printf.bprintf os "\n\nPossible best overload: '%s'." minfo | FunctionExpected _ -> os.Append(FunctionExpectedE().Format) |> ignore | BakedInMemberConstraintName(nm,_) -> os.Append(BakedInMemberConstraintNameE().Format nm) |> ignore - | StandardOperatorRedefinitionWarning(msg,_) -> + | StandardOperatorRedefinitionWarning(msg,_) -> os.Append(msg) |> ignore | BadEventTransformation(_) -> os.Append(BadEventTransformationE().Format) |> ignore @@ -731,54 +749,54 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | InterfaceNotRevealed(denv,ity,_) -> os.Append(InterfaceNotRevealedE().Format (NicePrint.minimalStringOfType denv ity)) |> ignore | NotAFunction(_,_,_,marg) -> - if marg.StartColumn = 0 then + if marg.StartColumn = 0 then os.Append(NotAFunction1E().Format) |> ignore else os.Append(NotAFunction2E().Format) |> ignore - - | TyconBadArgs(_,tcref,d,_) -> + + | TyconBadArgs(_,tcref,d,_) -> let exp = tcref.TyparsNoRange.Length if exp = 0 then os.Append(FSComp.SR.buildUnexpectedTypeArgs(fullDisplayTextOfTyconRef tcref, d)) |> ignore else os.Append(TyconBadArgsE().Format (fullDisplayTextOfTyconRef tcref) exp d) |> ignore - | IndeterminateType(_) -> + | IndeterminateType(_) -> os.Append(IndeterminateTypeE().Format) |> ignore - | NameClash(nm,k1,nm1,_,k2,nm2,_) -> - if nm = nm1 && nm1 = nm2 && k1 = k2 then + | NameClash(nm,k1,nm1,_,k2,nm2,_) -> + if nm = nm1 && nm1 = nm2 && k1 = k2 then os.Append(NameClash1E().Format k1 nm1) |> ignore else os.Append(NameClash2E().Format k1 nm1 nm k2 nm2) |> ignore - | Duplicate(k,s,_) -> - if k = "member" then + | Duplicate(k,s,_) -> + if k = "member" then os.Append(Duplicate1E().Format (DecompileOpName s)) |> ignore - else + else os.Append(Duplicate2E().Format k (DecompileOpName s)) |> ignore | UndefinedName(_,k,id,predictions) -> os.Append(k (DecompileOpName id.idText)) |> ignore if Set.isEmpty predictions |> not then let filtered = ErrorResolutionHints.FilterPredictions id.idText predictions os.Append(ErrorResolutionHints.FormatPredictions filtered) |> ignore - - | InternalUndefinedItemRef(f,smr,ccuName,s) -> - let _, errs = f(smr, ccuName, s) - os.Append(errs) |> ignore - | FieldNotMutable _ -> + + | InternalUndefinedItemRef(f,smr,ccuName,s) -> + let _, errs = f(smr, ccuName, s) + os.Append(errs) |> ignore + | FieldNotMutable _ -> os.Append(FieldNotMutableE().Format) |> ignore - | FieldsFromDifferentTypes (_,fref1,fref2,_) -> + | FieldsFromDifferentTypes (_,fref1,fref2,_) -> os.Append(FieldsFromDifferentTypesE().Format fref1.FieldName fref2.FieldName) |> ignore - | VarBoundTwice(id) -> + | VarBoundTwice(id) -> os.Append(VarBoundTwiceE().Format (DecompileOpName id.idText)) |> ignore - | Recursion (denv,id,ty1,ty2,_) -> + | Recursion (denv,id,ty1,ty2,_) -> let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(RecursionE().Format (DecompileOpName id.idText) t1 t2 tpcs) |> ignore - | InvalidRuntimeCoercion(denv,ty1,ty2,_) -> + | InvalidRuntimeCoercion(denv,ty1,ty2,_) -> let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(InvalidRuntimeCoercionE().Format t1 t2 tpcs) |> ignore - | IndeterminateRuntimeCoercion(denv,ty1,ty2,_) -> + | IndeterminateRuntimeCoercion(denv,ty1,ty2,_) -> let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(IndeterminateRuntimeCoercionE().Format t1 t2) |> ignore - | IndeterminateStaticCoercion(denv,ty1,ty2,_) -> + | IndeterminateStaticCoercion(denv,ty1,ty2,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(IndeterminateStaticCoercionE().Format t1 t2) |> ignore @@ -786,57 +804,57 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = // REVIEW: consider if we need to show _cxs (the type parameter constrants) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(StaticCoercionShouldUseBoxE().Format t1 t2) |> ignore - | TypeIsImplicitlyAbstract(_) -> + | TypeIsImplicitlyAbstract(_) -> os.Append(TypeIsImplicitlyAbstractE().Format) |> ignore - | NonRigidTypar(denv,tpnmOpt,typarRange,ty1,ty,_) -> + | NonRigidTypar(denv,tpnmOpt,typarRange,ty1,ty,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let _, (ty1,ty), _cxs = PrettyTypes.PrettifyTypes2 denv.g (ty1,ty) - match tpnmOpt with - | None -> + match tpnmOpt with + | None -> os.Append(NonRigidTypar1E().Format (stringOfRange typarRange) (NicePrint.stringOfTy denv ty)) |> ignore - | Some tpnm -> - match ty1 with - | TType_measure _ -> + | Some tpnm -> + match ty1 with + | TType_measure _ -> os.Append(NonRigidTypar2E().Format tpnm (NicePrint.stringOfTy denv ty)) |> ignore - | _ -> + | _ -> os.Append(NonRigidTypar3E().Format tpnm (NicePrint.stringOfTy denv ty)) |> ignore - | SyntaxError (ctxt,_) -> + | SyntaxError (ctxt,_) -> let ctxt = unbox>(ctxt) - - let (|EndOfStructuredConstructToken|_|) token = + + let (|EndOfStructuredConstructToken|_|) token = match token with - | Parser.TOKEN_ODECLEND - | Parser.TOKEN_OBLOCKSEP - | Parser.TOKEN_OEND - | Parser.TOKEN_ORIGHT_BLOCK_END + | Parser.TOKEN_ODECLEND + | Parser.TOKEN_OBLOCKSEP + | Parser.TOKEN_OEND + | Parser.TOKEN_ORIGHT_BLOCK_END | Parser.TOKEN_OBLOCKEND | Parser.TOKEN_OBLOCKEND_COMING_SOON | Parser.TOKEN_OBLOCKEND_IS_HERE -> Some() | _ -> None - let tokenIdToText tid = - match tid with + let tokenIdToText tid = + match tid with | Parser.TOKEN_IDENT -> getErrorString("Parser.TOKEN.IDENT") - | Parser.TOKEN_BIGNUM - | Parser.TOKEN_INT8 - | Parser.TOKEN_UINT8 - | Parser.TOKEN_INT16 - | Parser.TOKEN_UINT16 - | Parser.TOKEN_INT32 - | Parser.TOKEN_UINT32 - | Parser.TOKEN_INT64 - | Parser.TOKEN_UINT64 - | Parser.TOKEN_UNATIVEINT + | Parser.TOKEN_BIGNUM + | Parser.TOKEN_INT8 + | Parser.TOKEN_UINT8 + | Parser.TOKEN_INT16 + | Parser.TOKEN_UINT16 + | Parser.TOKEN_INT32 + | Parser.TOKEN_UINT32 + | Parser.TOKEN_INT64 + | Parser.TOKEN_UINT64 + | Parser.TOKEN_UNATIVEINT | Parser.TOKEN_NATIVEINT -> getErrorString("Parser.TOKEN.INT") - | Parser.TOKEN_IEEE32 + | Parser.TOKEN_IEEE32 | Parser.TOKEN_IEEE64 -> getErrorString("Parser.TOKEN.FLOAT") | Parser.TOKEN_DECIMAL -> getErrorString("Parser.TOKEN.DECIMAL") | Parser.TOKEN_CHAR -> getErrorString("Parser.TOKEN.CHAR") - + | Parser.TOKEN_BASE -> getErrorString("Parser.TOKEN.BASE") | Parser.TOKEN_LPAREN_STAR_RPAREN -> getErrorString("Parser.TOKEN.LPAREN.STAR.RPAREN") | Parser.TOKEN_DOLLAR -> getErrorString("Parser.TOKEN.DOLLAR") | Parser.TOKEN_INFIX_STAR_STAR_OP -> getErrorString("Parser.TOKEN.INFIX.STAR.STAR.OP") | Parser.TOKEN_INFIX_COMPARE_OP -> getErrorString("Parser.TOKEN.INFIX.COMPARE.OP") - | Parser.TOKEN_COLON_GREATER -> getErrorString("Parser.TOKEN.COLON.GREATER") + | Parser.TOKEN_COLON_GREATER -> getErrorString("Parser.TOKEN.COLON.GREATER") | Parser.TOKEN_COLON_COLON ->getErrorString("Parser.TOKEN.COLON.COLON") | Parser.TOKEN_PERCENT_OP -> getErrorString("Parser.TOKEN.PERCENT.OP") | Parser.TOKEN_INFIX_AT_HAT_OP -> getErrorString("Parser.TOKEN.INFIX.AT.HAT.OP") @@ -866,7 +884,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_GREATER_BAR_RBRACK -> getErrorString("Parser.TOKEN.GREATER.BAR.RBRACK") | Parser.TOKEN_MINUS -> getErrorString("Parser.TOKEN.MINUS") | Parser.TOKEN_ADJACENT_PREFIX_OP -> getErrorString("Parser.TOKEN.ADJACENT.PREFIX.OP") - | Parser.TOKEN_FUNKY_OPERATOR_NAME -> getErrorString("Parser.TOKEN.FUNKY.OPERATOR.NAME") + | Parser.TOKEN_FUNKY_OPERATOR_NAME -> getErrorString("Parser.TOKEN.FUNKY.OPERATOR.NAME") | Parser.TOKEN_COMMA-> getErrorString("Parser.TOKEN.COMMA") | Parser.TOKEN_DOT -> getErrorString("Parser.TOKEN.DOT") | Parser.TOKEN_BAR-> getErrorString("Parser.TOKEN.BAR") @@ -885,7 +903,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_BAR_RBRACK -> getErrorString("Parser.TOKEN.BAR.RBRACK") | Parser.TOKEN_GREATER_RBRACE -> getErrorString("Parser.TOKEN.GREATER.RBRACE") | Parser.TOKEN_GREATER_RBRACK -> getErrorString("Parser.TOKEN.GREATER.RBRACK") - | Parser.TOKEN_RQUOTE_DOT _ + | Parser.TOKEN_RQUOTE_DOT _ | Parser.TOKEN_RQUOTE -> getErrorString("Parser.TOKEN.RQUOTE") | Parser.TOKEN_RBRACK -> getErrorString("Parser.TOKEN.RBRACK") | Parser.TOKEN_RBRACE | Parser.TOKEN_RBRACE_COMING_SOON | Parser.TOKEN_RBRACE_IS_HERE -> getErrorString("Parser.TOKEN.RBRACE") @@ -904,15 +922,15 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_MEMBER -> getErrorString("Parser.TOKEN.MEMBER") | Parser.TOKEN_STATIC -> getErrorString("Parser.TOKEN.STATIC") | Parser.TOKEN_NAMESPACE-> getErrorString("Parser.TOKEN.NAMESPACE") - | Parser.TOKEN_OBLOCKBEGIN -> getErrorString("Parser.TOKEN.OBLOCKBEGIN") - | EndOfStructuredConstructToken -> getErrorString("Parser.TOKEN.OBLOCKEND") - | Parser.TOKEN_THEN + | Parser.TOKEN_OBLOCKBEGIN -> getErrorString("Parser.TOKEN.OBLOCKBEGIN") + | EndOfStructuredConstructToken -> getErrorString("Parser.TOKEN.OBLOCKEND") + | Parser.TOKEN_THEN | Parser.TOKEN_OTHEN -> getErrorString("Parser.TOKEN.OTHEN") | Parser.TOKEN_ELSE | Parser.TOKEN_OELSE -> getErrorString("Parser.TOKEN.OELSE") - | Parser.TOKEN_LET(_) + | Parser.TOKEN_LET(_) | Parser.TOKEN_OLET(_) -> getErrorString("Parser.TOKEN.OLET") - | Parser.TOKEN_OBINDER + | Parser.TOKEN_OBINDER | Parser.TOKEN_BINDER -> getErrorString("Parser.TOKEN.BINDER") | Parser.TOKEN_ODO -> getErrorString("Parser.TOKEN.ODO") | Parser.TOKEN_OWITH -> getErrorString("Parser.TOKEN.OWITH") @@ -920,7 +938,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_OFUN -> getErrorString("Parser.TOKEN.OFUN") | Parser.TOKEN_ORESET -> getErrorString("Parser.TOKEN.ORESET") | Parser.TOKEN_ODUMMY -> getErrorString("Parser.TOKEN.ODUMMY") - | Parser.TOKEN_DO_BANG + | Parser.TOKEN_DO_BANG | Parser.TOKEN_ODO_BANG -> getErrorString("Parser.TOKEN.ODO.BANG") | Parser.TOKEN_YIELD -> getErrorString("Parser.TOKEN.YIELD") | Parser.TOKEN_YIELD_BANG -> getErrorString("Parser.TOKEN.YIELD.BANG") @@ -977,9 +995,9 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_BEGIN -> getErrorString("Parser.TOKEN.BEGIN") | Parser.TOKEN_END -> getErrorString("Parser.TOKEN.END") | Parser.TOKEN_HASH_LIGHT - | Parser.TOKEN_HASH_LINE - | Parser.TOKEN_HASH_IF - | Parser.TOKEN_HASH_ELSE + | Parser.TOKEN_HASH_LINE + | Parser.TOKEN_HASH_IF + | Parser.TOKEN_HASH_ELSE | Parser.TOKEN_HASH_ENDIF -> getErrorString("Parser.TOKEN.HASH.ENDIF") | Parser.TOKEN_INACTIVECODE -> getErrorString("Parser.TOKEN.INACTIVECODE") | Parser.TOKEN_LEX_FAILURE-> getErrorString("Parser.TOKEN.LEX.FAILURE") @@ -992,23 +1010,23 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.TOKEN_KEYWORD_STRING -> getErrorString("Parser.TOKEN.KEYWORD_STRING") | Parser.TOKEN_EOF -> getErrorString("Parser.TOKEN.EOF") | Parser.TOKEN_CONST -> getErrorString("Parser.TOKEN.CONST") - | unknown -> + | unknown -> System.Diagnostics.Debug.Assert(false,"unknown token tag") let result = sprintf "%+A" unknown System.Diagnostics.Debug.Assert(false, result) result - match ctxt.CurrentToken with + match ctxt.CurrentToken with | None -> os.Append(UnexpectedEndOfInputE().Format) |> ignore - | Some token -> - match (token |> Parser.tagOfToken |> Parser.tokenTagToTokenId), token with + | Some token -> + match (token |> Parser.tagOfToken |> Parser.tokenTagToTokenId), token with | EndOfStructuredConstructToken,_ -> os.Append(OBlockEndSentenceE().Format) |> ignore | Parser.TOKEN_LEX_FAILURE, Parser.LEX_FAILURE str -> Printf.bprintf os "%s" str (* Fix bug://2431 *) | token,_ -> os.Append(UnexpectedE().Format (token |> tokenIdToText)) |> ignore (* Search for a state producing a single recognized non-terminal in the states on the stack *) let foundInContext = - + (* Merge a bunch of expression non terminals *) let (|NONTERM_Category_Expr|_|) = function | Parser.NONTERM_argExpr|Parser.NONTERM_minusExpr|Parser.NONTERM_parenExpr|Parser.NONTERM_atomicExpr @@ -1016,17 +1034,17 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.NONTERM_typedSeqExprBlock | Parser.NONTERM_interactiveExpr -> Some() | _ -> None - + (* Merge a bunch of pattern non terminals *) - let (|NONTERM_Category_Pattern|_|) = function - | Parser.NONTERM_constrPattern|Parser.NONTERM_parenPattern|Parser.NONTERM_atomicPattern -> Some() + let (|NONTERM_Category_Pattern|_|) = function + | Parser.NONTERM_constrPattern|Parser.NONTERM_parenPattern|Parser.NONTERM_atomicPattern -> Some() | _ -> None - + (* Merge a bunch of if/then/else non terminals *) let (|NONTERM_Category_IfThenElse|_|) = function | Parser.NONTERM_ifExprThen|Parser.NONTERM_ifExprElifs|Parser.NONTERM_ifExprCases -> Some() | _ -> None - + (* Merge a bunch of non terminals *) let (|NONTERM_Category_SignatureFile|_|) = function | Parser.NONTERM_signatureFile|Parser.NONTERM_moduleSpfn|Parser.NONTERM_moduleSpfns -> Some() @@ -1038,7 +1056,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Parser.NONTERM_fileModuleImpl|Parser.NONTERM_moduleDefn|Parser.NONTERM_interactiveDefns |Parser.NONTERM_moduleDefns|Parser.NONTERM_moduleDefnsOrExpr -> Some() | _ -> None - + let (|NONTERM_Category_Type|_|) = function | Parser.NONTERM_typ|Parser.NONTERM_tupleType -> Some() | _ -> None @@ -1046,24 +1064,24 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = let (|NONTERM_Category_Interaction|_|) = function | Parser.NONTERM_interactiveItemsTerminator|Parser.NONTERM_interaction|Parser.NONTERM__startinteraction -> Some() | _ -> None - - + + // Canonicalize the categories and check for a unique category - ctxt.ReducibleProductions |> List.exists (fun prods -> - match prods - |> List.map Parser.prodIdxToNonTerminal - |> List.map (function + ctxt.ReducibleProductions |> List.exists (fun prods -> + match prods + |> List.map Parser.prodIdxToNonTerminal + |> List.map (function | NONTERM_Category_Type -> Parser.NONTERM_typ - | NONTERM_Category_Expr -> Parser.NONTERM_declExpr - | NONTERM_Category_Pattern -> Parser.NONTERM_atomicPattern + | NONTERM_Category_Expr -> Parser.NONTERM_declExpr + | NONTERM_Category_Pattern -> Parser.NONTERM_atomicPattern | NONTERM_Category_IfThenElse -> Parser.NONTERM_ifExprThen | NONTERM_Category_SignatureFile -> Parser.NONTERM_signatureFile | NONTERM_Category_ImplementationFile -> Parser.NONTERM_implementationFile | NONTERM_Category_Definition -> Parser.NONTERM_moduleDefn | NONTERM_Category_Interaction -> Parser.NONTERM_interaction | nt -> nt) - |> Set.ofList - |> Set.toList with + |> Set.ofList + |> Set.toList with | [Parser.NONTERM_interaction] -> os.Append(NONTERM_interactionE().Format) |> ignore; true | [Parser.NONTERM_hashDirective] -> os.Append(NONTERM_hashDirectiveE().Format) |> ignore; true | [Parser.NONTERM_fieldDecl] -> os.Append(NONTERM_fieldDeclE().Format) |> ignore; true @@ -1098,9 +1116,9 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | [NONTERM_Category_Expr] -> os.Append(NONTERM_Category_ExprE().Format) |> ignore; true | [NONTERM_Category_Type] -> os.Append(NONTERM_Category_TypeE().Format) |> ignore; true | [Parser.NONTERM_typeArgsActual] -> os.Append(NONTERM_typeArgsActualE().Format) |> ignore; true - | _ -> + | _ -> false) - + #if DEBUG if not foundInContext then Printf.bprintf os ". (no 'in' context found: %+A)" (List.map (List.map Parser.prodIdxToNonTerminal) ctxt.ReducibleProductions) @@ -1108,18 +1126,18 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = foundInContext |> ignore // suppress unused variable warning in RELEASE #endif let fix (s:string) = s.Replace(SR.GetString("FixKeyword"),"").Replace(SR.GetString("FixSymbol"),"").Replace(SR.GetString("FixReplace"),"") - match (ctxt.ShiftTokens - |> List.map Parser.tokenTagToTokenId - |> List.filter (function Parser.TOKEN_error | Parser.TOKEN_EOF -> false | _ -> true) - |> List.map tokenIdToText - |> Set.ofList - |> Set.toList) with + match (ctxt.ShiftTokens + |> List.map Parser.tokenTagToTokenId + |> List.filter (function Parser.TOKEN_error | Parser.TOKEN_EOF -> false | _ -> true) + |> List.map tokenIdToText + |> Set.ofList + |> Set.toList) with | [tokenName1] -> os.Append(TokenName1E().Format (fix tokenName1)) |> ignore | [tokenName1;tokenName2] -> os.Append(TokenName1TokenName2E().Format (fix tokenName1) (fix tokenName2)) |> ignore | [tokenName1;tokenName2;tokenName3] -> os.Append(TokenName1TokenName2TokenName3E().Format (fix tokenName1) (fix tokenName2) (fix tokenName3)) |> ignore | _ -> () (* - Printf.bprintf os ".\n\n state = %A\n token = %A\n expect (shift) %A\n expect (reduce) %A\n prods=%A\n non terminals: %A" + Printf.bprintf os ".\n\n state = %A\n token = %A\n expect (shift) %A\n expect (reduce) %A\n prods=%A\n non terminals: %A" ctxt.StateStack ctxt.CurrentToken (List.map Parser.tokenTagToTokenId ctxt.ShiftTokens) @@ -1127,34 +1145,34 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = ctxt.ReducibleProductions (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) *) - | RuntimeCoercionSourceSealed(denv,ty,_) -> + | RuntimeCoercionSourceSealed(denv,ty,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let _, ty, _cxs = PrettyTypes.PrettifyTypes1 denv.g ty - if isTyparTy denv.g ty + if isTyparTy denv.g ty then os.Append(RuntimeCoercionSourceSealed1E().Format (NicePrint.stringOfTy denv ty)) |> ignore else os.Append(RuntimeCoercionSourceSealed2E().Format (NicePrint.stringOfTy denv ty)) |> ignore - | CoercionTargetSealed(denv,ty,_) -> + | CoercionTargetSealed(denv,ty,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let _, ty, _cxs= PrettyTypes.PrettifyTypes1 denv.g ty os.Append(CoercionTargetSealedE().Format (NicePrint.stringOfTy denv ty)) |> ignore - | UpcastUnnecessary(_) -> + | UpcastUnnecessary(_) -> os.Append(UpcastUnnecessaryE().Format) |> ignore - | TypeTestUnnecessary(_) -> + | TypeTestUnnecessary(_) -> os.Append(TypeTestUnnecessaryE().Format) |> ignore - | QuotationTranslator.IgnoringPartOfQuotedTermWarning (msg,_) -> + | QuotationTranslator.IgnoringPartOfQuotedTermWarning (msg,_) -> Printf.bprintf os "%s" msg | OverrideDoesntOverride(denv,impl,minfoVirtOpt,g,amap,m) -> let sig1 = DispatchSlotChecking.FormatOverride denv impl - match minfoVirtOpt with - | None -> + match minfoVirtOpt with + | None -> os.Append(OverrideDoesntOverride1E().Format sig1) |> ignore | Some minfoVirt -> - // https://github.com/Microsoft/visualfsharp/issues/35 + // https://github.com/Microsoft/visualfsharp/issues/35 // Improve error message when attempting to override generic return type with unit: // we need to check if unit was used as a type argument let rec hasUnitTType_app (types: TType list) = match types with - | TType_app (maybeUnit, []) :: ts -> + | TType_app (maybeUnit, []) :: ts -> match maybeUnit.TypeAbbrev with | Some ttype when Tastops.isUnitTy g ttype -> true | _ -> hasUnitTType_app ts @@ -1165,15 +1183,15 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | TType_app (t, types) when t.IsFSharpInterfaceTycon && hasUnitTType_app types -> // match abstract member with 'unit' passed as generic argument os.Append(OverrideDoesntOverride4E().Format sig1) |> ignore - | _ -> + | _ -> os.Append(OverrideDoesntOverride2E().Format sig1) |> ignore let sig2 = DispatchSlotChecking.FormatMethInfoSig g amap m denv minfoVirt - if sig1 <> sig2 then + if sig1 <> sig2 then os.Append(OverrideDoesntOverride3E().Format sig2) |> ignore | UnionCaseWrongArguments (_,n1,n2,_) -> os.Append(UnionCaseWrongArgumentsE().Format n2 n1) |> ignore - | UnionPatternsBindDifferentNames _ -> + | UnionPatternsBindDifferentNames _ -> os.Append(UnionPatternsBindDifferentNamesE().Format) |> ignore | ValueNotContained (denv,mref,implVal,sigVal,f) -> let text1,text2 = NicePrint.minimalStringsOfTwoValues denv implVal sigVal @@ -1188,10 +1206,10 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = let nsb = new System.Text.StringBuilder() name nsb; os.Append(RequiredButNotSpecifiedE().Format (fullDisplayTextOfModRef mref) k (nsb.ToString())) |> ignore - | UseOfAddressOfOperator _ -> + | UseOfAddressOfOperator _ -> os.Append(UseOfAddressOfOperatorE().Format) |> ignore | DefensiveCopyWarning(s,_) -> os.Append(DefensiveCopyWarningE().Format s) |> ignore - | DeprecatedThreadStaticBindingWarning(_) -> + | DeprecatedThreadStaticBindingWarning(_) -> os.Append(DeprecatedThreadStaticBindingWarningE().Format) |> ignore | FunctionValueUnexpected (denv,ty,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) @@ -1200,25 +1218,25 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | UnitTypeExpected (denv,ty,perhapsProp,_) -> // REVIEW: consider if we need to show _cxs (the type parameter constrants) let _, ty, _cxs = PrettyTypes.PrettifyTypes1 denv.g ty - if perhapsProp then + if perhapsProp then os.Append(UnitTypeExpected2E().Format (NicePrint.stringOfTy denv ty)) |> ignore else os.Append(UnitTypeExpected1E().Format) |> ignore - | RecursiveUseCheckedAtRuntime _ -> + | RecursiveUseCheckedAtRuntime _ -> os.Append(RecursiveUseCheckedAtRuntimeE().Format) |> ignore - | LetRecUnsound (_,[v],_) -> + | LetRecUnsound (_,[v],_) -> os.Append(LetRecUnsound1E().Format v.DisplayName) |> ignore - | LetRecUnsound (_,path,_) -> + | LetRecUnsound (_,path,_) -> let bos = new System.Text.StringBuilder() - (path.Tail @ [path.Head]) |> List.iter (fun (v:ValRef) -> bos.Append(LetRecUnsoundInnerE().Format v.DisplayName) |> ignore) + (path.Tail @ [path.Head]) |> List.iter (fun (v:ValRef) -> bos.Append(LetRecUnsoundInnerE().Format v.DisplayName) |> ignore) os.Append(LetRecUnsound2E().Format (List.head path).DisplayName (bos.ToString())) |> ignore - | LetRecEvaluatedOutOfOrder (_,_,_,_) -> + | LetRecEvaluatedOutOfOrder (_,_,_,_) -> os.Append(LetRecEvaluatedOutOfOrderE().Format) |> ignore - | LetRecCheckedAtRuntime _ -> + | LetRecCheckedAtRuntime _ -> os.Append(LetRecCheckedAtRuntimeE().Format) |> ignore - | SelfRefObjCtor(false,_) -> + | SelfRefObjCtor(false,_) -> os.Append(SelfRefObjCtor1E().Format) |> ignore - | SelfRefObjCtor(true,_) -> + | SelfRefObjCtor(true,_) -> os.Append(SelfRefObjCtor2E().Format) |> ignore | VirtualAugmentationOnNullValuedType(_) -> os.Append(VirtualAugmentationOnNullValuedTypeE().Format) |> ignore @@ -1231,41 +1249,41 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = // REVIEW: consider if we need to show _cxs (the type parameter constrants) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 os.Append(NonUniqueInferredAbstractSlot2E().Format) |> ignore - if t1 <> t2 then + if t1 <> t2 then os.Append(NonUniqueInferredAbstractSlot3E().Format t1 t2) |> ignore os.Append(NonUniqueInferredAbstractSlot4E().Format) |> ignore | Error ((_,s),_) -> os.Append(s) |> ignore | NumberedError ((_,s),_) -> os.Append(s) |> ignore - | InternalError (s,_) - | InvalidArgument s + | InternalError (s,_) + | InvalidArgument s | Failure s as exn -> ignore exn // use the argument, even in non DEBUG let f1 = SR.GetString("Failure1") - let f2 = SR.GetString("Failure2") - match s with + let f2 = SR.GetString("Failure2") + match s with | f when f = f1 -> os.Append(Failure3E().Format s) |> ignore | f when f = f2 -> os.Append(Failure3E().Format s) |> ignore | _ -> os.Append(Failure4E().Format s) |> ignore #if DEBUG Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) - if !showAssertForUnexpectedException then + if !showAssertForUnexpectedException then System.Diagnostics.Debug.Assert(false,sprintf "Bug seen in compiler: %s" (exn.ToString())) #endif | FullAbstraction(s,_) -> os.Append(FullAbstractionE().Format s) |> ignore | WrappedError (exn,_) -> OutputExceptionR os exn - | PatternMatchCompilation.MatchIncomplete (isComp,cexOpt,_) -> + | PatternMatchCompilation.MatchIncomplete (isComp,cexOpt,_) -> os.Append(MatchIncomplete1E().Format) |> ignore - match cexOpt with + match cexOpt with | None -> () | Some (cex,false) -> os.Append(MatchIncomplete2E().Format cex) |> ignore | Some (cex,true) -> os.Append(MatchIncomplete3E().Format cex) |> ignore - if isComp then + if isComp then os.Append(MatchIncomplete4E().Format) |> ignore | PatternMatchCompilation.RuleNeverMatched _ -> os.Append(RuleNeverMatchedE().Format) |> ignore | ValNotMutable(_,valRef,_) -> os.Append(ValNotMutableE().Format(valRef.DisplayName)) |> ignore | ValNotLocal _ -> os.Append(ValNotLocalE().Format) |> ignore - | ObsoleteError (s, _) - | ObsoleteWarning (s, _) -> + | ObsoleteError (s, _) + | ObsoleteWarning (s, _) -> os.Append(Obsolete1E().Format) |> ignore if s <> "" then os.Append(Obsolete2E().Format s) |> ignore | Experimental (s, _) -> os.Append(ExperimentalE().Format s) |> ignore @@ -1274,32 +1292,32 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | Deprecated(s, _) -> os.Append(DeprecatedE().Format s) |> ignore | LibraryUseOnly(_) -> os.Append(LibraryUseOnlyE().Format) |> ignore | MissingFields(sl,_) -> os.Append(MissingFieldsE().Format (String.concat "," sl + ".")) |> ignore - | ValueRestriction(denv,hassig,v,_,_) -> + | ValueRestriction(denv,hassig,v,_,_) -> let denv = { denv with showImperativeTyparAnnotations=true } let tau = v.TauType - if hassig then - if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then + if hassig then + if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then os.Append(ValueRestriction1E().Format - v.DisplayName + v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv v) v.DisplayName) |> ignore else os.Append(ValueRestriction2E().Format - v.DisplayName + v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv v) v.DisplayName) |> ignore else - match v.MemberInfo with - | Some(membInfo) when - begin match membInfo.MemberFlags.MemberKind with - | MemberKind.PropertyGet - | MemberKind.PropertySet + match v.MemberInfo with + | Some(membInfo) when + begin match membInfo.MemberFlags.MemberKind with + | MemberKind.PropertyGet + | MemberKind.PropertySet | MemberKind.Constructor -> true (* can't infer extra polymorphism *) | _ -> false (* can infer extra polymorphism *) - end -> + end -> os.Append(ValueRestriction3E().Format (NicePrint.stringOfQualifiedValOrMember denv v)) |> ignore - | _ -> - if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then + | _ -> + if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then os.Append(ValueRestriction4E().Format v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv v) @@ -1309,7 +1327,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = v.DisplayName (NicePrint.stringOfQualifiedValOrMember denv v) v.DisplayName) |> ignore - + | Parsing.RecoverableParseError -> os.Append(RecoverableParseErrorE().Format) |> ignore | ReservedKeyword (s,_) -> os.Append(ReservedKeywordE().Format s) |> ignore | IndentationProblem (s,_) -> os.Append(IndentationProblemE().Format s) |> ignore @@ -1320,7 +1338,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | UnresolvedReferenceError(assemblyname,_) | UnresolvedReferenceNoRange(assemblyname) -> os.Append(UnresolvedReferenceNoRangeE().Format assemblyname) |> ignore - | UnresolvedPathReference(assemblyname,pathname,_) + | UnresolvedPathReference(assemblyname,pathname,_) | UnresolvedPathReferenceNoRange(assemblyname,pathname) -> os.Append(UnresolvedPathReferenceNoRangeE().Format pathname assemblyname) |> ignore | DeprecatedCommandLineOptionFull(fullText,_) -> @@ -1339,16 +1357,16 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(HashReferenceNotAllowedInNonScriptE().Format) |> ignore | HashDirectiveNotAllowedInNonScript(_) -> os.Append(HashDirectiveNotAllowedInNonScriptE().Format) |> ignore - | FileNameNotResolved(filename,locations,_) -> + | FileNameNotResolved(filename,locations,_) -> os.Append(FileNameNotResolvedE().Format filename locations) |> ignore | AssemblyNotResolved(originalName,_) -> os.Append(AssemblyNotResolvedE().Format originalName) |> ignore | IllegalFileNameChar(fileName,invalidChar) -> os.Append(FSComp.SR.buildUnexpectedFileNameCharacter(fileName,string invalidChar)|>snd) |> ignore - | HashLoadedSourceHasIssues(warnings,errors,_) -> + | HashLoadedSourceHasIssues(warnings,errors,_) -> let Emit(l:exn list) = OutputExceptionR os (List.head l) - if errors=[] then + if errors=[] then os.Append(HashLoadedSourceHasIssues1E().Format) |> ignore Emit(warnings) else @@ -1356,17 +1374,18 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = Emit(errors) | HashLoadedScriptConsideredSource(_) -> os.Append(HashLoadedScriptConsideredSourceE().Format) |> ignore - | InvalidInternalsVisibleToAssemblyName(badName,fileNameOption) -> - match fileNameOption with + | InvalidInternalsVisibleToAssemblyName(badName,fileNameOption) -> + match fileNameOption with | Some file -> os.Append(InvalidInternalsVisibleToAssemblyName1E().Format badName file) |> ignore | None -> os.Append(InvalidInternalsVisibleToAssemblyName2E().Format badName) |> ignore | LoadedSourceNotFoundIgnoring(filename,_) -> os.Append(LoadedSourceNotFoundIgnoringE().Format filename) |> ignore - | MSBuildReferenceResolutionWarning(code,message,_) - | MSBuildReferenceResolutionError(code,message,_) -> + | MSBuildReferenceResolutionWarning(code,message,_) + | MSBuildReferenceResolutionError(code,message,_) -> os.Append(MSBuildReferenceResolutionErrorE().Format message code) |> ignore +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException as e -> + | :? System.Reflection.TargetInvocationException as e -> OutputExceptionR os e.InnerException | :? FileNotFoundException as e -> Printf.bprintf os "%s" e.Message | :? DirectoryNotFoundException as e -> Printf.bprintf os "%s" e.Message @@ -1374,45 +1393,47 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | :? System.NotSupportedException as e -> Printf.bprintf os "%s" e.Message | :? IOException as e -> Printf.bprintf os "%s" e.Message | :? System.UnauthorizedAccessException as e -> Printf.bprintf os "%s" e.Message - - | e -> +#endif + | e -> os.Append(TargetInvocationExceptionWrapperE().Format e.Message) |> ignore #if DEBUG Printf.bprintf os "\nStack Trace\n%s\n" (e.ToString()) - if !showAssertForUnexpectedException then + if !showAssertForUnexpectedException then System.Diagnostics.Debug.Assert(false,sprintf "Bug seen in compiler: %s" (e.ToString())) #endif OutputExceptionR os (err.Exception) -// remove any newlines and tabs -let OutputPhasedError (os:System.Text.StringBuilder) (err:PhasedError) (flattenErrors:bool) = +// remove any newlines and tabs +let OutputPhasedError (os:System.Text.StringBuilder) (err:PhasedError) (flattenErrors:bool) = let buf = new System.Text.StringBuilder() OutputPhasedErrorR buf err let s = if flattenErrors then ErrorLogger.NormalizeErrorString (buf.ToString()) else buf.ToString() - + os.Append(s) |> ignore -type ErrorStyle = - | DefaultErrors - | EmacsErrors - | TestErrors +type ErrorStyle = + | DefaultErrors + | EmacsErrors + | TestErrors | VSErrors | GccErrors +#if !FABLE_COMPILER + let SanitizeFileName fileName implicitIncludeDir = // The assert below is almost ok, but it fires in two cases: // - fsi.exe sometimes passes "stdin" as a dummy filename - // - if you have a #line directive, e.g. + // - 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 "filename should be absolute: '%s'" fileName) try let fullPath = FileSystem.GetFullPathShim(fileName) let currentDir = implicitIncludeDir - + // if the file name is not rooted in the current directory, return the full path if not(fullPath.StartsWith(currentDir)) then fullPath @@ -1430,61 +1451,61 @@ type ErrorLocation = IsEmpty : bool } [] -type CanonicalInformation = +type CanonicalInformation = { ErrorNumber : int Subcategory : string TextRepresentation : string } [] -type DetailedIssueInfo = +type DetailedIssueInfo = { Location : ErrorLocation option Canonical : CanonicalInformation Message : string } [] -type ErrorOrWarning = +type ErrorOrWarning = | Short of bool * string | Long of bool * DetailedIssueInfo /// returns sequence that contains ErrorOrWarning for the given error + ErrorOrWarning for all related errors -let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err:PhasedError) = - let outputWhere (showFullPaths,errorStyle) m : ErrorLocation = - if m = rangeStartup || m = rangeCmdArgs then +let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err:PhasedError) = + let outputWhere (showFullPaths,errorStyle) m : ErrorLocation = + if m = rangeStartup || m = rangeCmdArgs then { Range = m; TextRepresentation = ""; IsEmpty = true; File = "" } else let file = m.FileName - let file = if showFullPaths then + let file = if showFullPaths then Filename.fullpath implicitIncludeDir file - else + else SanitizeFileName file implicitIncludeDir - let text, m, file = + let text, m, file = match errorStyle with - | ErrorStyle.EmacsErrors -> + | ErrorStyle.EmacsErrors -> let file = file.Replace("\\","/") (sprintf "File \"%s\", line %d, characters %d-%d: " file m.StartLine m.StartColumn m.EndColumn), m, file // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output - | ErrorStyle.DefaultErrors -> + | ErrorStyle.DefaultErrors -> let file = file.Replace('/',System.IO.Path.DirectorySeparatorChar) let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) m.End (sprintf "%s(%d,%d): " file m.StartLine m.StartColumn), m, file // We may also want to change TestErrors to be 1-based - | ErrorStyle.TestErrors -> + | ErrorStyle.TestErrors -> let file = file.Replace("/","\\") let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) sprintf "%s(%d,%d-%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file - | ErrorStyle.GccErrors -> + | ErrorStyle.GccErrors -> let file = file.Replace('/',System.IO.Path.DirectorySeparatorChar) let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) sprintf "%s:%d:%d: " file m.StartLine m.StartColumn, m, file // Here, we want the complete range information so Project Systems can generate proper squiggles - | ErrorStyle.VSErrors -> + | ErrorStyle.VSErrors -> // Show prefix only for real files. Otherise, we just want a truncated error like: // parse error FS0031 : blah blah - if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then + if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then let file = file.Replace("/","\\") let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) ) sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file @@ -1492,48 +1513,48 @@ let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorS "", m, file { Range = m; TextRepresentation = text; IsEmpty = false; File = file } - match err.Exception with - | ReportedError _ -> - assert ("" = "Unexpected ReportedError") // this should never happen + match err.Exception with + | ReportedError _ -> + assert ("" = "Unexpected ReportedError") // this should never happen Seq.empty - | StopProcessing -> - assert ("" = "Unexpected StopProcessing") // this should never happen + | StopProcessing -> + assert ("" = "Unexpected StopProcessing") // this should never happen Seq.empty - | _ -> + | _ -> let errors = ResizeArray() let report err = - let OutputWhere(err) = - match GetRangeOfError err with + let OutputWhere(err) = + match GetRangeOfError err with | Some m -> Some(outputWhere (showFullPaths,errorStyle) m) | None -> None - let OutputCanonicalInformation(err:PhasedError,subcategory, errorNumber) : CanonicalInformation = - let text = + let OutputCanonicalInformation(err:PhasedError,subcategory, errorNumber) : CanonicalInformation = + let text = match errorStyle with // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness. | ErrorStyle.VSErrors -> sprintf "%s %s FS%04d: " subcategory (if warn then "warning" else "error") errorNumber | _ -> sprintf "%s FS%04d: " (if warn then "warning" else "error") (GetErrorNumber err) { ErrorNumber = errorNumber; Subcategory = subcategory; TextRepresentation = text} - + let mainError,relatedErrors = SplitRelatedErrors err let where = OutputWhere(mainError) let canonical = OutputCanonicalInformation(mainError,err.Subcategory(),GetErrorNumber mainError) - let message = + let message = let os = System.Text.StringBuilder() OutputPhasedError os mainError flattenErrors os.ToString() - + let entry : DetailedIssueInfo = { Location = where; Canonical = canonical; Message = message } - + errors.Add ( ErrorOrWarning.Long( not warn, entry ) ) let OutputRelatedError(err) = match errorStyle with // Give a canonical string when --vserror. - | ErrorStyle.VSErrors -> + | ErrorStyle.VSErrors -> let relWhere = OutputWhere(mainError) // mainError? let relCanonical = OutputCanonicalInformation(err, err.Subcategory(),GetErrorNumber mainError) // Use main error for code - let relMessage = + let relMessage = let os = System.Text.StringBuilder() OutputPhasedError os err flattenErrors os.ToString() @@ -1541,11 +1562,11 @@ let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorS let entry : DetailedIssueInfo = { Location = relWhere; Canonical = relCanonical; Message = relMessage} errors.Add( ErrorOrWarning.Long (not warn, entry) ) - | _ -> + | _ -> let os = System.Text.StringBuilder() OutputPhasedError os err flattenErrors errors.Add( ErrorOrWarning.Short((not warn), os.ToString()) ) - + relatedErrors |> List.iter OutputRelatedError match err with @@ -1562,13 +1583,13 @@ let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorS /// used by fsc.exe and fsi.exe, but not by VS /// prints error and related errors to the specified StringBuilder -let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) = - +let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) = + let errors = CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err) for e in errors do Printf.bprintf os "\n" match e with - | ErrorOrWarning.Short(_, txt) -> + | ErrorOrWarning.Short(_, txt) -> os.Append txt |> ignore | ErrorOrWarning.Long(_, details) -> match details.Location with @@ -1576,16 +1597,16 @@ let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,err | _ -> () os.Append( details.Canonical.TextRepresentation ) |> ignore os.Append( details.Message ) |> ignore - + let OutputErrorOrWarningContext prefix fileLineFn os err = match GetRangeOfError err with - | None -> () - | Some m -> + | None -> () + | Some m -> let filename = m.FileName let lineA = m.StartLine let lineB = m.EndLine let line = fileLineFn filename lineA - if line<>"" then + if line<>"" then let iA = m.StartColumn let iB = m.EndColumn let iLen = if lineA = lineB then max (iB - iA) 1 else 1 @@ -1596,9 +1617,9 @@ let OutputErrorOrWarningContext prefix fileLineFn os err = let GetFSharpCoreLibraryName () = "FSharp.Core" -let GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) = +let GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) = // On Mono, there is no good reference resolution - if useSimpleResolution then + if useSimpleResolution then GetFSharpCoreLibraryName()+".dll" else let fsCoreName = GetFSharpCoreLibraryName() @@ -1606,7 +1627,7 @@ let GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) = // RESHAPED_REFLECTION does not have Assembly.GetReferencedAssemblies() // So use the fsharp.core.dll from alongside the fsc compiler. // This can also be used for the out of gac work on DEV15 - let fscCoreLocation = + let fscCoreLocation = let fscLocation = typeof.Assembly.Location Path.Combine(Path.GetDirectoryName(fscLocation), fsCoreName + ".dll") if File.Exists(fscCoreLocation) then fsCoreName + ".dll" @@ -1625,13 +1646,13 @@ let GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) = // if not we use the referenced FSharp.Core from this project match foundReference with | Some fsharpCore -> fsharpCore - | None -> + | None -> // FSharp.Compiler.Service for F# 4.0 defaults to FSharp.Core 4.4.0.0 if no FSharp.Core is referenced statically by the host process. "FSharp.Core, Version=4.4.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" #endif -let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings" +let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings" -// This list is the default set of references for "non-project" files. +// This list is the default set of references for "non-project" files. // // These DLLs are // (a) included in the environment used for all .fsx files (see service.fs) @@ -1641,11 +1662,12 @@ let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings" #if TODO_REWORK_ASSEMBLY_LOAD // .NET Core references -let DefaultBasicReferencesForOutOfProjectSources = +let DefaultBasicReferencesForOutOfProjectSources = [ yield Path.Combine(Path.GetDirectoryName(typeof.Assembly.Location),"mscorlib.dll"); // mscorlib + yield typeof.Assembly.Location; // System.Private.CoreLib yield typeof.Assembly.Location; // System.Console yield typeof.Assembly.Location; // System.Runtime - yield typeof.Assembly.Location; // System.ObjectModel + yield typeof.Assembly.Location; // System.ObjectModel yield typeof.Assembly.Location; // System.IO yield typeof.Assembly.Location; // System.Linq yield typeof.Assembly.Location; // System.Xml.Linq @@ -1656,20 +1678,20 @@ let DefaultBasicReferencesForOutOfProjectSources = ] let DefaultBasicReferencesForOutOfProjectSources40 = [] -#else -let DefaultBasicReferencesForOutOfProjectSources = +#else +let DefaultBasicReferencesForOutOfProjectSources = [ yield "System" - yield "System.Xml" + yield "System.Xml" yield "System.Runtime.Remoting" yield "System.Runtime.Serialization.Formatters.Soap" yield "System.Data" yield "System.Drawing" yield "System.Core" // These are the Portable-profile and .NET Standard 1.6 dependencies of FSharp.Core.dll. These are needed - // when an F# sript references an F# profile 7, 78, 259 or .NET Standard 1.6 component which in turn refers + // when an F# sript references an F# profile 7, 78, 259 or .NET Standard 1.6 component which in turn refers // to FSharp.Core for profile 7, 78, 259 or .NET Standard. yield "System.Runtime" // lots of types - yield "System.Linq" // System.Linq.Expressions.Expression + yield "System.Linq" // System.Linq.Expressions.Expression yield "System.Reflection" // System.Reflection.ParameterInfo yield "System.Linq.Expressions" // System.Linq.IQueryable yield "System.Threading.Tasks" // valuetype [System.Threading.Tasks]System.Threading.CancellationToken @@ -1688,17 +1710,17 @@ let DefaultBasicReferencesForOutOfProjectSources = ] // Extra implicit references for .NET 4.0 -let DefaultBasicReferencesForOutOfProjectSources40 = +let DefaultBasicReferencesForOutOfProjectSources40 = [ "System.Numerics" ] - + #endif // A set of assemblies to always consider to be system assemblies -let SystemAssemblies primaryAssemblyName = - [ yield primaryAssemblyName - yield GetFSharpCoreLibraryName() +let SystemAssemblies primaryAssemblyName = + [ yield primaryAssemblyName + yield GetFSharpCoreLibraryName() yield "System" - yield "System.Xml" + yield "System.Xml" yield "System.Runtime.Remoting" yield "System.Runtime.Serialization.Formatters.Soap" yield "System.Data" @@ -1746,23 +1768,23 @@ let SystemAssemblies primaryAssemblyName = yield "System.Threading.Thread" yield "System.Threading.ThreadPool" yield "System.Threading.Timer" - ] + ] // The set of references entered into the TcConfigBuilder for scripts prior to computing -// the load closure. +// the load closure. // // REVIEW: it isn't clear if there is any negative effect // of leaving an assembly off this list. -let BasicReferencesForScriptLoadClosure(useSimpleResolution, useFsiAuxLib) = +let BasicReferencesForScriptLoadClosure(useSimpleResolution, useFsiAuxLib) = [ #if TODO_REWORK_ASSEMBLY_LOAD Path.Combine(Path.GetDirectoryName(typeof.Assembly.Location),"mscorlib.dll"); // mscorlib #else "mscorlib" #endif - GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) + GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) ] @ // Need to resolve these explicitly so they will be found in the reference assemblies directory which is where the .xml files are. - DefaultBasicReferencesForOutOfProjectSources @ + DefaultBasicReferencesForOutOfProjectSources @ [ if useFsiAuxLib then yield GetFsiLibraryName () ] let (++) x s = x @ [s] @@ -1775,15 +1797,15 @@ let (++) x s = x @ [s] /// Will return None if the filename is not found. let TryResolveFileUsingPaths(paths,m,name) = - let () = - try FileSystem.IsPathRootedShim(name) |> ignore + let () = + try FileSystem.IsPathRootedShim(name) |> ignore with :? System.ArgumentException as e -> error(Error(FSComp.SR.buildProblemWithFilename(name,e.Message),m)) - if FileSystem.IsPathRootedShim(name) && FileSystem.SafeExists name - then Some name + if FileSystem.IsPathRootedShim(name) && FileSystem.SafeExists name + then Some name else - let res = paths |> List.tryPick (fun path -> + let res = paths |> List.tryPick (fun path -> let n = Path.Combine (path, name) - if FileSystem.SafeExists n then Some n + if FileSystem.SafeExists n then Some n else None) res @@ -1793,55 +1815,48 @@ let ResolveFileUsingPaths(paths,m,name) = | Some(res) -> res | None -> let searchMessage = String.concat "\n " paths - raise (FileNameNotResolved(name,searchMessage,m)) - -let GetWarningNumber(m,s:string) = - try - Some (int32 s) - with err -> - warning(Error(FSComp.SR.buildInvalidWarningNumber(s),m)) - None + raise (FileNameNotResolved(name,searchMessage,m)) -let ComputeMakePathAbsolute implicitIncludeDir (path : string) = - try +let ComputeMakePathAbsolute implicitIncludeDir (path : string) = + try // remove any quotation marks from the path first let path = path.Replace("\"","") - if not (FileSystem.IsPathRootedShim(path)) + if not (FileSystem.IsPathRootedShim(path)) then Path.Combine (implicitIncludeDir, path) - else path - with - :? System.ArgumentException -> path + else path + with + :? System.ArgumentException -> path //---------------------------------------------------------------------------- // Configuration //---------------------------------------------------------------------------- -type CompilerTarget = - | WinExe - | ConsoleExe - | Dll +type CompilerTarget = + | WinExe + | ConsoleExe + | Dll | Module member x.IsExe = (match x with ConsoleExe | WinExe -> true | _ -> false) type ResolveAssemblyReferenceMode = Speculative | ReportErrors /// Represents the file or string used for the --version flag -type VersionFlag = +type VersionFlag = | VersionString of string | VersionFile of string | VersionNone member x.GetVersionInfo(implicitIncludeDir) = let vstr = x.GetVersionString(implicitIncludeDir) - try + try IL.parseILVersion vstr with _ -> errorR(Error(FSComp.SR.buildInvalidVersionString(vstr),rangeStartup)); IL.parseILVersion "0.0.0.0" - member x.GetVersionString(implicitIncludeDir) = - match x with + member x.GetVersionString(implicitIncludeDir) = + match x with | VersionString s -> s | VersionFile s -> let s = if FileSystem.IsPathRootedShim(s) then s else Path.Combine(implicitIncludeDir,s) - if not(FileSystem.SafeExists(s)) then + if not(FileSystem.SafeExists(s)) then errorR(Error(FSComp.SR.buildInvalidVersionFile(s),rangeStartup)); "0.0.0.0" else use is = System.IO.File.OpenText s @@ -1851,7 +1866,7 @@ type VersionFlag = /// Represents a reference to an assembly. May be backed by a real assembly on disk, or a cross-project /// reference backed by information generated by the the compiler service. -type IRawFSharpAssemblyData = +type IRawFSharpAssemblyData = /// The raw list AutoOpenAttribute attributes in the assembly abstract GetAutoOpenAttributes : ILGlobals -> string list /// The raw list InternalsVisibleToAttribute attributes in the assembly @@ -1872,7 +1887,7 @@ type IRawFSharpAssemblyData = abstract HasAnyFSharpSignatureDataAttribute : bool abstract HasMatchingFSharpSignatureDataAttribute : ILGlobals -> bool -type TimeStampCache() = +type TimeStampCache() = let cacheCreation = DateTime.Now let files = Dictionary() let projects = Dictionary(HashIdentity.Reference) @@ -1880,25 +1895,25 @@ type TimeStampCache() = member x.Files = files member x.Projects = projects -and IProjectReference = +and IProjectReference = /// The name of the assembly file generated by the project - abstract FileName : string + abstract FileName : string /// Evaluate raw contents of the assembly file generated by the project abstract EvaluateRawContents : unit -> IRawFSharpAssemblyData option /// Get the logical timestamp that would be the timestamp of the assembly file generated by the project abstract GetLogicalTimeStamp : TimeStampCache -> DateTime option -type AssemblyReference = +type AssemblyReference = | AssemblyReference of range * string * IProjectReference option member x.Range = (let (AssemblyReference(m,_,_)) = x in m) member x.Text = (let (AssemblyReference(_,text,_)) = x in text) member x.ProjectReference = (let (AssemblyReference(_,_,contents)) = x in contents) - member x.SimpleAssemblyNameIs(name) = + member x.SimpleAssemblyNameIs(name) = (String.Compare(fileNameWithoutExtension x.Text, name, StringComparison.OrdinalIgnoreCase) = 0) || (let text = x.Text.ToLowerInvariant() not (text.Contains "/") && not (text.Contains "\\") && not (text.Contains ".dll") && not (text.Contains ".exe") && - try let aname = System.Reflection.AssemblyName(x.Text) in aname.Name = name - with _ -> false) + try let aname = System.Reflection.AssemblyName(x.Text) in aname.Name = name + with _ -> false) override x.ToString() = sprintf "AssemblyReference(%s)" x.Text type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * AssemblyReference list @@ -1906,9 +1921,9 @@ type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * Assem type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted list #endif -type ImportedBinary = +type ImportedBinary = { FileName: string - RawMetadata: IRawFSharpAssemblyData + RawMetadata: IRawFSharpAssemblyData #if EXTENSIONTYPING ProviderGeneratedAssembly: System.Reflection.Assembly option IsProviderGenerated: bool @@ -1917,8 +1932,8 @@ type ImportedBinary = ILAssemblyRefs : ILAssemblyRef list ILScopeRef: ILScopeRef } -type ImportedAssembly = - { ILScopeRef: ILScopeRef +type ImportedAssembly = + { ILScopeRef: ILScopeRef FSharpViewOfMetadata: CcuThunk AssemblyAutoOpenAttributes: string list AssemblyInternalsVisibleToAttributes: string list @@ -1940,17 +1955,17 @@ type AvailableImportedAssembly = // - 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 CcuLoadFailureAction = +type CcuLoadFailureAction = | RaiseError | ReturnNone -type ISystemRuntimeCcuInitializer = +type ISystemRuntimeCcuInitializer = abstract BeginLoadingSystemRuntime : resolver : (AssemblyReference -> ImportedAssembly) * noDebug :bool -> ILGlobals * obj abstract EndLoadingSystemRuntime : state : obj * resolver : (CcuLoadFailureAction -> AssemblyReference -> ImportedAssembly option) -> ImportedAssembly -type NetCoreSystemRuntimeTraits(primaryAssembly) = +type NetCoreSystemRuntimeTraits(primaryAssembly) = - let valueOf name hole = + let valueOf name hole = match hole with | Some assembly -> assembly | None -> failwithf "Internal compiler error: scope ref hole '%s' is not initialized" name @@ -1961,7 +1976,7 @@ type NetCoreSystemRuntimeTraits(primaryAssembly) = let mutable systemCollections = None let mutable systemRuntimeInteropServices = None - member this.FixupImportedAssemblies(systemReflectionRef, systemDiagnosticsDebugRef, systemLinqExpressionsRef, systemCollectionsRef, systemRuntimeInteropServicesRef) = + member this.FixupImportedAssemblies(systemReflectionRef, systemDiagnosticsDebugRef, systemLinqExpressionsRef, systemCollectionsRef, systemRuntimeInteropServicesRef) = systemReflection <- systemReflectionRef systemDiagnosticsDebug <- systemDiagnosticsDebugRef systemLinqExpressions <- systemLinqExpressionsRef @@ -1976,9 +1991,9 @@ type NetCoreSystemRuntimeTraits(primaryAssembly) = member this.SerializationInfoTypeScopeRef = None member this.SecurityPermissionAttributeTypeScopeRef = None member this.SystemDiagnosticsDebugScopeRef = lazy ((valueOf "System.Diagnostics.Debug" systemDiagnosticsDebug).FSharpViewOfMetadata.ILScopeRef) - member this.SystemRuntimeInteropServicesScopeRef = - lazy - match systemRuntimeInteropServices with + member this.SystemRuntimeInteropServicesScopeRef = + lazy + match systemRuntimeInteropServices with | Some assemblyRef -> Some assemblyRef.FSharpViewOfMetadata.ILScopeRef | None -> None member this.IDispatchConstantAttributeScopeRef = None @@ -1992,7 +2007,7 @@ type NetCoreSystemRuntimeTraits(primaryAssembly) = member this.MarshalByRefObjectScopeRef = None member this.ArgIteratorTypeScopeRef = None -let getSystemRuntimeInitializer (primaryAssembly: PrimaryAssembly) (mkReference : string -> AssemblyReference) : ISystemRuntimeCcuInitializer = +let getSystemRuntimeInitializer (primaryAssembly: PrimaryAssembly) (mkReference : string -> AssemblyReference) : ISystemRuntimeCcuInitializer = let name = primaryAssembly.Name let primaryAssemblyReference = mkReference name @@ -2000,11 +2015,11 @@ let getSystemRuntimeInitializer (primaryAssembly: PrimaryAssembly) (mkReference | Mscorlib -> { new ISystemRuntimeCcuInitializer with - member this.BeginLoadingSystemRuntime(resolver, noData) = + 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) = + member this.EndLoadingSystemRuntime(state, _resolver) = unbox state } @@ -2016,11 +2031,11 @@ let getSystemRuntimeInitializer (primaryAssembly: PrimaryAssembly) (mkReference let systemRuntimeInteropServicesRef = mkReference "System.Runtime.InteropServices" { new ISystemRuntimeCcuInitializer with - member this.BeginLoadingSystemRuntime(resolver, noData) = + 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) = + member this.EndLoadingSystemRuntime(state, resolver) = let (primaryAssembly : ImportedAssembly, traits : NetCoreSystemRuntimeTraits) = unbox state // finish initialization of SystemRuntimeTraits traits.FixupImportedAssemblies @@ -2068,9 +2083,9 @@ type TcConfigBuilder = mutable embedResources : string list mutable globalWarnAsError: bool mutable globalWarnLevel: int - mutable specificWarnOff: int list - mutable specificWarnOn: int list - mutable specificWarnAsError: int list + mutable specificWarnOff: int list + mutable specificWarnOn: int list + mutable specificWarnAsError: int list mutable specificWarnAsWarn : int list mutable mlCompatibility: bool mutable checkOverflow: bool @@ -2104,10 +2119,10 @@ type TcConfigBuilder = mutable delaysign : bool mutable publicsign : bool - mutable version : VersionFlag + mutable version : VersionFlag mutable metadataVersion : string option mutable standalone : bool - mutable extraStaticLinkRoots : string list + mutable extraStaticLinkRoots : string list mutable noSignatureData : bool mutable onlyEssentialOptimizationData : bool mutable useOptimizationDataFile : bool @@ -2116,17 +2131,17 @@ type TcConfigBuilder = mutable portablePDB : bool mutable embeddedPDB : bool mutable embedAllSource : bool - mutable embedSourceList : string list + mutable embedSourceList : string list mutable ignoreSymbolStoreSequencePoints : bool mutable internConstantStrings : bool mutable extraOptimizationIterations : int - mutable win32res : string + mutable win32res : string mutable win32manifest : string mutable includewin32manifest : bool mutable linkResources : string list - mutable referenceResolver: ReferenceResolver.Resolver + mutable referenceResolver: ReferenceResolver.Resolver mutable showFullPaths : bool mutable errorStyle : ErrorStyle @@ -2137,7 +2152,7 @@ type TcConfigBuilder = mutable abortOnError : bool (* intended for fsi scripts that should exit on first error *) mutable baseAddress : int32 option #if DEBUG - mutable writeGeneratedILFiles : bool (* write il files? *) + mutable writeGeneratedILFiles : bool (* write il files? *) mutable showOptimizationData : bool #endif mutable showTerms : bool (* show terms between passes? *) @@ -2146,7 +2161,7 @@ type TcConfigBuilder = mutable doTLR : bool (* run TLR pass? *) mutable doFinalSimplify : bool (* do final simplification pass *) mutable optsOn : bool (* optimizations are turned on *) - mutable optSettings : Optimizer.OptimizationSettings + mutable optSettings : Optimizer.OptimizationSettings mutable emitTailcalls : bool #if PREFERRED_UI_LANG mutable preferredUiLang: string option @@ -2154,10 +2169,10 @@ type TcConfigBuilder = mutable lcid : int option #endif mutable productNameForBannerText : string - /// show the MS (c) notice, e.g. with help or fsi? + /// show the MS (c) notice, e.g. with help or fsi? mutable showBanner : bool - - /// show times between passes? + + /// show times between passes? mutable showTimes : bool mutable showLoadedAssemblies : bool mutable continueAfterParseFailure : bool @@ -2166,7 +2181,7 @@ type TcConfigBuilder = mutable showExtensionTypeMessages : bool #endif - /// pause between passes? + /// pause between passes? mutable pause : bool /// whenever possible, emit callvirt instead of call mutable alwaysCallVirt : bool @@ -2188,7 +2203,7 @@ type TcConfigBuilder = mutable emitDebugInfoInQuotations : bool mutable exename : string option - + // If true - the compiler will copy FSharp.Core.dll along the produced binaries mutable copyFSharpCore : bool @@ -2200,14 +2215,14 @@ type TcConfigBuilder = static member CreateNew (referenceResolver,defaultFSharpBinariesDir,optimizeForMemory,implicitIncludeDir,isInteractive,isInvalidationSupported) = System.Diagnostics.Debug.Assert(FileSystem.IsPathRootedShim(implicitIncludeDir), sprintf "implicitIncludeDir should be absolute: '%s'" implicitIncludeDir) - if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then + if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then failwith "Expected a valid defaultFSharpBinariesDir" - { + { #if TODO_REWORK_ASSEMBLY_LOAD primaryAssembly = PrimaryAssembly.DotNetCore // defaut value, can be overridden using the command line switch #else primaryAssembly = PrimaryAssembly.Mscorlib // defaut value, can be overridden using the command line switch -#endif +#endif light = None noFeedback=false stackReserveSize=None @@ -2234,9 +2249,9 @@ type TcConfigBuilder = loadedSources = [] globalWarnAsError=false globalWarnLevel=3 - specificWarnOff=[] - specificWarnOn=[] - specificWarnAsError=[] + specificWarnOff=[] + specificWarnOn=[] + specificWarnAsError=[] specificWarnAsWarn=[] embedResources = [] inputCodePage=None @@ -2254,7 +2269,7 @@ type TcConfigBuilder = debuginfo = false testFlagEmitFeeFeeAs100001 = false dumpDebugInfo = false - debugSymbolFile = None + debugSymbolFile = None (* Backend configuration *) typeCheckOnly = false @@ -2308,16 +2323,16 @@ type TcConfigBuilder = flatErrors = false #if DEBUG - writeGeneratedILFiles = false (* write il files? *) + writeGeneratedILFiles = false (* write il files? *) showOptimizationData = false #endif - showTerms = false - writeTermsToFiles = false + showTerms = false + writeTermsToFiles = false - doDetuple = false - doTLR = false + doDetuple = false + doTLR = false doFinalSimplify = false - optsOn = false + optsOn = false optSettings = Optimizer.OptimizationSettings.Defaults emitTailcalls = true #if PREFERRED_UI_LANG @@ -2327,14 +2342,14 @@ type TcConfigBuilder = #endif // See bug 6071 for product banner spec productNameForBannerText = (FSComp.SR.buildProductName(FSharpEnvironment.FSharpBannerVersion)) - showBanner = true - showTimes = false + showBanner = true + showTimes = false showLoadedAssemblies = false continueAfterParseFailure = false #if EXTENSIONTYPING showExtensionTypeMessages = false #endif - pause = false + pause = false alwaysCallVirt = true noDebugData = false isInteractive = isInteractive @@ -2350,31 +2365,31 @@ type TcConfigBuilder = #endif } - member tcConfigB.ResolveSourceFile(m,nm,pathLoadedFrom) = + member tcConfigB.ResolveSourceFile(m,nm,pathLoadedFrom) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) ResolveFileUsingPaths(tcConfigB.includes @ [pathLoadedFrom],m,nm) /// Decide names of output file, pdb and assembly member tcConfigB.DecideNames sourceFiles = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) if sourceFiles = [] then errorR(Error(FSComp.SR.buildNoInputsSpecified(),rangeCmdArgs)) let ext() = match tcConfigB.target with Dll -> ".dll" | Module -> ".netmodule" | ConsoleExe | WinExe -> ".exe" let implFiles = sourceFiles |> List.filter (fun lower -> List.exists (Filename.checkSuffix (String.lowercase lower)) FSharpImplFileSuffixes) - let outfile = - match tcConfigB.outputFile, List.rev implFiles with + let outfile = + match tcConfigB.outputFile, List.rev implFiles with | None,[] -> "out" + ext() - | None, h :: _ -> + | None, h :: _ -> let basic = fileNameOfPath h let modname = try Filename.chopExtension basic with _ -> basic modname+(ext()) | Some f,_ -> f - let assemblyName = + let assemblyName = let baseName = fileNameOfPath outfile (fileNameWithoutExtension baseName) - let pdbfile = + let pdbfile = if tcConfigB.debuginfo then - Some (match tcConfigB.debugSymbolFile with + Some (match tcConfigB.debugSymbolFile with | None -> Microsoft.FSharp.Compiler.AbstractIL.ILPdbWriter.getDebugFileName outfile #if ENABLE_MONO_SUPPORT | Some _ when runningOnMono -> @@ -2382,121 +2397,121 @@ type TcConfigBuilder = warning(Error(FSComp.SR.ilwriteMDBFileNameCannotBeChangedWarning(),rangeCmdArgs)) Microsoft.FSharp.Compiler.AbstractIL.ILPdbWriter.getDebugFileName outfile #endif - | Some f -> f) + | Some f -> f) elif (tcConfigB.debugSymbolFile <> None) && (not (tcConfigB.debuginfo)) then - error(Error(FSComp.SR.buildPdbRequiresDebug(),rangeStartup)) + error(Error(FSComp.SR.buildPdbRequiresDebug(),rangeStartup)) else None tcConfigB.outputFile <- Some(outfile) outfile, pdbfile, assemblyName member tcConfigB.TurnWarningOff(m,s:string) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) - match GetWarningNumber(m,s) with + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + match GetWarningNumber(m,s) with | None -> () - | Some n -> + | Some n -> // nowarn:62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus if n = 62 then tcConfigB.mlCompatibility <- true tcConfigB.specificWarnOff <- ListSet.insert (=) n tcConfigB.specificWarnOff member tcConfigB.TurnWarningOn(m, s:string) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) - match GetWarningNumber(m,s) with + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + match GetWarningNumber(m,s) with | None -> () - | Some n -> + | Some n -> // warnon 62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus if n = 62 then tcConfigB.mlCompatibility <- false tcConfigB.specificWarnOn <- ListSet.insert (=) n tcConfigB.specificWarnOn - member tcConfigB.AddIncludePath (m,path,pathIncludedFrom) = + member tcConfigB.AddIncludePath (m,path,pathIncludedFrom) = let absolutePath = ComputeMakePathAbsolute pathIncludedFrom path - let ok = - let existsOpt = - try Some(Directory.Exists(absolutePath)) + let ok = + let existsOpt = + try Some(Directory.Exists(absolutePath)) with e -> warning(Error(FSComp.SR.buildInvalidSearchDirectory(path),m)); None - match existsOpt with - | Some(exists) -> - if not exists then warning(Error(FSComp.SR.buildSearchDirectoryNotFound(absolutePath),m)) + match existsOpt with + | Some(exists) -> + if not exists then warning(Error(FSComp.SR.buildSearchDirectoryNotFound(absolutePath),m)) exists | None -> false - if ok && not (List.contains absolutePath tcConfigB.includes) then + if ok && not (List.contains absolutePath tcConfigB.includes) then tcConfigB.includes <- tcConfigB.includes ++ absolutePath member tcConfigB.AddLoadedSource(m,path,pathLoadedFrom) = if FileSystem.IsInvalidPathShim(path) then - warning(Error(FSComp.SR.buildInvalidFilename(path),m)) - else - let path = - match TryResolveFileUsingPaths(tcConfigB.includes @ [pathLoadedFrom],m,path) with + warning(Error(FSComp.SR.buildInvalidFilename(path),m)) + else + let path = + match TryResolveFileUsingPaths(tcConfigB.includes @ [pathLoadedFrom],m,path) with | Some(path) -> path | None -> // File doesn't exist in the paths. Assume it will be in the load-ed from directory. ComputeMakePathAbsolute pathLoadedFrom path - if not (List.contains path (List.map snd tcConfigB.loadedSources)) then + if not (List.contains path (List.map snd tcConfigB.loadedSources)) then tcConfigB.loadedSources <- tcConfigB.loadedSources ++ (m,path) - member tcConfigB.AddEmbeddedSourceFile (file) = + member tcConfigB.AddEmbeddedSourceFile (file) = tcConfigB.embedSourceList <- tcConfigB.embedSourceList ++ file member tcConfigB.AddEmbeddedResource filename = tcConfigB.embedResources <- tcConfigB.embedResources ++ filename - member tcConfigB.AddReferencedAssemblyByPath (m,path) = + member tcConfigB.AddReferencedAssemblyByPath (m,path) = if FileSystem.IsInvalidPathShim(path) then warning(Error(FSComp.SR.buildInvalidAssemblyName(path),m)) elif not (tcConfigB.referencedDLLs |> List.exists (fun ar2 -> m=ar2.Range && path=ar2.Text)) then // NOTE: We keep same paths if range is different. let projectReference = tcConfigB.projectReferences |> List.tryPick (fun pr -> if pr.FileName = path then Some pr else None) tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs ++ AssemblyReference(m,path,projectReference) - + member tcConfigB.RemoveReferencedAssemblyByPath (m,path) = tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs |> List.filter (fun ar-> ar.Range <> m || ar.Text <> path) - - static member SplitCommandLineResourceInfo ri = - if String.contains ri ',' then - let p = String.index ri ',' - let file = String.sub ri 0 p - let rest = String.sub ri (p+1) (String.length ri - p - 1) - if String.contains rest ',' then - let p = String.index rest ',' - let name = String.sub rest 0 p+".resources" - let pubpri = String.sub rest (p+1) (rest.Length - p - 1) - if pubpri = "public" then file,name,ILResourceAccess.Public + + static member SplitCommandLineResourceInfo ri = + if String.contains ri ',' then + let p = String.index ri ',' + let file = String.sub ri 0 p + let rest = String.sub ri (p+1) (String.length ri - p - 1) + if String.contains rest ',' then + let p = String.index rest ',' + let name = String.sub rest 0 p+".resources" + let pubpri = String.sub rest (p+1) (rest.Length - p - 1) + if pubpri = "public" then file,name,ILResourceAccess.Public elif pubpri = "private" then file,name,ILResourceAccess.Private else error(Error(FSComp.SR.buildInvalidPrivacy(pubpri),rangeStartup)) - else + else file,rest,ILResourceAccess.Public - else - ri,fileNameOfPath ri,ILResourceAccess.Public + else + ri,fileNameOfPath ri,ILResourceAccess.Public #if SHADOW_COPY_REFERENCES -let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, pdbPathOption, primaryAssemblyName, noDebugData, shadowCopyReferences) = +let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, pdbPathOption, primaryAssemblyName, noDebugData, shadowCopyReferences) = #else -let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, pdbPathOption, primaryAssemblyName, noDebugData) = +let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, pdbPathOption, primaryAssemblyName, noDebugData) = #endif - let ilGlobals = + 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 + match ilGlobalsOpt with | None -> mkILGlobals (IL.mkMscorlibBasedTraits ILScopeRef.Local) (Some primaryAssemblyName) noDebugData | Some ilGlobals -> ilGlobals - let opts = { ILBinaryReader.mkDefault ilGlobals with + 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 ILBinaryReader.optimizeForMemory=optimizeForMemory - ILBinaryReader.pdbPath = pdbPathOption } - + ILBinaryReader.pdbPath = pdbPathOption } + // Visual Studio uses OpenILModuleReaderAfterReadingAllBytes for all DLLs to avoid having to dispose of any readers explicitly - if openBinariesInMemory // && not syslib + if openBinariesInMemory // && not syslib then ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes filename opts else let location = #if SHADOW_COPY_REFERENCES // In order to use memory mapped files on the shadow copied version of the Assembly, we `preload the assembly // We swallow all exceptions so that we do not change the exception contract of this API - if shadowCopyReferences then + if shadowCopyReferences then try System.Reflection.Assembly.ReflectionOnlyLoadFrom(filename).Location with e -> filename @@ -2508,32 +2523,32 @@ let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, p #if DEBUG [] #endif -type AssemblyResolution = +type AssemblyResolution = { originalReference : AssemblyReference - resolvedPath : string + resolvedPath : string prepareToolTip : unit -> string - sysdir : bool + sysdir : bool ilAssemblyRef : ILAssemblyRef option ref } member this.ProjectReference = this.originalReference.ProjectReference - member this.ILAssemblyRef = - match !this.ilAssemblyRef with + member this.ILAssemblyRef = + match !this.ilAssemblyRef with | Some(assref) -> assref | None -> - let assRefOpt = - match this.ProjectReference with - | Some r -> - match r.EvaluateRawContents() with + let assRefOpt = + match this.ProjectReference with + | Some r -> + match r.EvaluateRawContents() with | None -> None - | Some contents -> - match contents.ILScopeRef with + | Some contents -> + match contents.ILScopeRef with | ILScopeRef.Assembly aref -> Some aref | _ -> None | None -> None - let assRef = - match assRefOpt with + let assRef = + match assRefOpt with | Some aref -> aref - | None -> + | None -> let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaILGlobals;optimizeForMemory=false} // ?? use reader = ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes this.resolvedPath readerSettings mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly @@ -2544,28 +2559,28 @@ type AssemblyResolution = // Names to match up refs and defs for assemblies and modules //-------------------------------------------------------------------------- -let GetNameOfILModule (m: ILModuleDef) = - match m.Manifest with +let GetNameOfILModule (m: ILModuleDef) = + match m.Manifest with | Some manifest -> manifest.Name | None -> m.Name -let MakeScopeRefForIlModule (ilModule: ILModuleDef) = - match ilModule.Manifest with +let MakeScopeRefForIlModule (ilModule: ILModuleDef) = + match ilModule.Manifest with | Some m -> ILScopeRef.Assembly (mkRefToILAssembly m) | None -> ILScopeRef.Module (mkRefToILModule ilModule) -let GetCustomAttributesOfIlModule (ilModule:ILModuleDef) = - (match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList +let GetCustomAttributesOfIlModule (ilModule:ILModuleDef) = + (match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList -let GetAutoOpenAttributes ilg ilModule = +let GetAutoOpenAttributes ilg ilModule = ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindAutoOpenAttr ilg) -let GetInternalsVisibleToAttributes ilg ilModule = +let GetInternalsVisibleToAttributes ilg ilModule = ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindInternalsVisibleToAttr ilg) - + //---------------------------------------------------------------------------- -// TcConfig +// TcConfig //-------------------------------------------------------------------------- [] @@ -2574,35 +2589,35 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // Validate the inputs - this helps ensure errors in options are shown in visual studio rather than only when built // However we only validate a minimal number of options at the moment - do if validate then try data.version.GetVersionInfo(data.implicitIncludeDir) |> ignore with e -> errorR(e) + do if validate then try data.version.GetVersionInfo(data.implicitIncludeDir) |> ignore with e -> errorR(e) // clone the input builder to ensure nobody messes with it. let data = { data with pause = data.pause } - let computeKnownDllReference(libraryName) = + let computeKnownDllReference(libraryName) = let defaultCoreLibraryReference = AssemblyReference(range0,libraryName+".dll",None) - let nameOfDll(r:AssemblyReference) = + let nameOfDll(r:AssemblyReference) = let filename = ComputeMakePathAbsolute data.implicitIncludeDir r.Text - if FileSystem.SafeExists(filename) then + if FileSystem.SafeExists(filename) then r,Some(filename) - else + else // If the file doesn't exist, let reference resolution logic report the error later... defaultCoreLibraryReference, if r.Range =rangeStartup then Some(filename) else None match data.referencedDLLs |> List.filter (fun assemblyReference -> assemblyReference.SimpleAssemblyNameIs libraryName) with | [r] -> nameOfDll r - | [] -> + | [] -> defaultCoreLibraryReference, None - | r:: _ -> + | r:: _ -> // Recover by picking the first one. - errorR(Error(FSComp.SR.buildMultipleReferencesNotAllowed(libraryName),rangeCmdArgs)) + errorR(Error(FSComp.SR.buildMultipleReferencesNotAllowed(libraryName),rangeCmdArgs)) nameOfDll(r) // Look for an explicit reference to mscorlib and use that to compute clrRoot and targetFrameworkVersion let primaryAssemblyReference, primaryAssemblyExplicitFilenameOpt = computeKnownDllReference(data.primaryAssembly.Name) - let fslibReference,fslibExplicitFilenameOpt = + let fslibReference,fslibExplicitFilenameOpt = let (_, fileNameOpt) as res = computeKnownDllReference(GetFSharpCoreLibraryName()) match fileNameOpt with - | None -> + | None -> // if FSharp.Core was not provided explicitly - use version that was referenced by compiler AssemblyReference(range0, GetFSharpCoreReferenceUsedByCompiler(data.useSimpleResolution), None), None | _ -> res @@ -2614,25 +2629,25 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = do if ((primaryAssemblyExplicitFilenameOpt.IsSome || fslibExplicitFilenameOpt.IsSome) && data.framework) then error(Error(FSComp.SR.buildExplicitCoreLibRequiresNoFramework("--noframework"),rangeStartup)) - let clrRootValue, (mscorlibMajorVersion,targetFrameworkVersionValue), primaryAssemblyIsSilverlight = + let clrRootValue, (mscorlibMajorVersion,targetFrameworkVersionValue), primaryAssemblyIsSilverlight = match primaryAssemblyExplicitFilenameOpt with | Some(primaryAssemblyFilename) -> let filename = ComputeMakePathAbsolute data.implicitIncludeDir primaryAssemblyFilename - try + try #if SHADOW_COPY_REFERENCES use ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None, data.primaryAssembly.Name, data.noDebugData, data.shadowCopyReferences) #else use ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None, data.primaryAssembly.Name, data.noDebugData) #endif let ilModule = ilReader.ILModuleDef - match ilModule.ManifestOfAssembly.Version with - | Some(v1,v2,v3,_) -> - if v1 = 1us then + match ilModule.ManifestOfAssembly.Version with + | Some(v1,v2,v3,_) -> + if v1 = 1us then warning(Error(FSComp.SR.buildRequiresCLI2(filename),rangeStartup)) let clrRoot = Some(Path.GetDirectoryName(FileSystem.GetFullPathShim(filename))) clrRoot, (int v1, sprintf "v%d.%d" v1 v2), (v1=5us && v2=0us && v3=5us) // SL5 mscorlib is 5.0.5.0 - | _ -> + | _ -> failwith (FSComp.SR.buildCouldNotReadVersionInfoFromMscorlib()) with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message), rangeStartup)) @@ -2648,26 +2663,26 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // 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, // so here we minimally validate if .Net version >= 4 or not. - do if data.prefer32Bit && mscorlibMajorVersion < 4 then - error(Error(FSComp.SR.invalidPlatformTargetForOldFramework(),rangeCmdArgs)) - + do if data.prefer32Bit && mscorlibMajorVersion < 4 then + error(Error(FSComp.SR.invalidPlatformTargetForOldFramework(),rangeCmdArgs)) + let systemAssemblies = SystemAssemblies data.primaryAssembly.Name - // Check that the referenced version of FSharp.Core.dll matches the referenced version of mscorlib.dll - let checkFSharpBinaryCompatWithMscorlib filename (ilAssemblyRefs: ILAssemblyRef list) explicitFscoreVersionToCheckOpt m = + // 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.primaryAssembly.Name) 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) <> (mscorlibMajorVersion < 4)) then // the versions mismatch, however they are allowed to mismatch in one case: if primaryAssemblyIsSilverlight && mscorlibMajorVersion=5 // SL5 - && (match explicitFscoreVersionToCheckOpt with - | Some(2us,3us,5us,_) // silverlight is supported for FSharp.Core 2.3.5.x and 3.47.x.y - | Some(3us,47us,_,_) + && (match explicitFscoreVersionToCheckOpt with + | Some(2us,3us,5us,_) // silverlight is supported for FSharp.Core 2.3.5.x and 3.47.x.y + | Some(3us,47us,_,_) | None -> true // the 'None' code path happens after explicit FSCore was already checked, from now on SL5 path is always excepted - | _ -> false) + | _ -> false) then () else @@ -2682,11 +2697,11 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = | _ -> () // Look for an explicit reference to FSharp.Core and use that to compute fsharpBinariesDir - let fsharpBinariesDirValue = + let fsharpBinariesDirValue = match fslibExplicitFilenameOpt with | Some(fslibFilename) -> let filename = ComputeMakePathAbsolute data.implicitIncludeDir fslibFilename - try + try #if SHADOW_COPY_REFERENCES use ilReader = OpenILBinary(filename,data.optimizeForMemory,data.openBinariesInMemory,None,None, data.primaryAssembly.Name, data.noDebugData, data.shadowCopyReferences) #else @@ -2695,7 +2710,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = checkFSharpBinaryCompatWithMscorlib filename ilReader.ILAssemblyRefs ilReader.ILModuleDef.ManifestOfAssembly.Version rangeStartup; let fslibRoot = Path.GetDirectoryName(FileSystem.GetFullPathShim(filename)) fslibRoot (* , sprintf "v%d.%d" v1 v2 *) - with e -> + with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message), rangeStartup)) | _ -> data.defaultFSharpBinariesDir @@ -2816,7 +2831,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = member x.showLoadedAssemblies = data.showLoadedAssemblies member x.continueAfterParseFailure = data.continueAfterParseFailure #if EXTENSIONTYPING - member x.showExtensionTypeMessages = data.showExtensionTypeMessages + member x.showExtensionTypeMessages = data.showExtensionTypeMessages #endif member x.pause = data.pause member x.alwaysCallVirt = data.alwaysCallVirt @@ -2831,27 +2846,27 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = #if SHADOW_COPY_REFERENCES member x.shadowCopyReferences = data.shadowCopyReferences #endif - static member Create(builder,validate) = + static member Create(builder,validate) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) TcConfig(builder,validate) member x.referenceResolver = data.referenceResolver - member tcConfig.CloneOfOriginalBuilder = + member tcConfig.CloneOfOriginalBuilder = { data with conditionalCompilationDefines=data.conditionalCompilationDefines } - member tcConfig.ComputeCanContainEntryPoint(sourceFiles:string list) = - let n = sourceFiles.Length in + member tcConfig.ComputeCanContainEntryPoint(sourceFiles:string list) = + let n = sourceFiles.Length in (sourceFiles |> List.mapi (fun i _ -> (i = n-1)), tcConfig.target.IsExe) - + // This call can fail if no CLR is found (this is the path to mscorlib) - member tcConfig.TargetFrameworkDirectories = + member tcConfig.TargetFrameworkDirectories = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) - match tcConfig.clrRoot with - | Some x -> + match tcConfig.clrRoot with + | Some x -> [tcConfig.MakePathAbsolute x] - | None -> + | None -> #if ENABLE_MONO_SUPPORT - if runningOnMono then + if runningOnMono then [ let runtimeRoot = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() let runtimeRootWithoutSlash = runtimeRoot.TrimEnd('/', '\\') let api = runtimeRootWithoutSlash + "-api" @@ -2865,27 +2880,27 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = if Directory.Exists(facades) then yield facades ] - else + else #endif - try - [ + try + [ match tcConfig.resolutionEnvironment with #if FX_MSBUILDRESOLVER_RUNTIMELIKE | ReferenceResolver.RuntimeLike -> - yield System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + yield System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() #endif - | _ -> + | _ -> let frameworkRoot = tcConfig.referenceResolver.DotNetFrameworkReferenceAssembliesRootDirectory let frameworkRootVersion = Path.Combine(frameworkRoot,tcConfig.targetFrameworkVersion) yield frameworkRootVersion let facades = Path.Combine(frameworkRootVersion, "Facades") if Directory.Exists(facades) then yield facades - ] - with e -> - errorRecovery e range0; [] + ] + with e -> + errorRecovery e range0; [] - member tcConfig.ComputeLightSyntaxInitialStatus filename = + member tcConfig.ComputeLightSyntaxInitialStatus filename = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) let lower = String.lowercase filename let lightOnByDefault = List.exists (Filename.checkSuffix lower) FSharpLightSyntaxFileSuffixes @@ -2895,17 +2910,17 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) let resolveLoadedSource (m,path) = try - if not(FileSystem.SafeExists(path)) then - error(LoadedSourceNotFoundIgnoring(path,m)) + if not(FileSystem.SafeExists(path)) then + error(LoadedSourceNotFoundIgnoring(path,m)) None else Some(m,path) with e -> errorRecovery e m; None - tcConfig.loadedSources - |> List.choose resolveLoadedSource - |> List.distinct + tcConfig.loadedSources + |> List.choose resolveLoadedSource + |> List.distinct /// A closed set of assemblies where, for any subset S: - /// - the TcImports object built for S (and thus the F# Compiler CCUs for the assemblies in S) + /// - the TcImports object built for S (and thus the F# Compiler CCUs for the assemblies in S) /// is a resource that can be shared between any two IncrementalBuild objects that reference /// precisely S /// @@ -2913,41 +2928,41 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = /// /// Returning true may mean that the file is locked and/or placed into the /// 'framework' reference set that is potentially shared across multiple compilations. - member tcConfig.IsSystemAssembly (filename:string) = - try - FileSystem.SafeExists filename && + member tcConfig.IsSystemAssembly (filename:string) = + try + FileSystem.SafeExists filename && ((tcConfig.TargetFrameworkDirectories |> List.exists (fun clrRoot -> clrRoot = Path.GetDirectoryName filename)) || (systemAssemblies |> List.exists (fun sysFile -> sysFile = fileNameWithoutExtension filename))) with _ -> - false + false - // This is not the complete set of search paths, it is just the set + // This is not the complete set of search paths, it is just the set // that is special to F# (as compared to MSBuild resolution) - member tcConfig.SearchPathsForLibraryFiles = - [ yield! tcConfig.TargetFrameworkDirectories + member tcConfig.SearchPathsForLibraryFiles = + [ yield! tcConfig.TargetFrameworkDirectories yield! List.map (tcConfig.MakePathAbsolute) tcConfig.includes - yield tcConfig.implicitIncludeDir + yield tcConfig.implicitIncludeDir yield tcConfig.fsharpBinariesDir ] - member tcConfig.MakePathAbsolute path = + member tcConfig.MakePathAbsolute path = let result = ComputeMakePathAbsolute tcConfig.implicitIncludeDir path result - member tcConfig.TryResolveLibWithDirectories (r:AssemblyReference) = + member tcConfig.TryResolveLibWithDirectories (r:AssemblyReference) = let m,nm = r.Range, r.Text use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) // Only want to resolve certain extensions (otherwise, 'System.Xml' is ambiguous). // MSBuild resolution is limitted to .exe and .dll so do the same here. let ext = System.IO.Path.GetExtension(nm) - let isNetModule = String.Compare(ext,".netmodule",StringComparison.OrdinalIgnoreCase)=0 - - let unknownToolTip (resolvedPath,resolved) = + let isNetModule = String.Compare(ext,".netmodule",StringComparison.OrdinalIgnoreCase)=0 + + let unknownToolTip (resolvedPath,resolved) = let line(append:string) = append.Trim([|' '|])+"\n" line(resolvedPath) + line(resolved) // See if the language service has already produced the contents of the assembly for us, virtually - match r.ProjectReference with - | Some _ -> + match r.ProjectReference with + | Some _ -> let resolved = r.Text let sysdir = tcConfig.IsSystemAssembly resolved Some @@ -2956,10 +2971,10 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = prepareToolTip = (fun () -> resolved) sysdir = sysdir ilAssemblyRef = ref None } - | None -> + | None -> - if String.Compare(ext,".dll",StringComparison.OrdinalIgnoreCase)=0 - || String.Compare(ext,".exe",StringComparison.OrdinalIgnoreCase)=0 + if String.Compare(ext,".dll",StringComparison.OrdinalIgnoreCase)=0 + || String.Compare(ext,".exe",StringComparison.OrdinalIgnoreCase)=0 || isNetModule then let searchPaths = @@ -2969,16 +2984,16 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // place that is checked. if m <> range0 && m <> rangeStartup && m <> rangeCmdArgs && FileSystem.IsPathRootedShim m.FileName then tcConfig.SearchPathsForLibraryFiles @ [Path.GetDirectoryName(m.FileName)] - else + else tcConfig.SearchPathsForLibraryFiles let resolved = TryResolveFileUsingPaths(searchPaths,m,nm) - match resolved with - | Some(resolved) -> + match resolved with + | Some(resolved) -> let sysdir = tcConfig.IsSystemAssembly resolved - let fusionName = + let fusionName = if isNetModule then "" - else + else try let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaILGlobals;optimizeForMemory=false} use reader = ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes resolved readerSettings @@ -3004,7 +3019,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = let isDLL = (String.Compare(ext,".dll",StringComparison.OrdinalIgnoreCase) = 0) let isNetModule = (String.Compare(ext,".netmodule",StringComparison.OrdinalIgnoreCase) = 0) - let rs = + let rs = if isExe || isDLL || isNetModule then [r] else @@ -3019,10 +3034,10 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = raise (FileNameNotResolved(nm,searchMessage,m)) | CcuLoadFailureAction.ReturnNone -> None - member tcConfig.ResolveSourceFile(m,nm,pathLoadedFrom) = + member tcConfig.ResolveSourceFile(m,nm,pathLoadedFrom) = data.ResolveSourceFile(m,nm,pathLoadedFrom) - member tcConfig.CheckFSharpBinary (filename,ilAssemblyRefs,m) = + member tcConfig.CheckFSharpBinary (filename,ilAssemblyRefs,m) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) checkFSharpBinaryCompatWithMscorlib filename ilAssemblyRefs None m @@ -3035,10 +3050,10 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = if tcConfig.useSimpleResolution then failwith "MSBuild resolution is not supported." if originalReferences=[] then [],[] - else + else // Group references by name with range values in the grouped value list. // In the grouped reference, store the index of the last use of the reference. - let groupedReferences = + let groupedReferences = originalReferences |> List.mapi (fun index reference -> (index, reference)) |> Seq.groupBy(fun (_, reference) -> reference.Text) @@ -3049,30 +3064,30 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = assemblyName, highestPosition, assemblyGroup) |> Array.ofSeq - let logMessage showMessages = + let logMessage showMessages = if showMessages && tcConfig.showReferenceResolutions then (fun (message:string)->dprintf "%s\n" message) else ignore - let logErrorOrWarning showMessages = + let logErrorOrWarning showMessages = (fun isError code message-> - if showMessages && mode = ReportErrors then + if showMessages && mode = ReportErrors then if isError then errorR(MSBuildReferenceResolutionError(code,message,errorAndWarningRange)) else - match code with + match code with // These are warnings that mean 'not resolved' for some assembly. // Note that we don't get to know the name of the assembly that couldn't be resolved. // Ignore these and rely on the logic below to emit an error for each unresolved reference. | "MSB3246" // Resolved file has a bad image, no metadata, or is otherwise inaccessible. - | "MSB3106" + | "MSB3106" -> () - | _ -> - if code = "MSB3245" then + | _ -> + if code = "MSB3245" then errorR(MSBuildReferenceResolutionWarning(code,message,errorAndWarningRange)) else warning(MSBuildReferenceResolutionWarning(code,message,errorAndWarningRange))) - let targetProcessorArchitecture = + let targetProcessorArchitecture = match tcConfig.platform with | None -> "MSIL" | Some(X86) -> "x86" @@ -3080,49 +3095,49 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = | Some(IA64) -> "ia64" // First, try to resolve everything as a file using simple resolution - let resolvedAsFile = - groupedReferences + let resolvedAsFile = + groupedReferences |>Array.map(fun (_filename,maxIndexOfReference,references)-> let assemblyResolution = references |> List.choose tcConfig.TryResolveLibWithDirectories - (maxIndexOfReference, assemblyResolution)) + (maxIndexOfReference, assemblyResolution)) |> Array.filter(fun (_,refs)->refs|>List.isEmpty|>not) - - + + // Whatever is left, pass to MSBuild. - let Resolve(references,showMessages) = - try + let Resolve(references,showMessages) = + try tcConfig.referenceResolver.Resolve (tcConfig.resolutionEnvironment, references, tcConfig.targetFrameworkVersion, - tcConfig.TargetFrameworkDirectories, - targetProcessorArchitecture, + tcConfig.TargetFrameworkDirectories, + targetProcessorArchitecture, tcConfig.fsharpBinariesDir, // FSharp binaries directory tcConfig.includes, // Explicit include directories tcConfig.implicitIncludeDir, // Implicit include directory (likely the project directory) logMessage showMessages, logErrorOrWarning showMessages) - with + with ReferenceResolver.ResolutionFailure -> error(Error(FSComp.SR.buildAssemblyResolutionFailed(),errorAndWarningRange)) - - let toMsBuild = [|0..groupedReferences.Length-1|] - |> Array.map(fun i->(p13 groupedReferences.[i]),(p23 groupedReferences.[i]),i) + + let toMsBuild = [|0..groupedReferences.Length-1|] + |> Array.map(fun i->(p13 groupedReferences.[i]),(p23 groupedReferences.[i]),i) |> Array.filter (fun (_,i0,_)->resolvedAsFile|>Array.exists(fun (i1,_) -> i0=i1)|>not) |> Array.map(fun (ref,_,i)->ref,string i) - let resolutions = Resolve(toMsBuild,(*showMessages*)true) + let resolutions = Resolve(toMsBuild,(*showMessages*)true) // Map back to original assembly resolutions. - let resolvedByMsbuild = + let resolvedByMsbuild = resolutions - |> Array.map(fun resolvedFile -> + |> Array.map(fun resolvedFile -> let i = int resolvedFile.baggage let _,maxIndexOfReference,ms = groupedReferences.[i] let assemblyResolutions = ms|>List.map(fun originalReference -> System.Diagnostics.Debug.Assert(FileSystem.IsPathRootedShim(resolvedFile.itemSpec), sprintf "msbuild-resolved path is not absolute: '%s'" resolvedFile.itemSpec) let canonicalItemSpec = FileSystem.GetFullPathShim(resolvedFile.itemSpec) - {originalReference=originalReference - resolvedPath=canonicalItemSpec + {originalReference=originalReference + resolvedPath=canonicalItemSpec prepareToolTip = (fun () -> resolvedFile.prepareToolTip (originalReference.Text, canonicalItemSpec)) sysdir= tcConfig.IsSystemAssembly canonicalItemSpec ilAssemblyRef = ref None}) @@ -3132,40 +3147,41 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // in the original specification and resort it to match the ordering that we had. let resultingResolutions = [resolvedByMsbuild;resolvedAsFile] - |> Array.concat + |> Array.concat |> Array.sortBy fst |> Array.map snd - |> List.ofArray - |> List.concat - + |> List.ofArray + |> List.concat + // O(N^2) here over a small set of referenced assemblies. let IsResolved(originalName:string) = if resultingResolutions |> List.exists(fun resolution -> resolution.originalReference.Text = originalName) then true - else + else // MSBuild resolution may have unified the result of two duplicate references. Try to re-resolve now. // If re-resolution worked then this was a removed duplicate. - Resolve([|originalName,""|],(*showMessages*)false).Length<>0 - - let unresolvedReferences = - groupedReferences + Resolve([|originalName,""|],(*showMessages*)false).Length<>0 + + let unresolvedReferences = + groupedReferences //|> Array.filter(p13 >> IsNotFileOrIsAssembly) - |> Array.filter(p13 >> IsResolved >> not) - |> List.ofArray + |> Array.filter(p13 >> IsResolved >> not) + |> List.ofArray // If mode=Speculative, then we haven't reported any errors. // We report the error condition by returning an empty list of resolutions - if mode = Speculative && (List.length unresolvedReferences) > 0 then + if mode = Speculative && (List.length unresolvedReferences) > 0 then [],(List.ofArray groupedReferences) |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference - else - resultingResolutions,unresolvedReferences |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference + else + resultingResolutions,unresolvedReferences |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference member tcConfig.PrimaryAssemblyDllReference() = primaryAssemblyReference member tcConfig.GetPrimaryAssemblyCcuInitializer() = primaryAssemblyCcuInitializer member tcConfig.CoreLibraryDllReference() = fslibReference - -let ReportWarning (globalWarnLevel : int, specificWarnOff : int list, specificWarnOn : int list) err = +#endif //!FABLE_COMPILER + +let ReportWarning (globalWarnLevel : int, specificWarnOff : int list, specificWarnOn : int list) err = let n = GetErrorNumber err warningOn err globalWarnLevel specificWarnOn && not (List.contains n specificWarnOff) @@ -3179,19 +3195,19 @@ let ReportWarningAsError (globalWarnLevel : int, specificWarnOff : int list, spe // Scoped #nowarn pragmas -let GetScopedPragmasForHashDirective hd = - [ match hd with +let GetScopedPragmasForHashDirective hd = + [ match hd with | ParsedHashDirective("nowarn",numbers,m) -> for s in numbers do - match GetWarningNumber(m,s) with + match GetWarningNumber(m,s) with | None -> () - | Some n -> yield ScopedPragma.WarningOff(m,n) + | Some n -> yield ScopedPragma.WarningOff(m,n) | _ -> () ] -let GetScopedPragmasForInput input = +let GetScopedPragmasForInput input = - match input with + match input with | ParsedInput.SigFile (ParsedSigFileInput(_,_,pragmas,_,_)) -> pragmas | ParsedInput.ImplFile (ParsedImplFileInput(_,_,_,pragmas,_,_,_)) ->pragmas @@ -3199,10 +3215,10 @@ let GetScopedPragmasForInput input = /// Build an ErrorLogger that delegates to another ErrorLogger but filters warnings turned off by the given pragma declarations // -// NOTE: we allow a flag to turn of strict file checking. This is because file names sometimes don't match due to use of +// NOTE: we allow a flag to turn of strict file checking. This is because file names sometimes don't match due to use of // #line directives, e.g. for pars.fs/pars.fsy. In this case we just test by line number - in most cases this is sufficent // because we install a filtering error handler on a file-by-file basis for parsing and type-checking. -// However this is indicative of a more systematic problem where source-line +// However this is indicative of a more systematic problem where source-line // sensitive operations (lexfilter and warning filtering) do not always // interact well with #line directives. type ErrorLoggerFilteringByScopedPragmas (checkFile,scopedPragmas,errorLogger:ErrorLogger) = @@ -3211,23 +3227,23 @@ type ErrorLoggerFilteringByScopedPragmas (checkFile,scopedPragmas,errorLogger:Er member x.ScopedPragmas with set v = scopedPragmas <- v override x.ErrorSinkImpl err = errorLogger.ErrorSink err override x.ErrorCount = errorLogger.ErrorCount - override x.WarnSinkImpl err = - let report = + override x.WarnSinkImpl err = + let report = let warningNum = GetErrorNumber err - match GetRangeOfError err with - | Some m -> + match GetRangeOfError err with + | Some m -> not (scopedPragmas |> List.exists (fun pragma -> - match pragma with - | ScopedPragma.WarningOff(pragmaRange,warningNumFromPragma) -> - warningNum = warningNumFromPragma && + match pragma with + | ScopedPragma.WarningOff(pragmaRange,warningNumFromPragma) -> + warningNum = warningNumFromPragma && (not checkFile || m.FileIndex = pragmaRange.FileIndex) && - Range.posGeq m.Start pragmaRange.Start)) + Range.posGeq m.Start pragmaRange.Start)) | None -> true if report then errorLogger.WarnSink(err) override x.ErrorNumbers = errorLogger.ErrorNumbers override x.WarningNumbers = errorLogger.WarningNumbers -let GetErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) = +let GetErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) = (ErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) :> ErrorLogger) /// Build an ErrorLogger that delegates to another ErrorLogger but filters warnings turned off by the given pragma declarations @@ -3237,7 +3253,7 @@ type DelayedErrorLogger(errorLogger:ErrorLogger) = override x.ErrorSinkImpl err = delayed.Add (err,true) override x.ErrorCount = delayed |> Seq.filter snd |> Seq.length override x.WarnSinkImpl err = delayed.Add(err,false) - member x.CommitDelayedErrorsAndWarnings() = + member x.CommitDelayedErrorsAndWarnings() = // Eagerly grab all the errors and warnings from the mutable collection let errors = delayed |> Seq.toList // Now report them @@ -3250,14 +3266,14 @@ type DelayedErrorLogger(errorLogger:ErrorLogger) = //-------------------------------------------------------------------------- -let CanonicalizeFilename filename = +let CanonicalizeFilename filename = let basic = fileNameOfPath filename String.capitalize (try Filename.chopExtension basic with _ -> basic) -let IsScript filename = - let lower = String.lowercase filename +let IsScript filename = + let lower = String.lowercase filename FSharpScriptFileSuffixes |> List.exists (Filename.checkSuffix lower) - + // Give a unique name to the different kinds of inputs. Used to correlate signature and implementation files // QualFileNameOfModuleName - files with a single module declaration or an anonymous module let QualFileNameOfModuleName m filename modname = QualifiedNameOfFile(mkSynId m (textOfLid modname + (if IsScript filename then "$fsx" else ""))) @@ -3266,13 +3282,13 @@ let QualFileNameOfFilename m filename = QualifiedNameOfFile(mkSynId m (Canonical // Interactive fragments let ComputeQualifiedNameOfFileFromUniquePath (m, p: string list) = QualifiedNameOfFile(mkSynId m (String.concat "_" p)) -let QualFileNameOfSpecs filename specs = - match specs with +let QualFileNameOfSpecs filename specs = + match specs with | [SynModuleOrNamespaceSig(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname | _ -> QualFileNameOfFilename (rangeN filename 1) filename -let QualFileNameOfImpls filename specs = - match specs with +let QualFileNameOfImpls filename specs = + match specs with | [SynModuleOrNamespace(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname | _ -> QualFileNameOfFilename (rangeN filename 1) filename @@ -3280,18 +3296,18 @@ let PrepandPathToQualFileName x (QualifiedNameOfFile(q)) = ComputeQualifiedNameO let PrepandPathToImpl x (SynModuleOrNamespace(p,b,c,d,e,f,g,h)) = SynModuleOrNamespace(x@p,b,c,d,e,f,g,h) let PrepandPathToSpec x (SynModuleOrNamespaceSig(p,b,c,d,e,f,g,h)) = SynModuleOrNamespaceSig(x@p,b,c,d,e,f,g,h) -let PrependPathToInput x inp = - match inp with +let PrependPathToInput x inp = + match inp with | ParsedInput.ImplFile (ParsedImplFileInput(b,c,q,d,hd,impls,e)) -> ParsedInput.ImplFile (ParsedImplFileInput(b,c,PrepandPathToQualFileName x q,d,hd,List.map (PrepandPathToImpl x) impls,e)) | ParsedInput.SigFile (ParsedSigFileInput(b,q,d,hd,specs)) -> ParsedInput.SigFile(ParsedSigFileInput(b,PrepandPathToQualFileName x q,d,hd,List.map (PrepandPathToSpec x) specs)) -let ComputeAnonModuleName check defaultNamespace filename (m: range) = +let ComputeAnonModuleName check defaultNamespace filename (m: range) = let modname = CanonicalizeFilename filename if check && not (modname |> String.forall (fun c -> System.Char.IsLetterOrDigit(c) || c = '_')) then if not (filename.EndsWith("fsx",StringComparison.OrdinalIgnoreCase) || filename.EndsWith("fsscript",StringComparison.OrdinalIgnoreCase)) then warning(Error(FSComp.SR.buildImplicitModuleIsNotLegalIdentifier(modname,(fileNameOfPath filename)),m)) - let combined = - match defaultNamespace with + let combined = + match defaultNamespace with | None -> modname | Some ns -> textOfPath [ns;modname] @@ -3300,18 +3316,18 @@ let ComputeAnonModuleName check defaultNamespace filename (m: range) = mkRange filename pos0 pos0 pathToSynLid anonymousModuleNameRange (splitNamespace combined) -let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) = - match impl with - | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> - let lid = - match lid with +let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) = + match impl with + | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> + let lid = + match lid with | [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m) - | ParsedImplFileFragment.AnonModule (defs,m)-> - let isLast, isExe = isLastCompiland + | ParsedImplFileFragment.AnonModule (defs,m)-> + let isLast, isExe = isLastCompiland let lower = String.lowercase filename if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix lower)) then match defs with @@ -3321,27 +3337,27 @@ let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) = let modname = ComputeAnonModuleName (not (List.isEmpty defs)) defaultNamespace filename (trimRangeToLine m) SynModuleOrNamespace(modname,false,true,defs,PreXmlDoc.Empty,[],None,m) - | ParsedImplFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> - let lid = - match lid with + | ParsedImplFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> + let lid = + match lid with | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid SynModuleOrNamespace(lid,a,b,c,d,e,None,m) -let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) = - match intf with - | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> - let lid = - match lid with +let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) = + match intf with + | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> + let lid = + match lid with | [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m) - | ParsedSigFileFragment.AnonModule (defs,m) -> + | ParsedSigFileFragment.AnonModule (defs,m) -> let isLast, isExe = isLastCompiland let lower = String.lowercase filename - if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix lower)) then + if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix lower)) then match defs with | SynModuleSigDecl.NestedModule(_) :: _ -> errorR(Error(FSComp.SR.noEqualSignAfterModule(),m)) | _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),m)) @@ -3349,81 +3365,81 @@ let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) = let modname = ComputeAnonModuleName (not (List.isEmpty defs)) defaultNamespace filename (trimRangeToLine m) SynModuleOrNamespaceSig(modname,false,true,defs,PreXmlDoc.Empty,[],None,m) - | ParsedSigFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> - let lid = - match lid with + | ParsedSigFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> + let lid = + match lid with | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid SynModuleOrNamespaceSig(lid,a,b,c,d,e,None,m) -let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFile(hashDirectives,impls)) = +let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFile(hashDirectives,impls)) = match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with - | Some lid when impls.Length > 1 -> + | Some lid when impls.Length > 1 -> errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid)) - | _ -> + | _ -> () - let impls = impls |> List.mapi (fun i x -> PostParseModuleImpl (i, defaultNamespace, isLastCompiland, filename, x)) + let impls = impls |> List.mapi (fun i x -> PostParseModuleImpl (i, defaultNamespace, isLastCompiland, filename, x)) let qualName = QualFileNameOfImpls filename impls let isScript = IsScript filename - let scopedPragmas = - [ for (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) in impls do + let scopedPragmas = + [ for (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) in impls do for d in decls do - match d with + match d with | SynModuleDecl.HashDirective (hd,_) -> yield! GetScopedPragmasForHashDirective hd - | _ -> () - for hd in hashDirectives do + | _ -> () + for hd in hashDirectives do yield! GetScopedPragmasForHashDirective hd ] ParsedInput.ImplFile(ParsedImplFileInput(filename,isScript,qualName,scopedPragmas,hashDirectives,impls,isLastCompiland)) - -let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFile(hashDirectives,specs)) = + +let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFile(hashDirectives,specs)) = match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with - | Some lid when specs.Length > 1 -> + | Some lid when specs.Length > 1 -> errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid)) - | _ -> + | _ -> () - - let specs = specs |> List.mapi (fun i x -> PostParseModuleSpec(i,defaultNamespace,isLastCompiland,filename,x)) + + let specs = specs |> List.mapi (fun i x -> PostParseModuleSpec(i,defaultNamespace,isLastCompiland,filename,x)) let qualName = QualFileNameOfSpecs filename specs - let scopedPragmas = - [ for (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) in specs do + let scopedPragmas = + [ for (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) in specs do for d in decls do - match d with + match d with | SynModuleSigDecl.HashDirective(hd,_) -> yield! GetScopedPragmasForHashDirective hd - | _ -> () - for hd in hashDirectives do + | _ -> () + for hd in hashDirectives do yield! GetScopedPragmasForHashDirective hd ] ParsedInput.SigFile(ParsedSigFileInput(filename,qualName,scopedPragmas,hashDirectives,specs)) -let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaultNamespace,filename,isLastCompiland) = +let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaultNamespace,filename,isLastCompiland) = // The assert below is almost ok, but it fires in two cases: // - fsi.exe sometimes passes "stdin" as a dummy filename - // - if you have a #line directive, e.g. + // - 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(System.IO.Path.IsPathRooted(filename), sprintf "should be absolute: '%s'" filename) - let lower = String.lowercase 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 let filteringErrorLogger = ErrorLoggerFilteringByScopedPragmas(false,[],errorLogger) let errorLogger = DelayedErrorLogger(filteringErrorLogger) use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - try - let input = - if mlCompatSuffixes |> List.exists (Filename.checkSuffix lower) then - mlCompatWarning (FSComp.SR.buildCompilingExtensionIsForML()) rangeStartup + try + let input = + if mlCompatSuffixes |> List.exists (Filename.checkSuffix lower) then + mlCompatWarning (FSComp.SR.buildCompilingExtensionIsForML()) rangeStartup - if FSharpImplFileSuffixes |> List.exists (Filename.checkSuffix lower) then - let impl = Parser.implementationFile lexer lexbuf + if FSharpImplFileSuffixes |> List.exists (Filename.checkSuffix lower) then + let impl = Parser.implementationFile lexer lexbuf PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,impl) - elif FSharpSigFileSuffixes |> List.exists (Filename.checkSuffix lower) then - let intfs = Parser.signatureFile lexer lexbuf + elif FSharpSigFileSuffixes |> List.exists (Filename.checkSuffix lower) then + let intfs = Parser.signatureFile lexer lexbuf PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,intfs) - else + else errorLogger.Error(Error(FSComp.SR.buildInvalidSourceFileExtension(filename),Range.rangeStartup)) filteringErrorLogger.ScopedPragmas <- GetScopedPragmasForInput input input @@ -3432,32 +3448,34 @@ let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaul errorLogger.CommitDelayedErrorsAndWarnings() (* unwindEL, unwindBP dispose *) +#if !FABLE_COMPILER + //---------------------------------------------------------------------------- // parsing - ParseOneInputFile -// Filename is (ml/mli/fs/fsi source). Parse it to AST. +// Filename is (ml/mli/fs/fsi source). Parse it to AST. //---------------------------------------------------------------------------- let ParseOneInputLexbuf (tcConfig:TcConfig,lexResourceManager,conditionalCompilationDefines,lexbuf,filename,isLastCompiland,errorLogger) = use unwindbuildphase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - try + try let skip = true in (* don't report whitespace from lexer *) - let lightSyntaxStatus = LightSyntaxStatus (tcConfig.ComputeLightSyntaxInitialStatus filename,true) + let lightSyntaxStatus = LightSyntaxStatus (tcConfig.ComputeLightSyntaxInitialStatus filename,true) let lexargs = mkLexargs (filename,conditionalCompilationDefines@tcConfig.conditionalCompilationDefines,lightSyntaxStatus,lexResourceManager, ref [],errorLogger) - let shortFilename = SanitizeFileName filename tcConfig.implicitIncludeDir - let input = + let shortFilename = SanitizeFileName filename tcConfig.implicitIncludeDir + let input = Lexhelp.usingLexbufForParsing (lexbuf,filename) (fun lexbuf -> if verbose then dprintn ("Parsing... "+shortFilename) let tokenizer = LexFilter.LexFilter(lightSyntaxStatus, tcConfig.compilingFslib, Lexer.token lexargs skip, lexbuf) - if tcConfig.tokenizeOnly then - while true do + if tcConfig.tokenizeOnly then + while true do printf "tokenize - getting one token from %s\n" shortFilename let t = tokenizer.Lexer lexbuf printf "tokenize - got %s @ %a\n" (Parser.token_to_string t) outputRange lexbuf.LexemeRange (match t with Parser.EOF _ -> exit 0 | _ -> ()) if lexbuf.IsPastEndOfStream then printf "!!! at end of stream\n" - if tcConfig.testInteractionParser then - while true do + if tcConfig.testInteractionParser then + while true do match (Parser.interaction tokenizer.Lexer lexbuf) with | IDefns(l,m) -> dprintf "Parsed OK, got %d defs @ %a\n" l.Length outputRange m | IHash (_,m) -> dprintf "Parsed OK, got hash @ %a\n" outputRange m @@ -3465,46 +3483,46 @@ let ParseOneInputLexbuf (tcConfig:TcConfig,lexResourceManager,conditionalCompila let res = ParseInput(tokenizer.Lexer,errorLogger,lexbuf,None,filename,isLastCompiland) - if tcConfig.reportNumDecls then - let rec flattenSpecs specs = + if tcConfig.reportNumDecls then + let rec flattenSpecs specs = specs |> List.collect (function (SynModuleSigDecl.NestedModule (_,_,subDecls,_)) -> flattenSpecs subDecls | spec -> [spec]) - let rec flattenDefns specs = + let rec flattenDefns specs = specs |> List.collect (function (SynModuleDecl.NestedModule (_,_,subDecls,_,_)) -> flattenDefns subDecls | defn -> [defn]) let flattenModSpec (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) = flattenSpecs decls let flattenModImpl (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) = flattenDefns decls - match res with - | ParsedInput.SigFile(ParsedSigFileInput(_,_,_,_,specs)) -> + match res with + | ParsedInput.SigFile(ParsedSigFileInput(_,_,_,_,specs)) -> dprintf "parsing yielded %d specs" (List.collect flattenModSpec specs).Length - | ParsedInput.ImplFile(ParsedImplFileInput(_,_,_,_,_,impls,_)) -> + | ParsedInput.ImplFile(ParsedImplFileInput(_,_,_,_,_,impls,_)) -> dprintf "parsing yielded %d definitions" (List.collect flattenModImpl impls).Length res ) if verbose then dprintn ("Parsed "+shortFilename) - Some input - with e -> (* errorR(Failure("parse failed")); *) errorRecovery e rangeStartup; None - - + Some input + with e -> (* errorR(Failure("parse failed")); *) errorRecovery e rangeStartup; None + + let ParseOneInputFile (tcConfig:TcConfig,lexResourceManager,conditionalCompilationDefines,filename,isLastCompiland,errorLogger,retryLocked) = - try + try let lower = String.lowercase filename - if List.exists (Filename.checkSuffix lower) (FSharpSigFileSuffixes@FSharpImplFileSuffixes) then + if List.exists (Filename.checkSuffix lower) (FSharpSigFileSuffixes@FSharpImplFileSuffixes) then if not(FileSystem.SafeExists(filename)) then error(Error(FSComp.SR.buildCouldNotFindSourceFile(filename),rangeStartup)) // bug 3155: if the file name is indirect, use a full path - let lexbuf = UnicodeLexing.UnicodeFileAsLexbuf(filename,tcConfig.inputCodePage,retryLocked) + let lexbuf = UnicodeLexing.UnicodeFileAsLexbuf(filename,tcConfig.inputCodePage,retryLocked) ParseOneInputLexbuf(tcConfig,lexResourceManager,conditionalCompilationDefines,lexbuf,filename,isLastCompiland,errorLogger) else error(Error(FSComp.SR.buildInvalidSourceFileExtension(SanitizeFileName filename tcConfig.implicitIncludeDir),rangeStartup)) - with e -> (* errorR(Failure("parse failed")); *) errorRecovery e rangeStartup; None - + with e -> (* errorR(Failure("parse failed")); *) errorRecovery e rangeStartup; None + -[] -type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : UnresolvedAssemblyReference list) = +[] +type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : UnresolvedAssemblyReference list) = let originalReferenceToResolution = results |> List.map (fun r -> r.originalReference.Text,r) |> Map.ofList let resolvedPathToResolution = results |> List.map (fun r -> r.resolvedPath,r) |> Map.ofList - /// Add some resolutions to the map of resolution results. + /// Add some resolutions to the map of resolution results. member tcResolutions.AddResolutionResults(newResults) = TcAssemblyResolutions(newResults @ results, unresolved) /// Add some unresolved results. member tcResolutions.AddUnresolvedReferences(newUnresolved) = TcAssemblyResolutions(results, newUnresolved @ unresolved) @@ -3516,16 +3534,16 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres member tcResolution.TryFindByExactILAssemblyRef assref = results |> List.tryFind (fun ar->ar.ILAssemblyRef = assref) member tcResolutions.TryFindByResolvedPath nm = resolvedPathToResolution.TryFind nm member tcResolutions.TryFindByOriginalReferenceText nm = originalReferenceToResolution.TryFind nm - + static member Resolve (tcConfig:TcConfig,assemblyList:AssemblyReference list, knownUnresolved:UnresolvedAssemblyReference list) : TcAssemblyResolutions = - let resolved,unresolved = - if tcConfig.useSimpleResolution then - let resolutions = - assemblyList - |> List.map (fun assemblyReference -> - try + let resolved,unresolved = + if tcConfig.useSimpleResolution then + let resolutions = + assemblyList + |> List.map (fun assemblyReference -> + try Choice1Of2 (tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError assemblyReference |> Option.get) - with e -> + with e -> errorRecovery e assemblyReference.Range Choice2Of2 assemblyReference) let successes = resolutions |> List.choose (function Choice1Of2 x -> Some x | _ -> None) @@ -3533,57 +3551,57 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres successes, failures else TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig,assemblyList,rangeStartup,ReportErrors) - TcAssemblyResolutions(resolved,unresolved @ knownUnresolved) + TcAssemblyResolutions(resolved,unresolved @ knownUnresolved) static member GetAllDllReferences (tcConfig:TcConfig) = [ yield tcConfig.PrimaryAssemblyDllReference() - if not tcConfig.compilingFslib then + if not tcConfig.compilingFslib then yield tcConfig.CoreLibraryDllReference() - if tcConfig.framework then - for s in DefaultBasicReferencesForOutOfProjectSources do + if tcConfig.framework then + for s in DefaultBasicReferencesForOutOfProjectSources do yield AssemblyReference(rangeStartup,s+".dll",None) - if tcConfig.framework || tcConfig.addVersionSpecificFrameworkReferences then - // For out-of-project context, then always reference some extra DLLs on .NET 4.0 - if tcConfig.MscorlibMajorVersion >= 4 then - for s in DefaultBasicReferencesForOutOfProjectSources40 do - yield AssemblyReference(rangeStartup,s+".dll",None) + if tcConfig.framework || tcConfig.addVersionSpecificFrameworkReferences then + // For out-of-project context, then always reference some extra DLLs on .NET 4.0 + if tcConfig.MscorlibMajorVersion >= 4 then + for s in DefaultBasicReferencesForOutOfProjectSources40 do + yield AssemblyReference(rangeStartup,s+".dll",None) - if tcConfig.useFsiAuxLib then + if tcConfig.useFsiAuxLib then let name = Path.Combine(tcConfig.fsharpBinariesDir, GetFsiLibraryName()+".dll") - yield AssemblyReference(rangeStartup,name,None) + yield AssemblyReference(rangeStartup,name,None) yield! tcConfig.referencedDLLs ] static member SplitNonFoundationalResolutions (tcConfig:TcConfig) = let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,tcConfig.knownUnresolvedReferences) - let frameworkDLLs,nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + let frameworkDLLs,nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) let unresolved = resolutions.GetUnresolvedReferences() #if DEBUG let itFailed = ref false let addedText = "\nIf you want to debug this right now, attach a debugger, and put a breakpoint in 'CompileOps.fs' near the text '!itFailed', and you can re-step through the assembly resolution logic." - unresolved + unresolved |> List.iter (fun (UnresolvedAssemblyReference(referenceText,_ranges)) -> if referenceText.Contains("mscorlib") then System.Diagnostics.Debug.Assert(false, sprintf "whoops, did not resolve mscorlib: '%s'%s" referenceText addedText) itFailed := true) - frameworkDLLs + frameworkDLLs |> List.iter (fun x -> if not(FileSystem.IsPathRootedShim(x.resolvedPath)) then System.Diagnostics.Debug.Assert(false, sprintf "frameworkDLL should be absolute path: '%s'%s" x.resolvedPath addedText) itFailed := true) - nonFrameworkReferences - |> List.iter (fun x -> + nonFrameworkReferences + |> List.iter (fun x -> if not(FileSystem.IsPathRootedShim(x.resolvedPath)) then - System.Diagnostics.Debug.Assert(false, sprintf "nonFrameworkReference should be absolute path: '%s'%s" x.resolvedPath addedText) + System.Diagnostics.Debug.Assert(false, sprintf "nonFrameworkReference should be absolute path: '%s'%s" x.resolvedPath addedText) itFailed := true) if !itFailed then // idea is, put a breakpoint here and then step through let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,[]) - let _frameworkDLLs,_nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) + let _frameworkDLLs,_nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) () #endif frameworkDLLs,nonFrameworkReferences,unresolved @@ -3591,7 +3609,7 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres static member BuildFromPriorResolutions (tcConfig:TcConfig,resolutions,knownUnresolved) = let references = resolutions |> List.map (fun r -> r.originalReference) TcAssemblyResolutions.Resolve(tcConfig,references,knownUnresolved) - + //---------------------------------------------------------------------------- // Typecheck and optimization environments on disk @@ -3603,14 +3621,14 @@ let GetSignatureDataResourceName (r: ILResource) = String.dropPrefix (String. let GetOptimizationDataResourceName (r: ILResource) = String.dropPrefix (String.dropPrefix r.Name FSharpOptimizationDataResourceName) "." let IsReflectedDefinitionsResource (r: ILResource) = String.hasPrefix r.Name QuotationPickler.SerializedReflectedDefinitionsResourceNameBase -type ILResource with +type ILResource with /// Get a function to read the bytes from a resource local to an assembly - member r.GetByteReader(m) = - match r.Location with + member r.GetByteReader(m) = + match r.Location with | ILResourceLocation.Local b -> b | _-> error(InternalError("UnpickleFromResource",m)) -let MakeILResource rname bytes = +let MakeILResource rname bytes = { Name = rname Location = ILResourceLocation.Local (fun () -> bytes) Access = ILResourceAccess.Public @@ -3618,33 +3636,33 @@ let MakeILResource rname bytes = #if NO_COMPILER_BACKEND #else -let PickleToResource file g scope rname p x = +let PickleToResource file g scope rname p x = { Name = rname Location = (let bytes = pickleObjWithDanglingCcus file g scope p x in ILResourceLocation.Local (fun () -> bytes)) Access = ILResourceAccess.Public CustomAttrs = emptyILCustomAttrs } #endif -let GetSignatureData (file, ilScopeRef, ilModule, byteReader) : PickledDataWithReferences = +let GetSignatureData (file, ilScopeRef, ilModule, byteReader) : PickledDataWithReferences = unpickleObjWithDanglingCcus file ilScopeRef ilModule unpickleCcuInfo byteReader #if NO_COMPILER_BACKEND #else -let WriteSignatureData (tcConfig:TcConfig,tcGlobals,exportRemapping,ccu:CcuThunk,file) : ILResource = +let WriteSignatureData (tcConfig:TcConfig,tcGlobals,exportRemapping,ccu:CcuThunk,file) : ILResource = let mspec = ccu.Contents let mspec = ApplyExportRemappingToEntity tcGlobals exportRemapping mspec - PickleToResource file tcGlobals ccu (FSharpSignatureDataResourceName+"."+ccu.AssemblyName) pickleCcuInfo - { mspec=mspec + PickleToResource file tcGlobals ccu (FSharpSignatureDataResourceName+"."+ccu.AssemblyName) pickleCcuInfo + { mspec=mspec compileTimeWorkingDir=tcConfig.implicitIncludeDir usesQuotations = ccu.UsesFSharp20PlusQuotations } #endif // NO_COMPILER_BACKEND -let GetOptimizationData (file, ilScopeRef, ilModule, byteReader) = +let GetOptimizationData (file, ilScopeRef, ilModule, byteReader) = unpickleObjWithDanglingCcus file ilScopeRef ilModule Optimizer.u_CcuOptimizationInfo (byteReader()) #if NO_COMPILER_BACKEND #else -let WriteOptimizationData (tcGlobals, file, ccu,modulInfo) = +let WriteOptimizationData (tcGlobals, file, ccu,modulInfo) = #if DEBUG if verbose then dprintf "Optimization data after remap:\n%s\n" (Layout.showL (Layout.squashTo 192 (Optimizer.moduleInfoL tcGlobals modulInfo))) #endif @@ -3654,60 +3672,60 @@ let WriteOptimizationData (tcGlobals, file, ccu,modulInfo) = //---------------------------------------------------------------------------- // Abstraction for project reference -type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyRefs) = +type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyRefs) = let externalSigAndOptData = ["FSharp.Core"] - interface IRawFSharpAssemblyData with - member __.GetAutoOpenAttributes(ilg) = GetAutoOpenAttributes ilg ilModule - member __.GetInternalsVisibleToAttributes(ilg) = GetInternalsVisibleToAttributes ilg ilModule - member __.TryGetRawILModule() = Some ilModule - member __.GetRawFSharpSignatureData(m,ilShortAssemName,filename) = + interface IRawFSharpAssemblyData with + member __.GetAutoOpenAttributes(ilg) = GetAutoOpenAttributes ilg ilModule + member __.GetInternalsVisibleToAttributes(ilg) = GetInternalsVisibleToAttributes ilg ilModule + member __.TryGetRawILModule() = Some ilModule + member __.GetRawFSharpSignatureData(m,ilShortAssemName,filename) = let resources = ilModule.Resources.AsList - let sigDataReaders = + let sigDataReaders = [ for iresource in resources do - if IsSignatureDataResource iresource then - let ccuName = GetSignatureDataResourceName iresource + if IsSignatureDataResource iresource then + let ccuName = GetSignatureDataResourceName iresource let byteReader = iresource.GetByteReader(m) yield (ccuName, byteReader()) ] - - let sigDataReaders = - if List.contains ilShortAssemName externalSigAndOptData then + + let sigDataReaders = + if List.contains ilShortAssemName externalSigAndOptData then let sigFileName = Path.ChangeExtension(filename, "sigdata") - if not sigDataReaders.IsEmpty then + if not sigDataReaders.IsEmpty then error(Error(FSComp.SR.buildDidNotExpectSigdataResource(FileSystem.GetFullPathShim filename),m)) - if not (FileSystem.SafeExists sigFileName) then + if not (FileSystem.SafeExists sigFileName) then error(Error(FSComp.SR.buildExpectedSigdataFile (FileSystem.GetFullPathShim sigFileName), m)) [ (ilShortAssemName, FileSystem.ReadAllBytesShim sigFileName)] else sigDataReaders sigDataReaders - member __.GetRawFSharpOptimizationData(m,ilShortAssemName,filename) = - let optDataReaders = + member __.GetRawFSharpOptimizationData(m,ilShortAssemName,filename) = + let optDataReaders = ilModule.Resources.AsList |> List.choose (fun r -> if IsOptimizationDataResource r then Some(GetOptimizationDataResourceName r,r.GetByteReader(m)) else None) - // Look for optimization data in a file - let optDataReaders = - if List.contains ilShortAssemName externalSigAndOptData then + // Look for optimization data in a file + let optDataReaders = + if List.contains ilShortAssemName externalSigAndOptData then let optDataFile = Path.ChangeExtension(filename, "optdata") - if not optDataReaders.IsEmpty then + if not optDataReaders.IsEmpty then error(Error(FSComp.SR.buildDidNotExpectOptDataResource(FileSystem.GetFullPathShim filename),m)) - if not (FileSystem.SafeExists optDataFile) then + if not (FileSystem.SafeExists optDataFile) then error(Error(FSComp.SR.buildExpectedFileAlongSideFSharpCore(optDataFile,FileSystem.GetFullPathShim optDataFile),m)) [ (ilShortAssemName, (fun () -> FileSystem.ReadAllBytesShim optDataFile))] else optDataReaders optDataReaders member __.GetRawTypeForwarders() = - match ilModule.Manifest with + match ilModule.Manifest with | Some manifest -> manifest.ExportedTypes | None -> mkILExportedTypes [] - member __.ShortAssemblyName = GetNameOfILModule ilModule + member __.ShortAssemblyName = GetNameOfILModule ilModule member __.ILScopeRef = MakeScopeRefForIlModule ilModule member __.ILAssemblyRefs = ilAssemblyRefs - member __.HasAnyFSharpSignatureDataAttribute = + member __.HasAnyFSharpSignatureDataAttribute = let attrs = GetCustomAttributesOfIlModule ilModule List.exists IsSignatureDataVersionAttr attrs - member __.HasMatchingFSharpSignatureDataAttribute(ilg) = + member __.HasMatchingFSharpSignatureDataAttribute(ilg) = let attrs = GetCustomAttributesOfIlModule ilModule List.exists (IsMatchingSignatureDataVersionAttr ilg (IL.parseILVersion Internal.Utilities.FSharpEnvironment.FSharpBinaryMetadataFormatRevision)) attrs @@ -3727,7 +3745,7 @@ let availableToOptionalCcu = function /// Represents a computation to return a TcConfig. Normally this is just a constant immutable TcConfig, /// but for F# Interactive it may be based on an underlying mutable TcConfigBuilder. -type TcConfigProvider = +type TcConfigProvider = | TcConfigProvider of (unit -> TcConfig) member x.Get() = (let (TcConfigProvider(f)) = x in f()) @@ -3737,16 +3755,16 @@ type TcConfigProvider = /// Get a TcConfigProvider which will continue to respect changes in the underlying /// TcConfigBuilder rather than delivering snapshots. static member BasedOnMutableBuilder(tcConfigB) = TcConfigProvider(fun () -> TcConfig.Create(tcConfigB,validate=false)) - - + + //---------------------------------------------------------------------------- // TcImports //-------------------------------------------------------------------------- - + /// Repreesnts a table of imported assemblies with their resolutions. -[] -type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResolutions, importsBase:TcImports option, ilGlobalsOpt) = +[] +type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResolutions, importsBase:TcImports option, ilGlobalsOpt) = let mutable resolutions = initialResolutions let mutable importsBase : TcImports option = importsBase @@ -3761,11 +3779,11 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti #if EXTENSIONTYPING let mutable generatedTypeRoots = new System.Collections.Generic.Dictionary() #endif - + let CheckDisposed() = if disposed then assert false - // REVIEW: Post-RTM, we should remove static dependencies over "expected" foundational CCUs, and + // REVIEW: Post-RTM, we should remove static dependencies over "expected" foundational CCUs, and // search over all imported CCUs for each cached type static let ccuHasType (ccu : CcuThunk) (nsname : string list) (tname : string) = match (Some ccu.Contents, nsname) ||> List.fold (fun entityOpt n -> match entityOpt with None -> None | Some entity -> entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind n) with @@ -3774,50 +3792,50 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | Some _ -> true | None -> false | None -> false - - member private tcImports.Base = + + member private tcImports.Base = CheckDisposed() importsBase member tcImports.CcuTable = CheckDisposed() ccuTable - + member tcImports.DllTable = CheckDisposed() - dllTable - + dllTable + member tcImports.RegisterCcu(ccuInfo) = CheckDisposed() ccuInfos <- ccuInfos ++ ccuInfo // Assembly Ref Resolution: remove this use of ccu.AssemblyName ccuTable <- NameMap.add (ccuInfo.FSharpViewOfMetadata.AssemblyName) ccuInfo ccuTable - + member tcImports.RegisterDll(dllInfo) = CheckDisposed() dllInfos <- dllInfos ++ dllInfo dllTable <- NameMap.add (getNameOfScopeRef dllInfo.ILScopeRef) dllInfo dllTable - member tcImports.GetDllInfos() = + member tcImports.GetDllInfos() = CheckDisposed() - match importsBase with + match importsBase with | Some(importsBase)-> importsBase.GetDllInfos() @ dllInfos | None -> dllInfos - - member tcImports.AllAssemblyResolutions() = + + member tcImports.AllAssemblyResolutions() = CheckDisposed() let ars = resolutions.GetAssemblyResolutions() - match importsBase with + match importsBase with | Some(importsBase)-> importsBase.AllAssemblyResolutions() @ ars | None -> ars - + member tcImports.TryFindDllInfo (m,assemblyName,lookupOnly) = CheckDisposed() - let rec look (t:TcImports) = + let rec look (t:TcImports) = match NameMap.tryFind assemblyName t.DllTable with | Some res -> Some(res) - | None -> - match t.Base with + | None -> + match t.Base with | Some t2 -> look(t2) | None -> None match look tcImports with @@ -3825,54 +3843,54 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | None -> tcImports.ImplicitLoadIfAllowed(m,assemblyName,lookupOnly) look tcImports - + member tcImports.FindDllInfo (m,assemblyName) = - match tcImports.TryFindDllInfo (m,assemblyName,lookupOnly=false) with + match tcImports.TryFindDllInfo (m,assemblyName,lookupOnly=false) with | Some res -> res | None -> error(Error(FSComp.SR.buildCouldNotResolveAssembly(assemblyName),m)) - member tcImports.GetImportedAssemblies() = + member tcImports.GetImportedAssemblies() = CheckDisposed() - match importsBase with + match importsBase with | Some(importsBase)-> importsBase.GetImportedAssemblies() @ ccuInfos - | None -> ccuInfos - - member tcImports.GetCcusExcludingBase() = + | None -> ccuInfos + + member tcImports.GetCcusExcludingBase() = CheckDisposed() - ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata) + ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata) - member tcImports.GetCcusInDeclOrder() = + member tcImports.GetCcusInDeclOrder() = CheckDisposed() - List.map (fun x -> x.FSharpViewOfMetadata) (tcImports.GetImportedAssemblies()) - - // This is the main "assembly reference --> assembly" resolution routine. - member tcImports.FindCcuInfo (m,assemblyName,lookupOnly) = + List.map (fun x -> x.FSharpViewOfMetadata) (tcImports.GetImportedAssemblies()) + + // This is the main "assembly reference --> assembly" resolution routine. + member tcImports.FindCcuInfo (m,assemblyName,lookupOnly) = CheckDisposed() - let rec look (t:TcImports) = + let rec look (t:TcImports) = match NameMap.tryFind assemblyName t.CcuTable with | Some res -> Some(res) - | None -> - match t.Base with - | Some t2 -> look t2 + | None -> + match t.Base with + | Some t2 -> look t2 | None -> None match look tcImports with | Some res -> ResolvedImportedAssembly(res) | None -> tcImports.ImplicitLoadIfAllowed(m,assemblyName,lookupOnly) - match look tcImports with + match look tcImports with | Some res -> ResolvedImportedAssembly(res) | None -> UnresolvedImportedAssembly(assemblyName) - - member tcImports.FindCcu (m, assemblyName,lookupOnly) = + + member tcImports.FindCcu (m, assemblyName,lookupOnly) = CheckDisposed() match tcImports.FindCcuInfo(m,assemblyName,lookupOnly) with | ResolvedImportedAssembly(importedAssembly) -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) | UnresolvedImportedAssembly(assemblyName) -> UnresolvedCcu(assemblyName) - member tcImports.FindCcuFromAssemblyRef(m,assref:ILAssemblyRef) = + member tcImports.FindCcuFromAssemblyRef(m,assref:ILAssemblyRef) = CheckDisposed() match tcImports.FindCcuInfo(m,assref.Name,lookupOnly=false) with | ResolvedImportedAssembly(importedAssembly) -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) @@ -3880,35 +3898,35 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti #if EXTENSIONTYPING - member tcImports.GetProvidedAssemblyInfo(m, assembly: Tainted) = + member tcImports.GetProvidedAssemblyInfo(m, assembly: Tainted) = let anameOpt = assembly.PUntaint((fun assembly -> match assembly with null -> None | a -> Some (a.GetName())), m) - match anameOpt with + match anameOpt with | None -> false, None - | Some aname -> + | Some aname -> let ilShortAssemName = aname.Name - match tcImports.FindCcu (m, ilShortAssemName, lookupOnly=true) with - | ResolvedCcu ccu -> - if ccu.IsProviderGenerated then + match tcImports.FindCcu (m, ilShortAssemName, lookupOnly=true) with + | ResolvedCcu ccu -> + if ccu.IsProviderGenerated then let dllinfo = tcImports.FindDllInfo(m,ilShortAssemName) true, dllinfo.ProviderGeneratedStaticLinkMap else false, None - | UnresolvedCcu _ -> + | UnresolvedCcu _ -> let g = tcImports.GetTcGlobals() let ilScopeRef = ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName aname) 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.mkDefault g.ilg with + let ilModule,ilAssemblyRefs = + let opts = { ILBinaryReader.mkDefault g.ilg with ILBinaryReader.optimizeForMemory=true - ILBinaryReader.pdbPath = None } + ILBinaryReader.pdbPath = None } let reader = ILBinaryReader.OpenILModuleReaderFromBytes fileName bytes opts reader.ILModuleDef, reader.ILAssemblyRefs let theActualAssembly = assembly.PUntaint((fun x -> x.Handle),m) - let dllinfo = - { RawMetadata= RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) + let dllinfo = + { RawMetadata= RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) FileName=fileName ProviderGeneratedAssembly=Some theActualAssembly IsProviderGenerated=true @@ -3916,25 +3934,25 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti ILScopeRef = ilScopeRef ILAssemblyRefs = ilAssemblyRefs } tcImports.RegisterDll(dllinfo) - let ccuData : CcuData = + let ccuData : CcuData = { IsFSharp=false UsesFSharp20PlusQuotations=false InvalidateEvent=(new Event<_>()).Publish IsProviderGenerated = true QualifiedName= Some (assembly.PUntaint((fun a -> a.FullName), m)) - Contents = NewCcuContents ilScopeRef m ilShortAssemName (NewEmptyModuleOrNamespaceType Namespace) + Contents = NewCcuContents ilScopeRef m ilShortAssemName (NewEmptyModuleOrNamespaceType Namespace) ILScopeRef = ilScopeRef Stamp = newStamp() - SourceCodeDirectory = "" + SourceCodeDirectory = "" FileName = Some fileName MemberSignatureEquality = (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll g ty1 ty2) ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) TypeForwarders = Map.empty } - + let ccu = CcuThunk.Create(ilShortAssemName,ccuData) - let ccuinfo = - { FSharpViewOfMetadata=ccu - ILScopeRef = ilScopeRef + let ccuinfo = + { FSharpViewOfMetadata=ccu + ILScopeRef = ilScopeRef AssemblyAutoOpenAttributes = [] AssemblyInternalsVisibleToAttributes = [] IsProviderGenerated = true @@ -3944,16 +3962,16 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Yes, it is generative true, dllinfo.ProviderGeneratedStaticLinkMap - member tcImports.RecordGeneratedTypeRoot root = - // checking if given ProviderGeneratedType was already recorded before (probably for another set of static parameters) + member tcImports.RecordGeneratedTypeRoot root = + // checking if given ProviderGeneratedType was already recorded before (probably for another set of static parameters) let (ProviderGeneratedType(_, ilTyRef, _)) = root - let index = + let index = match generatedTypeRoots.TryGetValue ilTyRef with | true,(index, _) -> index | false, _ -> generatedTypeRoots.Count generatedTypeRoots.[ilTyRef] <- (index, root) - member tcImports.ProviderGeneratedTypeRoots = + member tcImports.ProviderGeneratedTypeRoots = generatedTypeRoots.Values |> Seq.sortBy fst |> Seq.map snd @@ -3963,34 +3981,34 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti member tcImports.AttachDisposeAction(action) = CheckDisposed() disposeActions <- action :: disposeActions - - override obj.ToString() = + + override obj.ToString() = sprintf "tcImports = \n dllInfos=%A\n dllTable=%A\n ccuInfos=%A\n ccuTable=%A\n Base=%s\n" dllInfos dllTable ccuInfos ccuTable (match importsBase with None-> "None" | Some(importsBase) -> importsBase.ToString()) - - - // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed - // then the reader is closed. - member tcImports.OpenILBinaryModule(filename,m) = + + + // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed + // then the reader is closed. + member tcImports.OpenILBinaryModule(filename,m) = try CheckDisposed() let tcConfig = tcConfigP.Get() - let pdbPathOption = - // We open the pdb file if one exists parallel to the binary we - // are reading, so that --standalone will preserve debug information. - if tcConfig.openDebugInformationForLaterStaticLinking then - let pdbDir = (try Filename.directoryName filename with _ -> ".") - let pdbFile = (try Filename.chopExtension filename with _ -> filename)+".pdb" - if FileSystem.SafeExists pdbFile then + let pdbPathOption = + // We open the pdb file if one exists parallel to the binary we + // are reading, so that --standalone will preserve debug information. + if tcConfig.openDebugInformationForLaterStaticLinking then + let pdbDir = (try Filename.directoryName filename with _ -> ".") + let pdbFile = (try Filename.chopExtension filename with _ -> filename)+".pdb" + if FileSystem.SafeExists pdbFile then if verbose then dprintf "reading PDB file %s from directory %s\n" pdbFile pdbDir Some pdbDir - else - None - else + else + None + else None #if SHADOW_COPY_REFERENCES let ilILBinaryReader = OpenILBinary(filename,tcConfig.optimizeForMemory,tcConfig.openBinariesInMemory,ilGlobalsOpt,pdbPathOption, tcConfig.primaryAssembly.Name, tcConfig.noDebugData, tcConfig.shadowCopyReferences) @@ -4007,32 +4025,32 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti CheckDisposed() let auxModTable = HashMultiMap(10, HashIdentity.Structural) fun viewedScopeRef -> - + let tcConfig = tcConfigP.Get() match viewedScopeRef with - | ILScopeRef.Module modref -> + | ILScopeRef.Module modref -> let key = modref.Name if not (auxModTable.ContainsKey(key)) then let resolution = tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError (AssemblyReference(m,key,None)) |> Option.get let ilModule,_ = tcImports.OpenILBinaryModule(resolution.resolvedPath,m) auxModTable.[key] <- ilModule - auxModTable.[key] + auxModTable.[key] - | _ -> + | _ -> error(InternalError("Unexpected ILScopeRef.Local or ILScopeRef.Assembly in exported type table",m)) member tcImports.IsAlreadyRegistered nm = CheckDisposed() - tcImports.GetDllInfos() |> List.exists (fun dll -> - match dll.ILScopeRef with - | ILScopeRef.Assembly a -> a.Name = nm + tcImports.GetDllInfos() |> List.exists (fun dll -> + match dll.ILScopeRef with + | ILScopeRef.Assembly a -> a.Name = nm | _ -> false) - member tcImports.GetImportMap() = + member tcImports.GetImportMap() = CheckDisposed() - let loaderInterface = - { new Import.AssemblyLoader with - member x.LoadAssembly (m, ilAssemblyRef) = + let loaderInterface = + { new Import.AssemblyLoader with + member x.LoadAssembly (m, ilAssemblyRef) = tcImports.FindCcuFromAssemblyRef(m,ilAssemblyRef) #if EXTENSIONTYPING member x.GetProvidedAssemblyInfo (m,assembly) = tcImports.GetProvidedAssemblyInfo (m,assembly) @@ -4041,7 +4059,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti } new Import.ImportMap (tcImports.GetTcGlobals(), loaderInterface) - // Note the tcGlobals are only available once mscorlib and fslib have been established. For TcImports, + // Note the tcGlobals are only available once mscorlib and fslib have been established. For TcImports, // they are logically only needed when converting AbsIL data structures into F# data structures, and // when converting AbsIL types in particular, since these types are normalized through the tables // in the tcGlobals (E.g. normalizing 'System.Int32' to 'int'). On the whole ImportILAssembly doesn't @@ -4051,11 +4069,11 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // ImportILAssembly had a tcGlobals available when it really needs it. member tcImports.GetTcGlobals() : TcGlobals = CheckDisposed() - match tcGlobals with - | Some g -> g - | None -> - match importsBase with - | Some b -> b.GetTcGlobals() + match tcGlobals with + | Some g -> g + | None -> + match importsBase with + | Some b -> b.GetTcGlobals() | None -> failwith "unreachable: GetGlobals - are the references to mscorlib.dll and FSharp.Core.dll valid?" member private tcImports.SetILGlobals ilg = @@ -4067,26 +4085,26 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti tcGlobals <- Some g #if EXTENSIONTYPING - member private tcImports.InjectProvidedNamespaceOrTypeIntoEntity - (typeProviderEnvironment, + member private tcImports.InjectProvidedNamespaceOrTypeIntoEntity + (typeProviderEnvironment, tcConfig:TcConfig, m,entity:Entity, injectedNamspace,remainingNamespace, - provider, - st:Tainted option) = + provider, + st:Tainted option) = match remainingNamespace with | next::rest -> - // Inject the namespace entity + // Inject the namespace entity match entity.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(next) with | Some childEntity -> tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, childEntity, next::injectedNamspace, rest, provider, st) - | None -> + | None -> // Build up the artificial namespace if there is not a real one. let cpath = CompPath(ILScopeRef.Local, injectedNamspace |> List.rev |> List.map (fun n -> (n,ModuleOrNamespaceKind.Namespace)) ) - let newNamespace = NewModuleOrNamespace (Some cpath) taccessPublic (ident(next,rangeStartup)) XmlDoc.Empty [] (notlazy (NewEmptyModuleOrNamespaceType Namespace)) + let newNamespace = NewModuleOrNamespace (Some cpath) taccessPublic (ident(next,rangeStartup)) XmlDoc.Empty [] (notlazy (NewEmptyModuleOrNamespaceType Namespace)) entity.ModuleOrNamespaceType.AddModuleOrNamespaceByMutation(newNamespace) tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, newNamespace, next::injectedNamspace, rest, provider, st) - | [] -> + | [] -> match st with | Some st -> // Inject the wrapper type into the provider assembly. @@ -4094,39 +4112,39 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Generated types get properly injected into the provided (i.e. generated) assembly CCU in tc.fs let importProvidedType t = Import.ImportProvidedType (tcImports.GetImportMap()) m t - let isSuppressRelocate = tcConfig.isInteractive || st.PUntaint((fun st -> st.IsSuppressRelocate),m) - let newEntity = Construct.NewProvidedTycon(typeProviderEnvironment, st, importProvidedType, isSuppressRelocate, m) + let isSuppressRelocate = tcConfig.isInteractive || st.PUntaint((fun st -> st.IsSuppressRelocate),m) + let newEntity = Construct.NewProvidedTycon(typeProviderEnvironment, st, importProvidedType, isSuppressRelocate, m) entity.ModuleOrNamespaceType.AddProvidedTypeEntity(newEntity) | None -> () entity.Data.entity_tycon_repr <- - match entity.TypeReprInfo with - // This is the first extension - | TNoRepr -> + match entity.TypeReprInfo with + // This is the first extension + | TNoRepr -> TProvidedNamespaceExtensionPoint(typeProviderEnvironment, [provider]) - + // Add to the existing list of extensions - | TProvidedNamespaceExtensionPoint(resolutionFolder, prior) as repr -> - if not(prior |> List.exists(fun r->Tainted.EqTainted r provider)) then + | TProvidedNamespaceExtensionPoint(resolutionFolder, prior) as repr -> + if not(prior |> List.exists(fun r->Tainted.EqTainted r provider)) then TProvidedNamespaceExtensionPoint(resolutionFolder, provider::prior) - else + else repr | _ -> failwith "Unexpected representation in namespace entity referred to by a type provider" - member tcImports.ImportTypeProviderExtensions - (tcConfig:TcConfig, - fileNameOfRuntimeAssembly, + member tcImports.ImportTypeProviderExtensions + (tcConfig:TcConfig, + fileNameOfRuntimeAssembly, ilScopeRefOfRuntimeAssembly, - runtimeAssemblyAttributes:ILAttribute list, - entityToInjectInto, invalidateCcu:Event<_>, m) = + runtimeAssemblyAttributes:ILAttribute list, + entityToInjectInto, invalidateCcu:Event<_>, m) = let startingErrorCount = CompileThreadStatic.ErrorLogger.ErrorCount - // Find assembly level TypeProviderAssemblyAttributes. These will point to the assemblies that + // Find assembly level TypeProviderAssemblyAttributes. These will point to the assemblies that // have class which implement ITypeProvider and which have TypeProviderAttribute on them. - let providerAssemblies = - runtimeAssemblyAttributes + let providerAssemblies = + runtimeAssemblyAttributes |> 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) @@ -4135,60 +4153,60 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti if providerAssemblies.Count > 0 then // Find the SystemRuntimeAssemblyVersion value to report in the TypeProviderConfig. - let systemRuntimeAssemblyVersion = + let systemRuntimeAssemblyVersion = let primaryAssemblyRef = tcConfig.PrimaryAssemblyDllReference() let resolution = tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError primaryAssemblyRef |> Option.get // 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 - let typeProviderEnvironment = + let typeProviderEnvironment = { resolutionFolder = tcConfig.implicitIncludeDir outputFile = tcConfig.outputFile - showResolutionMessages = tcConfig.showExtensionTypeMessages + showResolutionMessages = tcConfig.showExtensionTypeMessages referencedAssemblies = [| for r in tcImports.AllAssemblyResolutions() -> r.resolvedPath |] |> Seq.distinct |> Seq.toArray temporaryFolder = FileSystem.GetTempPathShim() } // The type provider should not hold strong references to disposed // TcImport objects. So the callbacks provided in the type provider config - // dispatch via a thunk which gets set to a non-resource-capturing - // failing function when the object is disposed. - let systemRuntimeContainsType = - let systemRuntimeContainsTypeRef = ref tcImports.SystemRuntimeContainsType - tcImports.AttachDisposeAction(fun () -> systemRuntimeContainsTypeRef := (fun _ -> raise (System.ObjectDisposedException("The type provider has been disposed")))) - fun arg -> systemRuntimeContainsTypeRef.Value arg - - let providers = + // dispatch via a thunk which gets set to a non-resource-capturing + // failing function when the object is disposed. + let systemRuntimeContainsType = + let systemRuntimeContainsTypeRef = ref tcImports.SystemRuntimeContainsType + tcImports.AttachDisposeAction(fun () -> systemRuntimeContainsTypeRef := (fun _ -> raise (System.ObjectDisposedException("The type provider has been disposed")))) + fun arg -> systemRuntimeContainsTypeRef.Value arg + + let providers = [ for assemblyName in providerAssemblies do - yield ExtensionTyping.GetTypeProvidersOfAssembly(fileNameOfRuntimeAssembly, ilScopeRefOfRuntimeAssembly, assemblyName, typeProviderEnvironment, + yield ExtensionTyping.GetTypeProvidersOfAssembly(fileNameOfRuntimeAssembly, ilScopeRefOfRuntimeAssembly, assemblyName, typeProviderEnvironment, tcConfig.isInvalidationSupported, tcConfig.isInteractive, systemRuntimeContainsType, systemRuntimeAssemblyVersion, m) ] let providers = providers |> List.concat // Note, type providers are disposable objects. The TcImports owns the provider objects - when/if it is disposed, the providers are disposed. // We ignore all exceptions from provider disposal. - for provider in providers do - tcImports.AttachDisposeAction(fun () -> - try - provider.PUntaintNoFailure(fun x -> x).Dispose() - with e -> + for provider in providers do + tcImports.AttachDisposeAction(fun () -> + try + provider.PUntaintNoFailure(fun x -> x).Dispose() + with e -> ()) - + // Add the invalidation signal handlers to each provider - for provider in providers do - provider.PUntaint((fun tp -> - let handler = tp.Invalidate.Subscribe(fun _ -> invalidateCcu.Trigger ("The provider '" + fileNameOfRuntimeAssembly + "' reported a change")) - tcImports.AttachDisposeAction(fun () -> try handler.Dispose() with _ -> ())), m) - + for provider in providers do + provider.PUntaint((fun tp -> + let handler = tp.Invalidate.Subscribe(fun _ -> invalidateCcu.Trigger ("The provider '" + fileNameOfRuntimeAssembly + "' reported a change")) + tcImports.AttachDisposeAction(fun () -> try handler.Dispose() with _ -> ())), m) + match providers with - | [] -> - warning(Error(FSComp.SR.etHostingAssemblyFoundWithoutHosts(fileNameOfRuntimeAssembly,typeof.FullName),m)) - | _ -> + | [] -> + warning(Error(FSComp.SR.etHostingAssemblyFoundWithoutHosts(fileNameOfRuntimeAssembly,typeof.FullName),m)) + | _ -> if typeProviderEnvironment.showResolutionMessages then dprintfn "Found extension type hosting hosting assembly '%s' with the following extensions:" fileNameOfRuntimeAssembly providers |> List.iter(fun provider ->dprintfn " %s" (ExtensionTyping.DisplayNameOfTypeProvider(provider.TypeProvider, m))) - - for provider in providers do + + for provider in providers do try // Inject an entity for the namespace, or if one already exists, then record this as a provider // for that namespace. @@ -4196,45 +4214,45 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let path = ExtensionTyping.GetProvidedNamespaceAsPath(m,provider,providedNamespace.PUntaint((fun r -> r.NamespaceName), m)) tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, entityToInjectInto, [],path, provider, None) - // Inject entities for the types returned by provider.GetTypes(). + // Inject entities for the types returned by provider.GetTypes(). // // NOTE: The types provided by GetTypes() are available for name resolution // when the namespace is "opened". This is part of the specification of the language // feature. let tys = providedNamespace.PApplyArray((fun provider -> provider.GetTypes()), "GetTypes", m) let ptys = [| for ty in tys -> ty.PApply((fun ty -> ty |> ProvidedType.CreateNoContext), m) |] - for st in ptys do + for st in ptys do tcImports.InjectProvidedNamespaceOrTypeIntoEntity (typeProviderEnvironment, tcConfig, m, entityToInjectInto, [], path, provider, Some st) - for providedNestedNamespace in providedNamespace.PApplyArray((fun provider -> provider.GetNestedNamespaces()), "GetNestedNamespaces", m) do + for providedNestedNamespace in providedNamespace.PApplyArray((fun provider -> provider.GetNestedNamespaces()), "GetNestedNamespaces", m) do loop providedNestedNamespace let providedNamespaces = provider.PApplyArray((fun r -> r.GetNamespaces()), "GetNamespaces", m) for providedNamespace in providedNamespaces do loop providedNamespace - with e -> + with e -> errorRecovery e m if startingErrorCount aref + let aref = + match ilScopeRef with + | ILScopeRef.Assembly aref -> aref | _ -> error(InternalError("PrepareToImportReferencedIlDll: cannot reference .NET netmodules directly, reference the containing assembly instead",m)) let nm = aref.Name @@ -4252,21 +4270,21 @@ 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 + let ccuinfo = + { FSharpViewOfMetadata=ccu + ILScopeRef = ilScopeRef AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilg ilModule AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilg ilModule #if EXTENSIONTYPING - IsProviderGenerated = false + IsProviderGenerated = false TypeProviders = [] #endif FSharpOptimizationData = notlazy None } tcImports.RegisterCcu(ccuinfo) - let phase2 () = + let phase2 () = #if EXTENSIONTYPING ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) #endif @@ -4278,36 +4296,36 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let tcConfig = tcConfigP.Get() tcConfig.CheckFSharpBinary(filename,dllinfo.ILAssemblyRefs,m) - let ilModule = dllinfo.RawMetadata - let ilScopeRef = dllinfo.ILScopeRef - let ilShortAssemName = getNameOfScopeRef ilScopeRef + let ilModule = dllinfo.RawMetadata + let ilScopeRef = dllinfo.ILScopeRef + let ilShortAssemName = getNameOfScopeRef ilScopeRef if verbose then dprintn ("Converting F# assembly to F# data structures "+(getNameOfScopeRef ilScopeRef)) if verbose then dprintn ("Relinking interface info from F# assembly "+ilShortAssemName) let optDataReaders = ilModule.GetRawFSharpOptimizationData(m, ilShortAssemName, filename) - let ccuRawDataAndInfos = + let ccuRawDataAndInfos = ilModule.GetRawFSharpSignatureData(m, ilShortAssemName, filename) - |> List.map (fun (ccuName, sigDataReader) -> + |> List.map (fun (ccuName, sigDataReader) -> let data = GetSignatureData (filename, ilScopeRef, ilModule.TryGetRawILModule(), sigDataReader) let optDatas = Map.ofList optDataReaders - let minfo : PickledCcuInfo = data.RawData - let mspec = minfo.mspec + let minfo : PickledCcuInfo = data.RawData + let mspec = minfo.mspec #if EXTENSIONTYPING let invalidateCcu = new Event<_>() #endif let codeDir = minfo.compileTimeWorkingDir - let ccuData : CcuData = + let ccuData : CcuData = { ILScopeRef=ilScopeRef Stamp = newStamp() - FileName = Some filename + FileName = Some filename QualifiedName= Some(ilScopeRef.QualifiedName) SourceCodeDirectory = codeDir (* note: in some cases we fix up this information later *) IsFSharp=true - Contents = mspec + Contents = mspec #if EXTENSIONTYPING InvalidateEvent=invalidateCcu.Publish IsProviderGenerated = false @@ -4319,31 +4337,31 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let ccu = CcuThunk.Create(ccuName, ccuData) - let optdata = - lazy - (match Map.tryFind ccuName optDatas with - | None -> - if verbose then dprintf "*** no optimization data for CCU %s, was DLL compiled with --no-optimization-data??\n" ccuName + let optdata = + lazy + (match Map.tryFind ccuName optDatas with + | None -> + if verbose then dprintf "*** no optimization data for CCU %s, was DLL compiled with --no-optimization-data??\n" ccuName None - | Some info -> + | Some info -> let data = GetOptimizationData (filename, ilScopeRef, ilModule.TryGetRawILModule(), 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 + 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) let ilg = defaultArg ilGlobalsOpt EcmaILGlobals - let ccuinfo = - { FSharpViewOfMetadata=ccu + let ccuinfo = + { FSharpViewOfMetadata=ccu AssemblyAutoOpenAttributes = ilModule.GetAutoOpenAttributes(ilg) AssemblyInternalsVisibleToAttributes = ilModule.GetInternalsVisibleToAttributes(ilg) - FSharpOptimizationData=optdata + FSharpOptimizationData=optdata #if EXTENSIONTYPING IsProviderGenerated = false TypeProviders = [] #endif - ILScopeRef = ilScopeRef } - let phase2() = + ILScopeRef = ilScopeRef } + let phase2() = #if EXTENSIONTYPING - match ilModule.TryGetRawILModule() with + match ilModule.TryGetRawILModule() with | None -> () // no type providers can be used without a real IL Module present | Some ilModule -> ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) @@ -4351,46 +4369,46 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti () #endif data,ccuinfo,phase2) - - // Register all before relinking to cope with mutually-referential ccus + + // Register all before relinking to cope with mutually-referential ccus ccuRawDataAndInfos |> List.iter (p23 >> tcImports.RegisterCcu) - let phase2 () = + let phase2 () = (* Relink *) (* dprintf "Phase2: %s\n" filename; REMOVE DIAGNOSTICS *) ccuRawDataAndInfos |> List.iter (fun (data,_,_) -> data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(m,nm,lookupOnly=false))) |> ignore) #if EXTENSIONTYPING ccuRawDataAndInfos |> List.iter (fun (_,_,phase2) -> phase2()) #endif - ccuRawDataAndInfos |> List.map p23 |> List.map ResolvedImportedAssembly + ccuRawDataAndInfos |> List.map p23 |> List.map ResolvedImportedAssembly phase2 - + member tcImports.RegisterAndPrepareToImportReferencedDll (r:AssemblyResolution) : _*(unit -> AvailableImportedAssembly list)= CheckDisposed() let m = r.originalReference.Range let filename = r.resolvedPath - let contentsOpt = - match r.ProjectReference with + let contentsOpt = + match r.ProjectReference with | Some ilb -> ilb.EvaluateRawContents() | None -> None - let assemblyData = - match contentsOpt with + let assemblyData = + match contentsOpt with | Some ilb -> ilb - | None -> + | None -> let ilModule,ilAssemblyRefs = tcImports.OpenILBinaryModule(filename,m) RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) :> IRawFSharpAssemblyData - let ilShortAssemName = assemblyData.ShortAssemblyName + let ilShortAssemName = assemblyData.ShortAssemblyName let ilScopeRef = assemblyData.ILScopeRef - if tcImports.IsAlreadyRegistered ilShortAssemName then + if tcImports.IsAlreadyRegistered ilShortAssemName then let dllinfo = tcImports.FindDllInfo(m,ilShortAssemName) - let phase2() = [tcImports.FindCcuInfo(m,ilShortAssemName,lookupOnly=true)] + let phase2() = [tcImports.FindCcuInfo(m,ilShortAssemName,lookupOnly=true)] dllinfo,phase2 - else - let dllinfo = - { RawMetadata=assemblyData + else + let dllinfo = + { RawMetadata=assemblyData FileName=filename #if EXTENSIONTYPING ProviderGeneratedAssembly=None @@ -4401,24 +4419,24 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti ILAssemblyRefs = assemblyData.ILAssemblyRefs } tcImports.RegisterDll(dllinfo) let ilg = defaultArg ilGlobalsOpt EcmaILGlobals - let phase2 = - if assemblyData.HasAnyFSharpSignatureDataAttribute then - if not (assemblyData.HasMatchingFSharpSignatureDataAttribute(ilg)) then + let phase2 = + if assemblyData.HasAnyFSharpSignatureDataAttribute then + if not (assemblyData.HasMatchingFSharpSignatureDataAttribute(ilg)) then errorR(Error(FSComp.SR.buildDifferentVersionMustRecompile(filename),m)) tcImports.PrepareToImportReferencedIlDll m filename dllinfo - else + else try tcImports.PrepareToImportReferencedFSharpDll m filename dllinfo with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message),m)) - else + else tcImports.PrepareToImportReferencedIlDll m filename dllinfo dllinfo,phase2 member tcImports.RegisterAndImportReferencedAssemblies (nms:AssemblyResolution list) = CheckDisposed() - let dllinfos,phase2s = - nms |> List.choose + let dllinfos,phase2s = + nms |> List.choose (fun nm -> try Some(tcImports.RegisterAndPrepareToImportReferencedDll nm) @@ -4426,27 +4444,27 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti errorR(Error(FSComp.SR.buildProblemReadingAssembly(nm.resolvedPath, e.Message),nm.originalReference.Range)) None) |> List.unzip - let ccuinfos = (List.collect (fun phase2 -> phase2()) phase2s) + let ccuinfos = (List.collect (fun phase2 -> phase2()) phase2s) dllinfos,ccuinfos - - member tcImports.DoRegisterAndImportReferencedAssemblies(nms) = + + member tcImports.DoRegisterAndImportReferencedAssemblies(nms) = CheckDisposed() tcImports.RegisterAndImportReferencedAssemblies(nms) |> ignore - member tcImports.ImplicitLoadIfAllowed (m, assemblyName, lookupOnly) = + member tcImports.ImplicitLoadIfAllowed (m, assemblyName, lookupOnly) = CheckDisposed() // If the user is asking for the default framework then also try to resolve other implicit assemblies as they are discovered. // Using this flag to mean 'allow implicit discover of assemblies'. let tcConfig = tcConfigP.Get() - if not lookupOnly && tcConfig.implicitlyResolveAssemblies then - let tryFile speculativeFileName = + if not lookupOnly && tcConfig.implicitlyResolveAssemblies then + let tryFile speculativeFileName = let foundFile = tcImports.TryResolveAssemblyReference (AssemblyReference (m, speculativeFileName, None), ResolveAssemblyReferenceMode.Speculative) - match foundFile with + match foundFile with | OkResult (warns, res) -> ReportWarnings warns tcImports.DoRegisterAndImportReferencedAssemblies(res) true - | ErrorResult (_warns, _err) -> + | ErrorResult (_warns, _err) -> // Throw away warnings and errors - this is speculative loading false @@ -4454,87 +4472,87 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti else tryFile (assemblyName + ".exe") |> ignore #if EXTENSIONTYPING - member tcImports.TryFindProviderGeneratedAssemblyByName(assemblyName:string) : System.Reflection.Assembly option = + member tcImports.TryFindProviderGeneratedAssemblyByName(assemblyName:string) : System.Reflection.Assembly option = // The assembly may not be in the resolutions, but may be in the load set including EST injected assemblies - match tcImports.TryFindDllInfo (range0,assemblyName,lookupOnly=true) with - | Some res -> + match tcImports.TryFindDllInfo (range0,assemblyName,lookupOnly=true) with + | Some res -> // Provider-generated assemblies don't necessarily have an on-disk representation we can load. - res.ProviderGeneratedAssembly + res.ProviderGeneratedAssembly | _ -> None #endif - member tcImports.TryFindExistingFullyQualifiedPathFromAssemblyRef(assref:ILAssemblyRef) : string option = - match resolutions.TryFindByExactILAssemblyRef assref with + member tcImports.TryFindExistingFullyQualifiedPathFromAssemblyRef(assref:ILAssemblyRef) : string option = + match resolutions.TryFindByExactILAssemblyRef assref with | Some r -> Some r.resolvedPath | None -> None (* // The assembly may not be in the resolutions, but may be in the load set including EST injected assemblies let assemblyName = assref.Name - match tcImports.TryFindDllInfo (range0,assemblyName,lookupOnly=true) with - | Some res -> + match tcImports.TryFindDllInfo (range0,assemblyName,lookupOnly=true) with + | Some res -> #if EXTENSIONTYPING // Provider-generated assemblies don't necessarily have an on-disk representation we can load. - if res.IsProviderGenerated then None else + if res.IsProviderGenerated then None else #endif Some res.FileName | _ -> None *) - member tcImports.TryResolveAssemblyReference(assemblyReference:AssemblyReference,mode:ResolveAssemblyReferenceMode) : OperationResult = + member tcImports.TryResolveAssemblyReference(assemblyReference:AssemblyReference,mode:ResolveAssemblyReferenceMode) : OperationResult = let tcConfig = tcConfigP.Get() // First try to lookup via the original reference text. match resolutions.TryFindByOriginalReference assemblyReference with - | Some assemblyResolution -> + | Some assemblyResolution -> ResultD [assemblyResolution] | None -> #if NO_MSBUILD_REFERENCE_RESOLUTION - try + try ResultD [tcConfig.ResolveLibWithDirectories assemblyReference] - with e -> + with e -> ErrorD(e) -#else +#else // Next try to lookup up by the exact full resolved path. - match resolutions.TryFindByResolvedPath assemblyReference.Text with - | Some assemblyResolution -> + match resolutions.TryFindByResolvedPath assemblyReference.Text with + | Some assemblyResolution -> ResultD [assemblyResolution] - | None -> + | None -> if tcConfigP.Get().useSimpleResolution then - let action = - match mode with + let action = + match mode with | ResolveAssemblyReferenceMode.ReportErrors -> CcuLoadFailureAction.RaiseError | ResolveAssemblyReferenceMode.Speculative -> CcuLoadFailureAction.ReturnNone - match tcConfig.ResolveLibWithDirectories action assemblyReference with - | Some resolved -> + match tcConfig.ResolveLibWithDirectories action assemblyReference with + | Some resolved -> resolutions <- resolutions.AddResolutionResults [resolved] ResultD [resolved] | None -> ErrorD(AssemblyNotResolved(assemblyReference.Text,assemblyReference.Range)) - else + else // This is a previously unencounterd assembly. Resolve it and add it to the list. // But don't cache resolution failures because the assembly may appear on the disk later. let resolved,unresolved = TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig,[ assemblyReference ],assemblyReference.Range,mode) match resolved,unresolved with - | (assemblyResolution::_,_) -> + | (assemblyResolution::_,_) -> resolutions <- resolutions.AddResolutionResults resolved ResultD [assemblyResolution] - | (_,_::_) -> + | (_,_::_) -> resolutions <- resolutions.AddUnresolvedReferences unresolved ErrorD(AssemblyNotResolved(assemblyReference.Text,assemblyReference.Range)) - | [],[] -> + | [],[] -> // Note, if mode=ResolveAssemblyReferenceMode.Speculative and the resolution failed then TryResolveLibsUsingMSBuildRules returns // the empty list and we convert the failure into an AssemblyNotResolved here. ErrorD(AssemblyNotResolved(assemblyReference.Text,assemblyReference.Range)) - + #endif - - member tcImports.ResolveAssemblyReference(assemblyReference,mode) : AssemblyResolution list = + + member tcImports.ResolveAssemblyReference(assemblyReference,mode) : AssemblyResolution list = CommitOperationResult(tcImports.TryResolveAssemblyReference(assemblyReference,mode)) // Note: This returns a TcImports object. However, framework TcImports are not currently disposed. The only reason // we dispose TcImports is because we need to dispose type providers, and type providers are never included in the framework DLL set. // - // If this ever changes then callers may need to begin disposing the TcImports (though remember, not before all derived + // If this ever changes then callers may need to begin disposing the TcImports (though remember, not before all derived // non-frameworkk TcImports built related to this framework TcImports are disposed). static member BuildFrameworkTcImports (tcConfigP:TcConfigProvider, frameworkDLLs, nonFrameworkDLLs) = @@ -4543,13 +4561,13 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,nonFrameworkDLLs,[]) // Note: TcImports are disposable - the caller owns this object and must dispose - let frameworkTcImports = new TcImports(tcConfigP,tcResolutions,None,None) - let resolveAssembly loadFailureAction r = + let frameworkTcImports = new TcImports(tcConfigP,tcResolutions,None,None) + let resolveAssembly loadFailureAction r = // use existing resolutions before trying to search in known folders let resolution = match tcResolutions.TryFindByOriginalReference r with | Some r -> Some r - | None -> + | None -> match tcAltResolutions.TryFindByOriginalReference r with | Some r -> Some r | None -> tcConfig.ResolveLibWithDirectories loadFailureAction r @@ -4557,82 +4575,82 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | Some resolution -> match frameworkTcImports.RegisterAndImportReferencedAssemblies([resolution]) with | (_, [ResolvedImportedAssembly(ccu)]) -> Some ccu - | _ -> + | _ -> match loadFailureAction with | CcuLoadFailureAction.RaiseError -> error(InternalError("BuildFoundationalTcImports: no ccu for " + r.Text, rangeStartup)) | CcuLoadFailureAction.ReturnNone -> None | None -> None - + let ccuInitializer = tcConfig.GetPrimaryAssemblyCcuInitializer() - let ilGlobals, state = ccuInitializer.BeginLoadingSystemRuntime((resolveAssembly CcuLoadFailureAction.RaiseError) >> Option.get, tcConfig.noDebugData) + let ilGlobals, state = ccuInitializer.BeginLoadingSystemRuntime((resolveAssembly CcuLoadFailureAction.RaiseError) >> Option.get, 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 (tcResolutions.GetAssemblyResolutions()) - let fslibCcu = - if tcConfig.compilingFslib then + let fslibCcu = + if tcConfig.compilingFslib then // When compiling FSharp.Core.dll, the fslibCcu reference to FSharp.Core.dll is a delayed ccu thunk fixed up during type checking CcuThunk.CreateDelayed(GetFSharpCoreLibraryName()) else let fslibCcuInfo = let coreLibraryReference = tcConfig.CoreLibraryDllReference() - - let resolvedAssemblyRef = + + let resolvedAssemblyRef = match tcResolutions.TryFindByOriginalReference coreLibraryReference with | Some resolution -> Some resolution - | _ -> + | _ -> // Are we using a "non-cannonical" FSharp.Core? match tcAltResolutions.TryFindByOriginalReference coreLibraryReference with | Some resolution -> Some resolution | _ -> tcResolutions.TryFindByOriginalReferenceText (GetFSharpCoreLibraryName()) // was the ".dll" elided? - - match resolvedAssemblyRef with - | Some coreLibraryResolution -> + + match resolvedAssemblyRef with + | Some coreLibraryResolution -> match frameworkTcImports.RegisterAndImportReferencedAssemblies([coreLibraryResolution]) with | (_, [ResolvedImportedAssembly(fslibCcuInfo) ]) -> fslibCcuInfo - | _ -> + | _ -> error(InternalError("BuildFrameworkTcImports: no successful import of "+coreLibraryResolution.resolvedPath,coreLibraryResolution.originalReference.Range)) - | None -> + | None -> error(InternalError(sprintf "BuildFrameworkTcImports: no resolution of '%s'" coreLibraryReference.Text,rangeStartup)) - IlxSettings.ilxFsharpCoreLibAssemRef := + IlxSettings.ilxFsharpCoreLibAssemRef := (let scoref = fslibCcuInfo.ILScopeRef match scoref with | ILScopeRef.Assembly aref -> Some aref | ILScopeRef.Local | ILScopeRef.Module _ -> error(InternalError("not ILScopeRef.Assembly",rangeStartup))) - fslibCcuInfo.FSharpViewOfMetadata - + fslibCcuInfo.FSharpViewOfMetadata + let sysCcus = - [| yield sysCcu.FSharpViewOfMetadata - yield! frameworkTcImports.GetCcusInDeclOrder() - for dllName in SystemAssemblies tcConfig.primaryAssembly.Name do - match frameworkTcImports.CcuTable.TryFind dllName with + [| yield sysCcu.FSharpViewOfMetadata + yield! frameworkTcImports.GetCcusInDeclOrder() + for dllName in SystemAssemblies tcConfig.primaryAssembly.Name do + match frameworkTcImports.CcuTable.TryFind dllName with | Some sysCcu -> yield sysCcu.FSharpViewOfMetadata | None -> () |] // Search for a type let getTypeCcu nsname typeName = - if ccuHasType sysCcu.FSharpViewOfMetadata nsname typeName then + if ccuHasType sysCcu.FSharpViewOfMetadata nsname typeName then sysCcu.FSharpViewOfMetadata else let search = sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu nsname typeName) - match search with + match search with | Some x -> x | None -> fslibCcu - + // REVIEW: We use this in some places to work around bugs in the 2.0 runtime. // 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.traits.ScopeRef.AssemblyRef.Version with - | Some (v1, _v2, _v3, _v4) -> v1 >= 4us + let using40environment = + 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.isInteractive,getTypeCcu, tcConfig.emitDebugInfoInQuotations) + tcConfig.isInteractive,getTypeCcu, tcConfig.emitDebugInfoInQuotations) #if DEBUG // the global_g reference cell is used only for debug printing @@ -4642,22 +4660,22 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti #if NO_INLINE_IL_PARSER // inline IL not permitted by hostable compiler #else - Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiConstants.parseILGlobals := tcGlobals.ilg + Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiConstants.parseILGlobals := tcGlobals.ilg #endif frameworkTcImports.SetTcGlobals(tcGlobals) tcGlobals,frameworkTcImports member tcImports.ReportUnresolvedAssemblyReferences(knownUnresolved) = // Report that an assembly was not resolved. - let reportAssemblyNotResolved(file,originalReferences:AssemblyReference list) = + let reportAssemblyNotResolved(file,originalReferences:AssemblyReference list) = originalReferences |> List.iter(fun originalReference -> errorR(AssemblyNotResolved(file,originalReference.Range))) knownUnresolved |> List.map (function UnresolvedAssemblyReference(file,originalReferences) -> file,originalReferences) |> List.iter reportAssemblyNotResolved - - // Note: This returns a TcImports object. TcImports are disposable - the caller owns the returned TcImports object - // and when hosted in Visual Studio or another long-running process must dispose this object. - static member BuildNonFrameworkTcImports (tcConfigP:TcConfigProvider, tcGlobals:TcGlobals, baseTcImports, nonFrameworkReferences, knownUnresolved) = + + // Note: This returns a TcImports object. TcImports are disposable - the caller owns the returned TcImports object + // and when hosted in Visual Studio or another long-running process must dispose this object. + static member BuildNonFrameworkTcImports (tcConfigP:TcConfigProvider, tcGlobals:TcGlobals, baseTcImports, nonFrameworkReferences, knownUnresolved) = let tcConfig = tcConfigP.Get() let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,nonFrameworkReferences,knownUnresolved) let references = tcResolutions.GetAssemblyResolutions() @@ -4665,13 +4683,13 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti tcImports.DoRegisterAndImportReferencedAssemblies(references) tcImports.ReportUnresolvedAssemblyReferences(knownUnresolved) tcImports - - interface System.IDisposable with - member tcImports.Dispose() = + + interface System.IDisposable with + member tcImports.Dispose() = CheckDisposed() - // disposing deliberately only closes this tcImports, not the ones up the chain - disposed <- true - if verbose then + // disposing deliberately only closes this tcImports, not the ones up the chain + disposed <- true + if verbose then dprintf "disposing of TcImports, %d binaries\n" disposeActions.Length let actions = disposeActions disposeActions <- [] @@ -4679,148 +4697,148 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti /// Process #r in F# Interactive. /// Adds the reference to the tcImports and add the ccu to the type checking environment. -let RequireDLL (tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = +let RequireDLL (tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = let resolutions = CommitOperationResult(tcImports.TryResolveAssemblyReference(AssemblyReference(m,file,None),ResolveAssemblyReferenceMode.ReportErrors)) let dllinfos,ccuinfos = tcImports.RegisterAndImportReferencedAssemblies(resolutions) - - let asms = + + let asms = ccuinfos |> List.map (function | ResolvedImportedAssembly(asm) -> asm | UnresolvedImportedAssembly(assemblyName) -> error(Error(FSComp.SR.buildCouldNotResolveAssemblyRequiredByFile(assemblyName,file),m))) let g = tcImports.GetTcGlobals() let amap = tcImports.GetImportMap() - let tcEnv = (tcEnv, asms) ||> List.fold (fun tcEnv asm -> AddCcuToTcEnv(g,amap,m,tcEnv,thisAssemblyName,asm.FSharpViewOfMetadata,asm.AssemblyAutoOpenAttributes,asm.AssemblyInternalsVisibleToAttributes)) + let tcEnv = (tcEnv, asms) ||> List.fold (fun tcEnv asm -> AddCcuToTcEnv(g,amap,m,tcEnv,thisAssemblyName,asm.FSharpViewOfMetadata,asm.AssemblyAutoOpenAttributes,asm.AssemblyInternalsVisibleToAttributes)) tcEnv,(dllinfos,asms) - - -let ProcessMetaCommandsFromInput + + +let ProcessMetaCommandsFromInput (nowarnF: 'state -> range * string -> 'state, dllRequireF: 'state -> range * string -> 'state, - loadSourceF: 'state -> range * string -> unit) - (tcConfig:TcConfigBuilder) - inp + loadSourceF: 'state -> range * string -> unit) + (tcConfig:TcConfigBuilder) + inp pathOfMetaCommandSource state0 = - + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - let canHaveScriptMetaCommands = - match inp with + let canHaveScriptMetaCommands = + match inp with | ParsedInput.SigFile(_) -> false | ParsedInput.ImplFile(ParsedImplFileInput(_,isScript,_,_,_,_,_)) -> isScript let ProcessMetaCommand state hash = let mutable matchedm = range0 - try - match hash with + try + match hash with | ParsedHashDirective("I",args,m) -> - if not canHaveScriptMetaCommands then + if not canHaveScriptMetaCommands then errorR(HashIncludeNotAllowedInNonScript(m)) - match args with - | [path] -> + match args with + | [path] -> matchedm<-m tcConfig.AddIncludePath(m,path,pathOfMetaCommandSource) state - | _ -> + | _ -> errorR(Error(FSComp.SR.buildInvalidHashIDirective(),m)) state | ParsedHashDirective("nowarn",numbers,m) -> List.fold (fun state d -> nowarnF state (m,d)) state numbers - | ParsedHashDirective(("reference" | "r"),args,m) -> - if not canHaveScriptMetaCommands then + | ParsedHashDirective(("reference" | "r"),args,m) -> + if not canHaveScriptMetaCommands then errorR(HashReferenceNotAllowedInNonScript(m)) - match args with - | [path] -> + match args with + | [path] -> matchedm<-m dllRequireF state (m,path) - | _ -> + | _ -> errorR(Error(FSComp.SR.buildInvalidHashrDirective(),m)) state - | ParsedHashDirective("load",args,m) -> - if not canHaveScriptMetaCommands then + | ParsedHashDirective("load",args,m) -> + if not canHaveScriptMetaCommands then errorR(HashDirectiveNotAllowedInNonScript(m)) - match args with - | _ :: _ -> + match args with + | _ :: _ -> matchedm<-m args |> List.iter (fun path -> loadSourceF state (m,path)) - | _ -> + | _ -> errorR(Error(FSComp.SR.buildInvalidHashloadDirective(),m)) state - | ParsedHashDirective("time",args,m) -> - if not canHaveScriptMetaCommands then + | ParsedHashDirective("time",args,m) -> + if not canHaveScriptMetaCommands then errorR(HashDirectiveNotAllowedInNonScript(m)) - match args with - | [] -> + match args with + | [] -> () - | ["on" | "off"] -> + | ["on" | "off"] -> () - | _ -> + | _ -> errorR(Error(FSComp.SR.buildInvalidHashtimeDirective(),m)) state - - | _ -> - - (* warning(Error("This meta-command has been ignored",m)) *) + + | _ -> + + (* warning(Error("This meta-command has been ignored",m)) *) state with e -> errorRecovery e matchedm; state - let rec WarnOnIgnoredSpecDecls decls = - decls |> List.iter (fun d -> - match d with - | SynModuleSigDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) + let rec WarnOnIgnoredSpecDecls decls = + decls |> List.iter (fun d -> + match d with + | SynModuleSigDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) | SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls | _ -> ()) - let rec WarnOnIgnoredImplDecls decls = - decls |> List.iter (fun d -> - match d with - | SynModuleDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) + let rec WarnOnIgnoredImplDecls decls = + decls |> List.iter (fun d -> + match d with + | SynModuleDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) | SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls | _ -> ()) let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) = - List.fold (fun s d -> - match d with + List.fold (fun s d -> + match d with | SynModuleSigDecl.HashDirective (h,_) -> ProcessMetaCommand s h | SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls; s | _ -> s) state - decls + decls let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) = - List.fold (fun s d -> - match d with + List.fold (fun s d -> + match d with | SynModuleDecl.HashDirective (h,_) -> ProcessMetaCommand s h | SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls; s | _ -> s) state decls - match inp with - | ParsedInput.SigFile(ParsedSigFileInput(_,_,_,hashDirectives,specs)) -> + match inp with + | ParsedInput.SigFile(ParsedSigFileInput(_,_,_,hashDirectives,specs)) -> let state = List.fold ProcessMetaCommand state0 hashDirectives let state = List.fold ProcessMetaCommandsFromModuleSpec state specs state - | ParsedInput.ImplFile(ParsedImplFileInput(_,_,_,_,hashDirectives,impls,_)) -> + | ParsedInput.ImplFile(ParsedImplFileInput(_,_,_,_,hashDirectives,impls,_)) -> let state = List.fold ProcessMetaCommand state0 hashDirectives let state = List.fold ProcessMetaCommandsFromModuleImpl state impls state -let ApplyNoWarnsToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = +let ApplyNoWarnsToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = // Clone - let tcConfigB = tcConfig.CloneOfOriginalBuilder + let tcConfigB = tcConfig.CloneOfOriginalBuilder let addNoWarn = fun () (m,s) -> tcConfigB.TurnWarningOff(m,s) let addReferencedAssemblyByPath = fun () (_m,_s) -> () let addLoadedSource = fun () (_m,_s) -> () ProcessMetaCommandsFromInput (addNoWarn, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () TcConfig.Create(tcConfigB,validate=false) -let ApplyMetaCommandsFromInputToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = +let ApplyMetaCommandsFromInputToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = // Clone - let tcConfigB = tcConfig.CloneOfOriginalBuilder - let getWarningNumber = fun () _ -> () + let tcConfigB = tcConfig.CloneOfOriginalBuilder + let getWarningNumber = fun () _ -> () let addReferencedAssemblyByPath = fun () (m,s) -> tcConfigB.AddReferencedAssemblyByPath(m,s) let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () @@ -4835,9 +4853,9 @@ let GetAssemblyResolutionInformation(tcConfig : TcConfig) = let assemblyList = TcAssemblyResolutions.GetAllDllReferences(tcConfig) let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,[]) resolutions.GetAssemblyResolutions(),resolutions.GetUnresolvedReferences() - + [] -type LoadClosure = +type LoadClosure = { /// The source files along with the ranges of the #load positions in each file. SourceFiles: (string * range list) list /// The resolved references along with the ranges of the #r positions in each file. @@ -4851,7 +4869,7 @@ type LoadClosure = /// Errors seen while parsing root of closure RootErrors : PhasedError list /// Warnings seen while parsing root of closure - RootWarnings : PhasedError list } + RootWarnings : PhasedError list } [] @@ -4859,131 +4877,131 @@ type CodeContext = | Evaluation // in fsi.exe | Compilation // in fsc.exe | Editing // in VS - -module private ScriptPreprocessClosure = + +module private ScriptPreprocessClosure = open Internal.Utilities.Text.Lexing - + /// Represents an input to the closure finding process - type ClosureSource = ClosureSource of filename: string * referenceRange: range * sourceText: string * parseRequired: bool - + type ClosureSource = ClosureSource of filename: string * referenceRange: range * sourceText: string * parseRequired: bool + /// Represents an output of the closure finding process type ClosureFile = ClosureFile of string * range * ParsedInput option * PhasedError list * PhasedError list * (string * range) list // filename, range, errors, warnings, nowarns type Observed() = let seen = System.Collections.Generic.Dictionary<_,bool>() - member ob.SetSeen(check) = - if not(seen.ContainsKey(check)) then + member ob.SetSeen(check) = + if not(seen.ContainsKey(check)) then seen.Add(check,true) - + member ob.HaveSeen(check) = seen.ContainsKey(check) - + /// Parse a script from source. - let ParseScriptText(filename:string, source:string, tcConfig:TcConfig, codeContext, lexResourceManager:Lexhelp.LexResourceManager, errorLogger:ErrorLogger) = + let ParseScriptText(filename:string, source:string, tcConfig:TcConfig, codeContext, lexResourceManager:Lexhelp.LexResourceManager, errorLogger:ErrorLogger) = // fsc.exe -- COMPILED\!INTERACTIVE // fsi.exe -- !COMPILED\INTERACTIVE // Language service // .fs -- EDITING + COMPILED\!INTERACTIVE - // .fsx -- EDITING + !COMPILED\INTERACTIVE + // .fsx -- EDITING + !COMPILED\INTERACTIVE let defines = - match codeContext with + match codeContext with | CodeContext.Evaluation -> ["INTERACTIVE"] | CodeContext.Compilation -> ["COMPILED"] | CodeContext.Editing -> "EDITING" :: (if IsScript filename then ["INTERACTIVE"] else ["COMPILED"]) - let lexbuf = UnicodeLexing.StringAsLexbuf source - + let lexbuf = UnicodeLexing.StringAsLexbuf source + let isLastCompiland = (IsScript filename), tcConfig.target.IsExe // The root compiland is last in the list of compilands. - ParseOneInputLexbuf (tcConfig,lexResourceManager,defines,lexbuf,filename,isLastCompiland,errorLogger) - + ParseOneInputLexbuf (tcConfig,lexResourceManager,defines,lexbuf,filename,isLastCompiland,errorLogger) + /// Create a TcConfig for load closure starting from a single .fsx file - let CreateScriptSourceTcConfig (referenceResolver, filename:string, codeContext, useSimpleResolution, useFsiAuxLib, basicReferences, applyCommandLineArgs) = + let CreateScriptSourceTcConfig (referenceResolver, filename:string, codeContext, useSimpleResolution, useFsiAuxLib, basicReferences, applyCommandLineArgs) = let projectDir = Path.GetDirectoryName(filename) let isInteractive = (codeContext = CodeContext.Evaluation) let isInvalidationSupported = (codeContext = CodeContext.Editing) // always use primary assembly = mscorlib for scripts - let tcConfigB = TcConfigBuilder.CreateNew(referenceResolver, Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value, true (* optimize for memory *), projectDir, isInteractive, isInvalidationSupported) + let tcConfigB = TcConfigBuilder.CreateNew(referenceResolver, Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value, true (* optimize for memory *), projectDir, isInteractive, isInvalidationSupported) applyCommandLineArgs tcConfigB - match basicReferences with + match basicReferences with | None -> BasicReferencesForScriptLoadClosure(useSimpleResolution, useFsiAuxLib) |> List.iter(fun f->tcConfigB.AddReferencedAssemblyByPath(range0,f)) // Add script references | Some rs -> for m,r in rs do tcConfigB.AddReferencedAssemblyByPath(m,r) tcConfigB.resolutionEnvironment <- - match codeContext with + match codeContext with | CodeContext.Editing -> ReferenceResolver.DesignTimeLike #if FX_MSBUILDRESOLVER_RUNTIMELIKE | CodeContext.Compilation | CodeContext.Evaluation -> ReferenceResolver.RuntimeLike #else | CodeContext.Compilation | CodeContext.Evaluation -> ReferenceResolver.CompileTimeLike #endif - tcConfigB.framework <- false + tcConfigB.framework <- false tcConfigB.useSimpleResolution <- useSimpleResolution // Indicates that there are some references not in BasicReferencesForScriptLoadClosure which should // be added conditionally once the relevant version of mscorlib.dll has been detected. - tcConfigB.addVersionSpecificFrameworkReferences <- true + tcConfigB.addVersionSpecificFrameworkReferences <- true tcConfigB.implicitlyResolveAssemblies <- false TcConfig.Create(tcConfigB,validate=true) - - let ClosureSourceOfFilename(filename,m,inputCodePage,parseRequired) = + + let ClosureSourceOfFilename(filename,m,inputCodePage,parseRequired) = try let filename = FileSystem.GetFullPathShim(filename) use stream = FileSystem.FileStreamReadShim filename - use reader = - match inputCodePage with + use reader = + match inputCodePage with | None -> new StreamReader(stream,true) - | Some n -> new StreamReader(stream,Encoding.GetEncodingShim(n)) + | Some n -> new StreamReader(stream,Encoding.GetEncodingShim(n)) let source = reader.ReadToEnd() [ClosureSource(filename,m,source,parseRequired)] - with e -> - errorRecovery e m + with e -> + errorRecovery e m [] - - let ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = - let tcConfigB = tcConfig.CloneOfOriginalBuilder - let nowarns = ref [] + + let ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = + let tcConfigB = tcConfig.CloneOfOriginalBuilder + let nowarns = ref [] let getWarningNumber = fun () (m,s) -> nowarns := (s,m) :: !nowarns let addReferencedAssemblyByPath = fun () (m,s) -> tcConfigB.AddReferencedAssemblyByPath(m,s) let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) - try + try ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () with ReportedError _ -> // Recover by using whatever did end up in the tcConfig () - + try TcConfig.Create(tcConfigB,validate=false),nowarns with ReportedError _ -> // Recover by using a default TcConfig. - let tcConfigB = tcConfig.CloneOfOriginalBuilder + let tcConfigB = tcConfig.CloneOfOriginalBuilder TcConfig.Create(tcConfigB,validate=false),nowarns - + let FindClosureFiles(closureSources,tcConfig:TcConfig,codeContext,lexResourceManager:Lexhelp.LexResourceManager) = let tcConfig = ref tcConfig - + let observedSources = Observed() - let rec loop (ClosureSource(filename,m,source,parseRequired)) = + let rec loop (ClosureSource(filename,m,source,parseRequired)) = [ if not (observedSources.HaveSeen(filename)) then observedSources.SetSeen(filename) //printfn "visiting %s" filename - if IsScript(filename) || parseRequired then + if IsScript(filename) || parseRequired then let errors = ref [] - let warnings = ref [] - let errorLogger = - { new ErrorLogger("FindClosure") with + let warnings = ref [] + let errorLogger = + { new ErrorLogger("FindClosure") with member x.ErrorSinkImpl(e) = errors := e :: !errors member x.WarnSinkImpl(e) = warnings := e :: !warnings - member x.ErrorCount = (!errors).Length } + member x.ErrorCount = (!errors).Length } use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) let pathOfMetaCommandSource = Path.GetDirectoryName(filename) - match ParseScriptText(filename,source,!tcConfig,codeContext,lexResourceManager,errorLogger) with - | Some parsedScriptAst -> + match ParseScriptText(filename,source,!tcConfig,codeContext,lexResourceManager,errorLogger) with + | Some parsedScriptAst -> let preSources = (!tcConfig).GetAvailableLoadedSources() let tcConfigResult, noWarns = ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn !tcConfig (parsedScriptAst,pathOfMetaCommandSource) tcConfig := tcConfigResult // We accumulate the tcConfig in order to collect assembly references - + let postSources = (!tcConfig).GetAvailableLoadedSources() let sources = if preSources.Length < postSources.Length then postSources.[preSources.Length..] else [] @@ -4991,35 +5009,35 @@ module private ScriptPreprocessClosure = // printfn "visiting %s - has subsource of %s " filename subFile for (m,subFile) in sources do - if IsScript(subFile) then + if IsScript(subFile) then for subSource in ClosureSourceOfFilename(subFile,m,tcConfigResult.inputCodePage,false) do yield! loop subSource else - yield ClosureFile(subFile, m, None, [], [], []) + yield ClosureFile(subFile, m, None, [], [], []) //printfn "yielding source %s" filename yield ClosureFile(filename, m, Some parsedScriptAst, !errors, !warnings, !noWarns) - | None -> + | None -> //printfn "yielding source %s (failed parse)" filename yield ClosureFile(filename, m, None, !errors, !warnings, []) - else + else // Don't traverse into .fs leafs. //printfn "yielding non-script source %s" filename yield ClosureFile(filename, m, None, [], [], []) ] closureSources |> List.map loop |> List.concat, !tcConfig - + /// Reduce the full directive closure into LoadClosure - let GetLoadClosure(rootFilename,closureFiles,tcConfig:TcConfig,codeContext) = - - // Mark the last file as isLastCompiland. + let GetLoadClosure(rootFilename,closureFiles,tcConfig:TcConfig,codeContext) = + + // Mark the last file as isLastCompiland. let closureFiles = - if List.isEmpty closureFiles then - closureFiles - else + if List.isEmpty closureFiles then + closureFiles + else match List.frontAndBack closureFiles with - | rest, ClosureFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,_))),errs,warns,nowarns) -> + | rest, ClosureFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,_))),errs,warns,nowarns) -> rest @ [ClosureFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,(true, tcConfig.target.IsExe)))),errs,warns,nowarns)] | _ -> closureFiles @@ -5029,57 +5047,57 @@ module private ScriptPreprocessClosure = let globalNoWarns = closureFiles |> List.collect (fun (ClosureFile(_,_,_,_,_,noWarns)) -> noWarns) // Resolve all references. - let references, unresolvedReferences, resolutionWarnings, resolutionErrors = + let references, unresolvedReferences, resolutionWarnings, resolutionErrors = let resolutionErrors = ref [] - let resolutionWarnings = ref [] - let errorLogger = - { new ErrorLogger("GetLoadClosure") with + let resolutionWarnings = ref [] + let errorLogger = + { new ErrorLogger("GetLoadClosure") with member x.ErrorSinkImpl(e) = resolutionErrors := e :: !resolutionErrors member x.WarnSinkImpl(e) = resolutionWarnings := e :: !resolutionWarnings - member x.ErrorCount = (!resolutionErrors).Length } - - use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) + member x.ErrorCount = (!resolutionErrors).Length } + + use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) let references,unresolvedReferences = GetAssemblyResolutionInformation(tcConfig) let references = references |> List.map (fun ar -> ar.resolvedPath,ar) references, unresolvedReferences, resolutionWarnings, resolutionErrors // Root errors and warnings - look at the last item in the closureFiles list - let rootErrors, rootWarnings = + let rootErrors, rootWarnings = match List.rev closureFiles with | ClosureFile(_,_,_,errors,warnings,_) :: _ -> errors @ !resolutionErrors, warnings @ !resolutionWarnings | _ -> [],[] // When no file existed. - + let isRootRange exn = match GetRangeOfError exn with - | Some m -> + | Some m -> // Return true if the error was *not* from a #load-ed file. let isArgParameterWhileNotEditing = (codeContext <> CodeContext.Editing) && (m = range0 || m = rangeStartup || m = rangeCmdArgs) let isThisFileName = (0 = String.Compare(rootFilename, m.FileName, StringComparison.OrdinalIgnoreCase)) isArgParameterWhileNotEditing || isThisFileName | None -> true - + // Filter out non-root errors and warnings let rootErrors = rootErrors |> List.filter isRootRange let rootWarnings = rootWarnings |> List.filter isRootRange - - let result : LoadClosure = + + let result : LoadClosure = { SourceFiles = List.groupByFirst sourceFiles References = List.groupByFirst references UnresolvedReferences = unresolvedReferences Inputs = sourceInputs NoWarns = List.groupByFirst globalNoWarns RootErrors = rootErrors - RootWarnings = rootWarnings} + RootWarnings = rootWarnings} result /// Given source text, find the full load closure. Used from service.fs, when editing a script file - let GetFullClosureOfScriptSource(referenceResolver,filename,source,codeContext,useSimpleResolution,useFsiAuxLib,lexResourceManager:Lexhelp.LexResourceManager,applyCommmandLineArgs) = + let GetFullClosureOfScriptSource(referenceResolver,filename,source,codeContext,useSimpleResolution,useFsiAuxLib,lexResourceManager:Lexhelp.LexResourceManager,applyCommmandLineArgs) = // Resolve the basic references such as FSharp.Core.dll first, before processing any #I directives in the script // // This is tries to mimic the action of running the script in F# Interactive - the initial context for scripting is created // first, then #I and other directives are processed. - let references0 = + let references0 = let tcConfig = CreateScriptSourceTcConfig(referenceResolver,filename,codeContext,useSimpleResolution,useFsiAuxLib,None,applyCommmandLineArgs) let resolutions0,_unresolvedReferences = GetAssemblyResolutionInformation(tcConfig) let references0 = resolutions0 |> List.map (fun r->r.originalReference.Range,r.resolvedPath) |> Seq.distinct |> List.ofSeq @@ -5090,40 +5108,40 @@ module private ScriptPreprocessClosure = let closureSources = [ClosureSource(filename,range0,source,true)] let closureFiles,tcConfig = FindClosureFiles(closureSources,tcConfig,codeContext,lexResourceManager) GetLoadClosure(filename,closureFiles,tcConfig,codeContext) - + /// Given source filename, find the full load closure /// Used from fsi.fs and fsc.fs, for #load and command line - let GetFullClosureOfScriptFiles(tcConfig:TcConfig,files:(string*range) list,codeContext,_useDefaultScriptingReferences:bool,lexResourceManager:Lexhelp.LexResourceManager) = + let GetFullClosureOfScriptFiles(tcConfig:TcConfig,files:(string*range) list,codeContext,_useDefaultScriptingReferences:bool,lexResourceManager:Lexhelp.LexResourceManager) = let mainFile = fst (List.last files) - let closureSources = files |> List.map (fun (filename,m) -> ClosureSourceOfFilename(filename,m,tcConfig.inputCodePage,true)) |> List.concat + let closureSources = files |> List.map (fun (filename,m) -> ClosureSourceOfFilename(filename,m,tcConfig.inputCodePage,true)) |> List.concat let closureFiles,tcConfig = FindClosureFiles(closureSources,tcConfig,codeContext,lexResourceManager) - GetLoadClosure(mainFile,closureFiles,tcConfig,codeContext) + GetLoadClosure(mainFile,closureFiles,tcConfig,codeContext) type LoadClosure with // Used from service.fs, when editing a script file - static member ComputeClosureOfSourceText(referenceResolver,filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs) : LoadClosure = + static member ComputeClosureOfSourceText(referenceResolver,filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs) : LoadClosure = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) ScriptPreprocessClosure.GetFullClosureOfScriptSource(referenceResolver,filename,source,codeContext,useSimpleResolution,useFsiAuxLib, lexResourceManager, applyCommmandLineArgs) /// Used from fsi.fs and fsc.fs, for #load and command line. /// The resulting references are then added to a TcConfig. - static member ComputeClosureOfSourceFiles (tcConfig:TcConfig, files:(string*range) list, codeContext, useDefaultScriptingReferences:bool, lexResourceManager:Lexhelp.LexResourceManager) = + static member ComputeClosureOfSourceFiles (tcConfig:TcConfig, files:(string*range) list, codeContext, useDefaultScriptingReferences:bool, lexResourceManager:Lexhelp.LexResourceManager) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) ScriptPreprocessClosure.GetFullClosureOfScriptFiles (tcConfig, files, codeContext, useDefaultScriptingReferences, lexResourceManager) - - + + //---------------------------------------------------------------------------- // Initial type checking environment //-------------------------------------------------------------------------- /// Build the initial type checking environment -let GetInitialTcEnv (thisAssemblyName:string, initm:range, tcConfig:TcConfig, tcImports:TcImports, tcGlobals) = +let GetInitialTcEnv (thisAssemblyName:string, initm:range, tcConfig:TcConfig, tcImports:TcImports, tcGlobals) = let initm = initm.StartRange - let ccus = - tcImports.GetImportedAssemblies() - |> List.map (fun asm -> asm.FSharpViewOfMetadata, asm.AssemblyAutoOpenAttributes, asm.AssemblyInternalsVisibleToAttributes) + let ccus = + tcImports.GetImportedAssemblies() + |> List.map (fun asm -> asm.FSharpViewOfMetadata, asm.AssemblyAutoOpenAttributes, asm.AssemblyInternalsVisibleToAttributes) let amap = tcImports.GetImportMap() @@ -5139,7 +5157,7 @@ let GetInitialTcEnv (thisAssemblyName:string, initm:range, tcConfig:TcConfig, tc // Fault injection /// Inject faults into checking -let CheckSimulateException(tcConfig:TcConfig) = +let CheckSimulateException(tcConfig:TcConfig) = match tcConfig.simulateException with | Some("tc-oom") -> raise(System.OutOfMemoryException()) | Some("tc-an") -> raise(System.ArgumentNullException("simulated")) @@ -5165,6 +5183,66 @@ let CheckSimulateException(tcConfig:TcConfig) = | Some("tc-fail") -> failwith "simulated" | _ -> () +#endif //!FABLE_COMPILER + +#if FABLE_COMPILER + +type internal 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> } + +// cut-down TcConfig +type TcConfig() = + member x.implicitIncludeDir = "" + member x.compilingFslib = false + member x.isInteractive = false + member x.mlCompatibility = false + member x.emitDebugInfoInQuotations = false + member x.conditionalCompilationDefines = [] + member x.globalWarnAsError = false + member x.globalWarnLevel = 3 + member x.specificWarnOff: int list = [] + member x.specificWarnOn: int list = [] + member x.specificWarnAsError: int list = [] + member x.specificWarnAsWarn: int list = [] + +// cut-down TcImports +type TcImports() = + let mutable tcGlobalsOpt = None + let mutable ccuMap = Map([]) + + // This is the main "assembly reference --> assembly" resolution routine. + let FindCcuInfo (_, assemblyName) = + match ccuMap |> Map.tryFind assemblyName with + | Some ccuInfo -> ResolvedCcu(ccuInfo.FSharpViewOfMetadata) + | None -> UnresolvedCcu(assemblyName) + + member x.SetTcGlobals g = + tcGlobalsOpt <- Some g + member x.GetTcGlobals() = + tcGlobalsOpt.Value + member x.SetCcuMap m = + ccuMap <- m + member x.GetImportedAssemblies() = + ccuMap.Values + + member x.GetImportMap() = + let loaderInterface = + { new Import.AssemblyLoader with + member x.LoadAssembly (m, ilAssemblyRef) = + FindCcuInfo(m, ilAssemblyRef.Name) + } + new Import.ImportMap (tcGlobalsOpt.Value, loaderInterface) + +#endif //FABLE_COMPILER + //---------------------------------------------------------------------------- // Type-check sets of files //-------------------------------------------------------------------------- @@ -5175,35 +5253,35 @@ type TypecheckerSigsAndImpls = RootSigsAndImpls of RootSigs * RootImpls * Module let qnameOrder = Order.orderBy (fun (q:QualifiedNameOfFile) -> q.Text) -type TcState = +type TcState = { tcsCcu: CcuThunk tcsCcuType: ModuleOrNamespace tcsNiceNameGen: NiceNameGenerator tcsTcSigEnv: TcEnv tcsTcImplEnv: TcEnv - /// The accumulated results of type checking for this assembly + /// The accumulated results of type checking for this assembly tcsRootSigsAndImpls : TypecheckerSigsAndImpls } member x.NiceNameGenerator = x.tcsNiceNameGen member x.TcEnvFromSignatures = x.tcsTcSigEnv member x.TcEnvFromImpls = x.tcsTcImplEnv member x.Ccu = x.tcsCcu - member x.PartialAssemblySignature = + member x.PartialAssemblySignature = let (RootSigsAndImpls(_rootSigs,_rootImpls,_allSigModulTyp,allImplementedSigModulTyp)) = x.tcsRootSigsAndImpls allImplementedSigModulTyp - - member x.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) = + + member x.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) = { x with tcsTcSigEnv = tcEnvAtEndOfLastInput - tcsTcImplEnv = tcEnvAtEndOfLastInput } + tcsTcImplEnv = tcEnvAtEndOfLastInput } + - /// Create the initial type checking state for compiling an assembly let GetInitialTcState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImports,niceNameGen,tcEnv0) = ignore tcImports - // Create a ccu to hold all the results of compilation + // Create a ccu to hold all the results of compilation let ccuType = NewCcuContents ILScopeRef.Local m ccuName (NewEmptyModuleOrNamespaceType Namespace) - let ccuData : CcuData = + let ccuData : CcuData = { IsFSharp=true UsesFSharp20PlusQuotations=false #if EXTENSIONTYPING @@ -5211,10 +5289,10 @@ let GetInitialTcState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImports, IsProviderGenerated = false ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) #endif - FileName=None + FileName=None Stamp = newStamp() QualifiedName= None - SourceCodeDirectory = tcConfig.implicitIncludeDir + SourceCodeDirectory = tcConfig.implicitIncludeDir ILScopeRef=ILScopeRef.Local Contents=ccuType MemberSignatureEquality= (Tastops.typeEquivAux EraseAll tcGlobals) @@ -5222,10 +5300,10 @@ let GetInitialTcState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImports, let ccu = CcuThunk.Create(ccuName,ccuData) - // OK, is this is the FSharp.Core CCU then fix it up. - if tcConfig.compilingFslib then + // OK, is this is the FSharp.Core CCU then fix it up. + if tcConfig.compilingFslib then tcGlobals.fslibCcu.Fixup(ccu) - + let rootSigs = Zmap.empty qnameOrder let rootImpls = Zset.empty qnameOrder let allSigModulTyp = NewEmptyModuleOrNamespaceType Namespace @@ -5240,38 +5318,40 @@ let GetInitialTcState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImports, /// Typecheck a single file (or interactive entry into F# Interactive) let TypeCheckOneInputEventually - (checkForErrors , tcConfig:TcConfig, tcImports:TcImports, + (checkForErrors , tcConfig:TcConfig, tcImports:TcImports, tcGlobals, prefixPathOpt, tcSink, tcState: TcState, inp: ParsedInput) = eventually { - try + try +#if !FABLE_COMPILER CheckSimulateException(tcConfig) +#endif let (RootSigsAndImpls(rootSigs,rootImpls,allSigModulTyp,allImplementedSigModulTyp)) = tcState.tcsRootSigsAndImpls let m = inp.Range let amap = tcImports.GetImportMap() - let! (topAttrs, mimpls,tcEnvAtEnd,tcSigEnv,tcImplEnv,topSigsAndImpls,ccuType) = + let! (topAttrs, mimpls,tcEnvAtEnd,tcSigEnv,tcImplEnv,topSigsAndImpls,ccuType) = eventually { - match inp with + match inp with | ParsedInput.SigFile (ParsedSigFileInput(_, qualNameOfFile, _, _, _) as file) -> - - // Check if we've seen this top module signature before. - if Zmap.mem qualNameOfFile rootSigs then + + // Check if we've seen this top module signature before. + if Zmap.mem qualNameOfFile rootSigs then errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text),m.StartRange)) - // Check if the implementation came first in compilation order - if Zset.contains qualNameOfFile rootImpls then + // Check if the implementation came first in compilation order + if Zset.contains qualNameOfFile rootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGivenDetail(qualNameOfFile.Text),m)) - // Typecheck the signature file - let! (tcEnvAtEnd,tcEnv,smodulTypeRoot) = + // Typecheck the signature file + let! (tcEnvAtEnd,tcEnv,smodulTypeRoot) = TypeCheckOneSigFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcState.tcsTcSigEnv file let rootSigs = Zmap.add qualNameOfFile smodulTypeRoot rootSigs - // Open the prefixPath for fsi.exe - let tcEnv = - match prefixPathOpt with - | None -> tcEnv - | Some prefixPath -> + // Open the prefixPath for fsi.exe + let tcEnv = + match prefixPathOpt with + | None -> tcEnv + | Some prefixPath -> let m = qualNameOfFile.Range TcOpenDecl tcSink tcGlobals amap m m tcEnv prefixPath @@ -5279,20 +5359,20 @@ let TypeCheckOneInputEventually return res | ParsedInput.ImplFile (ParsedImplFileInput(filename,_,qualNameOfFile,_,_,_,_) as file) -> - - // Check if we've got an interface for this fragment + + // Check if we've got an interface for this fragment let rootSigOpt = rootSigs.TryFind(qualNameOfFile) if verbose then dprintf "ParsedInput.ImplFile, nm = %s, qualNameOfFile = %s, ?rootSigOpt = %b\n" filename qualNameOfFile.Text (Option.isSome rootSigOpt) - // Check if we've already seen an implementation for this fragment - if Zset.contains qualNameOfFile rootImpls then + // Check if we've already seen an implementation for this fragment + if Zset.contains qualNameOfFile rootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGiven(qualNameOfFile.Text),m)) let tcImplEnv = tcState.tcsTcImplEnv - // Typecheck the implementation file - let! topAttrs,implFile,tcEnvAtEnd = + // Typecheck the implementation file + let! topAttrs,implFile,tcEnvAtEnd = TypeCheckOneImplFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcImplEnv rootSigOpt file let hadSig = Option.isSome rootSigOpt @@ -5300,36 +5380,36 @@ let TypeCheckOneInputEventually if verbose then dprintf "done TypeCheckOneImplFile...\n" let rootImpls = Zset.add qualNameOfFile rootImpls - - // Only add it to the environment if it didn't have a signature + + // Only add it to the environment if it didn't have a signature let m = qualNameOfFile.Range // Add the implementation as to the implementation env let tcImplEnv = AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcImplEnv implFileSigType // Add the implementation as to the signature env (unless it had an explicit signature) - let tcSigEnv = - if hadSig then tcState.tcsTcSigEnv + let tcSigEnv = + if hadSig then tcState.tcsTcSigEnv else AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv implFileSigType - + // Open the prefixPath for fsi.exe (tcImplEnv) - let tcImplEnv = - match prefixPathOpt with + let tcImplEnv = + match prefixPathOpt with | Some prefixPath -> TcOpenDecl tcSink tcGlobals amap m m tcImplEnv prefixPath - | _ -> tcImplEnv + | _ -> tcImplEnv // Open the prefixPath for fsi.exe (tcSigEnv) - let tcSigEnv = - match prefixPathOpt with + let tcSigEnv = + match prefixPathOpt with | Some prefixPath when not hadSig -> TcOpenDecl tcSink tcGlobals amap m m tcSigEnv prefixPath - | _ -> tcSigEnv + | _ -> tcSigEnv let allImplementedSigModulTyp = CombineCcuContentFragments m [implFileSigType; allImplementedSigModulTyp] - // Add it to the CCU - let ccuType = - // The signature must be reestablished. - // [CHECK: Why? This seriously degraded performance] + // Add it to the CCU + let ccuType = + // The signature must be reestablished. + // [CHECK: Why? This seriously degraded performance] NewCcuContents ILScopeRef.Local m tcState.tcsCcu.AssemblyName allImplementedSigModulTyp if verbose then dprintf "done TypeCheckOneInputEventually...\n" @@ -5337,15 +5417,15 @@ let TypeCheckOneInputEventually let topSigsAndImpls = RootSigsAndImpls(rootSigs,rootImpls,allSigModulTyp,allImplementedSigModulTyp) let res = (topAttrs,[implFile], tcEnvAtEnd, tcSigEnv, tcImplEnv, topSigsAndImpls, ccuType) return res } - + return (tcEnvAtEnd,topAttrs,mimpls), - { tcState with + { tcState with tcsCcuType=ccuType tcsTcSigEnv=tcSigEnv tcsTcImplEnv=tcImplEnv tcsRootSigsAndImpls = topSigsAndImpls } - with e -> - errorRecovery e range0 + with e -> + errorRecovery e range0 return (tcState.TcEnvFromSignatures,EmptyTopAttrs,[]),tcState } @@ -5359,17 +5439,17 @@ let TypeCheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPat /// Finish checking multiple files (or one interactive entry into F# Interactive) let TypeCheckMultipleInputsFinish(results,tcState: TcState) = let tcEnvsAtEndFile,topAttrs,mimpls = List.unzip3 results - + let topAttrs = List.foldBack CombineTopAttrs topAttrs EmptyTopAttrs let mimpls = List.concat mimpls - // This is the environment required by fsi.exe when incrementally adding definitions + // This is the environment required by fsi.exe when incrementally adding definitions let tcEnvAtEndOfLastFile = (match tcEnvsAtEndFile with h :: _ -> h | _ -> tcState.TcEnvFromSignatures) - + (tcEnvAtEndOfLastFile,topAttrs,mimpls),tcState /// Check multiple files (or one interactive entry into F# Interactive) let TypeCheckMultipleInputs (checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = - let results,tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) + let results,tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) TypeCheckMultipleInputsFinish(results,tcState) let TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) = @@ -5379,19 +5459,19 @@ let TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig: TcConfig, tcI } let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = - // Publish the latest contents to the CCU + // Publish the latest contents to the CCU tcState.tcsCcu.Deref.Contents <- tcState.tcsCcuType - // Check all interfaces have implementations + // Check all interfaces have implementations let (RootSigsAndImpls(rootSigs,rootImpls,_,_)) = tcState.tcsRootSigsAndImpls - rootSigs |> Zmap.iter (fun qualNameOfFile _ -> - if not (Zset.contains qualNameOfFile rootImpls) then + rootSigs |> Zmap.iter (fun qualNameOfFile _ -> + if not (Zset.contains qualNameOfFile rootImpls) then errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) tcState, declaredImpls - + let TypeCheckClosedInputSet (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = - // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions + // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions let (tcEnvAtEndOfLastFile, topAttrs, mimpls),tcState = TypeCheckMultipleInputs (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) let tcState, declaredImpls = TypeCheckClosedInputSetFinish (mimpls, tcState) tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 769fbe33f9..112f870a5c 100755 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -3,10 +3,10 @@ /// Coordinating compiler operations - configuration, loading initial context, reporting errors etc. module internal Microsoft.FSharp.Compiler.CompileOps +open Internal.Utilities open System open System.Text open System.Collections.Generic -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -590,7 +590,7 @@ type TcAssemblyResolutions = -/// Repreesnts a table of imported assemblies with their resolutions. +/// Represents a table of imported assemblies with their resolutions. [] type TcImports = interface System.IDisposable diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index f74f5fa427..2147867ae9 100755 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -809,7 +809,9 @@ let testFlag tcConfigB = | "FunctionSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportFunctionSizes = true } | "TotalSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportTotalSizes = true } | "HasEffect" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportHasEffect = true } +#if !FABLE_COMPILER | "NoErrorText" -> FSComp.SR.SwallowResourceText <- true +#endif | "EmitFeeFeeAs100001" -> tcConfigB.testFlagEmitFeeFeeAs100001 <- true | "DumpDebugInfo" -> tcConfigB.dumpDebugInfo <- true | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index f51bb3a853..6e423714a5 100755 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -32,6 +32,9 @@ module internal Microsoft.FSharp.Compiler.ConstraintSolver open Internal.Utilities open Internal.Utilities.Collections +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL @@ -1877,7 +1880,7 @@ and CanMemberSigsMatchUpToCheck if isArray1DTy g calledArg.CalledArgumentType then let paramArrayElemTy = destArrayTy g calledArg.CalledArgumentType let reflArgInfo = calledArg.ReflArgInfo // propgate the reflected-arg info to each param array argument - calledMeth.ParamArrayCallerArgs |> OptionD (IterateD (fun callerArg -> subsumeArg (CalledArg((0,0),false,NotOptional,NoCallerInfo,false,None,reflArgInfo,paramArrayElemTy)) callerArg)) + calledMeth.ParamArrayCallerArgs |> OptionD (IterateD (fun callerArg -> subsumeArg (GetCalledArg((0,0),false,NotOptional,NoCallerInfo,false,None,reflArgInfo,paramArrayElemTy)) callerArg)) else CompleteD) @@ -1900,7 +1903,7 @@ and CanMemberSigsMatchUpToCheck let calledArgTy = rfinfo.FieldType rfinfo.Name, calledArgTy - subsumeArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller) )) ++ (fun () -> + subsumeArg (GetCalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller) )) ++ (fun () -> // - Always take the return type into account for // -- op_Explicit, op_Implicit diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index 07b4ae434f..1f094bd329 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -4,6 +4,9 @@ module (*internal*) Microsoft.FSharp.Compiler.ErrorLogger open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Lib @@ -88,22 +91,37 @@ let inline protectAssemblyExplorationNoReraise dflt1 dflt2 f = | UnresolvedPathReferenceNoRange _ -> dflt1 | _ -> dflt2 +#if FABLE_COMPILER +let (|IsException|_|) exnTypeName (exn: exn) = + if exn.GetType().FullName = exnTypeName then + Some (sprintf "%s (%s)" exn.Message (exn.GetType().Name)) + else None +#endif + // Attach a range if this is a range dual exception. let rec AttachRange m (exn:exn) = if m = range0 then exn else match exn with // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException -> AttachRange m exn.InnerException | UnresolvedReferenceNoRange(a) -> UnresolvedReferenceError(a,m) | UnresolvedPathReferenceNoRange(a,p) -> UnresolvedPathReference(a,p,m) - | Failure(msg) -> InternalError(msg^" (Failure)",m) - | :? System.ArgumentException as exn -> InternalError(exn.Message + " (ArgumentException)",m) +#if FABLE_COMPILER + | IsException "System.Reflection.TargetInvocationException" msg -> InternalError(msg, m) + | IsException "System.Exception" msg -> InternalError(msg, m) + | IsException "System.ArgumentException" msg -> InternalError(msg, m) +#else + | :? System.Reflection.TargetInvocationException -> AttachRange m exn.InnerException + | Failure(msg) -> InternalError(msg + " (Failure)",m) + | :? System.ArgumentException -> InternalError(exn.Message + " (ArgumentException)",m) +#endif | notARangeDual -> notARangeDual //---------------------------------------------------------------------------- // Error logger interface +#if !FABLE_COMPILER + type Exiter = abstract Exit : int -> 'T @@ -116,6 +134,7 @@ let QuitProcessExiter = with _ -> () failwithf "%s" <| FSComp.SR.elSysEnvExitDidntExit() } +#endif /// Closed enumeration of build phases. type BuildPhase = @@ -288,6 +307,7 @@ type internal CompileThreadStatic = module ErrorLoggerExtensions = open System.Reflection +#if !FABLE_COMPILER // Instruct the exception not to reset itself when thrown again. // Design Note: This enables the compiler to prompt the user to send mail to fsbugs@microsoft.com, // by catching the exception, prompting and then propagating the exception with reraise. @@ -318,6 +338,7 @@ module ErrorLoggerExtensions = PreserveStackTrace(exn) raise exn | _ -> () +#endif #endif type ErrorLogger with @@ -334,14 +355,18 @@ module ErrorLoggerExtensions = (* Don't send ThreadAbortException down the error channel *) #if FX_REDUCED_EXCEPTIONS #else +#if !FABLE_COMPILER | :? System.Threading.ThreadAbortException | WrappedError((:? System.Threading.ThreadAbortException),_) -> () +#endif #endif | ReportedError _ | WrappedError(ReportedError _,_) -> () | StopProcessing | WrappedError(StopProcessing,_) -> raise exn | _ -> try x.ErrorR (AttachRange m exn) // may raise exceptions, e.g. an fsi error sink raises StopProcessing. +#if !FABLE_COMPILER ReraiseIfWatsonable(exn) +#endif with | ReportedError _ | WrappedError(ReportedError _,_) -> () member x.StopProcessingRecovery (exn:exn) (m:range) = @@ -536,7 +561,7 @@ let NormalizeErrorString (text : string) = | c -> // handle remaining chars: control - replace with space, others - keep unchanged let c = if Char.IsControl(c) then ' ' else c - buf.Append(c) |> ignore + buf.Append(string c) |> ignore 1 i <- i + delta buf.ToString() \ No newline at end of file diff --git a/src/fsharp/ErrorResolutionHints.fs b/src/fsharp/ErrorResolutionHints.fs index 28bb2ff2d6..aa26fc5f7a 100644 --- a/src/fsharp/ErrorResolutionHints.fs +++ b/src/fsharp/ErrorResolutionHints.fs @@ -3,6 +3,10 @@ /// Functions to format error message details module internal Microsoft.FSharp.Compiler.ErrorResolutionHints +#if FABLE_COMPILER +open Internal.Utilities +#endif + /// Filters predictions based on edit distance to an unknown identifier. let FilterPredictions unknownIdent allPredictions = let rec take n predictions = diff --git a/src/fsharp/ExtensionTyping.fs b/src/fsharp/ExtensionTyping.fs index 27efa07386..80a9250463 100755 --- a/src/fsharp/ExtensionTyping.fs +++ b/src/fsharp/ExtensionTyping.fs @@ -282,16 +282,16 @@ module internal ExtensionTyping = match ctxt with | NoEntries -> None | Entries(d,_) -> - let mutable res = Unchecked.defaultof<_> - if d.TryGetValue(st,&res) then Some res else None + let ok, res = d.TryGetValue(st) + if ok then Some res else None member ctxt.TryGetTyconRef(st) = match ctxt with | NoEntries -> None | Entries(_,d) -> let d = d.Force() - let mutable res = Unchecked.defaultof<_> - if d.TryGetValue(st,&res) then Some res else None + let ok, res = d.TryGetValue(st) + if ok then Some res else None member ctxt.RemapTyconRefs (f:obj->obj) = match ctxt with diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index c3b8fe735b..f80e8dd299 100755 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1086,7 +1086,7 @@ lexIndentOffForML,"Consider using a file with extension '.ml' or '.mli' instead" 1246,tcCallerInfoWrongType,"'%s' must be applied to an argument of type '%s', but has been applied to an argument of type '%s'" 1247,tcCallerInfoNotOptional,"'%s' can only be applied to optional arguments" # reshapedmsbuild.fs -1300,toolLocationHelperUnsupportedFrameworkVersion,"The specified .NET Framework version "%s" is not supported. Please specify a value from the enumeration Microsoft.Build.Utilities.TargetDotNetFrameworkVersion." +1300,toolLocationHelperUnsupportedFrameworkVersion,"The specified .NET Framework version '%s' is not supported. Please specify a value from the enumeration Microsoft.Build.Utilities.TargetDotNetFrameworkVersion." # ----------------------------------------------------------------------------- # ilsign errors # ----------------------------------------------------------------------------- diff --git a/src/fsharp/FSharp.Compiler.Service/project.json b/src/fsharp/FSharp.Compiler.Service/project.json index 8360251b78..624f2ef335 100644 --- a/src/fsharp/FSharp.Compiler.Service/project.json +++ b/src/fsharp/FSharp.Compiler.Service/project.json @@ -279,7 +279,7 @@ "System.Runtime.Loader": "4.0.0", "System.Security.Cryptography.Algorithms": "4.2.0", "System.Security.Cryptography.Primitives": "4.0.0", - "Microsoft.FSharp.Core.netcore": "1.0.0-alpha-*" + "Microsoft.FSharp.Core.netcore": "1.0.0-alpha-161111" }, "tools": { "dotnet-fssrgen": "3.3.*", diff --git a/src/fsharp/Fable.FCS/.gitignore b/src/fsharp/Fable.FCS/.gitignore new file mode 100644 index 0000000000..9cc72b968c --- /dev/null +++ b/src/fsharp/Fable.FCS/.gitignore @@ -0,0 +1,5 @@ +# Output +out/ + +# Node +node_modules/ diff --git a/src/fsharp/Fable.FCS/Fable.FCS.fsx b/src/fsharp/Fable.FCS/Fable.FCS.fsx new file mode 100644 index 0000000000..f617323b7f --- /dev/null +++ b/src/fsharp/Fable.FCS/Fable.FCS.fsx @@ -0,0 +1,174 @@ +#load + "fsstrings.fs" + "unicode.fs" + "adapters.fs" + // "../../assemblyinfo/assemblyinfo.FSharp.Compiler.Service.dll.fs" + // "../../assemblyinfo/assemblyinfo.shared.fs" + "../FSharp.Compiler.Service/FSComp.fs" + "../FSharp.Compiler.Service/FSIstrings.fs" + // "../../utils/reshapedreflection.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/EditDistance.fs" + "../../utils/TaggedCollections.fsi" + "../../utils/TaggedCollections.fs" + "../QueueList.fs" + "../../absil/ildiag.fsi" + "../../absil/ildiag.fs" + "../../absil/illib.fs" + "../../utils/filename.fsi" + "../../utils/filename.fs" + "../../absil/bytes.fsi" + "../../absil/bytes.fs" + "../../absil/zmap.fsi" + "../../absil/zmap.fs" + "../../absil/zset.fsi" + "../../absil/zset.fs" + "../lib.fs" + "../ErrorResolutionHints.fs" + // "../InternalCollections.fsi" + // "../InternalCollections.fs" + "../rational.fsi" + "../rational.fs" + "../range.fsi" + "../range.fs" + "../ErrorLogger.fs" + "../ReferenceResolver.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/ilsign.fs" + // "../../absil/ilsupp.fsi" + // "../../absil/ilsupp.fs" + // "ilpars.fs" + // "illex.fs" + "../../absil/ilbinary.fsi" + "../../absil/ilbinary.fs" + "../../absil/ilread.fsi" + "../../absil/ilread.fs" + // "../../absil/ilwritepdb.fsi" + // "../../absil/ilwritepdb.fs" + // "../../absil/ilwrite.fsi" + // "../../absil/ilwrite.fs" + // "../../absil/ilreflect.fs" + // "../../utils/CompilerLocationUtils.fs" + "../PrettyNaming.fs" + "../../ilx/ilxsettings.fs" + // "../../ilx/EraseClosures.fsi" + // "../../ilx/EraseClosures.fs" + // "../../ilx/EraseUnions.fsi" + // "../../ilx/EraseUnions.fs" + "../UnicodeLexing.fsi" + "../UnicodeLexing.fs" + "../layout.fsi" + "../layout.fs" + "../ast.fs" + "../FSharp.Compiler.Service/pppars.fs" + "../FSharp.Compiler.Service/pars.fs" + "../lexhelp.fsi" + "../lexhelp.fs" + "../FSharp.Compiler.Service/pplex.fs" + "../FSharp.Compiler.Service/lex.fs" + "../LexFilter.fs" + // "../tainted.fsi" + // "../tainted.fs" + // "../ExtensionTyping.fsi" + // "../ExtensionTyping.fs" + "../QuotationPickler.fsi" + "../QuotationPickler.fs" + "../tast.fs" + "../TcGlobals.fs" + "../TastOps.fsi" + "../TastOps.fs" + "../TastPickle.fsi" + "../TastPickle.fs" + "../import.fsi" + "../import.fs" + "../infos.fs" + "../AccessibilityLogic.fs" + "../AttributeChecking.fs" + "../InfoReader.fs" + "../NicePrint.fs" + "../AugmentWithHashCompare.fsi" + "../AugmentWithHashCompare.fs" + "../NameResolution.fsi" + "../NameResolution.fs" + "../TypeRelations.fs" + "../SignatureConformance.fs" + "../MethodOverrides.fs" + "../MethodCalls.fs" + "../PatternMatchCompilation.fsi" + "../PatternMatchCompilation.fs" + "../ConstraintSolver.fsi" + "../ConstraintSolver.fs" + "../CheckFormatStrings.fsi" + "../CheckFormatStrings.fs" + "../FindUnsolved.fs" + "../QuotationTranslator.fsi" + "../QuotationTranslator.fs" + "../PostInferenceChecks.fsi" + "../PostInferenceChecks.fs" + "../TypeChecker.fsi" + "../TypeChecker.fs" + "../Optimizer.fsi" + "../Optimizer.fs" + // "../DetupleArgs.fsi" + // "../DetupleArgs.fs" + // "../InnerLambdasToTopLevelFuncs.fsi" + // "../InnerLambdasToTopLevelFuncs.fs" + // "../LowerCallsAndSeqs.fs" + // "../autobox.fs" + // "../IlxGen.fsi" + // "../IlxGen.fs" + // "../CompileOps.fsi" + "../CompileOps.fs" + // "../CompileOptions.fsi" + // "../CompileOptions.fs" + // "../fsc.fsi" + // "../fsc.fs" + // "../vs/IncrementalBuild.fsi" + // "../vs/IncrementalBuild.fs" + // "../vs/Reactor.fsi" + // "../vs/Reactor.fs" + "../vs/ServiceConstants.fs" + "../vs/ServiceDeclarations.fsi" + "../vs/ServiceDeclarations.fs" + "../vs/Symbols.fsi" + "../vs/Symbols.fs" + "../vs/Exprs.fsi" + "../vs/Exprs.fs" + // "../vs/ServiceLexing.fsi" + // "../vs/ServiceLexing.fs" + // "../vs/ServiceParseTreeWalk.fs" + // "../vs/ServiceNavigation.fsi" + // "../vs/ServiceNavigation.fs" + // "../vs/ServiceParamInfoLocations.fsi" + // "../vs/ServiceParamInfoLocations.fs" + // "../vs/ServiceUntypedParse.fsi" + // "../vs/ServiceUntypedParse.fs" + // "../../utils/reshapedmsbuild.fs" + // "../MSBuildReferenceResolver.fs" + // "../vs/service.fsi" + // "../vs/service.fs" + // "../vs/SimpleServices.fsi" + // "../vs/SimpleServices.fs" + // "../fsi/fsi.fsi" + // "../fsi/fsi.fs" + "service_shim.fs" diff --git a/src/fsharp/Fable.FCS/Fable.FCS.sln b/src/fsharp/Fable.FCS/Fable.FCS.sln new file mode 100644 index 0000000000..190ad56fde --- /dev/null +++ b/src/fsharp/Fable.FCS/Fable.FCS.sln @@ -0,0 +1,22 @@ + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 14 +VisualStudioVersion = 14.0.25420.1 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "project", "project.fsproj", "{503AD75D-B915-4DAB-8819-16F9E8711881}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Release|Any CPU = Release|Any CPU + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {503AD75D-B915-4DAB-8819-16F9E8711881}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {503AD75D-B915-4DAB-8819-16F9E8711881}.Debug|Any CPU.Build.0 = Debug|Any CPU + {503AD75D-B915-4DAB-8819-16F9E8711881}.Release|Any CPU.ActiveCfg = Release|Any CPU + {503AD75D-B915-4DAB-8819-16F9E8711881}.Release|Any CPU.Build.0 = Release|Any CPU + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/src/fsharp/Fable.FCS/adapters.fs b/src/fsharp/Fable.FCS/adapters.fs new file mode 100644 index 0000000000..775ad0c442 --- /dev/null +++ b/src/fsharp/Fable.FCS/adapters.fs @@ -0,0 +1,269 @@ +namespace Internal.Utilities + +#nowarn "1182" + +open System.Collections.Generic + +//------------------------------------------------------------------------- +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +//TODO: implement proper Unicode char, decimal + +module System = + + module Reflection = + type AssemblyName(assemblyName: string) = + member x.Name = assemblyName //TODO: proper implementation + + module Collections = + module Generic = + type System.Collections.Generic.Dictionary<'TKey, 'TValue> with + member x.TryAdd (key:'TKey, value:'TValue) = + x.[key] <- value; true + member x.GetOrAdd (key, valueFactory) = + match x.TryGetValue key with + | true, v -> v + | false, _ -> let v = valueFactory(key) in x.[key] <- v; v + module Concurrent = + type ConcurrentDictionary<'TKey, 'TValue> = System.Collections.Generic.Dictionary<'TKey, 'TValue> + + type StringComparer(comp: System.StringComparison) = + static member Ordinal = StringComparer(System.StringComparison.Ordinal) + static member OrdinalIgnoreCase = StringComparer(System.StringComparison.OrdinalIgnoreCase) + interface IEqualityComparer with + member x.Equals(a,b) = (compare a b) = 0 + member x.GetHashCode a = hash a + interface IComparer with + member x.Compare(a,b) = compare a b + + module Char = + open System.Globalization + + let GetUnicodeCategory (c: char): UnicodeCategory = + LanguagePrimitives.EnumOfValue (int categoryForLatin1.[int c]) //TODO: proper Unicode implementation + let IsControl (c: char) = + GetUnicodeCategory(c) = UnicodeCategory.Control + let IsDigit (c: char) = + GetUnicodeCategory(c) = UnicodeCategory.DecimalDigitNumber + let IsLetter (c: char) = + match GetUnicodeCategory(c) with + | UnicodeCategory.UppercaseLetter + | UnicodeCategory.LowercaseLetter + | UnicodeCategory.TitlecaseLetter + | UnicodeCategory.ModifierLetter + | UnicodeCategory.OtherLetter -> true + | _ -> false + let IsLetterOrDigit (c: char) = + IsLetter(c) || IsDigit(c) + let IsWhiteSpace (c: char) = + // There are characters which belong to UnicodeCategory.Control but are considered as white spaces. + c = ' ' || (c >= '\x09' && c <= '\x0d') || c = '\xa0' || c = '\x85' + let IsUpper (c: char) = + GetUnicodeCategory(c) = UnicodeCategory.UppercaseLetter + let IsLower (c: char) = + GetUnicodeCategory(c) = UnicodeCategory.LowercaseLetter + let IsPunctuation (c: char) = + match GetUnicodeCategory(c) with + | UnicodeCategory.ConnectorPunctuation + | UnicodeCategory.DashPunctuation + | UnicodeCategory.OpenPunctuation + | UnicodeCategory.ClosePunctuation + | UnicodeCategory.InitialQuotePunctuation + | UnicodeCategory.FinalQuotePunctuation + | UnicodeCategory.OtherPunctuation -> true + | _ -> false + let IsSurrogatePair (s,i) = false //TODO: Unicode implementation + let ToUpper (c: char) = if IsLower(c) then char(int('A') + (int(c) - int('a'))) else c + let ToLower (c: char) = if IsUpper(c) then char(int('a') + (int(c) - int('A'))) else c + let ToUpperInvariant (c: char) = ToUpper(c) + let ToLowerInvariant (c: char) = ToLower(c) + + module Convert = + let ToChar (d) = char d + + module Decimal = + let GetBits (d: decimal): int[] = [|0;0;0;0|] //TODO: proper implementation + let FromBits (bits: int[]) = new decimal(0) //TODO: proper implementation + + module Environment = + let NewLine = "\n" //TODO: proper implementation + + module Text = + + type StringBuilder(?s: string) = + let buf = ResizeArray() + do if Option.isSome s then buf.Add(s.Value) + new (capacity: int, ?maxCapacity: int) = StringBuilder() + new (s: string, ?maxCapacity: int) = StringBuilder(s) + member x.Append(s: string) = buf.Add(s); x + override x.ToString() = System.String.Concat(buf) + + module Encoding = + + module Unicode = // TODO: surrogate pairs + let GetBytes (s: string) = + let addUnicodeChar (buf: ResizeArray) (c: char) = + let i = int c + buf.Add (byte (i % 256)) + buf.Add (byte (i / 256)) + let buf = ResizeArray() + s.ToCharArray() |> Array.map (addUnicodeChar buf) |> ignore + buf.ToArray() + + let GetString (bytes: byte[], index: int, count: int) = + let sb = StringBuilder() + for i in 0 .. 2 .. count-1 do + let c = char ((int(bytes.[index+i+1]) <<< 8) ||| int(bytes.[index+i])) + sb.Append(string c) |> ignore + sb.ToString() + + module UTF8 = // TODO: surrogate pairs + let GetBytes (s: string) = + let buf = ResizeArray() + let encodeUtf8 (c: char) = + let i = int c + if i < 0x80 then + buf.Add (byte(i)) + else if i < 0x800 then + buf.Add (byte(0xC0 ||| (i >>> 6 &&& 0x1F))) + buf.Add (byte(0x80 ||| (i &&& 0x3F))) + else if i < 0x10000 then + buf.Add (byte(0xE0 ||| (i >>> 12 &&& 0xF))) + buf.Add (byte(0x80 ||| (i >>> 6 &&& 0x3F))) + buf.Add (byte(0x80 ||| (i &&& 0x3F))) + s.ToCharArray() |> Array.map encodeUtf8 |> ignore + buf.ToArray() + + let GetString (bytes: byte[], index: int, count: int) = + let decodeUtf8 pos = + let i1 = int(bytes.[pos]) + if i1 &&& 0x80 = 0 then + (i1 &&& 0x7F), 1 + else if i1 &&& 0xE0 = 0xC0 then + let i2 = int(bytes.[pos + 1]) in + ((i1 &&& 0x1F) <<< 6) ||| (i2 &&& 0x3F), 2 + else if i1 &&& 0xF0 = 0xE0 then + let i2 = int(bytes.[pos + 1]) in + let i3 = int(bytes.[pos + 2]) in + ((i1 &&& 0x1F) <<< 12) ||| ((i2 &&& 0x3F) <<< 6) ||| (i3 &&& 0x3F), 3 + else 0, 1 // invalid decoding + let sb = StringBuilder() + let mutable pos = index + let last = index + count + while pos < last do + let d, inc = decodeUtf8 pos + sb.Append(string (char d)) |> ignore + pos <- pos + inc + sb.ToString() + + +module Microsoft = + module FSharp = + + module Collections = + module HashIdentity = + let inline FromFunctions hash eq : IEqualityComparer<'T> = + { new IEqualityComparer<'T> with + member __.GetHashCode(x) = hash x + member __.Equals(x,y) = eq x y } + let inline Structural<'T when 'T : equality> : IEqualityComparer<'T> = + FromFunctions LanguagePrimitives.GenericHash LanguagePrimitives.GenericEquality + // let Reference<'T when 'T : not struct > : IEqualityComparer<'T> = + // FromFunctions LanguagePrimitives.PhysicalHash LanguagePrimitives.PhysicalEquality + + module ComparisonIdentity = + let inline FromFunction comparer = + { new IComparer<'T> with + member __.Compare(x,y) = comparer x y } + let inline Structural<'T when 'T : comparison> : IComparer<'T> = + FromFunction LanguagePrimitives.GenericComparison + + module Core = + module LanguagePrimitives = + let FastGenericComparer<'T when 'T : comparison> = + Collections.ComparisonIdentity.Structural<'T> + let PhysicalHash = + LanguagePrimitives.GenericHash //TODO: proper implementation + + module Operators = + let (|Failure|_|) (exn: exn) = Some exn.Message + //if exn.GetType().FullName.EndsWith("Exception") then Some exn.Message else None + let Failure message = new System.Exception(message) + let nullArg x = raise(System.ArgumentNullException(x)) + + module Printf = + let bprintf (sb: System.Text.StringBuilder) = + let f (s:string) = sb.Append(s) |> ignore + Printf.kprintf f + let fprintf (os: System.IO.TextWriter) = + let f (s:string) = System.Console.Write(s) //os.Write(s) + Printf.kprintf f + + //------------------------------------------------------------------------- + // From reshapedreflection.fs + //------------------------------------------------------------------------ + module XmlAdapters = + let s_escapeChars = [| '<'; '>'; '\"'; '\''; '&' |] + let getEscapeSequence c = + match c with + | '<' -> "<" + | '>' -> ">" + | '\"' -> """ + | '\'' -> "'" + | '&' -> "&" + | _ as ch -> ch.ToString() + let escape str = String.collect getEscapeSequence str + + //------------------------------------------------------------------------- + // From sr.fs + //------------------------------------------------------------------------ + module Compiler = + module SR = + let GetString(name:string) = SR.Resources.resources.[name] + + module internal DiagnosticMessage = + type ResourceString<'T>(sfmt: string, fmt: string) = + member x.Format = + let ar = fmt.Split('%') + |> Array.filter (fun s -> String.length s > 0) + |> Array.map (fun s -> box("%"+s)) + let tmp = System.String.Format(sfmt, ar) + let fmt = Printf.StringFormat<'T>(tmp) + sprintf fmt + + let postProcessString (s : string) = + s.Replace("\\n","\n").Replace("\\t","\t") + let DeclareResourceString ((messageID: string),(fmt: string)) = + let messageString = SR.GetString(messageID) |> postProcessString + ResourceString<'T>(messageString, fmt) + + +//------------------------------------------------------------------------- +// From sformat.fs +//------------------------------------------------------------------------ +module StructuredFormat = + type Joint = + | Unbreakable + | Breakable of int + | Broken of int + + type Layout = + | Leaf of bool * obj * bool + | Node of bool * layout * bool * layout * bool * joint + | Attr of string * (string * string) list * layout + and layout = Layout + and joint = Joint + +//------------------------------------------------------------------------- +// From IncrementalBuild.fs +//------------------------------------------------------------------------ +module ErrorScope = + let Protect m f1 f2 = try f1() with e -> f2(e.Message) + +//------------------------------------------------------------------------- +// From Reactor.fs +//------------------------------------------------------------------------ +type internal IReactorOperations = + abstract EnqueueAndAwaitOpAsync : string * (unit -> 'T) -> Async<'T> + abstract EnqueueOp: string * (unit -> unit) -> unit diff --git a/src/fsharp/Fable.FCS/app.fs b/src/fsharp/Fable.FCS/app.fs new file mode 100644 index 0000000000..059bf22378 --- /dev/null +++ b/src/fsharp/Fable.FCS/app.fs @@ -0,0 +1,69 @@ +module App +open Microsoft.FSharp.Compiler.SourceCodeServices + +#if DOTNETCORE || DOTNET40 +[] +#endif +let main argv = + ignore argv + printfn "Parsing begins..." + + let source = """ +printfn "answer: %A" 42 +""" + + let metadataPath = "/temp/metadata/" +#if DOTNETCORE + let references = + [ "mscorlib" + "System.Collections" + "System.Console" + "System.Diagnostics.Debug" + "System.Globalization" + "System.IO" + "System.Linq" + "System.Linq.Expressions" + "System.Net.Requests" + "System.ObjectModel" + "System.Reflection" + "System.Reflection.Primitives" + "System.Resources.ResourceManager" + "System.Runtime" + "System.Runtime.InteropServices" + "System.Runtime.Numerics" + "System.Threading" + "System.Threading.Tasks" + "System.Xml.XDocument" + ] +#else + let references = ["mscorlib";"System";"System.Core";"System.Data";"System.IO";"System.Xml";"System.Numerics"] +#endif + +#if DOTNETCORE || DOTNET40 + let readAllBytes = fun (fileName:string) -> System.IO.File.ReadAllBytes (metadataPath + fileName) +#else + let readFileSync: System.Func = Fable.Core.JsInterop.import "readFileSync" "fs" + let readAllBytes = fun (fileName:string) -> readFileSync.Invoke (metadataPath + fileName) +#endif + + let fileName = "stdin.fsx" + let checker = InteractiveChecker(references, readAllBytes) + // let untypedResults = checker.ParseScript(fileName,source) + let untypedResults, typeCheckResults, projectResults = checker.ParseAndCheckScript(fileName,source) + + printfn "untypedResults.ParseHadErrors: %A" untypedResults.ParseHadErrors + printfn "untypedResults.Errors: %A" untypedResults.Errors + //printfn "untypedResults.ParseTree: %A" untypedResults.ParseTree + + printfn "typeCheckResults Errors: %A" typeCheckResults.Errors + printfn "typeCheckResults Entities: %A" typeCheckResults.PartialAssemblySignature.Entities + //printfn "typeCheckResults Attributes: %A" typeCheckResults.PartialAssemblySignature.Attributes + + printfn "projectResults Errors: %A" projectResults.Errors + printfn "projectResults Contents: %A" projectResults.AssemblyContents + + printfn "Typed AST:" + projectResults.AssemblyContents.ImplementationFiles + |> Seq.iter (fun file -> AstPrint.printFSharpDecls "" file.Declarations |> Seq.iter (printfn "%s")) + + 0 // return an integer exit code diff --git a/src/fsharp/Fable.FCS/fableconfig.json b/src/fsharp/Fable.FCS/fableconfig.json new file mode 100644 index 0000000000..b785950975 --- /dev/null +++ b/src/fsharp/Fable.FCS/fableconfig.json @@ -0,0 +1,24 @@ +{ + "projFile": "project.fsx", + "module": "commonjs", + "sourceMaps": false, + "ecma": "es2015", + "outDir": "out", + "copyExt": true, + "plugins": [ + ], + "symbols": [ + "FX_NO_CORHOST_SIGNER", + "FX_NO_LINKEDRESOURCES", + "FX_NO_PDB_READER", + "FX_NO_PDB_WRITER", + "NO_COMPILER_BACKEND", + "NO_INLINE_IL_PARSER", + "TRACE", + "DEBUG" + ], + "scripts": { + "prebuild": "npm install", + "postbuild": "node out/Fable.FCS/project" + } +} \ No newline at end of file diff --git a/src/fsharp/Fable.FCS/fsstrings.fs b/src/fsharp/Fable.FCS/fsstrings.fs new file mode 100644 index 0000000000..fde66877c8 --- /dev/null +++ b/src/fsharp/Fable.FCS/fsstrings.fs @@ -0,0 +1,968 @@ +module internal SR.Resources + +let resources = + dict [ + ( "SeeAlso", + ". See also {0}." + ); + ( "ConstraintSolverTupleDiffLengths", + "The tuples have differing lengths of {0} and {1}" + ); + ( "ConstraintSolverInfiniteTypes", + "The types '{0}' and '{1}' cannot be unified." + ); + ( "ConstraintSolverMissingConstraint", + "A type parameter is missing a constraint '{0}'" + ); + ( "ConstraintSolverTypesNotInEqualityRelation1", + "The unit of measure '{0}' does not match the unit of measure '{1}'" + ); + ( "ConstraintSolverTypesNotInEqualityRelation2", + "The type '{0}' does not match the type '{1}'" + ); + ( "ConstraintSolverTypesNotInSubsumptionRelation", + "The type '{0}' is not compatible with the type '{1}'{2}" + ); + ( "ConstraintSolverError", + "{0}" + ); + ( "ConstraintSolverRelatedInformation", + " {0}" + ); + ( "ErrorFromAddingTypeEquation1", + "This expression was expected to have type\\n '{1}' \\nbut here has type\\n '{0}' {2}" + ); + ( "ErrorFromAddingTypeEquation2", + "Type mismatch. Expecting a\\n '{0}' \\nbut given a\\n '{1}' {2}\\n" + ); + ( "ErrorFromApplyingDefault1", + "Type constraint mismatch when applying the default type '{0}' for a type inference variable. " + ); + ( "ErrorFromApplyingDefault2", + " Consider adding further type constraints" + ); + ( "ErrorsFromAddingSubsumptionConstraint", + "Type constraint mismatch. The type \\n '{0}' \\nis not compatible with type\\n '{1}' {2}\\n" + ); + ( "UpperCaseIdentifierInPattern", + "Uppercase variable identifiers should not generally be used in patterns, and may indicate a misspelt pattern name." + ); + ( "NotUpperCaseConstructor", + "Discriminated union cases and exception labels must be uppercase identifiers" + ); + ( "PossibleOverload", + "Possible overload: '{0}'. {1}." + ); + ( "PossibleBestOverload", + "\\n\\nPossible best overload: '{0}'." + ); + ( "FunctionExpected", + "This function takes too many arguments, or is used in a context where a function is not expected" + ); + ( "BakedInMemberConstraintName", + "Member constraints with the name '{0}' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in runtime failures if you attempt to invoke the member constraint from your own code." + ); + ( "BadEventTransformation", + "A definition to be compiled as a .NET event does not have the expected form. Only property members can be compiled as .NET events." + ); + ( "ParameterlessStructCtor", + "Implicit object constructors for structs must take at least one argument" + ); + ( "InterfaceNotRevealed", + "The type implements the interface '{0}' but this is not revealed by the signature. You should list the interface in the signature, as the interface will be discoverable via dynamic type casts and/or reflection." + ); + ( "NotAFunction1", + "This value is not a function and cannot be applied. Did you forget to terminate a declaration?" + ); + ( "NotAFunction2", + "This value is not a function and cannot be applied" + ); + ( "TyconBadArgs", + "The type '{0}' expects {1} type argument(s) but is given {2}" + ); + ( "IndeterminateType", + "Lookup on object of indeterminate type based on information prior to this program point. A type annotation may be needed prior to this program point to constrain the type of the object. This may allow the lookup to be resolved." + ); + ( "NameClash1", + "Duplicate definition of {0} '{1}'" + ); + ( "NameClash2", + "The {0} '{1}' can not be defined because the name '{2}' clashes with the {3} '{4}' in this type or module" + ); + ( "Duplicate1", + "Two members called '{0}' have the same signature" + ); + ( "Duplicate2", + "Duplicate definition of {0} '{1}'" + ); + ( "UndefinedName2", + " A construct with this name was found in FSharp.PowerPack.dll, which contains some modules and types that were implicitly referenced in some previous versions of F#. You may need to add an explicit reference to this DLL in order to compile this code." + ); + ( "FieldNotMutable", + "This field is not mutable" + ); + ( "FieldsFromDifferentTypes", + "The fields '{0}' and '{1}' are from different types" + ); + ( "VarBoundTwice", + "'{0}' is bound twice in this pattern" + ); + ( "Recursion", + "A use of the function '{0}' does not match a type inferred elsewhere. The inferred type of the function is\\n {1}. \\nThe type of the function required at this point of use is\\n {2} {3}\\nThis error may be due to limitations associated with generic recursion within a 'let rec' collection or within a group of classes. Consider giving a full type signature for the targets of recursive calls including type annotations for both argument and return types." + ); + ( "InvalidRuntimeCoercion", + "Invalid runtime coercion or type test from type {0} to {1}\\n{2}" + ); + ( "IndeterminateRuntimeCoercion", + "This runtime coercion or type test from type\\n {0} \\n to \\n {1} \\ninvolves an indeterminate type based on information prior to this program point. Runtime type tests are not allowed on some types. Further type annotations are needed." + ); + ( "IndeterminateStaticCoercion", + "The static coercion from type\\n {0} \\nto \\n {1} \\n involves an indeterminate type based on information prior to this program point. Static coercions are not allowed on some types. Further type annotations are needed." + ); + ( "StaticCoercionShouldUseBox", + "A coercion from the value type \\n {0} \\nto the type \\n {1} \\nwill involve boxing. Consider using 'box' instead" + ); + ( "TypeIsImplicitlyAbstract", + "This type is 'abstract' since some abstract members have not been given an implementation. If this is intentional then add the '[]' attribute to your type." + ); + ( "NonRigidTypar1", + "This construct causes code to be less generic than indicated by its type annotations. The type variable implied by the use of a '#', '_' or other type annotation at or near '{0}' has been constrained to be type '{1}'." + ); + ( "NonRigidTypar2", + "This construct causes code to be less generic than indicated by the type annotations. The unit-of-measure variable '{0} has been constrained to be measure '{1}'." + ); + ( "NonRigidTypar3", + "This construct causes code to be less generic than indicated by the type annotations. The type variable '{0} has been constrained to be type '{1}'." + ); + ( "Parser.TOKEN.IDENT", + "identifier" + ); + ( "Parser.TOKEN.INT", + "integer literal" + ); + ( "Parser.TOKEN.FLOAT", + "floating point literal" + ); + ( "Parser.TOKEN.DECIMAL", + "decimal literal" + ); + ( "Parser.TOKEN.CHAR", + "character literal" + ); + ( "Parser.TOKEN.BASE", + "keyword 'base'" + ); + ( "Parser.TOKEN.LPAREN.STAR.RPAREN", + "symbol '(*)'" + ); + ( "Parser.TOKEN.DOLLAR", + "symbol '$'" + ); + ( "Parser.TOKEN.INFIX.STAR.STAR.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.COMPARE.OP", + "infix operator" + ); + ( "Parser.TOKEN.COLON.GREATER", + "symbol ':>'" + ); + ( "Parser.TOKEN.COLON.COLON", + "symbol '::'" + ); + ( "Parser.TOKEN.PERCENT.OP", + "symbol '{0}" + ); + ( "Parser.TOKEN.INFIX.AT.HAT.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.BAR.OP", + "infix operator" + ); + ( "Parser.TOKEN.PLUS.MINUS.OP", + "infix operator" + ); + ( "Parser.TOKEN.PREFIX.OP", + "prefix operator" + ); + ( "Parser.TOKEN.COLON.QMARK.GREATER", + "symbol ':?>'" + ); + ( "Parser.TOKEN.INFIX.STAR.DIV.MOD.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.AMP.OP", + "infix operator" + ); + ( "Parser.TOKEN.AMP", + "symbol '&'" + ); + ( "Parser.TOKEN.AMP.AMP", + "symbol '&&'" + ); + ( "Parser.TOKEN.BAR.BAR", + "symbol '||'" + ); + ( "Parser.TOKEN.LESS", + "symbol '<'" + ); + ( "Parser.TOKEN.GREATER", + "symbol '>'" + ); + ( "Parser.TOKEN.QMARK", + "symbol '?'" + ); + ( "Parser.TOKEN.QMARK.QMARK", + "symbol '??'" + ); + ( "Parser.TOKEN.COLON.QMARK", + "symbol ':?'" + ); + ( "Parser.TOKEN.INT32.DOT.DOT", + "integer.." + ); + ( "Parser.TOKEN.DOT.DOT", + "symbol '..'" + ); + ( "Parser.TOKEN.QUOTE", + "quote symbol" + ); + ( "Parser.TOKEN.STAR", + "symbol '*'" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.TYAPP", + "type application " + ); + ( "Parser.TOKEN.COLON", + "symbol ':'" + ); + ( "Parser.TOKEN.COLON.EQUALS", + "symbol ':='" + ); + ( "Parser.TOKEN.LARROW", + "symbol '<-'" + ); + ( "Parser.TOKEN.EQUALS", + "symbol '='" + ); + ( "Parser.TOKEN.GREATER.BAR.RBRACK", + "symbol '>|]'" + ); + ( "Parser.TOKEN.MINUS", + "symbol '-'" + ); + ( "Parser.TOKEN.ADJACENT.PREFIX.OP", + "prefix operator" + ); + ( "Parser.TOKEN.FUNKY.OPERATOR.NAME", + "operator name" + ); + ( "Parser.TOKEN.COMMA", + "symbol ','" + ); + ( "Parser.TOKEN.DOT", + "symbol '.'" + ); + ( "Parser.TOKEN.BAR", + "symbol '|'" + ); + ( "Parser.TOKEN.HASH", + "symbol #" + ); + ( "Parser.TOKEN.UNDERSCORE", + "symbol '_'" + ); + ( "Parser.TOKEN.SEMICOLON", + "symbol ';'" + ); + ( "Parser.TOKEN.SEMICOLON.SEMICOLON", + "symbol ';;'" + ); + ( "Parser.TOKEN.LPAREN", + "symbol '('" + ); + ( "Parser.TOKEN.RPAREN", + "symbol ')'" + ); + ( "Parser.TOKEN.SPLICE.SYMBOL", + "symbol 'splice'" + ); + ( "Parser.TOKEN.LQUOTE", + "start of quotation" + ); + ( "Parser.TOKEN.LBRACK", + "symbol '['" + ); + ( "Parser.TOKEN.LBRACK.BAR", + "symbol '[|'" + ); + ( "Parser.TOKEN.LBRACK.LESS", + "symbol '[<'" + ); + ( "Parser.TOKEN.LBRACE", + "symbol '{'" + ); + ( "Parser.TOKEN.LBRACE.LESS", + "symbol '{<'" + ); + ( "Parser.TOKEN.BAR.RBRACK", + "symbol '|]'" + ); + ( "Parser.TOKEN.GREATER.RBRACE", + "symbol '>}'" + ); + ( "Parser.TOKEN.GREATER.RBRACK", + "symbol '>]'" + ); + ( "Parser.TOKEN.RQUOTE", + "end of quotation" + ); + ( "Parser.TOKEN.RBRACK", + "symbol ']'" + ); + ( "Parser.TOKEN.RBRACE", + "symbol '}'" + ); + ( "Parser.TOKEN.PUBLIC", + "keyword 'public'" + ); + ( "Parser.TOKEN.PRIVATE", + "keyword 'private'" + ); + ( "Parser.TOKEN.INTERNAL", + "keyword 'internal'" + ); + ( "Parser.TOKEN.CONSTRAINT", + "keyword 'constraint'" + ); + ( "Parser.TOKEN.INSTANCE", + "keyword 'instance'" + ); + ( "Parser.TOKEN.DELEGATE", + "keyword 'delegate'" + ); + ( "Parser.TOKEN.INHERIT", + "keyword 'inherit'" + ); + ( "Parser.TOKEN.CONSTRUCTOR", + "keyword 'constructor'" + ); + ( "Parser.TOKEN.DEFAULT", + "keyword 'default'" + ); + ( "Parser.TOKEN.OVERRIDE", + "keyword 'override'" + ); + ( "Parser.TOKEN.ABSTRACT", + "keyword 'abstract'" + ); + ( "Parser.TOKEN.CLASS", + "keyword 'class'" + ); + ( "Parser.TOKEN.MEMBER", + "keyword 'member'" + ); + ( "Parser.TOKEN.STATIC", + "keyword 'static'" + ); + ( "Parser.TOKEN.NAMESPACE", + "keyword 'namespace'" + ); + ( "Parser.TOKEN.OBLOCKBEGIN", + "start of structured construct" + ); + ( "Parser.TOKEN.OBLOCKEND", + "incomplete structured construct at or before this point" + ); + ( "BlockEndSentence", + "Incomplete structured construct at or before this point" + ); + ( "Parser.TOKEN.OTHEN", + "keyword 'then'" + ); + ( "Parser.TOKEN.OELSE", + "keyword 'else'" + ); + ( "Parser.TOKEN.OLET", + "keyword 'let' or 'use'" + ); + ( "Parser.TOKEN.BINDER", + "binder keyword" + ); + ( "Parser.TOKEN.ODO", + "keyword 'do'" + ); + ( "Parser.TOKEN.CONST", + "keyword 'const'" + ); + ( "Parser.TOKEN.OWITH", + "keyword 'with'" + ); + ( "Parser.TOKEN.OFUNCTION", + "keyword 'function'" + ); + ( "Parser.TOKEN.OFUN", + "keyword 'fun'" + ); + ( "Parser.TOKEN.ORESET", + "end of input" + ); + ( "Parser.TOKEN.ODUMMY", + "internal dummy token" + ); + ( "Parser.TOKEN.ODO.BANG", + "keyword 'do!'" + ); + ( "Parser.TOKEN.YIELD", + "yield" + ); + ( "Parser.TOKEN.YIELD.BANG", + "yield!" + ); + ( "Parser.TOKEN.OINTERFACE.MEMBER", + "keyword 'interface'" + ); + ( "Parser.TOKEN.ELIF", + "keyword 'elif'" + ); + ( "Parser.TOKEN.RARROW", + "symbol '->'" + ); + ( "Parser.TOKEN.SIG", + "keyword 'sig'" + ); + ( "Parser.TOKEN.STRUCT", + "keyword 'struct'" + ); + ( "Parser.TOKEN.UPCAST", + "keyword 'upcast'" + ); + ( "Parser.TOKEN.DOWNCAST", + "keyword 'downcast'" + ); + ( "Parser.TOKEN.NULL", + "keyword 'null'" + ); + ( "Parser.TOKEN.RESERVED", + "reserved keyword" + ); + ( "Parser.TOKEN.MODULE", + "keyword 'module'" + ); + ( "Parser.TOKEN.AND", + "keyword 'and'" + ); + ( "Parser.TOKEN.AS", + "keyword 'as'" + ); + ( "Parser.TOKEN.ASSERT", + "keyword 'assert'" + ); + ( "Parser.TOKEN.ASR", + "keyword 'asr'" + ); + ( "Parser.TOKEN.DOWNTO", + "keyword 'downto'" + ); + ( "Parser.TOKEN.EXCEPTION", + "keyword 'exception'" + ); + ( "Parser.TOKEN.FALSE", + "keyword 'false'" + ); + ( "Parser.TOKEN.FOR", + "keyword 'for'" + ); + ( "Parser.TOKEN.FUN", + "keyword 'fun'" + ); + ( "Parser.TOKEN.FUNCTION", + "keyword 'function'" + ); + ( "Parser.TOKEN.FINALLY", + "keyword 'finally'" + ); + ( "Parser.TOKEN.LAZY", + "keyword 'lazy'" + ); + ( "Parser.TOKEN.MATCH", + "keyword 'match'" + ); + ( "Parser.TOKEN.MUTABLE", + "keyword 'mutable'" + ); + ( "Parser.TOKEN.NEW", + "keyword 'new'" + ); + ( "Parser.TOKEN.OF", + "keyword 'of'" + ); + ( "Parser.TOKEN.OPEN", + "keyword 'open'" + ); + ( "Parser.TOKEN.OR", + "keyword 'or'" + ); + ( "Parser.TOKEN.VOID", + "keyword 'void'" + ); + ( "Parser.TOKEN.EXTERN", + "keyword 'extern'" + ); + ( "Parser.TOKEN.INTERFACE", + "keyword 'interface'" + ); + ( "Parser.TOKEN.REC", + "keyword 'rec'" + ); + ( "Parser.TOKEN.TO", + "keyword 'to'" + ); + ( "Parser.TOKEN.TRUE", + "keyword 'true'" + ); + ( "Parser.TOKEN.TRY", + "keyword 'try'" + ); + ( "Parser.TOKEN.TYPE", + "keyword 'type'" + ); + ( "Parser.TOKEN.VAL", + "keyword 'val'" + ); + ( "Parser.TOKEN.INLINE", + "keyword 'inline'" + ); + ( "Parser.TOKEN.WHEN", + "keyword 'when'" + ); + ( "Parser.TOKEN.WHILE", + "keyword 'while'" + ); + ( "Parser.TOKEN.WITH", + "keyword 'with'" + ); + ( "Parser.TOKEN.IF", + "keyword 'if'" + ); + ( "Parser.TOKEN.DO", + "keyword 'do'" + ); + ( "Parser.TOKEN.GLOBAL", + "keyword 'global'" + ); + ( "Parser.TOKEN.DONE", + "keyword 'done'" + ); + ( "Parser.TOKEN.IN", + "keyword 'in'" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.PAREN.APP", + "symbol '('" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.BRACK.APP", + "symbol'['" + ); + ( "Parser.TOKEN.BEGIN", + "keyword 'begin'" + ); + ( "Parser.TOKEN.END", + "keyword 'end'" + ); + ( "Parser.TOKEN.HASH.ENDIF", + "directive" + ); + ( "Parser.TOKEN.INACTIVECODE", + "inactive code" + ); + ( "Parser.TOKEN.LEX.FAILURE", + "lex failure" + ); + ( "Parser.TOKEN.WHITESPACE", + "whitespace" + ); + ( "Parser.TOKEN.COMMENT", + "comment" + ); + ( "Parser.TOKEN.LINE.COMMENT", + "line comment" + ); + ( "Parser.TOKEN.STRING.TEXT", + "string text" + ); + ( "Parser.TOKEN.KEYWORD_STRING", + "compiler generated literal" + ); + ( "Parser.TOKEN.BYTEARRAY", + "byte array literal" + ); + ( "Parser.TOKEN.STRING", + "string literal" + ); + ( "Parser.TOKEN.EOF", + "end of input" + ); + ( "UnexpectedEndOfInput", + "Unexpected end of input" + ); + ( "Unexpected", + "Unexpected {0}" + ); + ( "NONTERM.interaction", + " in interaction" + ); + ( "NONTERM.hashDirective", + " in directive" + ); + ( "NONTERM.fieldDecl", + " in field declaration" + ); + ( "NONTERM.unionCaseRepr", + " in discriminated union case declaration" + ); + ( "NONTERM.localBinding", + " in binding" + ); + ( "NONTERM.hardwhiteLetBindings", + " in binding" + ); + ( "NONTERM.classDefnMember", + " in member definition" + ); + ( "NONTERM.defnBindings", + " in definitions" + ); + ( "NONTERM.classMemberSpfn", + " in member signature" + ); + ( "NONTERM.valSpfn", + " in value signature" + ); + ( "NONTERM.tyconSpfn", + " in type signature" + ); + ( "NONTERM.anonLambdaExpr", + " in lambda expression" + ); + ( "NONTERM.attrUnionCaseDecl", + " in union case" + ); + ( "NONTERM.cPrototype", + " in extern declaration" + ); + ( "NONTERM.objectImplementationMembers", + " in object expression" + ); + ( "NONTERM.ifExprCases", + " in if/then/else expression" + ); + ( "NONTERM.openDecl", + " in open declaration" + ); + ( "NONTERM.fileModuleSpec", + " in module or namespace signature" + ); + ( "NONTERM.patternClauses", + " in pattern matching" + ); + ( "NONTERM.beginEndExpr", + " in begin/end expression" + ); + ( "NONTERM.recdExpr", + " in record expression" + ); + ( "NONTERM.tyconDefn", + " in type definition" + ); + ( "NONTERM.exconCore", + " in exception definition" + ); + ( "NONTERM.typeNameInfo", + " in type name" + ); + ( "NONTERM.attributeList", + " in attribute list" + ); + ( "NONTERM.quoteExpr", + " in quotation literal" + ); + ( "NONTERM.typeConstraint", + " in type constraint" + ); + ( "NONTERM.Category.ImplementationFile", + " in implementation file" + ); + ( "NONTERM.Category.Definition", + " in definition" + ); + ( "NONTERM.Category.SignatureFile", + " in signature file" + ); + ( "NONTERM.Category.Pattern", + " in pattern" + ); + ( "NONTERM.Category.Expr", + " in expression" + ); + ( "NONTERM.Category.Type", + " in type" + ); + ( "NONTERM.typeArgsActual", + " in type arguments" + ); + ( "FixKeyword", + "keyword " + ); + ( "FixSymbol", + "symbol " + ); + ( "FixReplace", + " (due to indentation-aware syntax)" + ); + ( "TokenName1", + ". Expected {0} or other token." + ); + ( "TokenName1TokenName2", + ". Expected {0}, {1} or other token." + ); + ( "TokenName1TokenName2TokenName3", + ". Expected {0}, {1}, {2} or other token." + ); + ( "RuntimeCoercionSourceSealed1", + "The type '{0}' cannot be used as the source of a type test or runtime coercion" + ); + ( "RuntimeCoercionSourceSealed2", + "The type '{0}' does not have any proper subtypes and cannot be used as the source of a type test or runtime coercion." + ); + ( "CoercionTargetSealed", + "The type '{0}' does not have any proper subtypes and need not be used as the target of a static coercion" + ); + ( "UpcastUnnecessary", + "This upcast is unnecessary - the types are identical" + ); + ( "TypeTestUnnecessary", + "This type test or downcast will always hold" + ); + ( "OverrideDoesntOverride1", + "The member '{0}' does not have the correct type to override any given virtual method" + ); + ( "OverrideDoesntOverride2", + "The member '{0}' does not have the correct type to override the corresponding abstract method." + ); + ( "OverrideDoesntOverride3", + " The required signature is '{0}'." + ); + ( "OverrideDoesntOverride4", + "The member '{0}' is specialized with 'unit' but 'unit' can't be used as return type of an abstract method parameterized on return type." + ); + ( "UnionCaseWrongArguments", + "This constructor is applied to {0} argument(s) but expects {1}" + ); + ( "UnionPatternsBindDifferentNames", + "The two sides of this 'or' pattern bind different sets of variables" + ); + ( "ValueNotContained", + "Module '{0}' contains\\n {1} \\nbut its signature specifies\\n {2} \\n{3}." + ); + ( "RequiredButNotSpecified", + "Module '{0}' requires a {1} '{2}'" + ); + ( "UseOfAddressOfOperator", + "The use of native pointers may result in unverifiable .NET IL code" + ); + ( "DefensiveCopyWarning", + "{0}" + ); + ( "DeprecatedThreadStaticBindingWarning", + "Thread static and context static 'let' bindings are deprecated. Instead use a declaration of the form 'static val mutable : ' in a class. Add the 'DefaultValue' attribute to this declaration to indicate that the value is initialized to the default value on each new thread." + ); + ( "FunctionValueUnexpected", + "This expression is a function value, i.e. is missing arguments. Its type is {0}." + ); + ( "UnitTypeExpected1", + "The result of this expression is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'." + ); + ( "UnitTypeExpected2", + "This expression should have type 'unit', but has type '{0}'. If assigning to a property use the syntax 'obj.Prop <- expr'." + ); + ( "RecursiveUseCheckedAtRuntime", + "This recursive use will be checked for initialization-soundness at runtime. This warning is usually harmless, and may be suppressed by using '#nowarn \"21\"' or '--nowarn:21'." + ); + ( "LetRecUnsound1", + "The value '{0}' will be evaluated as part of its own definition" + ); + ( "LetRecUnsound2", + "This value will be eventually evaluated as part of its own definition. You may need to make the value lazy or a function. Value '{0}'{1}." + ); + ( "LetRecUnsoundInner", + " will evaluate '{0}'" + ); + ( "LetRecEvaluatedOutOfOrder", + "Bindings may be executed out-of-order because of this forward reference." + ); + ( "LetRecCheckedAtRuntime", + "This and other recursive references to the object(s) being defined will be checked for initialization-soundness at runtime through the use of a delayed reference. This is because you are defining one or more recursive objects, rather than recursive functions. This warning may be suppressed by using '#nowarn \"40\"' or '--nowarn:40'." + ); + ( "SelfRefObjCtor1", + "Recursive references to the object being defined will be checked for initialization soundness at runtime through the use of a delayed reference. Consider placing self-references in members or within a trailing expression of the form ' then '." + ); + ( "SelfRefObjCtor2", + "Recursive references to the object being defined will be checked for initialization soundness at runtime through the use of a delayed reference. Consider placing self-references within 'do' statements after the last 'let' binding in the construction sequence." + ); + ( "VirtualAugmentationOnNullValuedType", + "The containing type can use 'null' as a representation value for its nullary union case. Invoking an abstract or virtual member or an interface implementation on a null value will lead to an exception. If necessary add a dummy data value to the nullary constructor to avoid 'null' being used as a representation for this type." + ); + ( "NonVirtualAugmentationOnNullValuedType", + "The containing type can use 'null' as a representation value for its nullary union case. This member will be compiled as a static member." + ); + ( "NonUniqueInferredAbstractSlot1", + "The member '{0}' doesn't correspond to a unique abstract slot based on name and argument count alone" + ); + ( "NonUniqueInferredAbstractSlot2", + ". Multiple implemented interfaces have a member with this name and argument count" + ); + ( "NonUniqueInferredAbstractSlot3", + ". Consider implementing interfaces '{0}' and '{1}' explicitly." + ); + ( "NonUniqueInferredAbstractSlot4", + ". Additional type annotations may be required to indicate the relevant override. This warning can be disabled using '#nowarn \"70\"' or '--nowarn:70'." + ); + ( "Failure1", + "parse error" + ); + ( "Failure2", + "parse error: unexpected end of file" + ); + ( "Failure3", + "{0}" + ); + ( "Failure4", + "internal error: {0}" + ); + ( "FullAbstraction", + "{0}" + ); + ( "MatchIncomplete1", + "Incomplete pattern matches on this expression." + ); + ( "MatchIncomplete2", + " For example, the value '{0}' may indicate a case not covered by the pattern(s)." + ); + ( "MatchIncomplete3", + " For example, the value '{0}' may indicate a case not covered by the pattern(s). However, a pattern rule with a 'when' clause might successfully match this value." + ); + ( "MatchIncomplete4", + " Unmatched elements will be ignored." + ); + ( "RuleNeverMatched", + "This rule will never be matched" + ); + ( "ValNotMutable", + "This value is not mutable. Consider using the mutable keyword, e.g. 'let mutable {0} = expression'." + ); + ( "ValNotLocal", + "This value is not local" + ); + ( "Obsolete1", + "This construct is deprecated" + ); + ( "Obsolete2", + ". {0}" + ); + ( "Experimental", + "{0}. This warning can be disabled using '--nowarn:57' or '#nowarn \"57\"'." + ); + ( "PossibleUnverifiableCode", + "Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn \"9\"'." + ); + ( "Deprecated", + "This construct is deprecated: {0}" + ); + ( "LibraryUseOnly", + "This construct is deprecated: it is only for use in the F# library" + ); + ( "MissingFields", + "The following fields require values: {0}" + ); + ( "ValueRestriction1", + "Value restriction. The value '{0}' has generic type\\n {1} \\nEither make the arguments to '{2}' explicit or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction2", + "Value restriction. The value '{0}' has generic type\\n {1} \\nEither make '{2}' into a function with explicit arguments or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction3", + "Value restriction. This member has been inferred to have generic type\\n {0} \\nConstructors and property getters/setters cannot be more generic than the enclosing type. Add a type annotation to indicate the exact types involved." + ); + ( "ValueRestriction4", + "Value restriction. The value '{0}' has been inferred to have generic type\\n {1} \\nEither make the arguments to '{2}' explicit or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction5", + "Value restriction. The value '{0}' has been inferred to have generic type\\n {1} \\nEither define '{2}' as a simple data term, make it a function with explicit arguments or, if you do not intend for it to be generic, add a type annotation." + ); + ( "RecoverableParseError", + "syntax error" + ); + ( "ReservedKeyword", + "{0}" + ); + ( "IndentationProblem", + "{0}" + ); + ( "OverrideInIntrinsicAugmentation", + "Override implementations in augmentations are now deprecated. Override implementations should be given as part of the initial declaration of a type." + ); + ( "OverrideInExtrinsicAugmentation", + "Override implementations should be given as part of the initial declaration of a type." + ); + ( "IntfImplInIntrinsicAugmentation", + "Interface implementations in augmentations are now deprecated. Interface implementations should be given on the initial declaration of a type." + ); + ( "IntfImplInExtrinsicAugmentation", + "Interface implementations should be given on the initial declaration of a type." + ); + ( "UnresolvedReferenceNoRange", + "A required assembly reference is missing. You must add a reference to assembly '{0}'." + ); + ( "UnresolvedPathReferenceNoRange", + "The type referenced through '{0}' is defined in an assembly that is not referenced. You must add a reference to assembly '{1}'." + ); + ( "HashIncludeNotAllowedInNonScript", + "#I directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file, add a '-I' compiler option for this reference or delimit the directive with delimit it with '#if INTERACTIVE'/'#endif'." + ); + ( "HashReferenceNotAllowedInNonScript", + "#r directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file, add a '-r' compiler option for this reference or delimit the directive with '#if INTERACTIVE'/'#endif'." + ); + ( "HashDirectiveNotAllowedInNonScript", + "This directive may only be used in F# script files (extensions .fsx or .fsscript). Either remove the directive, move this code to a script file or delimit the directive with '#if INTERACTIVE'/'#endif'." + ); + ( "FileNameNotResolved", + "Unable to find the file '{0}' in any of\\n {1}" + ); + ( "AssemblyNotResolved", + "Assembly reference '{0}' was not found or is invalid" + ); + ( "HashLoadedSourceHasIssues1", + "One or more warnings in loaded file.\\n" + ); + ( "HashLoadedSourceHasIssues2", + "One or more errors in loaded file.\\n" + ); + ( "HashLoadedScriptConsideredSource", + "Loaded files may only be F# source files (extension .fs). This F# script file (.fsx or .fsscript) will be treated as an F# source file" + ); + ( "InvalidInternalsVisibleToAssemblyName1", + "Invalid assembly name '{0}' from InternalsVisibleTo attribute in {1}" + ); + ( "InvalidInternalsVisibleToAssemblyName2", + "Invalid assembly name '{0}' from InternalsVisibleTo attribute (assembly filename not available)" + ); + ( "LoadedSourceNotFoundIgnoring", + "Could not load file '{0}' because it does not exist or is inaccessible" + ); + ( "MSBuildReferenceResolutionError", + "{0} (Code={1})" + ); + ( "TargetInvocationExceptionWrapper", + "internal error: {0}" + ); + ] diff --git a/src/fsharp/Fable.FCS/package.json b/src/fsharp/Fable.FCS/package.json new file mode 100644 index 0000000000..3e27d1325a --- /dev/null +++ b/src/fsharp/Fable.FCS/package.json @@ -0,0 +1,9 @@ +{ + "private": true, + "engines": { + "fable": "^0.7.42" + }, + "dependencies": { + "fable-core": "^0.7.26" + } +} diff --git a/src/fsharp/Fable.FCS/project.fsproj b/src/fsharp/Fable.FCS/project.fsproj new file mode 100644 index 0000000000..2141186839 --- /dev/null +++ b/src/fsharp/Fable.FCS/project.fsproj @@ -0,0 +1,86 @@ + + + + + Debug + AnyCPU + 2.0 + 503ad75d-b915-4dab-8819-16f9e8711881 + Exe + Fable.FCS + Fable.FCS + v4.6 + true + 4.4.0.0 + Fable.FCS + false + $(DefineConstants);DOTNET40 + $(DefineConstants);FABLE_COMPILER + $(DefineConstants);FX_NO_CORHOST_SIGNER + $(DefineConstants);FX_NO_LINKEDRESOURCES + $(DefineConstants);FX_NO_PDB_READER + $(DefineConstants);FX_NO_PDB_WRITER + $(DefineConstants);NO_COMPILER_BACKEND + $(DefineConstants);NO_INLINE_IL_PARSER + $(DefineConstants);TRACE + + + true + full + false + false + bin\$(Configuration)\ + DEBUG;$(DefineConstants) + 3 + AnyCPU + bin\$(Configuration)\$(AssemblyName).XML + true + + + pdbonly + true + true + bin\$(Configuration)\ + $(DefineConstants) + 3 + AnyCPU + bin\$(Configuration)\$(AssemblyName).XML + true + + + 11 + + + + + $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets + + + + + $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets + + + + + + + + + + + + True + + + + + + + \ No newline at end of file diff --git a/src/fsharp/Fable.FCS/project.fsx b/src/fsharp/Fable.FCS/project.fsx new file mode 100644 index 0000000000..1d73084918 --- /dev/null +++ b/src/fsharp/Fable.FCS/project.fsx @@ -0,0 +1,11 @@ +#if FABLE_COMPILER && !DOTNETCORE +// #r "System.Threading.dll" +#r "node_modules/fable-core/Fable.Core.dll" +#endif + +#load + "Fable.FCS.fsx" + "app.fs" + +[] +let main argv = App.main argv diff --git a/src/fsharp/Fable.FCS/project.json b/src/fsharp/Fable.FCS/project.json new file mode 100644 index 0000000000..f00e24c403 --- /dev/null +++ b/src/fsharp/Fable.FCS/project.json @@ -0,0 +1,60 @@ +{ + "version": "1.0.0-*", + "buildOptions": { + "debugType": "portable", + "emitEntryPoint": true, + "compilerName": "fsc", + "compile": { + "includeFiles": [ + "Fable.FCS.fsx", + "app.fs" + ] + }, + "define": [ + "DOTNET40", + "FABLE_COMPILER", + "FX_NO_CORHOST_SIGNER", + "FX_NO_LINKEDRESOURCES", + "FX_NO_PDB_READER", + "FX_NO_PDB_WRITER", + "NO_COMPILER_BACKEND", + "NO_INLINE_IL_PARSER", + "TRACE" + ], + "nowarn": [], + "xmlDoc": true, + "delaySign": true, + "warningsAsErrors": true, + "additionalArguments": [ + "--fullpaths", + "--flaterrors", + "--warnon:1182" + ] + }, + "dependencies": { + "FSharp.Core": "4.0.1.7-alpha" + }, + "tools": { + "dotnet-compile-fsc": { + "version": "1.0.0-preview2-*", + "imports": "dnxcore50" + } + }, + "runtimes": { + "win7-x86": {}, + "win7-x64": {}, + "osx.10.11-x64": {}, + "ubuntu.14.04-x64": {} + }, + "frameworks": { + //"net462": {}, + "netcoreapp1.0": { + "dependencies": { + "Microsoft.NETCore.App": { + "version": "1.0.0-*", + "type": "platform" + } + } + } + } +} \ No newline at end of file diff --git a/src/fsharp/Fable.FCS/service_shim.fs b/src/fsharp/Fable.FCS/service_shim.fs new file mode 100644 index 0000000000..43bfd4e1c5 --- /dev/null +++ b/src/fsharp/Fable.FCS/service_shim.fs @@ -0,0 +1,860 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +// Open up the compiler as an incremental service for parsing, +// type checking and intellisense-like environment-reporting. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +#nowarn "1182" + +open System +//open System.IO +open System.Text +open System.Threading +//open System.Reflection.Emit +//open System.Runtime +open System.Collections.Generic + +//open Microsoft.FSharp.Core.Printf +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.CompileOps +//open Microsoft.FSharp.Compiler.Driver +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.ReferenceResolver +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Parser +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Lexhelp +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.Tastops.DebugPrint +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.TypeChecker +open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl + +open Internal.Utilities +open Internal.Utilities.Collections +open Microsoft.FSharp.Collections + +//------------------------------------------------------------------------- +// From IncrementalBuild.fs +//------------------------------------------------------------------------ +[] +type FSharpErrorSeverity = + | Warning + | Error + +type FSharpErrorInfo(fileName, s:pos, e:pos, severity: FSharpErrorSeverity, message: string, subcategory: string, errorNum: int) = + member __.StartLine = Line.toZ s.Line + member __.StartLineAlternate = s.Line + member __.EndLine = Line.toZ e.Line + member __.EndLineAlternate = e.Line + member __.StartColumn = s.Column + member __.EndColumn = e.Column + member __.Severity = severity + member __.Message = message + member __.Subcategory = subcategory + member __.FileName = fileName + member __.ErrorNumber = errorNum + member __.WithStart(newStart) = FSharpErrorInfo(fileName, newStart, e, severity, message, subcategory, errorNum) + member __.WithEnd(newEnd) = FSharpErrorInfo(fileName, s, newEnd, severity, message, subcategory, errorNum) + override __.ToString()= sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName (int s.Line) (s.Column + 1) (int e.Line) (e.Column + 1) subcategory (if severity=FSharpErrorSeverity.Warning then "warning" else "error") message + + /// Decompose a warning or error into parts: position, severity, message, error number + static member (*internal*) CreateFromException(exn,warn,trim:bool,fallbackRange:range) = + let m = match GetRangeOfError exn with Some m -> m | None -> fallbackRange + let e = if trim then m.Start else m.End + let msg = bufs (fun buf -> OutputPhasedError buf exn false) + let errorNum = GetErrorNumber exn + FSharpErrorInfo(m.FileName, m.Start, e, (if warn then FSharpErrorSeverity.Warning else FSharpErrorSeverity.Error), msg, exn.Subcategory(), errorNum) + + /// Decompose a warning or error into parts: position, severity, message, error number + static member internal CreateFromExceptionAndAdjustEof(exn,warn,trim:bool,fallbackRange:range, (linesCount:int, lastLength:int)) = + let r = FSharpErrorInfo.CreateFromException(exn,warn,trim,fallbackRange) + // Adjust to make sure that errors reported at Eof are shown at the linesCount + let startline, schange = min (r.StartLineAlternate, false) (linesCount, true) + let endline, echange = min (r.EndLineAlternate, false) (linesCount, true) + + if not (schange || echange) then r + else + let r = if schange then r.WithStart(mkPos startline lastLength) else r + if echange then r.WithEnd(mkPos endline (1 + lastLength)) else r + +//------------------------------------------------------------------------- +// From ServiceUntypedParse.fs +//------------------------------------------------------------------------ +[] +type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput option, parseHadErrors : bool, dependencyFiles : string list) = + + member scope.Errors = errors + member scope.ParseHadErrors = parseHadErrors + member scope.ParseTree = input + +//------------------------------------------------------------------------- +// From service.fs +//------------------------------------------------------------------------ + +// A scope represents everything we get back from the typecheck of a file. +// It acts like an in-memory database about the file. +// It is effectively immutable and not updated: when we re-typecheck we just drop the previous +// scope object on the floor and make a new one. +[] +type internal TypeCheckInfo + (// Information corresponding to miscellaneous command-line options (--define, etc). + _sTcConfig: TcConfig, + g: TcGlobals, + // The signature of the assembly being checked, up to and including the current file + ccuSig: ModuleOrNamespaceType, + thisCcu: CcuThunk, + tcImports: TcImports, + tcAccessRights: AccessorDomain, + projectFileName: string , + mainInputFileName: string , + sResolutions: TcResolutions, + sSymbolUses: TcSymbolUses, + // This is a name resolution environment to use if no better match can be found. + sFallback: NameResolutionEnv, + //loadClosure : LoadClosure option, + reactorOps : IReactorOperations, + checkAlive : (unit -> bool), + textSnapshotInfo:obj option) = + + member x.ScopeResolutions = sResolutions + member x.ScopeSymbolUses = sSymbolUses + member x.TcGlobals = g + member x.TcImports = tcImports + member x.CcuSig = ccuSig + member x.ThisCcu = thisCcu + member x.PartialAssemblySignature() = FSharpAssemblySignature(g, thisCcu, tcImports, None, ccuSig) + member x.AccessRights = tcAccessRights + + +module internal Parser = + + // We'll need number of lines for adjusting error messages at EOF + let GetFileInfoForLastLineErrors (source: string) = + // number of lines in the source file + let lastLine = (source |> Seq.sumBy (fun c -> if c = '\n' then 1 else 0)) + 1 + // length of the last line + let lastLineLength = source.Length - source.LastIndexOf("\n") - 1 //,StringComparison.Ordinal) - 1 + lastLine, lastLineLength + + let ReportError (tcConfig:TcConfig, allErrors, mainInputFileName, fileInfo, (exn, sev)) = + [ let warn = (sev = FSharpErrorSeverity.Warning) && not (ReportWarningAsError (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn, tcConfig.specificWarnAsError, tcConfig.specificWarnAsWarn, tcConfig.globalWarnAsError) exn) + if (not warn || ReportWarning (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn) exn) then + let oneError trim exn = + [ // We use the first line of the file as a fallbackRange for reporting unexpected errors. + // Not ideal, but it's hard to see what else to do. + let fallbackRange = rangeN mainInputFileName 1 + let ei = FSharpErrorInfo.CreateFromExceptionAndAdjustEof(exn,warn,trim,fallbackRange,fileInfo) + if allErrors || (ei.FileName=mainInputFileName) || (ei.FileName=Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation) then + yield ei ] + + let mainError,relatedErrors = SplitRelatedErrors exn + yield! oneError false mainError + for e in relatedErrors do + yield! oneError true e ] + + let CreateErrorInfos (tcConfig:TcConfig, allErrors, mainInputFileName, errors) = + let fileInfo = (Int32.MaxValue, Int32.MaxValue) + [| for (exn,warn) in errors do + yield! ReportError (tcConfig, allErrors, mainInputFileName, fileInfo, (exn, warn)) |] + + + /// Error handler for parsing & type checking while processing a single file + type ErrorHandler(reportErrors, mainInputFileName, tcConfig: TcConfig, source: string) = + let mutable tcConfig = tcConfig + let errorsAndWarningsCollector = new ResizeArray<_>() + let mutable errorCount = 0 + + // We'll need number of lines for adjusting error messages at EOF + let fileInfo = GetFileInfoForLastLineErrors source + + // This function gets called whenever an error happens during parsing or checking + let errorSink sev (exn:PhasedError) = + // Sanity check here. The phase of an error should be in a phase known to the language service. + let exn = + if not(exn.IsPhaseInCompile()) then + // Reaching this point means that the error would be sticky if we let it prop up to the language service. + // Assert and recover by replacing phase with one known to the language service. + System.Diagnostics.Debug.Assert(false, sprintf "The subcategory '%s' seen in an error should not be seen by the language service" (exn.Subcategory())) + {exn with Phase=BuildPhase.TypeCheck} + else exn + if reportErrors then + let report exn = + for ei in ReportError (tcConfig, false, mainInputFileName, fileInfo, (exn, sev)) do + errorsAndWarningsCollector.Add ei + if sev = FSharpErrorSeverity.Error then + errorCount <- errorCount + 1 + + match exn with +#if EXTENSIONTYPING + | {Exception = (:? TypeProviderError as tpe)} -> + tpe.Iter (fun e -> + let newExn = {exn with Exception = e} + report newExn + ) +#endif + | e -> report e + + let errorLogger = + { new ErrorLogger("ErrorHandler") with + member x.WarnSinkImpl exn = errorSink FSharpErrorSeverity.Warning exn + member x.ErrorSinkImpl exn = errorSink FSharpErrorSeverity.Error exn + member x.ErrorCount = errorCount } + + + // Public members + member x.ErrorLogger = errorLogger + member x.CollectedErrorsAndWarnings = errorsAndWarningsCollector.ToArray() + member x.ErrorCount = errorCount + member x.TcConfig with set tc = tcConfig <- tc + member x.AnyErrors = errorCount > 0 + + + /// ParseOneFile builds all the information necessary to report errors, match braces and build scopes + /// + /// projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true. + let ParseOneFile (source: string, matchBracesOnly: bool, reportErrors: bool, mainInputFileName: string, projectSourceFiles: string list, tcConfig: TcConfig) = + + // Initialize the error handler + let errHandler = new ErrorHandler(reportErrors, mainInputFileName, tcConfig, source) + + let lexbuf = UnicodeLexing.StringAsLexbuf source + + // Collector for parens matching + let matchPairRef = new ResizeArray<_>() + + use unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _oldLogger -> errHandler.ErrorLogger) + use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + + // Errors on while parsing project arguments + + let parseResult = + + // If editing a script then define INTERACTIVE otherwise COMPILED. + // If this parsing is for intellisense, also define EDITING +#if FABLE_COMPILER + let conditionalCompilationDefines = + ["COMPILED"] // ["INTERACTIVE";"EDITING"] + @ tcConfig.conditionalCompilationDefines + let lightSyntaxStatus = LightSyntaxStatus(true,true) +#else + let conditionalCompilationDefines = + SourceFileImpl.AdditionalDefinesForUseInEditor(mainInputFileName) @ tcConfig.conditionalCompilationDefines + let lightSyntaxStatusInital = tcConfig.ComputeLightSyntaxInitialStatus mainInputFileName + let lightSyntaxStatus = LightSyntaxStatus(lightSyntaxStatusInital,true) +#endif + + // Note: we don't really attempt to intern strings across a large scope + let lexResourceManager = new Lexhelp.LexResourceManager() + let lexargs = mkLexargs(mainInputFileName, + conditionalCompilationDefines, + lightSyntaxStatus, + lexResourceManager, + ref [], + errHandler.ErrorLogger) + Lexhelp.usingLexbufForParsing (lexbuf, mainInputFileName) (fun lexbuf -> + try + let skip = true + let tokenizer = LexFilter.LexFilter (lightSyntaxStatus, tcConfig.compilingFslib, Lexer.token lexargs skip, lexbuf) + let lexfun = tokenizer.Lexer + if matchBracesOnly then + // Quick bracket matching parse + let parenTokensBalance t1 t2 = + match t1,t2 with + | (LPAREN,RPAREN) + | (LPAREN,RPAREN_IS_HERE) + | (LBRACE,RBRACE) + | (LBRACE,RBRACE_IS_HERE) + | (SIG,END) + | (STRUCT,END) + | (LBRACK_BAR,BAR_RBRACK) + | (LBRACK,RBRACK) + | (LBRACK_LESS,GREATER_RBRACK) + | (BEGIN,END) -> true + | (LQUOTE q1,RQUOTE q2) when q1 = q2 -> true + | _ -> false + let rec matchBraces stack = + match lexfun lexbuf,stack with + | tok2,((tok1,m1) :: stack') when parenTokensBalance tok1 tok2-> + if matchBracesOnly then + matchPairRef.Add (m1, lexbuf.LexemeRange) + matchBraces stack' + | ((LPAREN | LBRACE | LBRACK | LBRACK_BAR | LQUOTE _ | LBRACK_LESS) as tok),_ -> matchBraces ((tok,lexbuf.LexemeRange) :: stack) + | (EOF _ | LEX_FAILURE _),_ -> () + | _ -> matchBraces stack + + matchBraces [] + None + else + let isLastCompiland = + projectSourceFiles.Length >= 1 && + System.String.Compare(projectSourceFiles.[projectSourceFiles.Length-1],mainInputFileName,StringComparison.CurrentCultureIgnoreCase)=0 + let isLastCompiland = isLastCompiland || CompileOps.IsScript(mainInputFileName) +#if FABLE_COMPILER + let isExe = false // true for NodeJS? +#else + let isExe = tcConfig.target.IsExe +#endif + let parseResult = ParseInput(lexfun,errHandler.ErrorLogger,lexbuf,None,mainInputFileName,(isLastCompiland,isExe)) + Some parseResult + with e -> + errHandler.ErrorLogger.ErrorR(e) + None) + + + errHandler.CollectedErrorsAndWarnings, + matchPairRef.ToArray(), + parseResult, + errHandler.AnyErrors + + + /// Indicates if the type check got aborted because it is no longer relevant. + type TypeCheckAborted = Yes | No of TypeCheckInfo + + // Type check a single file against an initial context, gleaning both errors and intellisense information. + let TypeCheckOneFile + (parseResults: FSharpParseFileResults, + source: string, + mainInputFileName: string, + projectFileName: string, + tcConfig: TcConfig, + tcGlobals: TcGlobals, + tcImports: TcImports, + tcState: TcState, + //loadClosure: LoadClosure option, + // These are the errors and warnings seen by the background compiler for the entire antecedant + backgroundErrors: (PhasedError * FSharpErrorSeverity) list, + reactorOps: IReactorOperations, + // Used by 'FSharpDeclarationListInfo' to check the IncrementalBuilder is still alive. + checkAlive : (unit -> bool), + isResultObsolete: unit->bool, + textSnapshotInfo : obj option) = + + match parseResults.ParseTree with + // When processing the following cases, we don't need to type-check + | None -> + [| |], TypeCheckAborted.Yes, [] + + // Run the type checker... + | Some parsedMainInput -> + + // Initialize the error handler + let errHandler = new ErrorHandler(true,mainInputFileName,tcConfig, source) + + use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) + use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) + + // // Apply nowarns to tcConfig (may generate errors, so ensure errorLogger is installed) + // let tcConfig = ApplyNoWarnsToTcConfig tcConfig (parsedMainInput,Path.GetDirectoryName mainInputFileName) + + // update the error handler with the modified tcConfig + errHandler.TcConfig <- tcConfig + + // Play background errors and warnings for this file. + for (err,sev) in backgroundErrors do + if sev = FSharpErrorSeverity.Error then errorSink err else warnSink err + + + // // If additional references were brought in by the preprocessor then we need to process them + // match loadClosure with + // | Some loadClosure -> + // // Play unresolved references for this file. + // tcImports.ReportUnresolvedAssemblyReferences(loadClosure.UnresolvedReferences) + + // // If there was a loadClosure, replay the errors and warnings + // loadClosure.RootErrors |> List.iter errorSink + // loadClosure.RootWarnings |> List.iter warnSink + + + // let fileOfBackgroundError err = (match GetRangeOfError (fst err) with Some m-> m.FileName | None -> null) + // let sameFile file hashLoadInFile = + // (0 = String.Compare(fst hashLoadInFile, file, StringComparison.OrdinalIgnoreCase)) + + // // walk the list of #loads and keep the ones for this file. + // let hashLoadsInFile = + // loadClosure.SourceFiles + // |> List.filter(fun (_,ms) -> ms<>[]) // #loaded file, ranges of #load + + // let hashLoadBackgroundErrors, otherBackgroundErrors = + // backgroundErrors |> List.partition (fun backgroundError -> hashLoadsInFile |> List.exists (sameFile (fileOfBackgroundError backgroundError))) + + // // Create single errors for the #load-ed files. + // // Group errors and warnings by file name. + // let hashLoadBackgroundErrorsGroupedByFileName = + // hashLoadBackgroundErrors + // |> List.map(fun err -> fileOfBackgroundError err,err) + // |> List.groupByFirst // fileWithErrors, error list + + // // Join the sets and report errors. + // // It is by-design that these messages are only present in the language service. A true build would report the errors at their + // // spots in the individual source files. + // for hashLoadInFile in hashLoadsInFile do + // for errorGroupedByFileName in hashLoadBackgroundErrorsGroupedByFileName do + // if sameFile (fst errorGroupedByFileName) hashLoadInFile then + // for rangeOfHashLoad in snd hashLoadInFile do // Handle the case of two #loads of the same file + // let errorsAndWarnings = snd errorGroupedByFileName |> List.map(fun (pe,f)->pe.Exception,f) // Strip the build phase here. It will be replaced, in total, with TypeCheck + // let errors = [ for (err,sev) in errorsAndWarnings do if sev = FSharpErrorSeverity.Error then yield err ] + // let warnings = [ for (err,sev) in errorsAndWarnings do if sev = FSharpErrorSeverity.Warning then yield err ] + + // let message = HashLoadedSourceHasIssues(warnings,errors,rangeOfHashLoad) + // if errors=[] then warning(message) + // else errorR(message) + + // // Replay other background errors. + // for (phasedError,sev) in otherBackgroundErrors do + // if sev = FSharpErrorSeverity.Warning then warning phasedError.Exception else errorR phasedError.Exception + + // | None -> + // // For non-scripts, check for disallow #r and #load. + // ApplyMetaCommandsFromInputToTcConfig tcConfig (parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore + + // A problem arises with nice name generation, which really should only + // be done in the backend, but is also done in the typechecker for better or worse. + // If we don't do this the NNG accumulates data and we get a memory leak. + tcState.NiceNameGenerator.Reset() + + // Typecheck the real input. + let sink = TcResultsSinkImpl(tcGlobals, source = source) + + let tcEnvAtEndOpt = + try + let checkForErrors() = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) + // Typecheck is potentially a long running operation. We chop it up here with an Eventually continuation and, at each slice, give a chance + // for the client to claim the result as obsolete and have the typecheck abort. + let computation = TypeCheckOneInputAndFinishEventually(checkForErrors,tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) + match computation |> Eventually.forceWhile (fun () -> not (isResultObsolete())) with + | Some((tcEnvAtEnd,_,typedImplFiles),tcState) -> Some (tcEnvAtEnd, typedImplFiles, tcState) + | None -> None // Means 'aborted' + with + | e -> + errorR e + Some(tcState.TcEnvFromSignatures, [], tcState) + + let errors = errHandler.CollectedErrorsAndWarnings + + match tcEnvAtEndOpt with + | Some (tcEnvAtEnd, _typedImplFiles, tcState) -> + let scope = + TypeCheckInfo(tcConfig, tcGlobals, + tcState.PartialAssemblySignature, + tcState.Ccu, + tcImports, + tcEnvAtEnd.AccessRights, + //typedImplFiles, + projectFileName, + mainInputFileName, + sink.GetResolutions(), + sink.GetSymbolUses(), + tcEnvAtEnd.NameEnv, + //loadClosure, + reactorOps, + checkAlive, + textSnapshotInfo) + errors, TypeCheckAborted.No scope, _typedImplFiles + | None -> + errors, TypeCheckAborted.Yes, [] + + +//type UnresolvedReferencesSet = UnresolvedReferencesSet of UnresolvedAssemblyReference list + +type FSharpProjectOptions = + { + ProjectFileName: string + ProjectFileNames: string[] + OtherOptions: string[] + ReferencedProjects: (string * FSharpProjectOptions)[] + IsIncompleteTypeCheckEnvironment : bool + UseScriptResolutionRules : bool + LoadTime : System.DateTime + //UnresolvedReferences : UnresolvedReferencesSet option + } + +[] +type FSharpProjectContext internal (thisCcu: CcuThunk, assemblies: FSharpAssembly list, ad: AccessorDomain) = + + /// Get the assemblies referenced + member __.GetReferencedAssemblies() = assemblies + + member __.AccessibilityRights = FSharpAccessibilityRights(thisCcu, ad) + + +[] +// 'details' is an option because the creation of the tcGlobals etc. for the project may have failed. +type FSharpCheckProjectResults internal (keepAssemblyContents, errors: FSharpErrorInfo[], details:(TcGlobals*TcImports*CcuThunk*ModuleOrNamespaceType*TcSymbolUses list*TopAttribs option*option<_> * ILAssemblyRef * AccessorDomain * TypedImplFile list option * string list) option, reactorOps: IReactorOperations) = + + let getDetails() = + match details with + | None -> invalidOp ("The project has no results due to critical errors in the project options. Check the HasCriticalErrors before accessing the detaild results. Errors: " + String.concat "\n" [ for e in errors -> e.Message ]) + | Some d -> d + + member info.Errors = errors + + member info.HasCriticalErrors = details.IsNone + + member info.AssemblySignature = + let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + FSharpAssemblySignature(tcGlobals, thisCcu, tcImports, topAttribs, ccuSig) + + member info.AssemblyContents = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to tru on the FSharpChecker in order to access the checked contents of assemblies" + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() + let mimpls = + match tcAssemblyExpr with + | None -> [] + | Some mimpls -> mimpls + FSharpAssemblyContents(tcGlobals, thisCcu, tcImports, mimpls) + + member info.ProjectContext = + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + let assemblies = + [ for x in tcImports.GetImportedAssemblies() do + yield FSharpAssembly(tcGlobals, tcImports, x.FSharpViewOfMetadata) ] + FSharpProjectContext(thisCcu, assemblies, ad) + + +[] +/// A live object of this type keeps the background corresponding background builder (and type providers) alive (through reference-counting). +// +// There is an important property of all the objects returned by the methods of this type: they do not require +// the corresponding background builder to be alive. That is, they are simply plain-old-data through pre-formatting of all result text. +type FSharpCheckFileResults internal (errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo option, dependencyFiles: string list, builderX: option<_>, reactorOpsX:IReactorOperations) = + + // This may be None initially, or may be set to None when the object is disposed or finalized + let mutable details = match scopeOptX with None -> None | Some scopeX -> Some (scopeX, builderX, reactorOpsX) + + // Run an operation that can be called from any thread + let threadSafeOp dflt f = + match details with + | None -> + dflt() + // | Some (_ , Some builder, _) when not builder.IsAlive -> + // System.Diagnostics.Debug.Assert(false,"unexpected dead builder") + // dflt() + | Some (scope, builderOpt, ops) -> + f(scope, builderOpt, ops) + + member info.Errors = errors + + member info.HasFullTypeCheckInfo = details.IsSome + + member info.PartialAssemblySignature = + threadSafeOp + (fun () -> failwith "not available") + (fun (scope, _builder, _reactor) -> + // This operation is not asynchronous - PartialAssemblySignature can be run on the calling thread + scope.PartialAssemblySignature()) + + +//------------------------------------------------------------------------- +// InteractiveChecker +//------------------------------------------------------------------------- +type InteractiveChecker(references: string list, readAllBytes: string -> byte[]) = + + //let references = ["mscorlib";"System";"System.Core";"System.Data";"System.IO";"System.Xml";"System.Numerics"] + + // load signature data + let GetSignatureData ((filename:string), ilScopeRef, (ilModule:ILModuleDef option), (bytes:byte[])) : TastPickle.PickledDataWithReferences = + TastPickle.unpickleObjWithDanglingCcus filename ilScopeRef ilModule TastPickle.unpickleCcuInfo bytes + + let tcConfig = TcConfig() + let tcImports = TcImports() + let ilGlobals = IL.EcmaILGlobals + + let LoadMod ccuName = + let fileName = ccuName + ".dll" + let bytes = readAllBytes fileName + let opts = ILBinaryReader.mkDefault ilGlobals + let reader = ILBinaryReader.OpenILModuleReaderFromBytes fileName bytes opts + reader.ILModuleDef //reader.ILAssemblyRefs + + let memoize_mod = new MemoizationTable<_,_> (LoadMod, keyComparer=HashIdentity.Structural) + + let LoadSig ccuName = + let fileName = ccuName + ".sigdata" + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssRef ccuName) + let ilModule = memoize_mod.Apply ccuName + let bytes = readAllBytes fileName + let data = GetSignatureData (fileName, ilScopeRef, Some ilModule, bytes) + data + + let memoize_sig = new MemoizationTable<_,_> (LoadSig, keyComparer=HashIdentity.Structural) + + let GetCustomAttributesOfIlModule (ilModule:ILModuleDef) = + (match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList + + let GetAutoOpenAttributes ilg ilModule = + ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindAutoOpenAttr ilg) + + let GetInternalsVisibleToAttributes ilg ilModule = + ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindInternalsVisibleToAttr ilg) + + let mkCcuInfo ilg ilScopeRef ilModule ccu = + { ILScopeRef = ilScopeRef + FSharpViewOfMetadata = ccu + AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilg ilModule + AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilg ilModule +#if EXTENSIONTYPING + IsProviderGenerated = false + TypeProviders = [] +#endif + FSharpOptimizationData = notlazy None } + + let GetCcuIL m ccuName = + let auxModuleLoader = function + | ILScopeRef.Local -> failwith "Unsupported reference" + | ILScopeRef.Module x -> memoize_mod.Apply x.Name + | ILScopeRef.Assembly x -> memoize_mod.Apply x.Name + let ilModule = memoize_mod.Apply ccuName + let fileName = ilModule.Name //ccuName + ".dll" + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssRef ccuName) + let invalidateCcu = new Event<_>() + let ccu = Import.ImportILAssembly(tcImports.GetImportMap,m,auxModuleLoader,ilScopeRef,tcConfig.implicitIncludeDir,Some fileName,ilModule,invalidateCcu.Publish) + let ccuInfo = mkCcuInfo ilGlobals ilScopeRef ilModule ccu + ccuInfo + + let rec GetCcuFS m sysCcus ccuName = + let data = memoize_sig.Apply ccuName + let ilModule = memoize_mod.Apply ccuName + let fileName = ilModule.Name //ccuName + ".sigdata" + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssRef ccuName) + + let GetRawTypeForwarders ilModule = + match ilModule.Manifest with + | Some manifest -> manifest.ExportedTypes + | None -> mkILExportedTypes [] +#if EXTENSIONTYPING + let invalidateCcu = new Event<_>() +#endif + let minfo : PickledCcuInfo = data.RawData + let codeDir = minfo.compileTimeWorkingDir + let ccuData : CcuData = + { ILScopeRef = ilScopeRef + Stamp = newStamp() + FileName = Some fileName + QualifiedName = Some (ilScopeRef.QualifiedName) + SourceCodeDirectory = codeDir + IsFSharp = true + Contents = minfo.mspec +#if EXTENSIONTYPING + InvalidateEvent=invalidateCcu.Publish + IsProviderGenerated = false + ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) +#endif + UsesFSharp20PlusQuotations = minfo.usesQuotations + MemberSignatureEquality = (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) + TypeForwarders = Import.ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, GetRawTypeForwarders ilModule) + } + + let ccu = CcuThunk.Create(ccuName, ccuData) + let ccuInfo = mkCcuInfo ilGlobals ilScopeRef ilModule ccu + let ccuInfos = [ccuInfo] @ sysCcus + let findCcuInfo name = (ccuInfos |> List.find (fun x -> x.FSharpViewOfMetadata.AssemblyName = name)).FSharpViewOfMetadata + let rawData = data.Fixup findCcuInfo + ccuInfo + + let m = range.Zero + let refCcus = references |> List.map (GetCcuIL m) + let sysCcus = refCcus |> List.filter (fun x -> x.FSharpViewOfMetadata.AssemblyName <> "FSharp.Core") + let sysCcu = sysCcus |> List.find (fun x -> x.FSharpViewOfMetadata.AssemblyName = "mscorlib") + let fslibCcu = GetCcuFS m sysCcus "FSharp.Core" + let ccuInfos = [fslibCcu] @ sysCcus + let ccuMap = ccuInfos |> List.map (fun ccuInfo -> ccuInfo.FSharpViewOfMetadata.AssemblyName, ccuInfo) |> Map.ofList + + // search over all imported CCUs for each cached type + let ccuHasType (ccu : CcuThunk) (nsname : string list) (tname : string) = + match (Some ccu.Contents, nsname) ||> List.fold (fun entityOpt n -> match entityOpt with None -> None | Some entity -> entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind n) with + | Some ns -> + match Map.tryFind tname ns.ModuleOrNamespaceType.TypesByMangledName with + | Some _ -> true + | None -> false + | None -> false + + // Search for a type + let getTypeCcu nsname typeName = + let search = ccuInfos |> List.tryFind (fun ccuInfo -> ccuHasType ccuInfo.FSharpViewOfMetadata nsname typeName) + match search with + | Some x -> x.FSharpViewOfMetadata + | None -> + printfn "Cannot find type %s.%s" (String.concat "." nsname) typeName + sysCcu.FSharpViewOfMetadata + + let using40environment = false + + let tcGlobals = mkTcGlobals (tcConfig.compilingFslib, sysCcu.FSharpViewOfMetadata, ilGlobals, fslibCcu.FSharpViewOfMetadata, + tcConfig.implicitIncludeDir, tcConfig.mlCompatibility, using40environment, + tcConfig.isInteractive, getTypeCcu, tcConfig.emitDebugInfoInQuotations) +#if DEBUG + // the global_g reference cell is used only for debug printing + do global_g := Some tcGlobals +#endif + // do this prior to parsing, since parsing IL assembly code may refer to mscorlib + do tcImports.SetCcuMap(ccuMap) + do tcImports.SetTcGlobals(tcGlobals) + + let niceNameGen = NiceNameGenerator() + let amap = tcImports.GetImportMap() + let rng = rangeN Lexhelp.stdinMockFilename 0 + + let assemblyName = "Project" + let ccus = ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata, x.AssemblyAutoOpenAttributes, x.AssemblyInternalsVisibleToAttributes) + let tcEnv = CreateInitialTcEnv (tcGlobals, amap, rng, assemblyName, ccus) + let tcState = GetInitialTcState (rangeStartup, assemblyName, tcConfig, tcGlobals, tcImports, niceNameGen, tcEnv) + let reactorOps = + { new IReactorOperations with + member __.EnqueueAndAwaitOpAsync (desc, op) = async.Return (op()) + member __.EnqueueOp (desc, op) = op() } + + member x.ParseScript (mainInputFileName, source) = + //let mainInputFileName = "stdin.fsx" + // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). + let projectSourceFiles = [] + let parseErrors, _matchPairs, inputOpt, anyErrors = + Parser.ParseOneFile (source, false, true, mainInputFileName, projectSourceFiles, tcConfig) + let dependencyFiles = [] // interactions have no dependencies + let parseResults = FSharpParseFileResults(parseErrors, inputOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) + parseResults + + member x.ParseAndCheckScript (mainInputFileName, source) = + //let mainInputFileName = "stdin.fsx" + // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). + let projectSourceFiles = [] + let parseErrors, _matchPairs, inputOpt, anyErrors = + Parser.ParseOneFile (source, false, true, mainInputFileName, projectSourceFiles, tcConfig) + let dependencyFiles = [] // interactions have no dependencies + let parseResults = FSharpParseFileResults(parseErrors, inputOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) + + let backgroundErrors = [] + let tcResults = Parser.TypeCheckOneFile(parseResults, + source, + mainInputFileName, + "project", + tcConfig, + tcGlobals, + tcImports, + tcState, + //loadClosure, + backgroundErrors, + reactorOps, + (fun () -> true), + (fun _ -> false), + None) + match tcResults with + | tcErrors, Parser.TypeCheckAborted.No scope, tcImplFiles -> + let errors = [| yield! parseErrors; yield! tcErrors |] + let typeCheckResults = FSharpCheckFileResults (errors, Some scope, dependencyFiles, None, reactorOps) + let projectResults = FSharpCheckProjectResults (true, errors, Some(tcGlobals, tcImports, scope.ThisCcu, scope.CcuSig, [scope.ScopeSymbolUses], None, None, mkSimpleAssRef "stdin", tcState.TcEnvFromImpls.AccessRights, Some tcImplFiles, dependencyFiles), reactorOps) + parseResults, typeCheckResults, projectResults + | _ -> + failwith "unexpected aborted" + + +module AstPrint = + + let attribsOfSymbol (s:FSharpSymbol) = + let tryOr f def = + try f() with _ -> def + [ match s with + | :? FSharpField as v -> + yield "field" + if v.IsCompilerGenerated then yield "compgen" + if v.IsDefaultValue then yield "default" + if v.IsMutable then yield "mutable" + if v.IsVolatile then yield "volatile" + if v.IsStatic then yield "static" + if v.IsLiteral then yield sprintf "%A" v.LiteralValue.Value + + | :? FSharpEntity as v -> + v.TryFullName |> ignore // check there is no failure here + match v.BaseType with + | Some t when t.HasTypeDefinition && t.TypeDefinition.TryFullName.IsSome -> + yield sprintf "inherits %s" t.TypeDefinition.FullName + | _ -> () + if v.IsNamespace then yield "namespace" + if v.IsFSharpModule then yield "module" + if v.IsByRef then yield "byref" + if v.IsClass then yield "class" + if v.IsDelegate then yield "delegate" + if v.IsEnum then yield "enum" + if v.IsFSharpAbbreviation then yield "abbrev" + if v.IsFSharpExceptionDeclaration then yield "exception" + if v.IsFSharpRecord then yield "record" + if v.IsFSharpUnion then yield "union" + if v.IsInterface then yield "interface" + if v.IsMeasure then yield "measure" +#if EXTENSIONTYPING + if v.IsProvided then yield "provided" + if v.IsStaticInstantiation then yield "static_inst" + if v.IsProvidedAndErased then yield "erased" + if v.IsProvidedAndGenerated then yield "generated" +#endif + if v.IsUnresolved then yield "unresolved" + if v.IsValueType then yield "valuetype" + + | :? FSharpMemberOrFunctionOrValue as v -> + yield "owner: " + (tryOr (fun () -> v.EnclosingEntity.CompiledName) "") + if v.IsActivePattern then yield "active_pattern" + if v.IsDispatchSlot then yield "dispatch_slot" + if v.IsModuleValueOrMember && not v.IsMember then yield "val" + if v.IsMember then yield "member" + if v.IsProperty then yield "property" + if v.IsExtensionMember then yield "extension_member" + if v.IsPropertyGetterMethod then yield "property_getter" + if v.IsPropertySetterMethod then yield "property_setter" + if v.IsEvent then yield "event" + if v.EventForFSharpProperty.IsSome then yield "property_event" + if v.IsEventAddMethod then yield "event_add" + if v.IsEventRemoveMethod then yield "event_remove" + if v.IsTypeFunction then yield "type_func" + if v.IsCompilerGenerated then yield "compiler_gen" + if v.IsImplicitConstructor then yield "implicit_ctor" + if v.IsMutable then yield "mutable" + if v.IsOverrideOrExplicitInterfaceImplementation then yield "override_impl" + if not v.IsInstanceMember then yield "static" + if v.IsInstanceMember && not v.IsInstanceMemberInCompiledCode && not v.IsExtensionMember then yield "funky" + if v.IsExplicitInterfaceImplementation then yield "interface_impl" + yield sprintf "%A" v.InlineAnnotation + // if v.IsConstructorThisValue then yield "ctorthis" + // if v.IsMemberThisValue then yield "this" + // if v.LiteralValue.IsSome then yield "literal" + | _ -> () ] + + let rec printFSharpDecls prefix decls = seq { + let mutable i = 0 + for decl in decls do + i <- i + 1 + match decl with + | FSharpImplementationFileDeclaration.Entity (e, sub) -> + yield sprintf "%s%i) ENTITY: %s %A" prefix i e.CompiledName (attribsOfSymbol e) + if not (Seq.isEmpty e.Attributes) then + yield sprintf "%sattributes: %A" prefix (Seq.toList e.Attributes) + if not (Seq.isEmpty e.DeclaredInterfaces) then + yield sprintf "%sinterfaces: %A" prefix (Seq.toList e.DeclaredInterfaces) + yield "" + yield! printFSharpDecls (prefix + "\t") sub + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (meth, args, body) -> + yield sprintf "%s%i) METHOD: %s %A" prefix i meth.CompiledName (attribsOfSymbol meth) + yield sprintf "%stype: %A" prefix meth.FullType + yield sprintf "%sargs: %A" prefix args + // if not meth.IsCompilerGenerated then + yield sprintf "%sbody: %A" prefix body + yield "" + | FSharpImplementationFileDeclaration.InitAction (expr) -> + yield sprintf "%s%i) ACTION" prefix i + yield sprintf "%s%A" prefix expr + yield "" + } diff --git a/src/fsharp/Fable.FCS/unicode.fs b/src/fsharp/Fable.FCS/unicode.fs new file mode 100644 index 0000000000..5808f27dde --- /dev/null +++ b/src/fsharp/Fable.FCS/unicode.fs @@ -0,0 +1,71 @@ +namespace System + +module Globalization = + + type UnicodeCategory = + | UppercaseLetter = 0 + | LowercaseLetter = 1 + | TitlecaseLetter = 2 + | ModifierLetter = 3 + | OtherLetter = 4 + | NonSpacingMark = 5 + | SpacingCombiningMark = 6 + | EnclosingMark = 7 + | DecimalDigitNumber = 8 + | LetterNumber = 9 + | OtherNumber = 10 + | SpaceSeparator = 11 + | LineSeparator = 12 + | ParagraphSeparator = 13 + | Control = 14 + | Format = 15 + | Surrogate = 16 + | PrivateUse = 17 + | ConnectorPunctuation = 18 + | DashPunctuation = 19 + | OpenPunctuation = 20 + | ClosePunctuation = 21 + | InitialQuotePunctuation = 22 + | FinalQuotePunctuation = 23 + | OtherPunctuation = 24 + | MathSymbol = 25 + | CurrencySymbol = 26 + | ModifierSymbol = 27 + | OtherSymbol = 28 + | OtherNotAssigned = 29 + + // Unicode category values from Unicode U+0000 ~ U+00FF. + let categoryForLatin1: byte[] = [| + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0000 - 0007 + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0008 - 000F + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0010 - 0017 + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0018 - 001F + byte UnicodeCategory.SpaceSeparator; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.CurrencySymbol; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; // 0020 - 0027 + byte UnicodeCategory.OpenPunctuation; byte UnicodeCategory.ClosePunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.DashPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; // 0028 - 002F + byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; // 0030 - 0037 + byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.DecimalDigitNumber; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.OtherPunctuation; // 0038 - 003F + byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; // 0040 - 0047 + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; // 0048 - 004F + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; // 0050 - 0057 + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.OpenPunctuation; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.ClosePunctuation; byte UnicodeCategory.ModifierSymbol; byte UnicodeCategory.ConnectorPunctuation; // 0058 - 005F + byte UnicodeCategory.ModifierSymbol; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 0060 - 0067 + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 0068 - 006F + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 0070 - 0077 + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.OpenPunctuation; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.ClosePunctuation; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.Control; // 0078 - 007F + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0080 - 0087 + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0088 - 008F + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0090 - 0097 + byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; byte UnicodeCategory.Control; // 0098 - 009F + byte UnicodeCategory.SpaceSeparator; byte UnicodeCategory.OtherPunctuation; byte UnicodeCategory.CurrencySymbol; byte UnicodeCategory.CurrencySymbol; byte UnicodeCategory.CurrencySymbol; byte UnicodeCategory.CurrencySymbol; byte UnicodeCategory.OtherSymbol; byte UnicodeCategory.OtherSymbol; // 00A0 - 00A7 + byte UnicodeCategory.ModifierSymbol; byte UnicodeCategory.OtherSymbol; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.InitialQuotePunctuation; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.DashPunctuation; byte UnicodeCategory.OtherSymbol; byte UnicodeCategory.ModifierSymbol; // 00A8 - 00AF + byte UnicodeCategory.OtherSymbol; byte UnicodeCategory.MathSymbol; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.ModifierSymbol; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.OtherSymbol; byte UnicodeCategory.OtherPunctuation; // 00B0 - 00B7 + byte UnicodeCategory.ModifierSymbol; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.FinalQuotePunctuation; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.OtherNumber; byte UnicodeCategory.OtherPunctuation; // 00B8 - 00BF + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; // 00C0 - 00C7 + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; // 00C8 - 00CF + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.MathSymbol; // 00D0 - 00D7 + byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.UppercaseLetter; byte UnicodeCategory.LowercaseLetter; // 00D8 - 00DF + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 00E0 - 00E7 + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 00E8 - 00EF + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.MathSymbol; // 00F0 - 00F7 + byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; byte UnicodeCategory.LowercaseLetter; // 00F8 - 00FF + |] diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index f0697622b6..3f0bdd9de5 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -5,6 +5,10 @@ module internal Microsoft.FSharp.Compiler.InfoReader open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics diff --git a/src/fsharp/LexFilter.fs b/src/fsharp/LexFilter.fs index 19f84669aa..fd05067428 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -5,6 +5,9 @@ module internal Microsoft.FSharp.Compiler.LexFilter open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core +#endif open Internal.Utilities.Text.Lexing open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL @@ -17,7 +20,6 @@ open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Parser open Microsoft.FSharp.Compiler.Lexhelp - let debug = false let stringOfPos (p:Position) = sprintf "(%d:%d)" p.OriginalLine p.Column @@ -410,13 +412,19 @@ type PositionTuple = new (x: Position, y: Position) = { X = x; Y = y } /// Used to save the state related to a token +#if FABLE_COMPILER +type TokenTup (token,state,lastTokenPos) = + member x.Token : token = token + member x.LexbufState : LexbufState = state + member x.LastTokenPos: PositionTuple = lastTokenPos +#else [] type TokenTup = val Token : token val LexbufState : LexbufState val LastTokenPos: PositionTuple new (token,state,lastTokenPos) = { Token=token; LexbufState=state;LastTokenPos=lastTokenPos } - +#endif /// Returns starting position of the token member x.StartPos = x.LexbufState.StartPos /// Returns end position of the token @@ -570,7 +578,11 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, // Fetch a raw token, either from the old lexer or from our delayedStack //-------------------------------------------------------------------------- +#if FABLE_COMPILER + let delayedStack = Internal.Utilities.Text.Parsing.Stack(100) +#else let delayedStack = System.Collections.Generic.Stack() +#endif let mutable tokensThatNeedNoProcessingCount = 0 let delayToken tokenTup = delayedStack.Push tokenTup @@ -2196,8 +2208,12 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, | NATIVEINT(v) -> delayMergedToken(NATIVEINT(if plus then v else -v)) | IEEE32(v) -> delayMergedToken(IEEE32(if plus then v else -v)) | IEEE64(v) -> delayMergedToken(IEEE64(if plus then v else -v)) +#if FABLE_COMPILER + | DECIMAL(v) -> delayMergedToken(DECIMAL(if plus then v else -v)) +#else | DECIMAL(v) -> delayMergedToken(DECIMAL(if plus then v else System.Decimal.op_UnaryNegation v)) - | BIGNUM(v,s) -> delayMergedToken(BIGNUM((if plus then v else "-"^v),s)) +#endif + | BIGNUM(v,s) -> delayMergedToken(BIGNUM((if plus then v else "-"+v),s)) | _ -> noMerge() else noMerge() @@ -2242,7 +2258,11 @@ type LexFilter (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, lexb // We don't interact with lexbuf state at all, any inserted tokens have same state/location as the real one read, so // we don't have to do any of the wrapped lexbuf magic that you see in LexFilterImpl. +#if FABLE_COMPILER + let delayedStack = Internal.Utilities.Text.Parsing.Stack(100) +#else let delayedStack = System.Collections.Generic.Stack() +#endif let delayToken tok = delayedStack.Push tok let popNextToken() = diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 794507bd93..4ce50f2041 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -68,7 +68,7 @@ type CalledArg = NameOpt: Ident option CalledArgumentType : TType } -let CalledArg(pos,isParamArray,optArgInfo,callerInfoInfo,isOutArg,nameOpt,reflArgInfo,calledArgTy) = +let GetCalledArg(pos,isParamArray,optArgInfo,callerInfoInfo,isOutArg,nameOpt,reflArgInfo,calledArgTy) = { Position=pos IsParamArray=isParamArray OptArgInfo =optArgInfo @@ -716,7 +716,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) @@ -786,7 +786,7 @@ let BuildNewDelegateExpr (eventInfoOpt:EventInfo option, g, amap, delegateTy, in if List.exists (isByrefTy g) delArgTys then error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m)) - let delArgVals = delArgTys |> List.mapi (fun i argty -> fst (mkCompGenLocal m ("delegateArg"^string i) argty)) + let delArgVals = delArgTys |> List.mapi (fun i argty -> fst (mkCompGenLocal m ("delegateArg"+string i) argty)) let expr = let args = match eventInfoOpt with diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index cd3b290e8c..a04fa70fda 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -8,6 +8,11 @@ module internal Microsoft.FSharp.Compiler.NameResolution open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -40,6 +45,9 @@ type NameResolver(g:TcGlobals, amap: Import.ImportMap, infoReader: InfoReader, instantiationGenerator: (range -> Typars -> TypeInst)) = +#if FABLE_COMPILER + new (g,amap,infoReader,instantiationGenerator,_) = NameResolver(g,amap,infoReader,instantiationGenerator) +#endif /// Used to transform typars into new inference typars // instantiationGenerator is a function to help us create the // type parameters by copying them from type parameter specifications read @@ -1352,6 +1360,9 @@ type TcResultsSinkImpl(g, ?source: string) = let capturedMethodGroupResolutions = ResizeArray<_>() let allowedRange (m:range) = not m.IsSynthetic +#if FABLE_COMPILER + new (g, source, _) = TcResultsSinkImpl(g, source) +#endif member this.GetResolutions() = TcResolutions(capturedEnvs, capturedExprTypings, capturedNameResolutions, capturedMethodGroupResolutions) @@ -1387,9 +1398,17 @@ type TcResultsSinkImpl(g, ?source: string) = | _ -> false if replace then +#if FABLE_COMPILER + let r1 = capturedNameResolutions.FindAll(fun cnr -> cnr.Range <> m) + let r2 = capturedMethodGroupResolutions.FindAll(fun cnr -> cnr.Range <> m) + capturedNameResolutions.Clear() + capturedMethodGroupResolutions.Clear() + capturedNameResolutions.AddRange(r1) + capturedMethodGroupResolutions.AddRange(r2) +#else capturedNameResolutions.RemoveAll(fun cnr -> cnr.Range = m) |> ignore capturedMethodGroupResolutions.RemoveAll(fun cnr -> cnr.Range = m) |> ignore - +#endif if not alreadyDone then capturedNameResolutions.Add(CapturedNameResolution(endPos,item,occurenceType,denv,nenv,ad,m)) capturedMethodGroupResolutions.Add(CapturedNameResolution(endPos,itemMethodGroup,occurenceType,denv,nenv,ad,m)) @@ -1696,7 +1715,11 @@ let SelectPropInfosFromExtMembers (infoReader:InfoReader,ad,optFilter) declaring let g = infoReader.g let amap = infoReader.amap // NOTE: multiple "open"'s push multiple duplicate values into eIndexedExtensionMembers, hence setify. +#if FABLE_COMPILER + let seen = HashSet<_>() //TODO: implement Map/Set with comparer +#else let seen = HashSet(ExtensionMember.Comparer g) +#endif let propCollector = new PropertyCollector(g,amap,m,declaringTy,optFilter,ad) for emem in extMemInfos do if seen.Add emem then @@ -1743,7 +1766,11 @@ let IntrinsicMethInfosOfType (infoReader:InfoReader) (optFilter,ad,allowMultiInt let SelectMethInfosFromExtMembers (infoReader:InfoReader) optFilter apparentTy m extMemInfos = let g = infoReader.g // NOTE: multiple "open"'s push multiple duplicate values into eIndexedExtensionMembers +#if FABLE_COMPILER + let seen = HashSet<_>() //TODO: implement Map/Set with comparer +#else let seen = HashSet(ExtensionMember.Comparer g) +#endif [ for emem in extMemInfos do if seen.Add emem then diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 1844cc6437..9f86db3ca7 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -103,7 +103,7 @@ module internal PrintUtilities = let tcref = attrib.TyconRef squareAngleL (layoutTyconRefImpl true denv tcref) -module private PrintIL = +module PrintIL = open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -172,7 +172,11 @@ module private PrintIL = let numParms = // can't find a way to see the number of generic parameters for *this* class (the GenericParams also include type variables for enclosing classes); this will have to do let rightMost = className |> SplitNamesForILPath |> List.last +#if FABLE_COMPILER + match System.Int32.TryParse(rightMost) with +#else match System.Int32.TryParse(rightMost, System.Globalization.NumberStyles.Integer, System.Globalization.CultureInfo.InvariantCulture) with +#endif | true, n -> n | false, _ -> 0 // looks like it's non-generic ilTyparSubst |> List.rev |> List.take numParms |> List.rev @@ -329,14 +333,22 @@ module private PrintIL = | ILFieldInit.UInt32 x -> Some ((x |> int64 |> string) + "u") | ILFieldInit.UInt64 x -> Some ((x |> int64 |> string) + "UL") | ILFieldInit.Single d -> +#if FABLE_COMPILER + let s = string d +#else let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture) +#endif let s = if String.forall (fun c -> System.Char.IsDigit c || c = '-') s then s + ".0" else s Some (s + "f") | ILFieldInit.Double d -> +#if FABLE_COMPILER + let s = string d +#else let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture) +#endif if String.forall (fun c -> System.Char.IsDigit c || c = '-') s then Some (s + ".0") else Some s @@ -530,7 +542,7 @@ module private PrintIL = (pre ^^ wordL "=") @@-- body -module private PrintTypes = +module PrintTypes = // Note: We need nice printing of constants in order to print literals and attributes let layoutConst g ty c = let str = @@ -547,12 +559,20 @@ module private PrintTypes = | Const.IntPtr x -> (x |> string)+"n" | Const.UIntPtr x -> (x |> string)+"un" | Const.Single d -> - (let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) - if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s +#if FABLE_COMPILER + let s = string d +#else + let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif + (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s) + "f" | Const.Double d -> +#if FABLE_COMPILER + let s = string d +#else let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s @@ -682,14 +702,22 @@ module private PrintTypes = | ILAttribElem.UInt64 x -> wordL ((x |> string)+"UL") | ILAttribElem.Single x -> let str = +#if FABLE_COMPILER + let s = string x +#else let s = x.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s) + "f" wordL str | ILAttribElem.Double x -> let str = +#if FABLE_COMPILER + let s = string x +#else let s = x.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s @@ -849,7 +877,7 @@ module private PrintTypes = and private layoutTraitWithInfo denv env (TTrait(tys,nm,memFlags,argtys,rty,_)) = let nm = DemangleOperatorName nm if denv.shortConstraints then - wordL ("member "^nm) + wordL ("member "+nm) else let rty = GetFSharpViewOfReturnType denv.g rty let stat = layoutMemberFlags memFlags @@ -967,7 +995,7 @@ module private PrintTypes = match argInfo.Name, isOptionalArg, isParamArray, tryDestOptionTy denv.g ty with // Layout an optional argument | Some(id), true, _, Some ty -> - leftL ("?"^id.idText) ^^ sepL ":" ^^ layoutTypeWithInfoAndPrec denv env 2 ty + leftL ("?"+id.idText) ^^ sepL ":" ^^ layoutTypeWithInfoAndPrec denv env 2 ty // Layout an unnamed argument | None, _,_, _ -> layoutTypeWithInfoAndPrec denv env 2 ty @@ -1074,7 +1102,7 @@ module private PrintTypes = layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 5 typ /// Printing TAST objects -module private PrintTastMemberOrVals = +module PrintTastMemberOrVals = open PrintTypes let private layoutMember denv (v:Val) = let v = mkLocalValRef v @@ -1328,7 +1356,7 @@ module InfoMemberPrinting = //------------------------------------------------------------------------- /// Printing TAST objects -module private TastDefinitionPrinting = +module TastDefinitionPrinting = open PrintTypes let layoutExtensionMember denv (v:Val) = @@ -1736,7 +1764,7 @@ module private TastDefinitionPrinting = //-------------------------------------------------------------------------- -module private InferredSigPrinting = +module InferredSigPrinting = open PrintTypes /// Layout the inferred signature of a compilation unit @@ -1781,7 +1809,7 @@ module private InferredSigPrinting = // Check if this namespace contains anything interesting if isConcreteNamespace def then // This is a container namespace. We print the header when we get to the first concrete module. - let headerL = wordL ("namespace " ^ (String.concat "." (innerPath |> List.map fst))) + let headerL = wordL ("namespace " + (String.concat "." (innerPath |> List.map fst))) headerL @@-- basic else // This is a namespace that only contains namespaces. Skipt the header @@ -1815,7 +1843,7 @@ module private InferredSigPrinting = //-------------------------------------------------------------------------- -module private PrintData = +module PrintData = open PrintTypes /// Nice printing of a subset of expressions, e.g. for refutations in pattern matching diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 242d3bfde2..52d90dd206 100755 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -511,8 +511,7 @@ let GetInfoForLocalValue cenv env (v:Val) m = (* Abstract slots do not have values *) if v.IsDispatchSlot then UnknownValInfo else - let mutable res = Unchecked.defaultof<_> - let ok = cenv.localInternalVals.TryGetValue(v.Stamp, &res) + let ok, res = cenv.localInternalVals.TryGetValue(v.Stamp) if ok then res else match env.localExternalVals.TryFind v.Stamp with | Some vval -> vval diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 2a85ccce9b..0e94767fde 100755 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -4,6 +4,9 @@ module internal Microsoft.FSharp.Compiler.PatternMatchCompilation open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -919,7 +922,7 @@ let CompilePatternBasic if not (List.isEmpty topgtvs) then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)) let rty = apinfo.ResultType g m resTys - let v,vexp = mkCompGenLocal m ("activePatternResult"^string (newUnique())) rty + let v,vexp = mkCompGenLocal m ("activePatternResult"+string (newUnique())) rty if topv.IsMemberOrModuleBinding then AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData let argexp = GetSubExprOfInput subexpr diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 9926771ffc..b0a62172f0 100755 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -6,6 +6,9 @@ module internal Microsoft.FSharp.Compiler.PostTypeCheckSemanticChecks open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL @@ -1344,10 +1347,10 @@ let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = // Properties get 'get_X', only if there are no args // Properties get 'get_X' match v.ValReprInfo with - | Some arity when arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("get_"^v.DisplayName) + | Some arity when arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("get_"+v.DisplayName) | _ -> () match v.ValReprInfo with - | Some arity when v.IsMutable && arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("set_"^v.DisplayName) + | Some arity when v.IsMutable && arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("set_"+v.DisplayName) | _ -> () match TryChopPropertyName v.DisplayName with | Some res -> check true res diff --git a/src/fsharp/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index 542918cc96..24527541b2 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -165,7 +165,7 @@ module (*internal*) Microsoft.FSharp.Compiler.PrettyNaming | true, x -> sb.Append(x) |> ignore | false, _ -> - sb.Append(c) |> ignore + sb.Append(string c) |> ignore /// The compiled (mangled) operator name. let opName = sb.ToString () @@ -250,7 +250,7 @@ module (*internal*) Microsoft.FSharp.Compiler.PrettyNaming // 'opCharName' matched the current position in 'opName'. // Append the corresponding operator character to the StringBuilder // and continue decompiling at the index following this instance of 'opCharName'. - sb.Append opChar |> ignore + sb.Append (string opChar) |> ignore decompile sb (idx + opCharName.Length) let opNamePrefixLen = opNamePrefix.Length @@ -524,11 +524,11 @@ module (*internal*) Microsoft.FSharp.Compiler.PrettyNaming // split when seeing a separator | c, false when c = separator -> split (i+1, "", cur::group, false) // keep reading if a separator is inside quotation - | c, true when c = separator -> split (i+1, cur+(System.Char.ToString c), group, true) + | c, true when c = separator -> split (i+1, cur+(string c), group, true) // open or close quotation | '\"', _ when isNotQuotedQuotation i -> split (i+1, cur+"\"", group, not insideQuotation) // keep reading - | c, _ -> split (i+1, cur+(System.Char.ToString c), group, insideQuotation) + | c, _ -> split (i+1, cur+(string c), group, insideQuotation) split (0, "", [], false) |> Array.ofList // Return a string array delimited by the given separator up to the maximum number. @@ -537,7 +537,7 @@ module (*internal*) Microsoft.FSharp.Compiler.PrettyNaming if count <= 1 then [| text |] else let mangledText = splitAroundQuotation text separator match mangledText.Length > count with - | true -> Array.append (mangledText.[0..(count-2)]) ([| mangledText.[(count-1)..] |> String.concat (System.Char.ToString separator) |]) + | true -> Array.append (mangledText.[0..(count-2)]) ([| mangledText.[(count-1)..] |> String.concat (string separator) |]) | false -> mangledText let [] FSharpModuleSuffix = "Module" diff --git a/src/fsharp/QuotationPickler.fs b/src/fsharp/QuotationPickler.fs index dfd981c2da..a5a33de344 100755 --- a/src/fsharp/QuotationPickler.fs +++ b/src/fsharp/QuotationPickler.fs @@ -8,9 +8,12 @@ module internal Microsoft.FSharp.Compiler.QuotationPickler -open System.Text open Internal.Utilities open Internal.Utilities.Collections +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif +open System.Text open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 2c4875502d..460505bc3a 100755 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -22,8 +22,11 @@ open System.Collections.Generic module QP = Microsoft.FSharp.Compiler.QuotationPickler - +#if FABLE_COMPILER +let verboseCReflect = false +#else let verboseCReflect = condition "VERBOSE_CREFLECT" +#endif [] @@ -255,7 +258,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. match takesInstanceArg,curriedArgs with | false,curriedArgs -> [],curriedArgs | true,(objArg::curriedArgs) -> [objArg],curriedArgs - | true,[] -> wfail(InternalError("warning: unexpected missing object argument when generating quotation for call to F# object member "^vref.LogicalName,m)) + | true,[] -> wfail(InternalError("warning: unexpected missing object argument when generating quotation for call to F# object member "+vref.LogicalName,m)) if verboseCReflect then dprintfn "vref.DisplayName = %A, #objArgs = %A, #curriedArgs = %A" vref.DisplayName objArgs.Length curriedArgs.Length @@ -272,7 +275,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. // partially applied arguments to 'let' bindings let topValInfo = match vref.ValReprInfo with - | None -> error(InternalError("no arity information found for F# value "^vref.LogicalName,vref.Range)) + | None -> error(InternalError("no arity information found for F# value "+vref.LogicalName,vref.Range)) | Some a -> a let expr,exprty = AdjustValForExpectedArity cenv.g m vref vFlags topValInfo diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index 55a573d1e9..6cc9b645b6 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -6,6 +6,9 @@ module internal Microsoft.FSharp.Compiler.SignatureConformance open Internal.Utilities open System.Text +#if FABLE_COMPILER +open Microsoft.FSharp.Core +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 773eeebb1a..5e19d51628 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -5,6 +5,9 @@ module internal Microsoft.FSharp.Compiler.Tastops open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX @@ -1030,6 +1033,9 @@ let primMkMatch(spBind,exprm,tree,targets,matchm,ty) = Expr.Match (spBind,exprm, type MatchBuilder(spBind,inpRange: Range.range) = let targets = new ResizeArray<_>(10) +#if FABLE_COMPILER + new (spBind,inpRange,_) = MatchBuilder(spBind,inpRange) +#endif member x.AddTarget(tg) = let n = targets.Count targets.Add(tg); @@ -2919,7 +2925,7 @@ module DebugPrint = begin let sortCons (cs:(TyconRef * Rational) list) = cs |> List.sortBy (fun (c,_) -> c.DisplayName) let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> SignRational e < 0) let negcs,poscs = ListMeasureConOccsWithNonZeroExponents g false unt |> sortCons |> List.partition (fun (_,e) -> SignRational e < 0) - let unparL (uv:Typar) = wordL ("'" ^ uv.DisplayName) + let unparL (uv:Typar) = wordL ("'" + uv.DisplayName) let unconL tc = layoutTyconRef tc let rationalL e = wordL (RationalToString e) let measureToPowerL x e = if e = OneRational then x else x -- wordL "^" -- rationalL e @@ -3136,12 +3142,20 @@ module DebugPrint = begin | Const.IntPtr x -> (x |> string)+"n" | Const.UIntPtr x -> (x |> string)+"un" | Const.Single d -> - (let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) - if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s +#if FABLE_COMPILER + let s = string d +#else + let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif + (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s) + "f" | Const.Double d -> +#if FABLE_COMPILER + let s = string d +#else let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) +#endif if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s @@ -3338,15 +3352,15 @@ module DebugPrint = begin | Expr.Op (TOp.ValFieldGetAddr rf,_,[],_) -> leftL "&" ^^ (recdFieldRefL rf) | Expr.Op (TOp.UnionCaseTagGet tycr,_,[x],_) -> - wordL ("#" ^ tycr.LogicalName ^ ".tag") ^^ atomL x + wordL ("#" + tycr.LogicalName + ".tag") ^^ atomL x | Expr.Op (TOp.UnionCaseProof c,_,[x],_) -> - wordL ("#" ^ c.CaseName^ ".cast") ^^ atomL x + wordL ("#" + c.CaseName + ".cast") ^^ atomL x | Expr.Op (TOp.UnionCaseFieldGet (c,i),_,[x],_) -> - wordL ("#" ^ c.CaseName ^ "." ^ string i) --- atomL x + wordL ("#" + c.CaseName + "." + string i) --- atomL x | Expr.Op (TOp.UnionCaseFieldSet (c,i),_,[x;y],_) -> - ((atomL x --- (rightL ("#" ^ c.CaseName ^ "." ^ string i))) ^^ wordL ":=") --- exprL y + ((atomL x --- (rightL ("#" + c.CaseName + "." + string i))) ^^ wordL ":=") --- exprL y | Expr.Op (TOp.TupleFieldGet (_,i),_,[x],_) -> - wordL ("#" ^ string i) --- atomL x + wordL ("#" + string i) --- atomL x | Expr.Op (TOp.Coerce,[typ;_],[x],_) -> atomL x --- (wordL ":>" ^^ typeL typ) | Expr.Op (TOp.Reraise,[_],[],_) -> @@ -4365,7 +4379,7 @@ let underlyingTypeOfEnumTy g typ = | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> match tycon.GetFieldByName "value__" with | Some rf -> rf.FormalType - | None -> error(InternalError("no 'value__' field found for enumeration type "^tycon.LogicalName,tycon.Range)) + | None -> error(InternalError("no 'value__' field found for enumeration type "+tycon.LogicalName,tycon.Range)) // CLEANUP NOTE: Get rid of this mutation. @@ -4839,7 +4853,7 @@ and renameTycon tyenv x = let res = tyenv.tyconRefRemap.[mkLocalTyconRef x] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon "^showL(DebugPrint.tyconL x),x.Range)); + errorR(InternalError("couldn't remap internal tycon "+showL(DebugPrint.tyconL x),x.Range)); mkLocalTyconRef x tcref.Deref @@ -4881,7 +4895,7 @@ and copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs = let res = tmenvinner.tyconRefRemap.[mkLocalTyconRef tycon] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon "^showL(DebugPrint.tyconL tycon),tycon.Range)); + errorR(InternalError("couldn't remap internal tycon "+showL(DebugPrint.tyconL tycon),tycon.Range)); mkLocalTyconRef tycon tcref.Deref @@ -5375,7 +5389,7 @@ let rec simplifyTrivialMatch spBind exprm matchm ty tree (targets : _[]) = if n >= targets.Length then failwith "simplifyTrivialMatch: target out of range"; // REVIEW: should we use _spTarget here? let (TTarget(vs,rhs,_spTarget)) = targets.[n] - if vs.Length <> es.Length then failwith ("simplifyTrivialMatch: invalid argument, n = "^string n^", List.length targets = "^string targets.Length); + if vs.Length <> es.Length then failwith ("simplifyTrivialMatch: invalid argument, n = "+string n+", List.length targets = "+string targets.Length); mkInvisibleLetsFromBindings rhs.Range vs es rhs | _ -> primMkMatch (spBind,exprm,tree,targets,matchm,ty) @@ -5808,7 +5822,7 @@ let ExprStats x = let count = ref 0 let folders = {ExprFolder0 with exprIntercept = (fun _ _ _ -> (count := !count + 1; None))} let () = FoldExpr folders () x - string !count ^ " TExpr nodes" + string !count + " TExpr nodes" #endif //------------------------------------------------------------------------- @@ -6326,7 +6340,7 @@ let AdjustArityOfLambdaBody g arity (vs:Val list) body = if (untupledTys.Length <> arity) then failwith "length untupledTys <> arity"; let dummyvs,dummyes = untupledTys - |> List.mapi (fun i ty -> mkCompGenLocal v.Range (v.LogicalName ^"_"^string i) ty) + |> List.mapi (fun i ty -> mkCompGenLocal v.Range (v.LogicalName + "_" + string i) ty) |> List.unzip let body = mkInvisibleLet v.Range v (mkRefTupled g v.Range dummyes untupledTys) body dummyvs,body @@ -6416,7 +6430,7 @@ let MakeArgsForTopArgs _g m argtysl tpenv = let ty = instType tpenv argty let nm = match argInfo.Name with - | None -> CompilerGeneratedName ("arg"^ string i^ string j) + | None -> CompilerGeneratedName ("arg" + string i + string j) | Some id -> id.idText fst (mkCompGenLocal m nm ty))) @@ -6533,7 +6547,7 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex argtysl |> List.mapi (fun i argtys -> argtys |> List.mapi (fun j (_,argInfo) -> match argInfo.Name with - | None -> CompilerGeneratedName ("arg" ^ string i ^string j) + | None -> CompilerGeneratedName ("arg" + string i + string j) | Some id -> id.idText)) | _ -> [] @@ -6661,11 +6675,11 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex assert (inpArgTys.Length = actualArgTys.Length) - let inpsAsVars,inpsAsExprs = inpArgTys |> List.mapi (fun j ty -> mkCompGenLocal appm ("arg"^string i^string j) ty) |> List.unzip + let inpsAsVars,inpsAsExprs = inpArgTys |> List.mapi (fun j ty -> mkCompGenLocal appm ("arg"+string i+string j) ty) |> List.unzip let inpsAsActualArg = CoerceDetupled inpArgTys inpsAsExprs actualArgTys let inpCloVarType = (mkFunTy (mkRefTupledTy g actualArgTys) cloVar.Type) let newResTy = mkFunTy inpArgTy resTy - let inpCloVar,inpCloVarAsExpr = mkCompGenLocal appm ("clo"^string i) inpCloVarType + let inpCloVar,inpCloVarAsExpr = mkCompGenLocal appm ("clo"+string i) inpCloVarType let newRes = // For the final arg we can skip introducing the dummy variable if i = N - 1 then @@ -6707,7 +6721,7 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex let niceNames = match niceNames with | nms when nms.Length = inpArgTys.Length -> nms - | [nm] -> inpArgTys |> List.mapi (fun i _ -> (nm^string i)) + | [nm] -> inpArgTys |> List.mapi (fun i _ -> (nm + string i)) | nms -> nms match suppliedArg with | Some arg -> @@ -6853,18 +6867,18 @@ let LinearizeTopMatch g parent = function let commaEncs strs = String.concat "," strs -let angleEnc str = "{" ^ str ^ "}" +let angleEnc str = "{" + str + "}" let ticksAndArgCountTextOfTyconRef (tcref:TyconRef) = - // Generic type names are (name ^ "`" ^ digits) where name does not contain "`". + // Generic type names are (name + "`" + digits) where name does not contain "`". let path = Array.toList (fullMangledPathToTyconRef tcref) @ [tcref.CompiledName] textOfPath path let typarEnc _g (gtpsType,gtpsMethod) typar = match List.tryFindIndex (typarEq typar) gtpsType with - | Some idx -> "`" ^ string idx // single-tick-index for typar from type + | Some idx -> "`" + string idx // single-tick-index for typar from type | None -> match List.tryFindIndex (typarEq typar) gtpsMethod with - | Some idx -> "``" ^ string idx // double-tick-index for typar from method + | Some idx -> "``" + string idx // double-tick-index for typar from method | None -> warning(InternalError("Typar not found during XmlDoc generation",typar.Range)) "``0" // REVIEW: this should be ERROR not WARNING? @@ -6888,19 +6902,19 @@ let rec typeEnc g (gtpsType,gtpsMethod) ty = | 3 -> "[0:,0:,0:]" | 4 -> "[0:,0:,0:,0:]" | _ -> failwith "impossible: rankOfArrayTyconRef: unsupported array rank" - typeEnc g (gtpsType,gtpsMethod) (List.head tinst) ^ arraySuffix + typeEnc g (gtpsType,gtpsMethod) (List.head tinst) + arraySuffix | TType_ucase (UCRef(tcref,_),tinst) | TType_app (tcref,tinst) -> if tyconRefEq g g.byref_tcr tcref then - typeEnc g (gtpsType,gtpsMethod) (List.head tinst) ^ "@" + typeEnc g (gtpsType,gtpsMethod) (List.head tinst) + "@" elif tyconRefEq g tcref g.nativeptr_tcr then - typeEnc g (gtpsType,gtpsMethod) (List.head tinst) ^ "*" + typeEnc g (gtpsType,gtpsMethod) (List.head tinst) + "*" else let tyName = let ty = stripTyEqnsAndMeasureEqns g ty match ty with | TType_app (tcref,_tinst) -> - // Generic type names are (name ^ "`" ^ digits) where name does not contain "`". + // Generic type names are (name + "`" + digits) where name does not contain "`". // In XML doc, when used in type instances, these do not use the ticks. let path = Array.toList (fullMangledPathToTyconRef tcref) @ [tcref.CompiledName] textOfPath (List.map DemangleGenericTypeName path) diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 0392ea8c29..59d867b087 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -5,6 +5,9 @@ module internal Microsoft.FSharp.Compiler.TastPickle open System.Collections.Generic open System.Text open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -72,8 +75,7 @@ type Table<'T> = tbl.rows.Add(x); n member tbl.FindOrAdd x = - let mutable res = Unchecked.defaultof<_> - let ok = tbl.tbl.TryGetValue(x,&res) + let ok, res = tbl.tbl.TryGetValue(x) if ok then res else tbl.Add x @@ -2208,7 +2210,13 @@ and u_const st = | 14 -> u_string st |> Const.String | 15 -> Const.Unit | 16 -> Const.Zero - | 17 -> u_array u_int32 st |> (fun bits -> Const.Decimal (new System.Decimal(bits))) + | 17 -> u_array u_int32 st |> (fun bits -> + Const.Decimal ( +#if FABLE_COMPILER + System.Decimal.FromBits(bits))) +#else + new System.Decimal(bits))) +#endif | _ -> ufailwith st "u_const" diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 1a5b753a28..4836afdbd9 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -9,6 +9,9 @@ module internal Microsoft.FSharp.Compiler.TcGlobals open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -845,11 +848,11 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa | TType_tuple (_structness2, t8plus) -> TType_tuple (tupInfo, [t1;t2;t3;t4;t5;t6;t7] @ t8plus) | _ -> TType_tuple (tupInfo, l) | _ -> TType_tuple (tupInfo, l) - + let mk_MFCore_attrib nm : BuiltinAttribInfo = AttribInfo(mkILTyRef(IlxSettings.ilxFsharpCoreLibScopeRef (), FSharpLib.Core + "." + nm),mk_MFCore_tcref fslibCcu nm) - + let mkAttrib (nm:string) scopeRef : BuiltinAttribInfo = let path, typeName = splitILTypeName nm AttribInfo(mkILTyRef (scopeRef, nm), mkSysTyconRef path typeName) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 44e4a6d74f..3db302d362 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -4,12 +4,15 @@ /// with generalization at appropriate points. module internal Microsoft.FSharp.Compiler.TypeChecker -open System -open System.Collections.Generic - open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Internal.Utilities.Collections +open System +open System.Collections.Generic + open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -1009,8 +1012,8 @@ let MakeMemberDataAndMangledNameForMemberVal(g,tcref,isExtrinsic,attrs,optImplSl if isExtrinsic then let tname = tcref.LogicalName let text = tname + "." + logicalName - let text = if memberFlags.MemberKind <> MemberKind.Constructor && memberFlags.MemberKind <> MemberKind.ClassConstructor && not memberFlags.IsInstance then text^".Static" else text - let text = if memberFlags.IsOverrideOrExplicitImpl then text^".Override" else text + let text = if memberFlags.MemberKind <> MemberKind.Constructor && memberFlags.MemberKind <> MemberKind.ClassConstructor && not memberFlags.IsInstance then text+".Static" else text + let text = if memberFlags.IsOverrideOrExplicitImpl then text+".Override" else text text else List.foldBack (tcrefOfAppTy g >> qualifiedMangledNameOfTyconRef) optIntfSlotTys logicalName @@ -2534,7 +2537,7 @@ module EventDeclarationNormalization = if CompileAsEvent cenv.g bindingAttribs then let MakeOne (prefix,target) = - let declPattern = RenameBindingPattern (fun s -> prefix^s) declPattern + let declPattern = RenameBindingPattern (fun s -> prefix+s) declPattern let argName = "handler" // modify the rhs and argument data let bindingRhs,valSynData = @@ -9469,7 +9472,14 @@ and TcMethodApplication | CallerLineNumber, _ when typeEquiv cenv.g currCalledArgTy cenv.g.int_ty -> emptyPreBinder,Expr.Const(Const.Int32(mMethExpr.StartLine), mMethExpr, currCalledArgTy) | CallerFilePath, _ when typeEquiv cenv.g currCalledArgTy cenv.g.string_ty -> - emptyPreBinder,Expr.Const(Const.String(System.IO.Path.GetFullPath(mMethExpr.FileName)), mMethExpr, currCalledArgTy) + emptyPreBinder,Expr.Const( + Const.String( +#if FABLE_COMPILER + mMethExpr.FileName +#else + System.IO.Path.GetFullPath(mMethExpr.FileName) +#endif + ), mMethExpr, currCalledArgTy) | CallerMemberName, Some(callerName) when (typeEquiv cenv.g currCalledArgTy cenv.g.string_ty) -> emptyPreBinder,Expr.Const(Const.String(callerName), mMethExpr, currCalledArgTy) | _ -> @@ -9508,7 +9518,15 @@ and TcMethodApplication let lineExpr = Expr.Const(Const.Int32(mMethExpr.StartLine), mMethExpr, calledNonOptTy) emptyPreBinder,mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[lineExpr],mMethExpr) | CallerFilePath, _ when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty -> - let filePathExpr = Expr.Const(Const.String(System.IO.Path.GetFullPath(mMethExpr.FileName)), mMethExpr, calledNonOptTy) + let filePathExpr = + Expr.Const( + Const.String( +#if FABLE_COMPILER + mMethExpr.FileName +#else + System.IO.Path.GetFullPath(mMethExpr.FileName) +#endif + ), mMethExpr, calledNonOptTy) emptyPreBinder,mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[filePathExpr],mMethExpr) | CallerMemberName, Some(callerName) when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty -> let memberNameExpr = Expr.Const(Const.String(callerName), mMethExpr, calledNonOptTy) @@ -11625,8 +11643,8 @@ module TcRecdUnionAndEnumDeclarations = begin 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 + let ok, synField = seen.TryGetValue(f.Name) + if ok then match sf, synField with | Field(_, _, Some(id), _, _, _, _, _), Field(_, _, Some(_), _, _, _, _, _) -> error(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(id.idText), id.idRange)) diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index c3cdc8d338..27360834de 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -41,7 +41,7 @@ open Microsoft.FSharp.Compiler.NameResolution // ilxgen.fs: GenCoerce (omit unnecessary 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 @@ -80,7 +80,7 @@ type CanCoerce = CanCoerce | NoCoerce /// The feasible equivalence relation. Part of the language spec. let rec TypesFeasiblyEquiv ndeep g amap m ty1 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 @@ -102,7 +102,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 diff --git a/src/fsharp/UnicodeLexing.fs b/src/fsharp/UnicodeLexing.fs index 08a4c152e1..f16afa8566 100755 --- a/src/fsharp/UnicodeLexing.fs +++ b/src/fsharp/UnicodeLexing.fs @@ -19,7 +19,9 @@ let StringAsLexbuf (s:string) : Lexbuf = let FunctionAsLexbuf (bufferFiller: char[] * int * int -> int) : Lexbuf = LexBuffer<_>.FromFunction bufferFiller - + +#if !FABLE_COMPILER + // The choice of 60 retries times 50 ms is not arbitrary. The NTFS FILETIME structure // uses 2 second resolution for LastWriteTime. We retry long enough to surpass this threshold // plus 1 second. Once past the threshold the incremental builder will be able to retry asynchronously based @@ -67,3 +69,5 @@ let UnicodeFileAsLexbuf (filename,codePage : int option, retryLocked:bool) : Le let source = getSource 0 let lexbuf = LexBuffer<_>.FromChars(source.ToCharArray()) lexbuf + +#endif \ No newline at end of file diff --git a/src/fsharp/UnicodeLexing.fsi b/src/fsharp/UnicodeLexing.fsi index fd775860e0..704521b828 100755 --- a/src/fsharp/UnicodeLexing.fsi +++ b/src/fsharp/UnicodeLexing.fsi @@ -8,4 +8,7 @@ open Internal.Utilities.Text.Lexing type Lexbuf = LexBuffer val internal StringAsLexbuf : string -> Lexbuf val public FunctionAsLexbuf : (char [] * int * int -> int) -> Lexbuf + +#if !FABLE_COMPILER val public UnicodeFileAsLexbuf :string * int option * (*retryLocked*) bool -> Lexbuf +#endif \ No newline at end of file diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index c0bca3ec1e..f3fe21006d 100755 --- a/src/fsharp/import.fs +++ b/src/fsharp/import.fs @@ -6,6 +6,9 @@ module internal Microsoft.FSharp.Compiler.Import open System.Reflection open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -55,6 +58,9 @@ type AssemblyLoader = [] type ImportMap(g:TcGlobals,assemblyLoader:AssemblyLoader) = let typeRefToTyconRefCache = new System.Collections.Generic.Dictionary() +#if FABLE_COMPILER + new (g,assemblyLoader,_) = ImportMap(g,assemblyLoader) +#endif member this.g = g member this.assemblyLoader = assemblyLoader member this.ILTypeRefToTyconRefCache = typeRefToTyconRefCache diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 16aed80b7a..4a295fd202 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -1594,8 +1594,8 @@ type ILFieldInfo = | ILFieldInfo(_, x1), ILFieldInfo(_, x2) -> (x1 === x2) #if EXTENSIONTYPING | ProvidedField(_,fi1,_), ProvidedField(_,fi2,_)-> ProvidedFieldInfo.TaintedEquals (fi1, fi2) - | _ -> false #endif + /// Get an (uninstantiated) reference to the field as an Abstract IL ILFieldRef member x.ILFieldRef = rescopeILFieldRef x.ScopeRef (mkILFieldRef(x.ILTypeRef,x.FieldName,x.ILFieldType)) override x.ToString() = x.FieldName diff --git a/src/fsharp/layout.fs b/src/fsharp/layout.fs index 187211fb77..747ce66276 100755 --- a/src/fsharp/layout.fs +++ b/src/fsharp/layout.fs @@ -3,6 +3,10 @@ module internal Microsoft.FSharp.Compiler.Layout open System +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core.Operators +#endif open System.IO open Internal.Utilities.StructuredFormat open Microsoft.FSharp.Core.Printf @@ -260,6 +264,7 @@ let stringR = type NoState = NoState type NoResult = NoResult +#if !FABLE_COMPILER /// channel LayoutRenderer let channelR (chan:TextWriter) = { new LayoutRenderer with @@ -268,6 +273,7 @@ let channelR (chan:TextWriter) = member r.AddBreak z n = chan.WriteLine(); chan.Write (spaces n); z member r.AddTag z (tag,attrs,start) = z member r.Finish z = NoResult } +#endif /// buffer render let bufferR os = @@ -283,5 +289,7 @@ let bufferR os = //-------------------------------------------------------------------------- let showL layout = renderL stringR layout +#if !FABLE_COMPILER let outL (chan:TextWriter) layout = renderL (channelR chan) layout |> ignore +#endif let bufferL os layout = renderL (bufferR os) layout |> ignore diff --git a/src/fsharp/layout.fsi b/src/fsharp/layout.fsi index 8d8ec6c589..321d865ed1 100755 --- a/src/fsharp/layout.fsi +++ b/src/fsharp/layout.fsi @@ -2,6 +2,9 @@ module internal Microsoft.FSharp.Compiler.Layout +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.Text open System.IO open Internal.Utilities.StructuredFormat @@ -42,7 +45,9 @@ val listL : ('a -> Layout) -> 'a list -> Layout val squashTo : int -> Layout -> Layout val showL : Layout -> string +#if !FABLE_COMPILER val outL : TextWriter -> Layout -> unit +#endif val bufferL : StringBuilder -> Layout -> unit /// render a Layout yielding an 'a using a 'b (hidden state) type @@ -61,6 +66,8 @@ val renderL : LayoutRenderer<'b,'a> -> Layout -> 'b /// Primitive renders val stringR : LayoutRenderer +#if !FABLE_COMPILER val channelR : TextWriter -> LayoutRenderer +#endif val bufferR : StringBuilder -> LayoutRenderer diff --git a/src/fsharp/lex.fsl b/src/fsharp/lex.fsl index f93eeb1bfe..2529367a2c 100755 --- a/src/fsharp/lex.fsl +++ b/src/fsharp/lex.fsl @@ -10,10 +10,11 @@ module internal Microsoft.FSharp.Compiler.Lexer // whitespace etc. //----------------------------------------------------------------------- +open Internal.Utilities + open System open System.Globalization open System.Text -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -48,10 +49,10 @@ let fail args (lexbuf:UnicodeLexing.Lexbuf) msg dflt = // version of the F# core library parsing code with the call to "Trim" // removed, which appears in profiling runs as a small but significant cost. -let getSign32 (s:string) (p:byref) l = +let getSign32 (s:string) (p:int) l = if (l >= p + 1 && s.[p] = '-') - then p <- p + 1; -1 - else 1 + then -1, p + 1 + else 1, p let isOXB c = #if FX_NO_TO_LOWER_INVARIANT @@ -63,14 +64,15 @@ let isOXB c = let is0OXB (s:string) p l = l >= p + 2 && s.[p] = '0' && isOXB s.[p+1] -let get0OXB (s:string) (p:byref) l = + +let get0OXB (s:string) (p:int) l = if is0OXB s p l #if FX_NO_TO_LOWER_INVARIANT - then let r = Char.ToLower s.[p+1] in p <- p + 2; r + then let r = Char.ToLower s.[p+1] in r, p + 2 #else - then let r = Char.ToLowerInvariant s.[p+1] in p <- p + 2; r + then let r = Char.ToLowerInvariant s.[p+1] in r, p + 2 #endif - else 'd' + else 'd', p let formatError() = raise (new System.FormatException(SR.GetString("bad format string"))) @@ -90,18 +92,26 @@ let removeUnderscores (s:string) = let parseInt32 (s:string) = let s = removeUnderscores s let l = s.Length - let mutable p = 0 - let sign = getSign32 s &p l - let specifier = get0OXB s &p l + let p = 0 + let sign, p = getSign32 s p l + let specifier, p = get0OXB s p l #if FX_RESHAPED_GLOBALIZATION match CultureInfo.InvariantCulture.TextInfo.ToLower(specifier) with #else - match Char.ToLower(specifier,CultureInfo.InvariantCulture) with + match Char.ToLowerInvariant(specifier) with #endif - | 'x' -> sign * (int32 (Convert.ToUInt32(UInt64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture)))) - | 'b' -> sign * (int32 (Convert.ToUInt32(parseBinaryUInt64 s p l))) - | 'o' -> sign * (int32 (Convert.ToUInt32(parseOctalUInt64 s p l))) +#if FABLE_COMPILER + | 'x' -> sign * Convert.ToInt32(s.Substring(p), 16) +#else + | 'x' -> sign * (int32 (uint32(UInt64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture)))) +#endif + | 'b' -> sign * (int32 (uint32(parseBinaryUInt64 s p l))) + | 'o' -> sign * (int32 (uint32(parseOctalUInt64 s p l))) +#if FABLE_COMPILER + | _ -> Convert.ToInt32(s) +#else | _ -> Int32.Parse(s, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture) +#endif let lexemeTrimRightToInt32 args lexbuf n = try parseInt32 (lexemeTrimRight lexbuf n) @@ -357,23 +367,36 @@ rule token args skip = parse { try let s = lexemeTrimRight lexbuf 1 // This implements a range check for decimal literals +#if FABLE_COMPILER + let d = Convert.ToDecimal(s) +#else let d = System.Decimal.Parse(s,System.Globalization.NumberStyles.AllowExponent ||| System.Globalization.NumberStyles.Number,System.Globalization.CultureInfo.InvariantCulture) +#endif DECIMAL d with e -> fail args lexbuf (FSComp.SR.lexOusideDecimal()) (DECIMAL (decimal 0)) } | xieee32 { +#if FABLE_COMPILER + fail args lexbuf (FSComp.SR.lexInvalidFloat()) (IEEE32 0.0f) +#else let s = lexemeTrimRight lexbuf 2 // Even though the intermediate step is an int64, display the "invalid float" message, since it will be less confusing to the user let n64 = (try (int64 s) with _ -> fail args lexbuf (FSComp.SR.lexInvalidFloat()) 0L) if n64 > 0xFFFFFFFFL || n64 < 0L then fail args lexbuf (FSComp.SR.lexOusideThirtyTwoBitFloat()) (IEEE32 0.0f) else - IEEE32 (System.BitConverter.ToSingle(System.BitConverter.GetBytes(int32 (uint32 (uint64 n64))),0)) } - + IEEE32 (System.BitConverter.ToSingle(System.BitConverter.GetBytes(int32 (uint32 (uint64 n64))),0)) +#endif + } | xieee64 { +#if FABLE_COMPILER + fail args lexbuf (FSComp.SR.lexInvalidFloat()) (IEEE64 0.0) +#else let n64 = (try int64 (lexemeTrimRight lexbuf 2) with _ -> fail args lexbuf (FSComp.SR.lexInvalidFloat()) 0L) - IEEE64 (System.BitConverter.Int64BitsToDouble(n64)) } + IEEE64 (System.BitConverter.Int64BitsToDouble(n64)) +#endif + } | bignum { let s = lexeme lexbuf diff --git a/src/fsharp/lexhelp.fs b/src/fsharp/lexhelp.fs index f441549997..18cb4824a3 100755 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -2,12 +2,12 @@ module internal Microsoft.FSharp.Compiler.Lexhelp -open System -open System.Text open Internal.Utilities open Internal.Utilities.Collections open Internal.Utilities.Text open Internal.Utilities.Text.Lexing +open System +open System.Text open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -31,6 +31,9 @@ let stdinMockFilename = "stdin" [] type LightSyntaxStatus(initial:bool,warn:bool) = let mutable status = None +#if FABLE_COMPILER + new (initial,warn, _) = LightSyntaxStatus(initial,warn) +#endif member x.Status with get() = match status with None -> initial | Some v -> v and set v = status <- Some(v) @@ -41,14 +44,18 @@ type LightSyntaxStatus(initial:bool,warn:bool) = /// Manage lexer resources (string interning) [] type LexResourceManager() = - let strings = new System.Collections.Generic.Dictionary(100) - member x.InternIdentifierToken(s) = - let mutable res = Unchecked.defaultof<_> - let ok = strings.TryGetValue(s,&res) - if ok then res else - let res = IDENT s - (strings.[s] <- res; res) - + let strings = new System.Collections.Generic.Dictionary(100) +#if FABLE_COMPILER + new (_) = LexResourceManager() +#endif + member x.InternIdentifierToken(s) = + let ok, res = strings.TryGetValue(s) + if ok then res + else + let res = token.IDENT s + strings.[s] <- res + res + /// Lexer parameters type lexargs = { defines: string list @@ -321,6 +328,10 @@ module Keywords = | _ -> v | _ -> match s with +#if FABLE_COMPILER + | "__SOURCE_DIRECTORY__" -> KEYWORD_STRING "" //TODO: implement + | "__SOURCE_FILE__" -> KEYWORD_STRING "" //TODO: implement +#else | "__SOURCE_DIRECTORY__" -> let filename = fileOfFileIndex lexbuf.StartPos.FileIndex let dirname = @@ -335,6 +346,7 @@ module Keywords = KEYWORD_STRING dirname | "__SOURCE_FILE__" -> KEYWORD_STRING (System.IO.Path.GetFileName((fileOfFileIndex lexbuf.StartPos.FileIndex))) +#endif | "__LINE__" -> KEYWORD_STRING (string lexbuf.StartPos.Line) | _ -> diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi index 2d42776079..53863f0697 100755 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -44,13 +44,13 @@ val reusingLexbufForParsing : UnicodeLexing.Lexbuf -> (unit -> 'a) -> 'a val usingLexbufForParsing : UnicodeLexing.Lexbuf * string -> (UnicodeLexing.Lexbuf -> 'a) -> 'a val defaultStringFinisher : 'a -> 'b -> byte[] -> Parser.token -val callStringFinisher : ('a -> 'b -> byte[] -> 'c) -> AbstractIL.Internal.ByteBuffer -> 'a -> 'b -> 'c -val addUnicodeString : AbstractIL.Internal.ByteBuffer -> string -> unit -val addUnicodeChar : AbstractIL.Internal.ByteBuffer -> int -> unit -val addByteChar : AbstractIL.Internal.ByteBuffer -> char -> unit +val callStringFinisher : ('a -> 'b -> byte[] -> 'c) -> ByteBuffer -> 'a -> 'b -> 'c +val addUnicodeString : ByteBuffer -> string -> unit +val addUnicodeChar : ByteBuffer -> int -> unit +val addByteChar : ByteBuffer -> char -> unit val stringBufferAsString : byte[] -> string -val stringBufferAsBytes : AbstractIL.Internal.ByteBuffer -> byte[] -val stringBufferIsBytes : AbstractIL.Internal.ByteBuffer -> bool +val stringBufferAsBytes : ByteBuffer -> byte[] +val stringBufferIsBytes : ByteBuffer -> bool val newline : Lexing.LexBuffer<'a> -> unit val trigraph : char -> char -> char -> char val digit : char -> int32 diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index f9b774095c..01952a8b85 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -5,6 +5,9 @@ module internal Microsoft.FSharp.Compiler.Lib open System.IO open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -16,6 +19,7 @@ let verbose = false let progress = ref false let tracking = ref false // intended to be a general hook to control diagnostic output when tracking down bugs +#if !FABLE_COMPILER let condition _s = try (System.Environment.GetEnvironmentVariable(_s) <> null) with _ -> false @@ -31,6 +35,7 @@ type SaveAndRestoreConsoleEncoding () = try System.Console.SetOut(savedOut) with _ -> () +#endif //------------------------------------------------------------------------- // Library: bits @@ -54,6 +59,9 @@ module Bits = module Filename = let fullpath cwd nm = +#if FABLE_COMPILER + cwd + "/" + nm //TODO: proper implementation +#else let p = if FileSystem.IsPathRootedShim(nm) then nm else Path.Combine(cwd,nm) try FileSystem.GetFullPathShim(p) with | :? System.ArgumentException @@ -61,9 +69,10 @@ module Filename = | :? System.NotSupportedException | :? System.IO.PathTooLongException | :? System.Security.SecurityException -> p +#endif let hasSuffixCaseInsensitive suffix filename = (* case-insensitive *) - Filename.checkSuffix (String.lowercase filename) (String.lowercase suffix) + Filename.checkSuffix (String.lowercase filename) (String.lowercase suffix) let isDll file = hasSuffixCaseInsensitive ".dll" file @@ -304,6 +313,7 @@ let bufs f = f buf buf.ToString() +#if !FABLE_COMPILER let buff (os: TextWriter) f x = let buf = System.Text.StringBuilder 100 f buf x @@ -316,7 +326,8 @@ let writeViaBufferWithEnvironmentNewLines (os: TextWriter) f x = let text = buf.ToString() let text = text.Replace("\n",System.Environment.NewLine) os.Write text - +#endif + //--------------------------------------------------------------------------- // Imperative Graphs //--------------------------------------------------------------------------- @@ -424,6 +435,7 @@ type Dumper(x:obj) = member self.Dump = sprintf "%A" x #endif +#if !FABLE_COMPILER //--------------------------------------------------------------------------- // AsyncUtil //--------------------------------------------------------------------------- @@ -563,3 +575,5 @@ module UnmanagedProcessExecutionOptions = GetLastError().ToString("X").PadLeft(8,'0') + ".")) #endif + +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 53d5ec743a..d196afea6a 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -279,7 +279,7 @@ let rangeOfLongIdent(lid:LongIdent) = %type typedSeqExprBlock %type atomicExpr %type tyconDefnOrSpfnSimpleRepr -%type <(Ast.SynEnumCase, Ast.SynUnionCase) Choice list> unionTypeRepr +%type list> unionTypeRepr %type tyconDefnAugmentation %type exconDefn %type exconCore @@ -2811,7 +2811,7 @@ atomicPattern: { SynPat.OptionalVal($2,lhs parseState) } | atomicPatternLongIdent %prec prec_atompat_pathop { let vis,lidwd = $1 - if List.length lidwd.Lid > 1 || (let c = (List.head lidwd.Lid).idText.[0] in Char.IsUpper(c) && not (Char.IsLower c)) + if List.length lidwd.Lid > 1 || (String.isUpper (List.head lidwd.Lid).idText) then mkSynPatMaybeVar lidwd vis (lhs parseState) else mkSynPatVar vis (List.head lidwd.Lid) } | constant @@ -3506,7 +3506,7 @@ minusExpr: { mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) "~-" $2 } | PLUS_MINUS_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | ADJACENT_PREFIX_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) if $1 = "&" then @@ -3514,10 +3514,10 @@ minusExpr: elif $1 = "&&" then SynExpr.AddressOf(false,$2,rhs parseState 1,unionRanges (rhs parseState 1) $2.Range) else - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | PERCENT_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | AMP minusExpr { SynExpr.AddressOf(true,$2,rhs parseState 1,unionRanges (rhs parseState 1) $2.Range) } | AMP_AMP minusExpr @@ -3547,7 +3547,7 @@ argExpr: { let arg2,hpa2 = $2 if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt arg2.Range (FSComp.SR.parsInvalidPrefixOperator()) if hpa2 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsSuccessiveArgsShouldBeSpacedOrTupled()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~"^($1)) arg2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~"+($1)) arg2 } | atomicExpr { let arg,hpa = $1 if hpa then reportParseErrorAt arg.Range (FSComp.SR.parsSuccessiveArgsShouldBeSpacedOrTupled()) diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index abad7849d9..5edf973d46 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -3,14 +3,14 @@ /// Anything to do with special names of identifiers and other lexical rules module (*internal*) Microsoft.FSharp.Compiler.Range +open Internal.Utilities open System.IO open System.Collections.Generic open Microsoft.FSharp.Core.Printf -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Lib.Bits @@ -27,8 +27,12 @@ let posColumnMask = mask32 0 columnBitCount let lineColumnMask = mask32 columnBitCount lineBitCount let inline (lsr) (x:int) (y:int) = int32 (uint32 x >>> y) +#if FABLE_COMPILER +[] +#else [] [] +#endif type pos(code:int32) = new (l,c) = let l = max 0 l @@ -43,11 +47,18 @@ type pos(code:int32) = member r.Encoding = code static member EncodingSize = posBitCount static member Decode (code:int32) : pos = pos code +#if FABLE_COMPILER + override p.ToString() = sprintf "(%d,%d)" p.Line p.Column +#else override p.Equals(obj) = match obj with :? pos as p2 -> code = p2.Encoding | _ -> false override p.GetHashCode() = hash code +#endif [] let fileIndexBitCount = 14 + +#if !FABLE_COMPILER + [] let startLineBitCount = lineBitCount [] @@ -61,7 +72,7 @@ let isSyntheticBitCount = 1 #if DEBUG let _ = assert (fileIndexBitCount + startLineBitCount + startColumnBitCount + heightBitCount + endColumnBitCount + isSyntheticBitCount = 64) #endif - + [] let fileIndexShift = 0 [] @@ -103,18 +114,22 @@ let _ = assert (endColumnMask = mask64 endColumnShift endColumnBitCount) let _ = assert (isSyntheticMask = mask64 isSyntheticShift isSyntheticBitCount) #endif +#endif //!FABLE_COMPILER + // This is just a standard unique-index table type FileIndexTable() = let indexToFileTable = new ResizeArray<_>(11) let fileToIndexTable = new Dictionary(11) member t.FileToIndex f = - let mutable res = 0 - let ok = fileToIndexTable.TryGetValue(f,&res) +#if FABLE_COMPILER + ( +#else + let ok, res = fileToIndexTable.TryGetValue f in if ok then res else lock fileToIndexTable (fun () -> - let mutable res = 0 in - let ok = fileToIndexTable.TryGetValue(f,&res) in +#endif + let ok, res = fileToIndexTable.TryGetValue(f) in if ok then res else let n = indexToFileTable.Count in @@ -139,6 +154,30 @@ let fileOfFileIndex n = fileIndexTable.IndexToFile(n) let mkPos l c = pos (l,c) +#if FABLE_COMPILER +[] +let fileIndexMask = 0b0011111111111111 +[] +let isSyntheticMask = 0b0100000000000000 + +[] +type range(code:int, b:pos, e:pos) = + static member Zero = range(0, pos(0), pos(0)) + member r.StartLine = b.Line + member r.StartColumn = b.Column + member r.EndLine = e.Line + member r.EndColumn = e.Column + member r.IsSynthetic = (code &&& isSyntheticMask) <> 0 + member r.Start = b + member r.End = e + member r.FileIndex = (code &&& fileIndexMask) + member m.StartRange = range (m.FileIndex, m.Start, m.Start) + member m.EndRange = range (m.FileIndex, m.End, m.End) + member r.FileName = fileOfFileIndex r.FileIndex + member r.MakeSynthetic() = range(code ||| isSyntheticMask, b, e) + override r.ToString() = sprintf "%s (%d,%d--%d,%d) IsSynthetic=%b" r.FileName r.StartLine r.StartColumn r.EndLine r.EndColumn r.IsSynthetic + member r.ToShortString() = sprintf "(%d,%d--%d,%d)" r.StartLine r.StartColumn r.EndLine r.EndColumn +#else [] [] type range(code:int64) = @@ -169,7 +208,7 @@ type range(code:int64) = member r.Code = code override r.Equals(obj) = match obj with :? range as r2 -> code = r2.Code | _ -> false override r.GetHashCode() = hash code - +#endif let mkRange f b e = range (fileIndexOfFile f, b, e) let mkFileIndexRange fi b e = range (fi, b, e) @@ -180,10 +219,15 @@ let posOrder = Order.orderOn (fun (p:pos) -> p.Line, p.Column) (Pair.order (In let rangeOrder = Order.orderOn (fun (r:range) -> r.FileName, r.Start) (Pair.order (String.order,posOrder)) let outputPos (os:TextWriter) (m:pos) = fprintf os "(%d,%d)" m.Line m.Column -let outputRange (os:TextWriter) (m:range) = fprintf os "%s%a-%a" m.FileName outputPos m.Start outputPos m.End let boutputPos os (m:pos) = bprintf os "(%d,%d)" m.Line m.Column +#if FABLE_COMPILER +let stringPos (m:pos) = sprintf "(%d,%d)" m.Line m.Column +let outputRange (os:TextWriter) (m:range) = fprintf os "%s%s-%s" m.FileName (stringPos m.Start) (stringPos m.End) +let boutputRange os (m:range) = bprintf os "%s%s-%s" m.FileName (stringPos m.Start) (stringPos m.End) +#else +let outputRange (os:TextWriter) (m:range) = fprintf os "%s%a-%a" m.FileName outputPos m.Start outputPos m.End let boutputRange os (m:range) = bprintf os "%s%a-%a" m.FileName boutputPos m.Start boutputPos m.End - +#endif let posGt (p1:pos) (p2:pos) = (p1.Line > p2.Line || (p1.Line = p2.Line && p1.Column > p2.Column)) let posEq (p1:pos) (p2:pos) = (p1.Line = p2.Line && p1.Column = p2.Column) let posGeq p1 p2 = posEq p1 p2 || posGt p1 p2 @@ -198,7 +242,11 @@ let unionRanges (m1:range) (m2:range) = let e = if (m1.EndLine > m2.EndLine || (m1.EndLine = m2.EndLine && m1.EndColumn > m2.EndColumn)) then m1 else m2 +#if FABLE_COMPILER + range (m1.FileIndex, b.Start, e.End) +#else range (m1.FileIndex, b.StartLine, b.StartColumn, e.EndLine, e.EndColumn) +#endif let rangeContainsRange (m1:range) (m2:range) = m1.FileIndex = m2.FileIndex && @@ -222,10 +270,14 @@ let trimRangeToLine (r:range) = let startL,startC = r.StartLine,r.StartColumn let endL ,_endC = r.EndLine,r.EndColumn if endL <= startL then - r + r else - let endL,endC = startL+1,0 (* Trim to the start of the next line (we do not know the end of the current line) *) - range (r.FileIndex, startL, startC, endL, endC) + let endL,endC = startL+1,0 (* Trim to the start of the next line (we do not know the end of the current line) *) +#if FABLE_COMPILER + range (r.FileIndex, pos(startL, startC), pos(endL, endC)) +#else + range (r.FileIndex, startL, startC, endL, endC) +#endif (* For Diagnostics *) let stringOfPos (pos:pos) = sprintf "(%d,%d)" pos.Line pos.Column @@ -245,7 +297,11 @@ type Range01 = Pos01 * Pos01 module Line = // Visual Studio uses line counts starting at 0, F# uses them starting at 1 let fromZ (line:Line0) = int line+1 +#if FABLE_COMPILER + let toZ (line:int) : Line0 = int (line - 1) +#else let toZ (line:int) : Line0 = LanguagePrimitives.Int32WithMeasure(line - 1) +#endif module Pos = let fromZ (line:Line0) idx = mkPos (Line.fromZ line) idx diff --git a/src/fsharp/range.fsi b/src/fsharp/range.fsi index 4b0a34fdf8..571bbeb2d3 100755 --- a/src/fsharp/range.fsi +++ b/src/fsharp/range.fsi @@ -2,9 +2,9 @@ module (*internal*) Microsoft.FSharp.Compiler.Range +open Internal.Utilities open System.Text open System.Collections.Generic -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler @@ -15,7 +15,11 @@ type FileIndex = int32 val fileIndexOfFile : string -> FileIndex val fileOfFileIndex : FileIndex -> string +#if FABLE_COMPILER +[] +#else [] +#endif type pos = member Line : int member Column : int @@ -30,7 +34,11 @@ val mkPos : line:int -> column:int -> pos val posOrder : IComparer +#if FABLE_COMPILER +[] +#else [] +#endif type range = member StartLine : int member StartColumn : int @@ -65,7 +73,7 @@ val outputPos : System.IO.TextWriter -> pos -> unit val outputRange : System.IO.TextWriter -> range -> unit val boutputPos : StringBuilder -> pos -> unit val boutputRange : StringBuilder -> range -> unit - + val posLt : pos -> pos -> bool val posGt : pos -> pos -> bool val posEq : pos -> pos -> bool diff --git a/src/fsharp/rational.fs b/src/fsharp/rational.fs index e17ebb93ac..a9b108f529 100644 --- a/src/fsharp/rational.fs +++ b/src/fsharp/rational.fs @@ -3,6 +3,9 @@ /// Rational arithmetic, used for exponents on units-of-measure module internal Microsoft.FSharp.Compiler.Rational +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.Numerics type Rational = { diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index c9d5584572..11a47fae50 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -26,6 +26,9 @@ open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.QuotationPickler open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler.Rational +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -35,12 +38,20 @@ open Microsoft.FSharp.Core.CompilerServices /// Unique name generator for stamps attached to lambdas and object expressions type Unique = int64 //++GLOBAL MUTABLE STATE +#if FABLE_COMPILER +let newUnique = let i = ref 0L in fun () -> i := !i + 1L; !i +#else let newUnique = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment(i) -type Stamp = int64 +#endif /// Unique name generator for stamps attached to to val_specs, tycon_specs etc. +type Stamp = int64 //++GLOBAL MUTABLE STATE +#if FABLE_COMPILER +let newStamp = let i = ref 0L in fun () -> i := !i + 1L; !i +#else let newStamp = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment(i) +#endif /// A global generator of compiler generated names // ++GLOBAL MUTABLE STATE @@ -386,7 +397,7 @@ type EntityFlags(flags:int64) = member x.PickledBits = (flags &&& ~~~0b00000000100L) -#if DEBUG +#if DEBUG && !FABLE_COMPILER assert (sizeof = 8) assert (sizeof = 8) assert (sizeof = 4) @@ -522,7 +533,7 @@ type Entity = /// The code location where the module, namespace or type is defined. member x.Range = -#if EXTENSIONTYPING +#if EXTENSIONTYPING match x.TypeReprInfo with | TProvidedTypeExtensionPoint info -> match definitionLocationOfProvidedItem info.ProvidedType with @@ -900,7 +911,7 @@ type Entity = match x.GeneratedHashAndEqualsWithComparerValues with | None -> () | Some (v1,v2,v3) -> yield v1; yield v2; yield v3 ] - + /// Gets the data indicating the compiled representation of a type or module in terms of Abstract IL data structures. member x.CompiledRepresentation = @@ -3795,7 +3806,7 @@ and // // Indicates the expression is a quoted expression tree. | Quote of Expr * (ILTypeRef list * TTypes * Exprs * ExprData) option ref * bool * range * TType - + /// Typechecking residue: Indicates a free choice of typars that arises due to /// minimization of polymorphism at let-rec bindings. These are /// resolved to a concrete instantiation on subsequent rewrites. diff --git a/src/fsharp/vs/Exprs.fs b/src/fsharp/vs/Exprs.fs index f78e3a1f12..de948b2fe8 100644 --- a/src/fsharp/vs/Exprs.fs +++ b/src/fsharp/vs/Exprs.fs @@ -955,11 +955,16 @@ module FSharpExprConvert = | Const.Int32 i -> E.Const(box i, tyR) | Const.UInt32 i -> E.Const(box i, tyR) | Const.Int64 i -> E.Const(box i, tyR) - | Const.IntPtr i -> E.Const(box (nativeint i), tyR) | Const.UInt64 i -> E.Const(box i, tyR) - | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) - | Const.Double i -> E.Const(box i, tyR) - | Const.Single i -> E.Const(box i, tyR) +#if FABLE_COMPILER + | Const.IntPtr i -> E.Const(box i, tyR) + | Const.UIntPtr i -> E.Const(box i, tyR) +#else + | Const.IntPtr i -> E.Const(box (nativeint i), tyR) + | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) +#endif + | Const.Double i -> E.Const(box i, tyR) + | Const.Single i -> E.Const(box i, tyR) | Const.String i -> E.Const(box i, tyR) | Const.Char i -> E.Const(box i, tyR) | Const.Unit -> E.Const(box (), tyR) diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/vs/ServiceDeclarations.fs index c4b9c34811..ad62043149 100644 --- a/src/fsharp/vs/ServiceDeclarations.fs +++ b/src/fsharp/vs/ServiceDeclarations.fs @@ -7,6 +7,9 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif open System open System.Collections.Generic open System.IO @@ -34,11 +37,16 @@ open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionIcons module EnvMisc2 = +#if FABLE_COMPILER + let maxMembers = 10 + let dataTipSpinWaitTime = 300 +#else let maxMembers = GetEnvInteger "FCS_MaxMembersInQuickInfo" 10 /// dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. /// This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. let dataTipSpinWaitTime = GetEnvInteger "FCS_ToolTipSpinWaitTime" 300 +#endif //---------------------------------------------------------------------------- // Display characteristics of typechecking items @@ -216,9 +224,13 @@ module internal ItemDescriptionsImpl = | _ -> None /// 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 fileNameOfItem (g:TcGlobals) (qualProjectDir: string option) (m:range) (h:Item) = let file = m.FileName if verbose then dprintf "file stored in metadata is '%s'\n" file +#if FABLE_COMPILER + ignore g; ignore qualProjectDir; ignore h + file +#else if not (FileSystem.IsPathRootedShim file) then match ccuOfItem g h with | Some ccu -> @@ -227,7 +239,8 @@ module internal ItemDescriptionsImpl = match qualProjectDir with | None -> file | Some dir -> Path.Combine(dir, file) - else file + else file +#endif /// Cut long filenames to make them visually appealing let cutFileName s = if String.length s > 40 then String.sub s 0 10 + "..."+String.sub s (String.length s - 27) 27 else s @@ -444,7 +457,7 @@ module internal ItemDescriptionsImpl = // Like Seq.distinctBy but only filters out duplicates for some of the elements let partialDistinctBy (per:IPartialEqualityComparer<_>) seq = // Wrap a Wrap _ around all keys in case the key type is itself a type using null as a representation - let dict = new Dictionary,obj>(per) + let dict = new Dictionary,obj>(3, per) seq |> List.filter (fun v -> let v = Wrap(v) if (per.InEqualityRelation(v)) then @@ -536,7 +549,11 @@ module internal ItemDescriptionsImpl = if isAppTy g ty then hash (tcrefOfAppTy g ty).Stamp else 1010 | Wrap(Item.ILField(ILFieldInfo(_, fld))) -> +#if FABLE_COMPILER + (box fld).GetHashCode() // hash on the object identity of the AbstractIL metadata blob for the field +#else System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode fld // hash on the object identity of the AbstractIL metadata blob for the field +#endif | Wrap(Item.TypeVar (nm,_tp)) -> hash nm | Wrap(Item.CustomOperation (_,_,Some minfo)) -> minfo.ComputeHashCode() | Wrap(Item.CustomOperation (_,_,None)) -> 1 @@ -1029,7 +1046,7 @@ module internal ItemDescriptionsImpl = // namespaces from type providers need to be handled separately because they don't have compiled representation // otherwise we'll fail at tast.fs match modref.Deref.TypeReprInfo with -#if EXTENSIONTYPING +#if EXTENSIONTYPING | TProvidedNamespaceExtensionPoint _ -> modref.CompilationPathOpt |> Option.bind (fun path -> @@ -1211,8 +1228,9 @@ module internal ItemDescriptionsImpl = [] type FSharpDeclarationListItem(name, glyph:int, info) = let mutable descriptionTextHolder:FSharpToolTipText option = None +#if !FABLE_COMPILER let mutable task = null - +#endif member decl.Name = name member decl.DescriptionTextAsync = @@ -1235,6 +1253,7 @@ type FSharpDeclarationListItem(name, glyph:int, info) = | None -> match info with | Choice1Of2 _ -> +#if !FABLE_COMPILER let work() = let text = decl.DescriptionTextAsync |> Async.RunSynchronously descriptionTextHolder<-Some text @@ -1249,7 +1268,9 @@ type FSharpDeclarationListItem(name, glyph:int, info) = task.Wait EnvMisc2.dataTipSpinWaitTime |> ignore match descriptionTextHolder with | Some text -> text - | None -> FSharpToolTipText [ FSharpToolTipElement.Single(FSComp.SR.loadingDescription(), FSharpXmlDoc.None) ] + | None -> +#endif + FSharpToolTipText [ FSharpToolTipElement.Single(FSComp.SR.loadingDescription(), FSharpXmlDoc.None) ] | Choice2Of2 result -> result diff --git a/src/fsharp/vs/ServiceDeclarations.fsi b/src/fsharp/vs/ServiceDeclarations.fsi index fae3e56b68..1426979312 100755 --- a/src/fsharp/vs/ServiceDeclarations.fsi +++ b/src/fsharp/vs/ServiceDeclarations.fsi @@ -7,6 +7,9 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs index 53f0d65ed0..0887e614a7 100755 --- a/src/fsharp/vs/ServiceLexing.fs +++ b/src/fsharp/vs/ServiceLexing.fs @@ -740,6 +740,9 @@ type FSharpSourceTokenizer(defineConstants : string list, filename : Option] type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput option, parseHadErrors : bool, dependencyFiles : string list) = +#if FABLE_COMPILER + new (errors, input, parseHadErrors, dependencyFiles, _) = FSharpParseFileResults(errors, input, parseHadErrors, dependencyFiles) +#endif member scope.Errors = errors member scope.ParseHadErrors = parseHadErrors diff --git a/src/fsharp/vs/SimpleServices.fs b/src/fsharp/vs/SimpleServices.fs index e9a596e327..a71a9915cd 100644 --- a/src/fsharp/vs/SimpleServices.fs +++ b/src/fsharp/vs/SimpleServices.fs @@ -17,7 +17,7 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices open Microsoft.FSharp.Compiler.AbstractIL.IL [] - module private Utils = + module Utils = let buildFormatComment (xmlCommentRetriever: string * string -> string) cmt (sb: StringBuilder) = match cmt with diff --git a/src/fsharp/vs/Symbols.fs b/src/fsharp/vs/Symbols.fs index d611b713dc..e006b3a7ea 100644 --- a/src/fsharp/vs/Symbols.fs +++ b/src/fsharp/vs/Symbols.fs @@ -32,7 +32,11 @@ module Impl = f let makeReadOnlyCollection (arr : seq<'T>) = +#if FABLE_COMPILER + System.Collections.Generic.List<_>(Seq.toArray arr) :> IList<_> +#else System.Collections.ObjectModel.ReadOnlyCollection<_>(Seq.toArray arr) :> IList<_> +#endif let makeXmlDoc (XmlDoc x) = makeReadOnlyCollection (x) @@ -102,11 +106,11 @@ module Impl = /// Convert an IL type definition accessibility into an F# accessibility let getApproxFSharpAccessibilityOfEntity (entity: EntityRef) = match metadataOfTycon entity.Deref with - #if EXTENSIONTYPING +#if EXTENSIONTYPING | ProvidedTypeMetadata _info -> // This is an approximation - for generative type providers some type definitions can be private. taccessPublic - #endif +#endif | ILTypeMetadata (_,td) -> match td.Access with | ILTypeDefAccess.Public @@ -144,6 +148,9 @@ module Impl = type cenv(g:TcGlobals, thisCcu: CcuThunk , tcImports: TcImports) = let amapV = tcImports.GetImportMap() let infoReaderV = InfoReader(g, amapV) +#if FABLE_COMPILER + new (g, thisCcu, tcImports, _) = cenv(g, thisCcu, tcImports) +#endif member __.g = g member __.amap = amapV member __.thisCcu = thisCcu @@ -220,6 +227,9 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = let isResolved() = not (isUnresolved()) let checkIsResolved() = checkEntityIsResolved entity +#if FABLE_COMPILER + new (cenv, entity, _) = FSharpEntity(cenv, entity) +#endif member __.Entity = entity member __.LogicalName = @@ -254,11 +264,11 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.QualifiedName = checkIsResolved() let fail() = invalidOp (sprintf "the type '%s' does not have a qualified name" x.LogicalName) - #if EXTENSIONTYPING - if entity.IsTypeAbbrev || entity.IsProvidedErasedTycon || entity.IsNamespace then fail() - #else - if entity.IsTypeAbbrev || entity.IsNamespace then fail() - #endif + if entity.IsTypeAbbrev +#if EXTENSIONTYPING + || entity.IsProvidedErasedTycon +#endif + || entity.IsNamespace then fail() match entity.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref,_,_) -> tref.QualifiedName | CompiledTypeRepr.ILAsmOpen _ -> fail() @@ -271,11 +281,11 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.TryFullName = if isUnresolved() then None - #if EXTENSIONTYPING - elif entity.IsTypeAbbrev || entity.IsProvidedErasedTycon then None - #else - elif entity.IsTypeAbbrev then None - #endif + elif entity.IsTypeAbbrev +#if EXTENSIONTYPING + || entity.IsProvidedErasedTycon +#endif + then None elif entity.IsNamespace then Some entity.DemangledModuleOrNamespaceName else match entity.CompiledRepresentation with @@ -312,6 +322,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.ArrayRank = checkIsResolved() rankOfArrayTyconRef cenv.g entity + #if EXTENSIONTYPING member __.IsProvided = isResolved() && @@ -329,12 +340,13 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = isResolved() && entity.IsProvidedGeneratedTycon #endif + member __.IsClass = isResolved() && - match metadataOfTycon entity.Deref with - #if EXTENSIONTYPING + match metadataOfTycon entity.Deref with +#if EXTENSIONTYPING | ProvidedTypeMetadata info -> info.IsClass - #endif +#endif | ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Class) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Deref.IsFSharpClassTycon @@ -353,9 +365,9 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.IsDelegate = isResolved() && match metadataOfTycon entity.Deref with - #if EXTENSIONTYPING +#if EXTENSIONTYPING | ProvidedTypeMetadata info -> info.IsDelegate () - #endif +#endif | ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Delegate) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.IsFSharpDelegateTycon @@ -481,6 +493,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = if isUnresolved() then XmlDoc.Empty |> makeXmlDoc else entity.XmlDoc |> makeXmlDoc +#if EXTENSIONTYPING member x.StaticParameters = match entity.TypeReprInfo with #if EXTENSIONTYPING @@ -493,6 +506,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = #endif | _ -> [| |] |> makeReadOnlyCollection +#endif member __.NestedEntities = if isUnresolved() then makeReadOnlyCollection[] else @@ -558,6 +572,10 @@ and FSharpUnionCase(cenv, v: UnionCaseRef) = if v.TryUnionCase.IsNone then invalidOp (sprintf "The union case '%s' could not be found in the target type" v.CaseName) +#if FABLE_COMPILER + new (cenv, v, _) = FSharpUnionCase(cenv, v) +#endif + member __.IsUnresolved = isUnresolved() @@ -690,7 +708,11 @@ and FSharpField(cenv, d: FSharpFieldData) = if isUnresolved() then None else match d.TryRecdField with | Choice1Of2 r -> getLiteralValue r.LiteralValue +#if FABLE_COMPILER + | Choice2Of2 _ -> None +#else | Choice2Of2 f -> f.LiteralValue |> Option.map AbstractIL.ILRuntimeWriter.convFieldInit +#endif member __.IsVolatile = if isUnresolved() then false else @@ -828,10 +850,10 @@ and [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:AccessorDomain) = member internal __.Contents = ad -and FSharpActivePatternCase(cenv, apinfo: PrettyNaming.ActivePatternInfo, typ, n, valOpt: ValRef option, item) = +and FSharpActivePatternCase(cenv, apinfo: PrettyNaming.ActivePatternInfo, typ, n, valOpt: ValRef option, item2) = inherit FSharpSymbol (cenv, - (fun () -> item), + (fun () -> item2), (fun _ _ _ -> true)) member __.Name = apinfo.ActiveTags.[n] @@ -873,6 +895,9 @@ and FSharpGenericParameter(cenv, v:Typar) = inherit FSharpSymbol (cenv, (fun () -> Item.TypeVar(v.Name, v)), (fun _ _ _ad -> true)) +#if FABLE_COMPILER + new (cenv, v, _) = FSharpGenericParameter(cenv, v) +#endif member __.Name = v.DisplayName member __.DeclarationLocation = v.Range member __.IsCompilerGenerated = v.IsCompilerGenerated @@ -939,6 +964,9 @@ and FSharpAbstractParameter(cenv, info : SlotParam) = and FSharpAbstractSignature(cenv, info : SlotSig) = +#if FABLE_COMPILER + new (cenv, info, _) = FSharpAbstractSignature(cenv, info) +#endif member __.AbstractArguments = info.FormalParams |> List.map (List.map (fun p -> FSharpAbstractParameter(cenv, p)) >> makeReadOnlyCollection) @@ -1104,10 +1132,10 @@ and FSharpMemberOrVal = FSharpMemberOrFunctionOrValue and FSharpMemberFunctionOrValue = FSharpMemberOrFunctionOrValue -and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = +and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item2) = inherit FSharpSymbol(cenv, - (fun () -> item), + (fun () -> item2), (fun this thisCcu2 ad -> let this = this :?> FSharpMemberOrFunctionOrValue checkForCrossProjectAccessibility (thisCcu2, ad) (cenv.thisCcu, this.Accessibility.Contents)) @@ -1160,7 +1188,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = checkIsResolved() match d with | M m -> - match item with + match item2 with | Item.MethodGroup (_name, methodInfos, _) -> let methods = if matchParameterNumber then @@ -1168,7 +1196,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = |> List.filter (fun methodInfo -> not (methodInfo.NumArgs = m.NumArgs) ) else methodInfos methods - |> List.map (fun mi -> FSharpMemberOrFunctionOrValue(cenv, M mi, item)) + |> List.map (fun mi -> FSharpMemberOrFunctionOrValue(cenv, M mi, item2)) |> makeReadOnlyCollection |> Some | _ -> None @@ -1761,7 +1789,11 @@ and FSharpType(cenv, typ:TType) = let isResolved() = not (isUnresolved()) +#if FABLE_COMPILER + new (cenv, typ, _) = FSharpType(cenv, typ) +#else new (g, thisCcu, tcImports, typ) = FSharpType(cenv(g,thisCcu,tcImports), typ) +#endif member __.IsUnresolved = isUnresolved() @@ -1912,7 +1944,7 @@ and FSharpType(cenv, typ:TType) = |> makeReadOnlyCollection static member Prettify(parameter: FSharpParameter) = - let prettyTyp = parameter.V |> PrettyTypes.PrettifyTypes1 parameter.cenv.g |> p23 + let prettyTyp = parameter.V |> PrettyTypes.PrettifyTypes1 parameter.cenv2.g |> p23 parameter.AdjustType(prettyTyp) static member Prettify(parameters: IList) = @@ -1920,7 +1952,7 @@ and FSharpType(cenv, typ:TType) = match parameters with | [] -> [] | h :: _ -> - let cenv = h.cenv + let cenv = h.cenv2 let prettyTyps = parameters |> List.map (fun p -> p.V) |> PrettyTypes.PrettifyTypesN cenv.g |> p23 (parameters, prettyTyps) ||> List.map2 (fun p pty -> p.AdjustType(pty)) |> makeReadOnlyCollection @@ -1931,14 +1963,14 @@ and FSharpType(cenv, typ:TType) = match hOpt with | None -> xs | Some h -> - let cenv = h.cenv + let cenv = h.cenv2 let prettyTyps = xs |> List.mapSquared (fun p -> p.V) |> PrettyTypes.PrettifyTypesNN cenv.g |> p23 (xs, prettyTyps) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType(pty))) |> List.map makeReadOnlyCollection |> makeReadOnlyCollection static member Prettify(parameters: IList>, returnParameter: FSharpParameter) = let xs = parameters |> List.ofSeq |> List.map List.ofSeq - let cenv = returnParameter.cenv + let cenv = returnParameter.cenv2 let prettyTyps, prettyRetTy = xs |> List.mapSquared (fun p -> p.V) |> (fun tys -> PrettyTypes.PrettifyTypesNN1 cenv.g (tys,returnParameter.V) )|> p23 let ps = (xs, prettyTyps) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType(pty))) |> List.map makeReadOnlyCollection |> makeReadOnlyCollection ps, returnParameter.AdjustType(prettyRetTy) @@ -1977,7 +2009,9 @@ and FSharpAttribute(cenv: cenv, attrib: AttribInfo) = override __.ToString() = if entityIsUnresolved attrib.TyconRef then "attribute ???" else "attribute " + attrib.TyconRef.CompiledName + "(...)" -#if EXTENSIONTYPING + +#if EXTENSIONTYPING + and FSharpStaticParameter(cenv, sp: Tainted< ExtensionTyping.ProvidedParameterInfo >, m) = inherit FSharpSymbol(cenv, (fun () -> @@ -2017,6 +2051,7 @@ and FSharpStaticParameter(cenv, sp: Tainted< ExtensionTyping.ProvidedParameterI override x.ToString() = "static parameter " + x.Name #endif + and FSharpParameter(cenv, typ:TType, topArgInfo:ArgReprInfo, mOpt, isParamArrayArg, isOutArg, isOptionalArg) = inherit FSharpSymbol(cenv, (fun () -> @@ -2027,7 +2062,7 @@ and FSharpParameter(cenv, typ:TType, topArgInfo:ArgReprInfo, mOpt, isParamArrayA let idOpt = topArgInfo.Name let m = match mOpt with Some m -> m | None -> range0 member __.Name = match idOpt with None -> None | Some v -> Some v.idText - member __.cenv : cenv = cenv + member __.cenv2 : cenv = cenv member __.AdjustType(t) = FSharpParameter(cenv, t, topArgInfo, mOpt, isParamArrayArg, isOutArg, isOptionalArg) member __.Type : FSharpType = FSharpType(cenv, typ) member __.V = typ @@ -2088,9 +2123,9 @@ and FSharpAssembly internal (cenv, ccu: CcuThunk) = member __.CodeLocation = ccu.SourceCodeDirectory member __.FileName = ccu.FileName member __.SimpleName = ccu.AssemblyName - #if EXTENSIONTYPING +#if EXTENSIONTYPING member __.IsProviderGenerated = ccu.IsProviderGenerated - #endif +#endif member __.Contents = FSharpAssemblySignature(cenv, ccu) override x.ToString() = x.QualifiedName diff --git a/src/fsharp/vs/Symbols.fsi b/src/fsharp/vs/Symbols.fsi index 9633104288..e06e73758e 100644 --- a/src/fsharp/vs/Symbols.fsi +++ b/src/fsharp/vs/Symbols.fsi @@ -857,8 +857,10 @@ and [] FSharpActivePatternGroup = and [] FSharpType = /// Internal use only. Create a ground type. - internal new : g:TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * typ:TType -> FSharpType internal new : Impl.cenv * typ:TType -> FSharpType +#if !FABLE_COMPILER + internal new : g:TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * typ:TType -> FSharpType +#endif /// Indicates this is a named type in an unresolved assembly member IsUnresolved : bool diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 4bf5535e44..de69e76002 100755 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -549,8 +549,7 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = for (i,case) in cases do dict.[i] <- case let failLab = cg.GenerateDelayMark () let emitCase i _ = - let mutable res = Unchecked.defaultof<_> - let ok = dict.TryGetValue(i, &res) + let ok, res = dict.TryGetValue(i) if ok then res else cg.CodeLabel failLab let dests = Array.mapi emitCase cuspec.AlternativesArray diff --git a/src/utils/HashMultiMap.fs b/src/utils/HashMultiMap.fs index 90197b1d20..2c84afdbdb 100755 --- a/src/utils/HashMultiMap.fs +++ b/src/utils/HashMultiMap.fs @@ -12,20 +12,20 @@ open Microsoft.FSharp.Collections type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) = let firstEntries = Dictionary<_,_>(n,hasheq) let rest = Dictionary<_,_>(3,hasheq) - +#if FABLE_COMPILER + new (n, hasheq, _) = HashMultiMap<'Key,'Value>(n, hasheq) +#else new (hasheq : IEqualityComparer<'Key>) = HashMultiMap<'Key,'Value>(11, hasheq) new (seq : seq<'Key * 'Value>, hasheq : IEqualityComparer<'Key>) as x = new HashMultiMap<'Key,'Value>(11, hasheq) then seq |> Seq.iter (fun (k,v) -> x.Add(k,v)) - +#endif member x.GetRest(k) = - let mutable res = [] - let ok = rest.TryGetValue(k,&res) + let ok, res = rest.TryGetValue(k) if ok then res else [] member x.Add(y,z) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then rest.[y] <- res :: x.GetRest(y) firstEntries.[y] <- z @@ -37,7 +37,7 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.FirstEntries = firstEntries member x.Rest = rest member x.Copy() = - let res = HashMultiMap<'Key,'Value>(firstEntries.Count,firstEntries.Comparer) + let res = HashMultiMap<'Key,'Value>(firstEntries.Count, hasheq) for kvp in firstEntries do res.FirstEntries.Add(kvp.Key,kvp.Value) @@ -47,15 +47,13 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Item with get(y : 'Key) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then res else raise (KeyNotFoundException("The item was not found in collection")) and set (y:'Key) (z:'Value) = x.Replace(y,z) member x.FindAll(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then res :: x.GetRest(y) else [] member x.Fold f acc = @@ -83,13 +81,11 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.ContainsKey(y) = firstEntries.ContainsKey(y) member x.Remove(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, _ = firstEntries.TryGetValue(y) // NOTE: If not ok then nothing to remove - nop if ok then // We drop the FirstEntry. Here we compute the new FirstEntry and residue MoreEntries - let mutable res = [] - let ok = rest.TryGetValue(y,&res) + let ok, res = rest.TryGetValue(y) if ok then match res with | [h] -> @@ -107,12 +103,25 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) firstEntries.[y] <- z member x.TryFind(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then Some(res) else None member x.Count = firstEntries.Count +#if FABLE_COMPILER + interface System.Collections.IEnumerable with + member s.GetEnumerator() = ((s :> IEnumerable>).GetEnumerator() :> System.Collections.IEnumerator) + + interface IEnumerable> with + member s.GetEnumerator() = + let elems = seq { + for kvp in firstEntries do + yield kvp + for z in s.GetRest(kvp.Key) do + yield KeyValuePair(kvp.Key, z) + } + elems.GetEnumerator() +#else interface IEnumerable> with member s.GetEnumerator() = let elems = List<_>(firstEntries.Count + rest.Count) @@ -138,6 +147,7 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member s.Remove(k:'Key) = let res = s.ContainsKey(k) in s.Remove(k); res +#endif interface ICollection> with member s.Add(x) = s.[x.Key] <- x.Value diff --git a/src/utils/HashMultiMap.fsi b/src/utils/HashMultiMap.fsi index c08edd73ff..4020fc1263 100755 --- a/src/utils/HashMultiMap.fsi +++ b/src/utils/HashMultiMap.fsi @@ -10,16 +10,17 @@ open System.Collections.Generic /// The table may map a single key to multiple bindings. [] type internal HashMultiMap<'Key,'Value> = - /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. - new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> - /// Create a new empty mutable HashMultiMap with an internal bucket array of the given approximate size /// and with the given key hash/equality functions. new : size:int * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> + +#if !FABLE_COMPILER + /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. + new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> /// Build a map that contains the bindings of the given IEnumerable. new : entries:seq<'Key * 'Value> * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> - +#endif /// Make a shallow copy of the collection. member Copy : unit -> HashMultiMap<'Key,'Value> @@ -58,7 +59,9 @@ type internal HashMultiMap<'Key,'Value> = /// Apply the given function to each binding in the hash table. member Iterate : ('Key -> 'Value -> unit) -> unit - interface IDictionary<'Key, 'Value> +#if !FABLE_COMPILER + interface IDictionary<'Key, 'Value> +#endif interface ICollection> interface IEnumerable> interface System.Collections.IEnumerable diff --git a/src/utils/ResizeArray.fs b/src/utils/ResizeArray.fs index cc392e92c0..29bc7423e6 100755 --- a/src/utils/ResizeArray.fs +++ b/src/utils/ResizeArray.fs @@ -69,17 +69,29 @@ module internal ResizeArray = res let mapi f (arr: ResizeArray<_>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif let len = length arr let res = new ResizeArray<_>(len) for i = 0 to len - 1 do +#if FABLE_COMPILER + res.Add(f i arr.[i]) +#else res.Add(f.Invoke(i, arr.[i])) +#endif res let iteri f (arr: ResizeArray<_>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif for i = 0 to arr.Count - 1 do +#if FABLE_COMPILER + f i arr.[i] +#else f.Invoke(i, arr.[i]) +#endif let exists (f: 'T -> bool) (arr: ResizeArray<'T>) = let len = length arr @@ -116,19 +128,31 @@ module internal ResizeArray = loop 0 let iter2 f (arr1: ResizeArray<'T>) (arr2: ResizeArray<'b>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif let len1 = length arr1 if len1 <> length arr2 then invalidArg "arr2" "the arrays have different lengths" for i = 0 to len1 - 1 do +#if FABLE_COMPILER + f arr1.[i] arr2.[i] +#else f.Invoke(arr1.[i], arr2.[i]) +#endif let map2 f (arr1: ResizeArray<'T>) (arr2: ResizeArray<'b>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif let len1 = length arr1 if len1 <> length arr2 then invalidArg "arr2" "the arrays have different lengths" let res = new ResizeArray<_>(len1) for i = 0 to len1 - 1 do +#if FABLE_COMPILER + res.Add(f arr1.[i] arr2.[i]) +#else res.Add(f.Invoke(arr1.[i], arr2.[i])) +#endif res let choose f (arr: ResizeArray<_>) = @@ -220,21 +244,33 @@ module internal ResizeArray = else foldBackSub f arr 0 (arrn - 2) arr.[arrn - 1] let fold2 f (acc: 'T) (arr1: ResizeArray<'T1>) (arr2: ResizeArray<'T2>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_,_>.Adapt(f) +#endif let mutable res = acc let len = length arr1 if len <> length arr2 then invalidArg "arr2" "the arrays have different lengths" for i = 0 to len - 1 do +#if FABLE_COMPILER + res <- (f res arr1.[i] arr2.[i]) +#else res <- f.Invoke(res,arr1.[i],arr2.[i]) +#endif res let foldBack2 f (arr1: ResizeArray<'T1>) (arr2: ResizeArray<'T2>) (acc: 'b) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_,_>.Adapt(f) +#endif let mutable res = acc let len = length arr1 if len <> length arr2 then invalidArg "arr2" "the arrays have different lengths" for i = len - 1 downto 0 do +#if FABLE_COMPILER + res <- (f arr1.[i] arr2.[i] res) +#else res <- f.Invoke(arr1.[i],arr2.[i],res) +#endif res let forall2 f (arr1: ResizeArray<_>) (arr2: ResizeArray<_>) = @@ -246,33 +282,57 @@ module internal ResizeArray = let isEmpty (arr: ResizeArray<_>) = length (arr: ResizeArray<_>) = 0 let iteri2 f (arr1: ResizeArray<'T>) (arr2: ResizeArray<'b>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_,_>.Adapt(f) +#endif let len1 = length arr1 if len1 <> length arr2 then invalidArg "arr2" "the arrays have different lengths" for i = 0 to len1 - 1 do +#if FABLE_COMPILER + f i arr1.[i] arr2.[i] +#else f.Invoke(i,arr1.[i], arr2.[i]) +#endif let mapi2 (f: int -> 'T -> 'b -> 'c) (arr1: ResizeArray<'T>) (arr2: ResizeArray<'b>) = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_,_>.Adapt(f) +#endif let len1 = length arr1 if len1 <> length arr2 then invalidArg "arr2" "the arrays have different lengths" +#if FABLE_COMPILER + init len1 (fun i -> (f i arr1.[i] arr2.[i])) +#else init len1 (fun i -> f.Invoke(i, arr1.[i], arr2.[i])) +#endif let scanBackSub f (arr: ResizeArray<'T>) start fin acc = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif let mutable state = acc let res = create (2+fin-start) acc for i = fin downto start do +#if FABLE_COMPILER + state <- (f arr.[i] state) +#else state <- f.Invoke(arr.[i], state) +#endif res.[i - start] <- state res let scanSub f acc (arr : ResizeArray<'T>) start fin = +#if !FABLE_COMPILER let f = FSharpFunc<_,_,_>.Adapt(f) +#endif let mutable state = acc let res = create (fin-start+2) acc for i = start to fin do +#if FABLE_COMPILER + state <- (f state arr.[i]) +#else state <- f.Invoke(state, arr.[i]) +#endif res.[i - start+1] <- state res diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 60a2e0bab9..d9c3f2a2b9 100755 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -6,13 +6,13 @@ namespace Internal.Utilities.Collections.Tagged #nowarn "69" // interface implementations in augmentations #nowarn "60" // override implementations in augmentations + open Internal.Utilities + open Internal.Utilities.Collections open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open System open System.Collections.Generic - open Internal.Utilities - open Internal.Utilities.Collections [] diff --git a/src/utils/filename.fs b/src/utils/filename.fs index 6d76e518dd..d197741442 100755 --- a/src/utils/filename.fs +++ b/src/utils/filename.fs @@ -2,6 +2,9 @@ module internal Internal.Utilities.Filename +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.IO open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -12,7 +15,11 @@ exception IllegalFileNameChar of string * char /// a new array each time it's called (by necessity, for security reasons). /// This is only used within `checkPathForIllegalChars`, and is only read from. let illegalPathChars = +#if FABLE_COMPILER + let chars = Seq.toArray "<>|\"\b\0\t" //TODO: more +#else let chars = Path.GetInvalidPathChars () +#endif chars type private PathState = @@ -45,30 +52,50 @@ let hasExtension (s:string) = checkPathForIllegalChars s let sLen = s.Length (sLen >= 1 && s.[sLen - 1] = '.' && s <> ".." && s <> ".") +#if FABLE_COMPILER + //TODO: proper implementation +#else || Path.HasExtension(s) +#endif let chopExtension (s:string) = checkPathForIllegalChars s if s = "." then "" else // for OCaml compatibility if not (hasExtension s) then raise (System.ArgumentException("chopExtension")) // message has to be precisely this, for OCaml compatibility, and no argument name can be set +#if FABLE_COMPILER + s //TODO: proper implementation +#else Path.Combine (Path.GetDirectoryName s,Path.GetFileNameWithoutExtension(s)) +#endif let directoryName (s:string) = checkPathForIllegalChars s if s = "" then "." else - match Path.GetDirectoryName(s) with - | null -> if FileSystem.IsPathRootedShim(s) then s else "." - | res -> if res = "" then "." else res +#if FABLE_COMPILER + s //TODO: proper implementation +#else + match Path.GetDirectoryName(s) with + | null -> if FileSystem.IsPathRootedShim(s) then s else "." + | res -> if res = "" then "." else res +#endif let fileNameOfPath s = checkPathForIllegalChars s +#if FABLE_COMPILER + s //TODO: proper implementation +#else Path.GetFileName(s) +#endif let fileNameWithoutExtension s = checkPathForIllegalChars s +#if FABLE_COMPILER + s //TODO: proper implementation +#else Path.GetFileNameWithoutExtension(s) +#endif let trimQuotes (s:string) = s.Trim( [|' '; '\"'|] ) diff --git a/src/utils/prim-lexing.fs b/src/utils/prim-lexing.fs index eb5e932846..a6ab70d5be 100755 --- a/src/utils/prim-lexing.fs +++ b/src/utils/prim-lexing.fs @@ -5,6 +5,9 @@ namespace Internal.Utilities.Text.Lexing +#if FABLE_COMPILER + open Internal.Utilities +#endif open Microsoft.FSharp.Core open Microsoft.FSharp.Collections open System.Collections.Generic @@ -165,7 +168,7 @@ namespace Internal.Utilities.Text.Lexing static member FromChars (arr:char[]) = LexBuffer.FromArray arr - module GenericImplFragments = + module internal GenericImplFragments = let startInterpret(lexBuffer:LexBuffer)= lexBuffer.BufferScanStart <- lexBuffer.BufferScanStart + lexBuffer.LexemeLength; lexBuffer.BufferMaxScanLength <- lexBuffer.BufferMaxScanLength - lexBuffer.LexemeLength; diff --git a/src/utils/prim-parsing.fs b/src/utils/prim-parsing.fs index 3db27bb503..6504b67b69 100755 --- a/src/utils/prim-parsing.fs +++ b/src/utils/prim-parsing.fs @@ -79,6 +79,9 @@ type Stack<'a>(n) = let mutable contents = Array.zeroCreate<'a>(n) let mutable count = 0 +#if FABLE_COMPILER + new (n, _) = Stack<'a>(n) +#endif member buf.Ensure newSize = let oldSize = contents.Length if newSize > oldSize then @@ -87,7 +90,7 @@ type Stack<'a>(n) = Array.blit old 0 contents 0 count member buf.Count = count - member buf.Pop() = count <- count - 1 + member buf.Pop() = count <- count - 1; contents.[count] member buf.Peep() = contents.[count - 1] member buf.Top(n) = [ for x in contents.[max 0 (count-n)..count - 1] -> x ] |> List.rev member buf.Push(x) = @@ -96,10 +99,11 @@ type Stack<'a>(n) = count <- count + 1 member buf.IsEmpty = (count = 0) +#if DEBUG member buf.PrintStack() = for i = 0 to (count - 1) do System.Console.Write("{0}{1}",(contents.[i]),if i=count-1 then ":" else "-") - +#endif #if DEBUG module Flags = @@ -156,8 +160,7 @@ module internal Implementation = assert (keyToFind < 0x10000) let cacheKey = (rowNumber <<< 16) ||| keyToFind #if OLD_CACHE - let mutable res = 0 - let ok = cache.TryGetValue(cacheKey, &res) + let ok, res = cache.TryGetValue(cacheKey) if ok then res else #else @@ -298,8 +301,8 @@ module internal Implementation = if Flags.debug then System.Console.WriteLine("popping stack during error recovery"); #endif - valueStack.Pop(); - stateStack.Pop(); + valueStack.Pop() |> ignore; + stateStack.Pop() |> ignore; popStackUntilErrorShifted(tokenOpt) while not finished do @@ -368,8 +371,8 @@ module internal Implementation = for i = 0 to n - 1 do if valueStack.IsEmpty then failwith "empty symbol stack"; let topVal = valueStack.Peep() - valueStack.Pop(); - stateStack.Pop(); + valueStack.Pop() |> ignore; + stateStack.Pop() |> ignore; ruleValues.[(n-i)-1] <- topVal.value; ruleStartPoss.[(n-i)-1] <- topVal.startPos; ruleEndPoss.[(n-i)-1] <- topVal.endPos; diff --git a/src/utils/prim-parsing.fsi b/src/utils/prim-parsing.fsi index 36c32ff4e3..0e375b1f41 100755 --- a/src/utils/prim-parsing.fsi +++ b/src/utils/prim-parsing.fsi @@ -4,7 +4,18 @@ namespace Internal.Utilities.Text.Parsing open Internal.Utilities open Internal.Utilities.Text.Lexing +#if FABLE_COMPILER +type Stack<'T> = + new : int -> Stack<'T> + member Count : int + member Pop : unit -> 'T + member Peep : unit -> 'T + member Top : int -> 'T list + member Push : 'T -> unit + member IsEmpty : bool +#else open System.Collections.Generic +#endif [] type internal IParseState =