From e063dd2a7005faf953619ab4f232d1e3606c7ed2 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 11 May 2022 22:46:14 +0100 Subject: [PATCH] More cleanup (#13123) * fix merge problem * fix merge problem * more cleanup * more cleanup * improve CheckExpressions * format * fix build * remove ModuleOrNamespaceExprWithSig and put it in CheckedImplFile * format * cleanup the cleanup --- .vscode/settings.json | 3 +- DEVGUIDE.md | 2 +- release-notes.md | 2 + src/Compiler/AbstractIL/il.fs | 12 +- src/Compiler/AbstractIL/ilmorph.fs | 2 +- src/Compiler/AbstractIL/ilread.fs | 12 +- .../Checking/CheckComputationExpressions.fs | 44 +- src/Compiler/Checking/CheckDeclarations.fs | 446 +-- src/Compiler/Checking/CheckDeclarations.fsi | 5 +- src/Compiler/Checking/CheckExpressions.fs | 2700 +++++++++-------- src/Compiler/Checking/CheckExpressions.fsi | 111 +- src/Compiler/Checking/CheckFormatStrings.fs | 79 +- src/Compiler/Checking/ConstraintSolver.fs | 462 +-- src/Compiler/Checking/ConstraintSolver.fsi | 31 +- src/Compiler/Checking/FindUnsolved.fs | 11 +- src/Compiler/Checking/FindUnsolved.fsi | 3 +- src/Compiler/Checking/InfoReader.fs | 2 +- src/Compiler/Checking/MethodCalls.fs | 32 +- src/Compiler/Checking/MethodCalls.fsi | 6 +- src/Compiler/Checking/MethodOverrides.fs | 89 +- src/Compiler/Checking/MethodOverrides.fsi | 42 +- src/Compiler/Checking/NameResolution.fs | 51 +- src/Compiler/Checking/NameResolution.fsi | 25 +- src/Compiler/Checking/NicePrint.fs | 38 +- src/Compiler/Checking/NicePrint.fsi | 26 +- .../Checking/PatternMatchCompilation.fs | 126 +- .../Checking/PatternMatchCompilation.fsi | 6 +- src/Compiler/Checking/PostInferenceChecks.fs | 19 +- src/Compiler/Checking/PostInferenceChecks.fsi | 5 +- src/Compiler/Checking/QuotationTranslator.fs | 71 +- src/Compiler/Checking/SignatureConformance.fs | 4 +- src/Compiler/Checking/TypeHierarchy.fs | 18 +- src/Compiler/Checking/TypeHierarchy.fsi | 12 +- src/Compiler/Checking/import.fs | 10 +- src/Compiler/Checking/import.fsi | 4 +- src/Compiler/Checking/infos.fs | 20 +- src/Compiler/Checking/infos.fsi | 22 +- src/Compiler/CodeGen/EraseUnions.fs | 2 +- src/Compiler/CodeGen/IlxGen.fs | 690 ++--- src/Compiler/CodeGen/IlxGen.fsi | 4 +- src/Compiler/Driver/BuildGraph.fs | 36 +- src/Compiler/Driver/CompilerDiagnostics.fs | 116 +- src/Compiler/Driver/CompilerDiagnostics.fsi | 9 +- src/Compiler/Driver/CompilerImports.fs | 20 +- src/Compiler/Driver/CompilerOptions.fs | 1 + src/Compiler/Driver/OptimizeInputs.fs | 20 +- src/Compiler/Driver/OptimizeInputs.fsi | 14 +- src/Compiler/Driver/ParseAndCheckInputs.fs | 57 +- src/Compiler/Driver/ParseAndCheckInputs.fsi | 20 +- src/Compiler/Driver/ScriptClosure.fs | 30 +- src/Compiler/Driver/fsc.fs | 137 +- src/Compiler/Driver/fsc.fsi | 6 +- src/Compiler/FSharp.Compiler.Service.fsproj | 36 +- .../{Diagnostics.fs => DiagnosticOptions.fs} | 0 ...{Diagnostics.fsi => DiagnosticOptions.fsi} | 0 ...nHints.fs => DiagnosticResolutionHints.fs} | 4 +- ...ints.fsi => DiagnosticResolutionHints.fsi} | 2 +- src/Compiler/Facilities/DiagnosticsLogger.fs | 133 +- src/Compiler/Facilities/DiagnosticsLogger.fsi | 90 +- src/Compiler/Facilities/LanguageFeatures.fsi | 4 +- src/Compiler/Facilities/prim-lexing.fs | 2 +- src/Compiler/Facilities/prim-parsing.fs | 85 +- src/Compiler/Facilities/prim-parsing.fsi | 16 +- src/Compiler/Interactive/fsi.fs | 304 +- src/Compiler/Interactive/fsi.fsi | 2 +- src/Compiler/Optimize/DetupleArgs.fsi | 4 +- .../Optimize/InnerLambdasToTopLevelFuncs.fs | 33 +- .../Optimize/InnerLambdasToTopLevelFuncs.fsi | 2 +- src/Compiler/Optimize/LowerCalls.fsi | 2 +- .../Optimize/LowerComputedCollections.fs | 8 +- src/Compiler/Optimize/LowerLocalMutables.fsi | 2 +- src/Compiler/Optimize/LowerSequences.fs | 4 +- src/Compiler/Optimize/LowerStateMachines.fs | 14 +- src/Compiler/Optimize/Optimizer.fs | 86 +- src/Compiler/Optimize/Optimizer.fsi | 4 +- src/Compiler/Service/FSharpCheckerResults.fs | 128 +- src/Compiler/Service/FSharpCheckerResults.fsi | 10 +- src/Compiler/Service/IncrementalBuild.fs | 58 +- src/Compiler/Service/IncrementalBuild.fsi | 12 +- src/Compiler/Service/ItemKey.fs | 4 +- .../Service/ServiceCompilerDiagnostics.fs | 2 +- .../Service/ServiceDeclarationLists.fs | 42 +- src/Compiler/Service/ServiceLexing.fs | 52 +- src/Compiler/Service/service.fs | 24 +- src/Compiler/Symbols/Exprs.fs | 14 +- src/Compiler/Symbols/Exprs.fsi | 4 +- src/Compiler/Symbols/FSharpDiagnostic.fs | 111 +- src/Compiler/Symbols/FSharpDiagnostic.fsi | 8 +- src/Compiler/Symbols/SymbolHelpers.fs | 22 +- src/Compiler/Symbols/SymbolHelpers.fsi | 2 +- src/Compiler/Symbols/Symbols.fs | 12 +- src/Compiler/SyntaxTree/LexFilter.fs | 16 +- src/Compiler/SyntaxTree/LexFilter.fsi | 4 +- src/Compiler/SyntaxTree/LexHelpers.fs | 10 +- src/Compiler/SyntaxTree/LexHelpers.fsi | 8 +- src/Compiler/SyntaxTree/SyntaxTree.fs | 2 +- src/Compiler/SyntaxTree/SyntaxTree.fsi | 2 +- src/Compiler/TypedTree/QuotationPickler.fs | 38 +- src/Compiler/TypedTree/QuotationPickler.fsi | 29 +- src/Compiler/TypedTree/TcGlobals.fs | 105 +- src/Compiler/TypedTree/TypeProviders.fsi | 152 + src/Compiler/TypedTree/TypedTree.fs | 88 +- src/Compiler/TypedTree/TypedTreeBasics.fs | 14 - src/Compiler/TypedTree/TypedTreeBasics.fsi | 11 - src/Compiler/TypedTree/TypedTreeOps.fs | 160 +- src/Compiler/TypedTree/TypedTreeOps.fsi | 87 +- src/Compiler/TypedTree/TypedTreePickle.fs | 6 +- src/Compiler/Utilities/EditDistance.fs | 2 +- src/Compiler/Utilities/EditDistance.fsi | 2 +- src/Compiler/Utilities/lib.fs | 2 +- src/Compiler/Utilities/lib.fsi | 2 +- src/Compiler/lex.fsl | 10 +- src/Compiler/pars.fsy | 8 +- src/Compiler/pplex.fsl | 2 +- src/FSharp.Core/Linq.fs | 2 +- src/FSharp.Core/Query.fs | 31 +- src/FSharp.Core/QueryExtensions.fs | 2 +- src/FSharp.Core/quotations.fs | 9 +- ...erService.SurfaceArea.netstandard.expected | 12 +- .../FSharp.Compiler.UnitTests/EditDistance.fs | 2 +- .../HashIfExpression.fs | 12 +- .../SuggestionBuffer.fs | 2 +- .../CompilerServiceBenchmarks/Benchmarks.fs | 4 +- tests/service/data/TestTP/ProvidedTypes.fs | 18 +- .../Diagnostics/DocumentDiagnosticAnalyzer.fs | 22 +- .../ProvidedTypes.fs | 18 +- 126 files changed, 4290 insertions(+), 3661 deletions(-) rename src/Compiler/Facilities/{Diagnostics.fs => DiagnosticOptions.fs} (100%) rename src/Compiler/Facilities/{Diagnostics.fsi => DiagnosticOptions.fsi} (100%) rename src/Compiler/Facilities/{ErrorResolutionHints.fs => DiagnosticResolutionHints.fs} (96%) rename src/Compiler/Facilities/{ErrorResolutionHints.fsi => DiagnosticResolutionHints.fsi} (92%) diff --git a/.vscode/settings.json b/.vscode/settings.json index d27047ae420..c3d00d8284e 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -45,5 +45,6 @@ "MD025": { "front_matter_title": "" } - } + }, + "editor.inlayHints.enabled": "offUnlessPressed" } \ No newline at end of file diff --git a/DEVGUIDE.md b/DEVGUIDE.md index bf20dd41a00..9e0fbb2cd3f 100644 --- a/DEVGUIDE.md +++ b/DEVGUIDE.md @@ -290,7 +290,7 @@ Existing compiler benchmarks can be found in `tests\benchmarks\`. { SourceFiles = [|"CheckExpressions.fs"|] ConditionalDefines = [] - ErrorSeverityOptions = FSharpDiagnosticOptions.Default + DiagnosticOptions = FSharpDiagnosticOptions.Default LangVersionText = "default" IsInteractive = false LightSyntax = None diff --git a/release-notes.md b/release-notes.md index 28f788b806a..4ff32eb62ae 100644 --- a/release-notes.md +++ b/release-notes.md @@ -25,6 +25,8 @@ These release notes track our current efforts to document changes to the F# proj A 'do expr' declaration in a module will correspond to a SynModuleDecl.Expr enclosing a SynExpr.Do This constructo also loses the debug point as it was always None. The debug point is always implicit for this construct. +* In FCS API, FSharpParsingOptions, `CompilingFsLib` --> `CompilingFSharpCore` +* In FCS API, FSharpParsingOptions, `ErrorSeverityOptions` --> `DiagnosticOptions` ### F# 6.0 / Visual Studio 17.0 diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index a972c7cd4b1..0ba00344546 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -4019,7 +4019,7 @@ type ILTypeSigParser (tstring : string) = | None -> [] | Some genericArgs -> genericArgs let tspec = ILTypeSpec.Create (tref, genericArgs) - let ilty = + let ilTy = match tspec.Name with | "System.SByte" | "System.Byte" @@ -4037,13 +4037,13 @@ type ILTypeSigParser (tstring : string) = // if it's an array, wrap it - otherwise, just return the IL type match rank with - | Some r -> ILType.Array (r, ilty) - | _ -> ilty + | Some r -> ILType.Array (r, ilTy) + | _ -> ilTy member x.ParseTypeSpec() = reset() - let ilty = x.ParseType() - ILAttribElem.Type (Some ilty) + let ilTy = x.ParseType() + ILAttribElem.Type (Some ilTy) let decodeILAttribData (ca: ILAttribute) = match ca with @@ -4328,7 +4328,7 @@ and refsOfILCode s (c: ILCode) = for exnClause in c.Exceptions do match exnClause.Clause with - | ILExceptionClause.TypeCatch (ilty, _) -> refsOfILType s ilty + | ILExceptionClause.TypeCatch (ilTy, _) -> refsOfILType s ilTy | _ -> () and refsOfILMethodBody s (il: ILMethodBody) = diff --git a/src/Compiler/AbstractIL/ilmorph.fs b/src/Compiler/AbstractIL/ilmorph.fs index 9ddcdf7df89..6d50df04c5b 100644 --- a/src/Compiler/AbstractIL/ilmorph.fs +++ b/src/Compiler/AbstractIL/ilmorph.fs @@ -45,7 +45,7 @@ let code_instr2instr_ty2ty (finstr,fTy) (code: ILCode) = [ for exnSpec in codeR.Exceptions do let clause = match exnSpec.Clause with - | ILExceptionClause.TypeCatch (ilty, b) -> ILExceptionClause.TypeCatch (fTy ilty, b) + | ILExceptionClause.TypeCatch (ilTy, b) -> ILExceptionClause.TypeCatch (fTy ilTy, b) | cl -> cl { exnSpec with Clause = clause } ] { codeR with Exceptions = exnSpecsR } diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index 32ad2e8ca88..9446bd09ad8 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -3678,13 +3678,13 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) = (* PE SIGNATURE *) let machine = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 0) let numSections = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 2) - let optHeaderSize = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 16) - if optHeaderSize <> 0xe0 && - optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size" - let x64adjust = optHeaderSize - 0xe0 - let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) + let headerSizeOpt = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 16) + if headerSizeOpt <> 0xe0 && + headerSizeOpt <> 0xf0 then failwith "not a PE file - bad optional header size" + let x64adjust = headerSizeOpt - 0xe0 + let only64 = (headerSizeOpt = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) let platform = match machine with | 0x8664 -> Some AMD64 | 0x200 -> Some IA64 | _ -> Some X86 - let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize + let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + headerSizeOpt let flags = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 18) let isDll = (flags &&& 0x2000) <> 0x0 diff --git a/src/Compiler/Checking/CheckComputationExpressions.fs b/src/Compiler/Checking/CheckComputationExpressions.fs index e27825992d9..4792a818dbb 100644 --- a/src/Compiler/Checking/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/CheckComputationExpressions.fs @@ -662,22 +662,22 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let (|OptionalIntoSuffix|) e = match e with - | IntoSuffix (body, intoWordRange, optInfo) -> (body, Some (intoWordRange, optInfo)) + | IntoSuffix (body, intoWordRange, intoInfo) -> (body, Some (intoWordRange, intoInfo)) | body -> (body, None) let (|CustomOperationClause|_|) e = match e with - | OptionalIntoSuffix(StripApps(SingleIdent nm, _) as core, optInto) when isCustomOperation nm -> + | OptionalIntoSuffix(StripApps(SingleIdent nm, _) as core, intoOpt) when isCustomOperation nm -> // Now we know we have a custom operation, commit the name resolution - let optIntoInfo = - match optInto with - | Some (intoWordRange, optInfo) -> + let intoInfoOpt = + match intoOpt with + | Some (intoWordRange, intoInfo) -> let item = Item.CustomOperation ("into", (fun () -> None), None) CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - Some optInfo + Some intoInfo | None -> None - Some (nm, Option.get (tryGetDataForCustomOperation nm), core, core.Range, optIntoInfo) + Some (nm, Option.get (tryGetDataForCustomOperation nm), core, core.Range, intoInfoOpt) | _ -> None let mkSynLambda p e m = SynExpr.Lambda (false, false, p, e, None, m, SynExprLambdaTrivia.Zero) @@ -806,13 +806,13 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpaceWithFirstVars = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (firstSourcePat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv firstSourcePat None vspecs, envinner) let varSpaceWithSecondVars = addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (secondSourcePat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv secondSourcePat None vspecs, envinner) let varSpaceWithGroupJoinVars = @@ -820,7 +820,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol | Some pat3 -> addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (pat3, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat3 None vspecs, envinner) | None -> varSpace @@ -971,7 +971,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpace = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (pat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None vspecs, envinner) Some (trans CompExprTranslationPass.Initial q varSpace innerComp @@ -1191,7 +1191,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol | [NormalizedBinding(_vis, SynBindingKind.Normal, false, false, _, _, _, _, pat, _, _, _)] -> // successful case use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (pat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None vspecs, envinner | _ -> // error case @@ -1224,7 +1224,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpace = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (pat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None vspecs, envinner) let rhsExpr = mkSourceExprConditional isFromSource rhsExpr @@ -1290,7 +1290,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpace = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (consumePat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None vspecs, envinner) Some (transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) @@ -1306,7 +1306,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpace = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (consumePat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None vspecs, envinner) Some (transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) @@ -1364,7 +1364,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpace = addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv (consumePat, None) + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None vspecs, envinner) // Build the 'Bind' call @@ -1845,7 +1845,7 @@ let mkSeqFinally (cenv: cenv) env m genTy e1 e2 = mkCallSeqFinally cenv.g m genResultTy e1 e2 let mkSeqExprMatchClauses (pat, vspecs) innerExpr = - [TClause(pat, None, TTarget(vspecs, innerExpr, None), pat.Range) ] + [MatchClause(pat, None, TTarget(vspecs, innerExpr, None), pat.Range) ] let compileSeqExprMatchClauses (cenv: cenv) env inputExprMark (pat: Pattern, vspecs) innerExpr inputExprOpt bindPatTy genInnerTy = let patMark = pat.Range @@ -1888,7 +1888,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = // This expression is not checked with the knowledge it is an IEnumerable, since we permit other enumerable types with GetEnumerator/MoveNext methods, as does C# let pseudoEnumExpr, arbitraryTy, tpenv = TcExprOfUnknownType cenv env tpenv pseudoEnumExpr let enumExpr, enumElemTy = ConvertArbitraryExprToEnumerable cenv arbitraryTy env pseudoEnumExpr - let patR, _, vspecs, envinner, tpenv = TcMatchPattern cenv enumElemTy env tpenv (pat, None) + let patR, _, vspecs, envinner, tpenv = TcMatchPattern cenv enumElemTy env tpenv pat None let innerExpr, tpenv = let envinner = { envinner with eIsControlFlow = true } tcSequenceExprBody envinner genOuterTy tpenv innerComp @@ -1907,7 +1907,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = // "seq { .. for x in e1 do yield e2 .. }" == "e1 |> Seq.map (fun x -> e2)" // // This transformation is visible in quotations and thus needs to remain. - | (TPat_as (TPat_wild _, PBind (v, _), _), + | (TPat_as (TPat_wild _, PatternValBinding (v, _), _), [_], DebugPoints(Expr.App (Expr.Val (vf, _, _), _, [genEnumElemTy], [yieldExpr], _mYield), recreate)) when valRefEq cenv.g vf cenv.g.seq_singleton_vref -> @@ -2021,7 +2021,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let bindPatTy = NewInferenceType g let inputExprTy = NewInferenceType g - let pat', _, vspecs, envinner, tpenv = TcMatchPattern cenv bindPatTy env tpenv (pat, None) + let pat', _, vspecs, envinner, tpenv = TcMatchPattern cenv bindPatTy env tpenv pat None UnifyTypes cenv env m inputExprTy bindPatTy @@ -2055,13 +2055,13 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let tclauses, tpenv = (tpenv, clauses) ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, _, sp, _)) -> - let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv (pat, cond) + let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv pat cond let envinner = match sp with | DebugPointAtTarget.Yes -> { envinner with eIsControlFlow = true } | DebugPointAtTarget.No -> envinner let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp - TClause(patR, condR, TTarget(vspecs, innerExpr, None), patR.Range), tpenv) + MatchClause(patR, condR, TTarget(vspecs, innerExpr, None), patR.Range), tpenv) let inputExprTy = tyOfExpr cenv.g inputExpr let inputExprMark = inputExpr.Range diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index bebef739d09..25ef10fedf7 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -229,15 +229,15 @@ let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = env /// Add a "module X = ..." definition to the TcEnv -let AddLocalSubModule g amap m env (modul: ModuleOrNamespace) = +let AddLocalSubModule g amap m env (moduleEntity: ModuleOrNamespace) = let env = { env with - eNameResEnv = AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights env.eNameResEnv (mkLocalModuleRef modul) - eUngeneralizableItems = addFreeItemOfModuleTy modul.ModuleOrNamespaceType env.eUngeneralizableItems } + eNameResEnv = AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights env.eNameResEnv (mkLocalModuleRef moduleEntity) + eUngeneralizableItems = addFreeItemOfModuleTy moduleEntity.ModuleOrNamespaceType env.eUngeneralizableItems } env /// Add a "module X = ..." definition to the TcEnv and report it to the sink -let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul: ModuleOrNamespace) = - let env = AddLocalSubModule g amap m env modul +let AddLocalSubModuleAndReport tcSink scopem g amap m env (moduleEntity: ModuleOrNamespace) = + let env = AddLocalSubModule g amap m env moduleEntity if not (equals scopem m) then // Don't report another environment for top-level module at its own range, // so it doesn't overwrite inner environment used by features like code completion. @@ -245,17 +245,17 @@ let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul: ModuleOrNamesp env /// Given an inferred module type, place that inside a namespace path implied by a "namespace X.Y.Z" definition -let BuildRootModuleType enclosingNamespacePath (cpath: CompilationPath) modTy = - (enclosingNamespacePath, (cpath, (modTy, []))) - ||> List.foldBack (fun id (cpath, (modTy, moduls)) -> - let a, b = wrapModuleOrNamespaceTypeInNamespace id cpath.ParentCompPath modTy +let BuildRootModuleType enclosingNamespacePath (cpath: CompilationPath) moduleTy = + (enclosingNamespacePath, (cpath, (moduleTy, []))) + ||> List.foldBack (fun id (cpath, (moduleTy, moduls)) -> + let a, b = wrapModuleOrNamespaceTypeInNamespace id cpath.ParentCompPath moduleTy cpath.ParentCompPath, (a, b :: moduls)) - |> fun (_, (modTy, moduls)) -> modTy, List.rev moduls + |> fun (_, (moduleTy, moduls)) -> moduleTy, List.rev moduls /// Given a resulting module expression, place that inside a namespace path implied by a "namespace X.Y.Z" definition -let BuildRootModuleExpr enclosingNamespacePath (cpath: CompilationPath) mexpr = - (enclosingNamespacePath, (cpath, mexpr)) - ||> List.foldBack (fun id (cpath, mexpr) -> (cpath.ParentCompPath, wrapModuleOrNamespaceContentsInNamespace id cpath.ParentCompPath mexpr)) +let BuildRootModuleContents enclosingNamespacePath (cpath: CompilationPath) moduleContents = + (enclosingNamespacePath, (cpath, moduleContents)) + ||> List.foldBack (fun id (cpath, moduleContents) -> (cpath.ParentCompPath, wrapModuleOrNamespaceContentsInNamespace id cpath.ParentCompPath moduleContents)) |> snd /// Try to take the "FSINNN" prefix off a namespace path @@ -336,15 +336,15 @@ let AddNonLocalCcu g amap scopem env assemblyName (ccu: CcuThunk, internalsVisib env /// Adjust the TcEnv to account for a fully processed "namespace" declaration in this file -let AddLocalRootModuleOrNamespace tcSink g amap scopem env (modTy: ModuleOrNamespaceType) = +let AddLocalRootModuleOrNamespace tcSink g amap scopem env (moduleTy: ModuleOrNamespaceType) = // Compute the top-rooted module or namespace references - let modrefs = modTy.ModuleAndNamespaceDefinitions |> List.map mkLocalModuleRef + let modrefs = moduleTy.ModuleAndNamespaceDefinitions |> List.map mkLocalModuleRef // Compute the top-rooted type definitions - let tcrefs = modTy.TypeAndExceptionDefinitions |> List.map mkLocalTyconRef + let tcrefs = moduleTy.TypeAndExceptionDefinitions |> List.map mkLocalTyconRef let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs let env = { env with eNameResEnv = if isNil tcrefs then env.eNameResEnv else AddTyconRefsToNameEnv BulkAdd.No false g amap env.eAccessRights scopem true env.eNameResEnv tcrefs - eUngeneralizableItems = addFreeItemOfModuleTy modTy env.eUngeneralizableItems } + eUngeneralizableItems = addFreeItemOfModuleTy moduleTy env.eUngeneralizableItems } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env @@ -434,15 +434,15 @@ module TcRecdUnionAndEnumDeclarations = let TcAnonFieldDecl cenv env parent tpenv nm (SynField(Attributes attribs, isStatic, idOpt, ty, isMutable, xmldoc, vis, m)) = let id = (match idOpt with None -> mkSynId m nm | Some id -> id) - let doc = xmldoc.ToXmlDoc(true, Some []) - TcFieldDecl cenv env parent false tpenv (isStatic, attribs, id, idOpt.IsNone, ty, isMutable, doc, vis, m) + let xmlDoc = xmldoc.ToXmlDoc(true, Some []) + TcFieldDecl cenv env parent false tpenv (isStatic, attribs, id, idOpt.IsNone, ty, isMutable, xmlDoc, vis, m) let TcNamedFieldDecl cenv env parent isIncrClass tpenv (SynField(Attributes attribs, isStatic, id, ty, isMutable, xmldoc, vis, m)) = match id with | None -> error (Error(FSComp.SR.tcFieldRequiresName(), m)) | Some id -> - let doc = xmldoc.ToXmlDoc(true, Some []) - TcFieldDecl cenv env parent isIncrClass tpenv (isStatic, attribs, id, false, ty, isMutable, doc, vis, m) + let xmlDoc = xmldoc.ToXmlDoc(true, Some []) + TcFieldDecl cenv env parent isIncrClass tpenv (isStatic, attribs, id, false, ty, isMutable, xmlDoc, vis, m) let TcNamedFieldDecls cenv env parent isIncrClass tpenv fields = fields |> List.map (TcNamedFieldDecl cenv env parent isIncrClass tpenv) @@ -503,7 +503,7 @@ module TcRecdUnionAndEnumDeclarations = | SynUnionCaseKind.FullType (ty, arity) -> let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty - let curriedArgTys, recordTy = GetTopTauTypeInFSharpForm g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos tyR m + let curriedArgTys, recordTy = GetTopTauTypeInFSharpForm g (arity |> TranslateSynValInfo m (TcAttributes cenv env) |> TranslatePartialValReprInfo []).ArgInfos tyR m if curriedArgTys.Length > 1 then errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(), m)) @@ -521,8 +521,8 @@ module TcRecdUnionAndEnumDeclarations = rfields, recordTy let names = rfields |> List.map (fun f -> f.DisplayNameCore) - let doc = xmldoc.ToXmlDoc(true, Some names) - Construct.NewUnionCase id rfields recordTy attrs doc vis + let xmlDoc = xmldoc.ToXmlDoc(true, Some names) + Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis let TcUnionCaseDecls cenv env parent (thisTy: TType) thisTyInst tpenv unionCases = let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv) @@ -539,8 +539,8 @@ module TcRecdUnionAndEnumDeclarations = let vis, _ = ComputeAccessAndCompPath env None m None None parent let vis = CombineReprAccess parent vis if id.idText = "value__" then errorR(Error(FSComp.SR.tcNotValidEnumCaseName(), id.idRange)) - let doc = xmldoc.ToXmlDoc(true, Some []) - Construct.NewRecdField true (Some v) id false thisTy false false [] attrs doc vis false + let xmlDoc = xmldoc.ToXmlDoc(true, Some []) + Construct.NewRecdField true (Some v) id false thisTy false false [] attrs xmlDoc vis false let TcEnumDecls (cenv: cenv) env parent thisTy enumCases = let g = cenv.g @@ -552,36 +552,34 @@ module TcRecdUnionAndEnumDeclarations = // Bind elements of classes //------------------------------------------------------------------------- -let PublishInterface (cenv: cenv) denv (tcref: TyconRef) m compgen tyR = +let PublishInterface (cenv: cenv) denv (tcref: TyconRef) m isCompGen interfaceTy = let g = cenv.g - if not (isInterfaceTy g tyR) then - errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalStringOfType denv tyR), m)) + if not (isInterfaceTy g interfaceTy) then + errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalStringOfType denv interfaceTy), m)) - if tcref.HasInterface g tyR then + if tcref.HasInterface g interfaceTy then errorR(Error(FSComp.SR.tcDuplicateSpecOfInterface(), m)) let tcaug = tcref.TypeContents - tcaug.tcaug_interfaces <- (tyR, compgen, m) :: tcaug.tcaug_interfaces + tcaug.tcaug_interfaces <- (interfaceTy, isCompGen, m) :: tcaug.tcaug_interfaces let TcAndPublishMemberSpec cenv env containerInfo declKind tpenv memb = match memb with | SynMemberSig.ValField(_, m) -> error(Error(FSComp.SR.tcFieldValIllegalHere(), m)) | SynMemberSig.Inherit(_, m) -> error(Error(FSComp.SR.tcInheritIllegalHere(), m)) | SynMemberSig.NestedType(_, m) -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(), m)) - | SynMemberSig.Member(valSpfn, memberFlags, _) -> - TcAndPublishValSpec (cenv, env, containerInfo, declKind, Some memberFlags, tpenv, valSpfn) + | SynMemberSig.Member(synValSig, memberFlags, _) -> + TcAndPublishValSpec (cenv, env, containerInfo, declKind, Some memberFlags, tpenv, synValSig) | SynMemberSig.Interface _ -> // These are done in TcMutRecDefns_Phase1 [], tpenv - let TcTyconMemberSpecs cenv env containerInfo declKind tpenv augSpfn = let members, tpenv = List.mapFold (TcAndPublishMemberSpec cenv env containerInfo declKind) tpenv augSpfn List.concat members, tpenv - //------------------------------------------------------------------------- // Bind 'open' declarations //------------------------------------------------------------------------- @@ -747,7 +745,7 @@ module IncrClassChecking = /// Check and elaborate the "left hand side" of the implicit class construction /// syntax. - let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, doc: PreXmlDoc) = + let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc: PreXmlDoc) = let g = cenv.g let baseValOpt = @@ -790,14 +788,14 @@ module IncrClassChecking = CheckForNonAbstractInterface ModuleOrMemberBinding tcref memberFlags id.idRange let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, attribs, [], memberFlags, valSynData, id, false) - let partialValReprInfo = TranslateTopValSynInfo m (TcAttributes cenv env) valSynData - let prelimTyschemeG = TypeScheme(copyOfTyconTypars, ctorTy) + let prelimValReprInfo = TranslateSynValInfo m (TcAttributes cenv env) valSynData + let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, ctorTy) let isComplete = ComputeIsComplete copyOfTyconTypars [] ctorTy - let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG partialValReprInfo + let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo let ctorValScheme = ValScheme(id, prelimTyschemeG, Some topValInfo, Some memberInfo, false, ValInline.Never, NormalVal, vis, false, true, false, false) let paramNames = topValInfo.ArgNames - let doc = doc.ToXmlDoc(true, Some paramNames) - let ctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValInRecScope isComplete, ctorValScheme, attribs, doc, None, false) + let xmlDoc = xmlDoc.ToXmlDoc(true, Some paramNames) + let ctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValInRecScope isComplete, ctorValScheme, attribs, xmlDoc, None, false) ctorValScheme, ctorVal // We only generate the cctor on demand, because we don't need it if there are no cctor actions. @@ -812,9 +810,9 @@ module IncrClassChecking = let id = ident ("cctor", m) CheckForNonAbstractInterface ModuleOrMemberBinding tcref (ClassCtorMemberFlags SynMemberFlagsTrivia.Zero) id.idRange let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, [(*no attributes*)], [], (ClassCtorMemberFlags SynMemberFlagsTrivia.Zero), valSynData, id, false) - let partialValReprInfo = TranslateTopValSynInfo m (TcAttributes cenv env) valSynData - let prelimTyschemeG = TypeScheme(copyOfTyconTypars, cctorTy) - let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG partialValReprInfo + let prelimValReprInfo = TranslateSynValInfo m (TcAttributes cenv env) valSynData + let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, cctorTy) + let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo let cctorValScheme = ValScheme(id, prelimTyschemeG, Some topValInfo, Some memberInfo, false, ValInline.Never, NormalVal, Some SynAccess.Private, false, true, false, false) let cctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValNotInRecScope, cctorValScheme, [(* no attributes*)], XmlDoc.Empty, None, false) @@ -850,7 +848,7 @@ module IncrClassChecking = /// The "v" is the local typed w.r.t. tyvars of the implicit ctor. /// The formalTyparInst does the formal-typars/implicit-ctor-typars subst. /// Field specifications added to a tcref must be in terms of the tcrefs formal typars. - let private MakeIncrClassField(g, cpath, formalTyparInst: TyparInst, v: Val, isStatic, rfref: RecdFieldRef) = + let private MakeIncrClassField(g, cpath, formalTyparInst: TyparInstantiation, v: Val, isStatic, rfref: RecdFieldRef) = let name = rfref.FieldName let id = ident (name, v.Range) let ty = v.Type |> instType formalTyparInst @@ -1005,7 +1003,7 @@ module IncrClassChecking = let (ValReprInfo(tpNames, args, ret)) = topValInfo ValReprInfo(tpNames@ValReprInfo.InferTyparInfo copyOfTyconTypars, args, ret) - let prelimTyschemeG = TypeScheme(copyOfTyconTypars@tps, memberTauTy) + let prelimTyschemeG = GeneralizedType(copyOfTyconTypars@tps, memberTauTy) // NOTE: putting isCompilerGenerated=true here is strange. The method is not public, nor is // it a "member" in the F# sense, but the F# spec says it is generated and it is reasonable to reflect on it. @@ -1691,12 +1689,12 @@ module MutRecBindingChecking = error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(), (trimRangeToLine m))) match classMemberDef, containerInfo with - | SynMemberDefn.ImplicitCtor (vis, Attributes attrs, SynSimplePats.SimplePats(spats, _), thisIdOpt, doc, m), ContainerInfo(_, Some(MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _))) -> + | SynMemberDefn.ImplicitCtor (vis, Attributes attrs, SynSimplePats.SimplePats(spats, _), thisIdOpt, xmlDoc, m), ContainerInfo(_, Some(MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _))) -> if tcref.TypeOrMeasureKind = TyparKind.Measure then error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) // Phase2A: make incrClassCtorLhs - ctorv, thisVal etc, type depends on argty(s) - let incrClassCtorLhs = TcImplicitCtorLhs_Phase2A(cenv, envForTycon, tpenv, tcref, vis, attrs, spats, thisIdOpt, baseValOpt, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, doc) + let incrClassCtorLhs = TcImplicitCtorLhs_Phase2A(cenv, envForTycon, tpenv, tcref, vis, attrs, spats, thisIdOpt, baseValOpt, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc) // Phase2A: Add copyOfTyconTypars from incrClassCtorLhs - or from tcref let envForTycon = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envForTycon @@ -2267,14 +2265,14 @@ module MutRecBindingChecking = /// Update the contents accessible via the recursive namespace declaration, if any let TcMutRecDefns_UpdateNSContents mutRecNSInfo = match mutRecNSInfo with - | Some (Some (modulNS: ModuleOrNamespace), modTyAcc: _ ref) -> - modulNS.entity_modul_contents <- MaybeLazy.Strict modTyAcc.Value + | Some (Some (modulNS: ModuleOrNamespace), moduleTyAcc: _ ref) -> + modulNS.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value | _ -> () /// Updates the types of the modules to contain the contents so far let TcMutRecDefns_UpdateModuleContents mutRecNSInfo defns = - defns |> MutRecShapes.iterModules (fun (MutRecDefnsPhase2DataForModule (modTyAcc, modul), _) -> - modul.entity_modul_contents <- MaybeLazy.Strict modTyAcc.Value) + defns |> MutRecShapes.iterModules (fun (MutRecDefnsPhase2DataForModule (moduleTyAcc, moduleEntity), _) -> + moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value) TcMutRecDefns_UpdateNSContents mutRecNSInfo @@ -2282,12 +2280,14 @@ module MutRecBindingChecking = let TcMutRecDefns_ComputeEnvs getTyconOpt getVals (cenv: cenv) report scopem m envInitial mutRecShape = let g = cenv.g (envInitial, mutRecShape) ||> MutRecShapes.computeEnvs - (fun envAbove (MutRecDefnsPhase2DataForModule (modTyAcc, modul)) -> MakeInnerEnvWithAcc true envAbove modul.Id modTyAcc modul.ModuleOrNamespaceType.ModuleOrNamespaceKind) + (fun envAbove (MutRecDefnsPhase2DataForModule (moduleTyAcc, moduleEntity)) -> + MakeInnerEnvWithAcc true envAbove moduleEntity.Id moduleTyAcc moduleEntity.ModuleOrNamespaceType.ModuleOrNamespaceKind) + (fun envAbove decls -> // Collect the type definitions, exception definitions, modules and "open" declarations let tycons = decls |> List.choose (function MutRecShape.Tycon d -> getTyconOpt d | _ -> None) - let moduls = decls |> List.choose (function MutRecShape.Module (MutRecDefnsPhase2DataForModule (_, modul), _) -> Some modul | _ -> None) + let moduls = decls |> List.choose (function MutRecShape.Module (MutRecDefnsPhase2DataForModule (_, moduleEntity), _) -> Some moduleEntity | _ -> None) let moduleAbbrevs = decls |> List.choose (function MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev (id, mp, m)) -> Some (id, mp, m) | _ -> None) let opens = decls |> List.choose (function MutRecShape.Open (MutRecDataForOpen (target, m, moduleRange, openDeclsRef)) -> Some (target, m, moduleRange, openDeclsRef) | _ -> None) let lets = decls |> List.collect (function MutRecShape.Lets binds -> getVals binds | _ -> []) @@ -3003,7 +3003,7 @@ let CheckForDuplicateModule env nm m = /// Check 'exception' declarations in implementations and signatures module TcExceptionDeclarations = - let TcExnDefnCore_Phase1A cenv env parent (SynExceptionDefnRepr(Attributes synAttrs, SynUnionCase(ident= SynIdent(id,_)), _, doc, vis, m)) = + let TcExnDefnCore_Phase1A cenv env parent (SynExceptionDefnRepr(Attributes synAttrs, SynUnionCase(ident= SynIdent(id,_)), _, xmlDoc, vis, m)) = let attrs = TcAttributes cenv env AttributeTargets.ExnDecl synAttrs if not (String.isLeadingIdentifierCharacterUpperCase id.idText) then errorR(NotUpperCaseConstructor m) let vis, cpath = ComputeAccessAndCompPath env None m vis None parent @@ -3011,8 +3011,8 @@ module TcExceptionDeclarations = CheckForDuplicateConcreteType env (id.idText + "Exception") id.idRange CheckForDuplicateConcreteType env id.idText id.idRange let repr = TExnFresh (Construct.MakeRecdFieldsTable []) - let doc = doc.ToXmlDoc(true, Some []) - Construct.NewExn cpath id vis repr attrs doc + let xmlDoc = xmlDoc.ToXmlDoc(true, Some []) + Construct.NewExn cpath id vis repr attrs xmlDoc let TcExnDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) (env: TcEnv) parent (exnc: Entity) (SynExceptionDefnRepr(_, SynUnionCase(caseType=args), reprIdOpt, _, _, m)) = let g = cenv.g @@ -3208,17 +3208,20 @@ module EstablishTypeDefinitionCores = for SynUnionCase (caseType=args; range=m) in unionCases do match args with | SynUnionCaseKind.Fields flds -> - for SynField(_, _, _, ty, _, _, _, m) in flds do - let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty - yield (tyR, m) + for SynField(_, _, _, ty, _, _, _, m) in flds do + let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty + yield (tyR, m) + | SynUnionCaseKind.FullType (ty, arity) -> - let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty - let curriedArgTys, _ = GetTopTauTypeInFSharpForm g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos tyR m - if curriedArgTys.Length > 1 then - errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(), m)) - for argTys in curriedArgTys do - for argTy, _ in argTys do - yield (argTy, m) + let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty + let curriedArgTys, _ = GetTopTauTypeInFSharpForm g (arity |> TranslateSynValInfo m (TcAttributes cenv env) |> TranslatePartialValReprInfo []).ArgInfos tyR m + + if curriedArgTys.Length > 1 then + errorR(Error(FSComp.SR.tcIllegalFormForExplicitTypeDeclaration(), m)) + + for argTys in curriedArgTys do + for argTy, _ in argTys do + yield (argTy, m) | SynTypeDefnSimpleRepr.General (_, _, _, fields, _, _, implicitCtorSynPats, _) when tycon.IsFSharpStructOrEnumTycon -> // for structs for SynField(_, isStatic, _, ty, _, _, _, m) in fields do @@ -3250,8 +3253,8 @@ module EstablishTypeDefinitionCores = elif ModuleNameIsMangled g attribs || Set.contains nm typeNames then FSharpModuleWithSuffix else ModuleOrType - let AdjustModuleName modKind nm = - match modKind with + let AdjustModuleName moduleKind nm = + match moduleKind with | FSharpModuleWithSuffix -> nm+FSharpModuleSuffix | _ -> nm @@ -3326,8 +3329,8 @@ module EstablishTypeDefinitionCores = let (SynComponentInfo(Attributes attribs, _, _, longPath, xml, _, vis, im)) = compInfo let id = ComputeModuleName longPath let modAttrs = TcAttributes cenv envInitial AttributeTargets.ModuleDecl attribs - let modKind = ComputeModuleOrNamespaceKind g true typeNames modAttrs id.idText - let modName = AdjustModuleName modKind id.idText + let moduleKind = ComputeModuleOrNamespaceKind g true typeNames modAttrs id.idText + let modName = AdjustModuleName moduleKind id.idText let vis, _ = ComputeAccessAndCompPath envInitial None id.idRange vis None parent @@ -3336,13 +3339,13 @@ module EstablishTypeDefinitionCores = CheckForDuplicateConcreteType envInitial id.idText im CheckNamespaceModuleOrTypeName g id - let envForDecls, modTyAcc = MakeInnerEnv true envInitial id modKind - let modTy = Construct.NewEmptyModuleOrNamespaceType modKind - let doc = xml.ToXmlDoc(true, Some []) - let modul = Construct.NewModuleOrNamespace (Some envInitial.eCompPath) vis id doc modAttrs (MaybeLazy.Strict modTy) - let innerParent = Parent (mkLocalModuleRef modul) + let envForDecls, moduleTyAcc = MakeInnerEnv true envInitial id moduleKind + let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind + let xmlDoc = xml.ToXmlDoc(true, Some []) + let moduleEntity = Construct.NewModuleOrNamespace (Some envInitial.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy) + let innerParent = Parent (mkLocalModuleRef moduleEntity) let innerTypeNames = TypeNamesInMutRecDecls cenv envForDecls decls - MutRecDefnsPhase2DataForModule (modTyAcc, modul), (innerParent, innerTypeNames, envForDecls) + MutRecDefnsPhase2DataForModule (moduleTyAcc, moduleEntity), (innerParent, innerTypeNames, envForDecls) /// Establish 'type C < T1... TN > = ...' including /// - computing the mangled name for C @@ -3350,7 +3353,7 @@ module EstablishTypeDefinitionCores = /// - we don't yet 'properly' establish constraints on type parameters let private TcTyconDefnCore_Phase1A_BuildInitialTycon (cenv: cenv) env parent (MutRecDefnsPhase1DataForTycon(synTyconInfo, synTyconRepr, _, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, _)) = let g = cenv.g - let (SynComponentInfo (_, TyparDecls synTypars, _, id, doc, preferPostfix, synVis, _)) = synTyconInfo + let (SynComponentInfo (_, TyparDecls synTypars, _, id, xmlDoc, preferPostfix, synVis, _)) = synTyconInfo let checkedTypars = TcTyparDecls cenv env synTypars id |> List.iter (CheckNamespaceModuleOrTypeName g) @@ -3406,10 +3409,10 @@ module EstablishTypeDefinitionCores = patNames | _ -> [] - let doc = doc.ToXmlDoc(true, Some paramNames ) + let xmlDoc = xmlDoc.ToXmlDoc(true, Some paramNames ) Construct.NewTycon (cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, - doc, preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmodTy) + xmlDoc, preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmodTy) //------------------------------------------------------------------------- /// Establishing type definitions: early phase: work out the basic kind of the type definition @@ -3556,8 +3559,8 @@ module EstablishTypeDefinitionCores = | _ -> failwith "unreachable" if IsGeneratedTypeDirectReference (typeBeforeArguments, m) then - let optGeneratedTypePath = Some (tcref.CompilationPath.MangledPath @ [ tcref.LogicalName ]) - let _hasNoArgs, providedTypeAfterStaticArguments, checkTypeName = TcProvidedTypeAppToStaticConstantArgs cenv envinner optGeneratedTypePath tpenv tcrefBeforeStaticArguments args m + let generatedTypePath = tcref.CompilationPath.MangledPath @ [ tcref.LogicalName ] + let _hasNoArgs, providedTypeAfterStaticArguments, checkTypeName = TcProvidedTypeAppToStaticConstantArgs cenv envinner (Some generatedTypePath) tpenv tcrefBeforeStaticArguments args m let isGenerated = providedTypeAfterStaticArguments.PUntaint((fun st -> not st.IsErased), m) if isGenerated then Some (tcrefBeforeStaticArguments, providedTypeAfterStaticArguments, checkTypeName, args, m) @@ -3733,7 +3736,7 @@ module EstablishTypeDefinitionCores = let private TcTyconDefnCore_Phase1C_Phase1E_EstablishAbbreviations (cenv: cenv) envinner inSig tpenv pass (MutRecDefnsPhase1DataForTycon(_, synTyconRepr, _, _, _, _)) (tycon: Tycon) (attrs: Attribs) = let g = cenv.g let m = tycon.Range - let checkCxs = if (pass = SecondPass) then CheckCxs else NoCheckCxs + let checkConstraints = if (pass = SecondPass) then CheckCxs else NoCheckCxs let firstPass = (pass = FirstPass) try let id = tycon.Id @@ -3773,7 +3776,7 @@ module EstablishTypeDefinitionCores = // This case deals with ordinary type and measure abbreviations if not hasMeasureableAttr then let kind = if hasMeasureAttr then TyparKind.Measure else TyparKind.Type - let ty, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars checkCxs ItemOccurence.UseInType envinner tpenv rhsType + let ty, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner tpenv rhsType if not firstPass then let ftyvs = freeInTypeLeftToRight g false ty @@ -3793,7 +3796,7 @@ module EstablishTypeDefinitionCores = // and once after let private TcTyconDefnCore_Phase1D_Phase1F_EstablishSuperTypesAndInterfaceTypes (cenv: cenv) tpenv inSig pass (envMutRec, mutRecDefns: MutRecShape<_ * (Tycon * (Attribs * _)) option, _, _> list) = let g = cenv.g - let checkCxs = if (pass = SecondPass) then CheckCxs else NoCheckCxs + let checkConstraints = if (pass = SecondPass) then CheckCxs else NoCheckCxs let firstPass = (pass = FirstPass) // Publish the immediately declared interfaces. @@ -3807,7 +3810,7 @@ module EstablishTypeDefinitionCores = let envinner = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars m) envinner let envinner = MakeInnerEnvForTyconRef envinner tcref false - let implementedTys, _ = List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkCxs ItemOccurence.UseInType envinner)) tpenv explicitImplements + let implementedTys, _ = List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner)) tpenv explicitImplements if firstPass then tycon.entity_attribs <- attrs @@ -3819,7 +3822,7 @@ module EstablishTypeDefinitionCores = let kind = InferTyconKind g (kind, attrs, slotsigs, fields, inSig, isConcrete, m) let inherits = inherits |> List.map (fun (ty, m, _) -> (ty, m)) - let inheritedTys = fst (List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkCxs ItemOccurence.UseInType envinner)) tpenv inherits) + let inheritedTys = fst (List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner)) tpenv inherits) let implementedTys, inheritedTys = match kind with | SynTypeDefnKind.Interface -> @@ -4172,7 +4175,7 @@ module EstablishTypeDefinitionCores = noAbstractClassAttributeCheck() noFieldsCheck userFields let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner tpenv ty - let _, _, curriedArgInfos, returnTy, _ = GetTopValTypeInCompiledForm g (arity |> TranslateTopValSynInfo m (TcAttributes cenv envinner) |> TranslatePartialArity []) 0 tyR m + let _, _, curriedArgInfos, returnTy, _ = GetTopValTypeInCompiledForm g (arity |> TranslateSynValInfo m (TcAttributes cenv envinner) |> TranslatePartialValReprInfo []) 0 tyR m if curriedArgInfos.Length < 1 then error(Error(FSComp.SR.tcInvalidDelegateSpecification(), m)) if curriedArgInfos.Length > 1 then error(Error(FSComp.SR.tcDelegatesCannotBeCurried(), m)) let ttps = thisTyconRef.Typars m @@ -4199,13 +4202,13 @@ module EstablishTypeDefinitionCores = | Some id -> Some id let abstractSlots = - [ for valSpfn, memberFlags in slotsigs do + [ for synValSig, memberFlags in slotsigs do - let (SynValSig(range=m)) = valSpfn + let (SynValSig(range=m)) = synValSig CheckMemberFlags None NewSlotsOK OverridesOK memberFlags m - let slots = fst (TcAndPublishValSpec (cenv, envinner, containerInfo, ModuleOrMemberBinding, Some memberFlags, tpenv, valSpfn)) + let slots = fst (TcAndPublishValSpec (cenv, envinner, containerInfo, ModuleOrMemberBinding, Some memberFlags, tpenv, synValSig)) // Multiple slots may be returned, e.g. for // abstract P: int with get, set @@ -4467,7 +4470,7 @@ module EstablishTypeDefinitionCores = // Interlude between Phase1D and Phase1E - Check and publish the explicit constraints. - let TcMutRecDefns_CheckExplicitConstraints cenv tpenv m checkCxs envMutRecPrelim withEnvs = + let TcMutRecDefns_CheckExplicitConstraints cenv tpenv m checkConstraints envMutRecPrelim withEnvs = (envMutRecPrelim, withEnvs) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (origInfo, tyconOpt) -> match origInfo, tyconOpt with | (typeDefCore, _, _), Some (tycon: Tycon) -> @@ -4478,7 +4481,7 @@ module EstablishTypeDefinitionCores = let thisTyconRef = mkLocalTyconRef tycon let envForTycon = MakeInnerEnvForTyconRef envForTycon thisTyconRef false try - TcTyparConstraints cenv NoNewTypars checkCxs ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore + TcTyparConstraints cenv NoNewTypars checkConstraints ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore with exn -> errorRecovery exn m | _ -> ()) @@ -4513,9 +4516,9 @@ module EstablishTypeDefinitionCores = // Phase1AB - Publish modules let envTmp, withEnvs = (envInitial, withEntities) ||> MutRecShapes.computeEnvs - (fun envAbove (MutRecDefnsPhase2DataForModule (modTyAcc, modul)) -> - PublishModuleDefn cenv envAbove modul - MakeInnerEnvWithAcc true envAbove modul.Id modTyAcc modul.ModuleOrNamespaceType.ModuleOrNamespaceKind) + (fun envAbove (MutRecDefnsPhase2DataForModule (moduleTyAcc, moduleEntity)) -> + PublishModuleDefn cenv envAbove moduleEntity + MakeInnerEnvWithAcc true envAbove moduleEntity.Id moduleTyAcc moduleEntity.ModuleOrNamespaceType.ModuleOrNamespaceKind) (fun envAbove _ -> envAbove) // Updates the types of the modules to contain the contents so far, which now includes the nested modules and types @@ -5068,10 +5071,10 @@ module TcDeclarations = // members of the type let preEstablishedHasDefaultCtor = members |> List.exists (function - | SynMemberSig.Member (valSpfn, memberFlags, _) -> + | SynMemberSig.Member (synValSig, memberFlags, _) -> memberFlags.MemberKind=SynMemberKind.Constructor && // REVIEW: This is a syntactic approximation - (match valSpfn.SynType, valSpfn.SynInfo.CurriedArgInfos with + (match synValSig.SynType, synValSig.SynInfo.CurriedArgInfos with | StripParenTypes (SynType.Fun (StripParenTypes (SynType.LongIdent (SynLongIdent([id], _, _))), _, _)), [[_]] when id.idText = "unit" -> true | _ -> false) | _ -> false) @@ -5195,10 +5198,10 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE let env = List.foldBack (AddLocalVal g cenv.tcSink scopem) idvs env return env - | SynModuleSigDecl.NestedModule(SynComponentInfo(attributes=Attributes attribs; longId=longPath; xmlDoc=xml; accessibility=vis; range=im) as compInfo, isRec, mdefs, m, trivia) -> + | SynModuleSigDecl.NestedModule(SynComponentInfo(attributes=Attributes attribs; longId=longPath; xmlDoc=xml; accessibility=vis; range=im) as compInfo, isRec, moduleDefs, m, trivia) -> if isRec then // Treat 'module rec M = ...' as a single mutually recursive definition group 'module M = ...' - let modDecl = SynModuleSigDecl.NestedModule(compInfo, false, mdefs, m, trivia) + let modDecl = SynModuleSigDecl.NestedModule(compInfo, false, moduleDefs, m, trivia) return! TcSignatureElementsMutRec cenv parent typeNames endm None env [modDecl] else @@ -5206,23 +5209,23 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE let vis, _ = ComputeAccessAndCompPath env None im vis None parent let attribs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs CheckNamespaceModuleOrTypeName g id - let modKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind g true typeNames attribs id.idText - let modName = EstablishTypeDefinitionCores.AdjustModuleName modKind id.idText + let moduleKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind g true typeNames attribs id.idText + let modName = EstablishTypeDefinitionCores.AdjustModuleName moduleKind id.idText CheckForDuplicateConcreteType env modName id.idRange // Now typecheck the signature, accumulating and then recording the submodule description. let id = ident (modName, id.idRange) - let modTy = Construct.NewEmptyModuleOrNamespaceType modKind - let doc = xml.ToXmlDoc(true, Some []) - let modul = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id doc attribs (MaybeLazy.Strict modTy) + let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind + let xmlDoc = xml.ToXmlDoc(true, Some []) + let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc attribs (MaybeLazy.Strict moduleTy) - let! modTy, _ = TcModuleOrNamespaceSignatureElementsNonMutRec cenv (Parent (mkLocalModuleRef modul)) env (id, modKind, mdefs, m, xml) + let! moduleTy, _ = TcModuleOrNamespaceSignatureElementsNonMutRec cenv (Parent (mkLocalModuleRef moduleEntity)) env (id, moduleKind, moduleDefs, m, xml) - modul.entity_modul_contents <- MaybeLazy.Strict modTy + moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTy let scopem = unionRanges m endm - PublishModuleDefn cenv env modul - let env = AddLocalSubModuleAndReport cenv.tcSink scopem g cenv.amap m env modul + PublishModuleDefn cenv env moduleEntity + let env = AddLocalSubModuleAndReport cenv.tcSink scopem g cenv.amap m env moduleEntity return env | SynModuleSigDecl.ModuleAbbrev (id, p, m) -> @@ -5269,7 +5272,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE else longId, defs - let envNS = LocateEnv cenv.topCcu env enclosingNamespacePath + let envNS = LocateEnv cenv.thisCcu env enclosingNamespacePath let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink g cenv.amap m enclosingNamespacePath envNS // For 'namespace rec' and 'module rec' we add the thing being defined @@ -5277,10 +5280,10 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE let modTyRoot, modulNSs = BuildRootModuleType enclosingNamespacePath envNS.eCompPath modTyNS let modulNSOpt = List.tryHead modulNSs - modulNSs |> List.iter (fun modul -> - let modref = mkLocalModuleRef modul + modulNSs |> List.iter (fun moduleEntity -> + let modref = mkLocalModuleRef moduleEntity let item = Item.ModuleOrNamespaces [modref] - CallNameResolutionSink cenv.tcSink (modul.Range, env.NameEnv, item, emptyTyparInst, ItemOccurence.Binding, env.AccessRights)) + CallNameResolutionSink cenv.tcSink (moduleEntity.Range, env.NameEnv, item, emptyTyparInst, ItemOccurence.Binding, env.AccessRights)) // For 'namespace rec' and 'module rec' we add the thing being defined let envNS = if isRec then AddLocalRootModuleOrNamespace cenv.tcSink g cenv.amap m envNS modTyRoot else envNS @@ -5320,8 +5323,8 @@ and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = cancellable { // Ensure the .Deref call in UpdateAccModuleOrNamespaceType succeeds if cenv.compilingCanonicalFslibModuleType then - let doc = xml.ToXmlDoc(true, Some []) - ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath doc + let xmlDoc = xml.ToXmlDoc(true, Some []) + ensureCcuHasModuleOrNamespaceAtPath cenv.thisCcu env.ePath env.eCompPath xmlDoc let typeNames = EstablishTypeDefinitionCores.TypeNamesInNonMutRecSigDecls defs match mutRecNSInfo with @@ -5353,8 +5356,8 @@ and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (d decls, (openOk, moduleAbbrevOk) | SynModuleSigDecl.Exception (exnSig=SynExceptionSig(exnRepr=exnRepr; withKeyword=withKeyword; members=members)) -> - let ( SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _, doc, vis, m)) = exnRepr - let compInfo = SynComponentInfo(synAttrs, None, [], [id], doc, false, vis, id.idRange) + let ( SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _, xmlDoc, vis, m)) = exnRepr + let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange) let decls = [ MutRecShape.Tycon(SynTypeDefnSig.SynTypeDefnSig(compInfo, None, SynTypeDefnSigRepr.Exception exnRepr, withKeyword, members, m)) ] decls, (false, false) @@ -5387,19 +5390,19 @@ and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (d -and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id, modKind, defs, m: range, xml) = +and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id, moduleKind, defs, m: range, xml) = cancellable { let endm = m.EndRange // use end of range for errors // Create the module type that will hold the results of type checking.... - let envForModule, modTyAcc = MakeInnerEnv true env id modKind + let envForModule, moduleTyAcc = MakeInnerEnv true env id moduleKind // Now typecheck the signature, using mutation to fill in the submodule description. let! envAtEnd = TcSignatureElements cenv parent endm envForModule xml None defs - // modTyAcc has now accumulated the module type - return modTyAcc.Value, envAtEnd + // moduleTyAcc has now accumulated the module type + return moduleTyAcc.Value, envAtEnd } //------------------------------------------------------------------------- @@ -5460,34 +5463,39 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem | SynModuleDecl.ModuleAbbrev (id, p, m) -> let env = MutRecBindingChecking.TcModuleAbbrevDecl cenv scopem env (id, p, m) - return (Operators.id, []), env, env + return ([], [], []), env, env | SynModuleDecl.Exception (edef, m) -> let binds, decl, env = TcExceptionDeclarations.TcExnDefn cenv env parent (edef, scopem) - return ((fun e -> TMDefRec(true, [], [decl], binds |> List.map ModuleOrNamespaceBinding.Binding, m) :: e), []), env, env + let defn = TMDefRec(true, [], [decl], binds |> List.map ModuleOrNamespaceBinding.Binding, m) + return ([defn], [], []), env, env | SynModuleDecl.Types (typeDefs, m) -> let scopem = unionRanges m scopem let mutRecDefns = typeDefs |> List.map MutRecShape.Tycon let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv env parent typeNames tpenv m scopem None mutRecDefns // Check the non-escaping condition as we build the expression on the way back up - let exprfWithEscapeCheck e = + let defn = TcMutRecDefsFinish cenv mutRecDefnsChecked m + let escapeCheck () = TcMutRecDefnsEscapeCheck mutRecDefnsChecked env - TcMutRecDefsFinish cenv mutRecDefnsChecked m :: e - return (exprfWithEscapeCheck, []), envAfter, envAfter + return ([defn], [escapeCheck], []), envAfter, envAfter | SynModuleDecl.Open (target, m) -> let scopem = unionRanges m.EndRange scopem let env, openDecls = TcOpenDecl cenv m scopem env target - return ((fun decls -> (match openDecls with [] -> decls | _ -> TMDefOpens openDecls :: decls)), []), env, env + let defns = + match openDecls with + | [] -> [] + | _ -> [ TMDefOpens openDecls ] + return (defns, [], []), env, env | SynModuleDecl.Let (letrec, binds, m) -> match parent with | ParentNone -> CheckLetOrDoInNamespace binds m - return (id, []), env, env + return ([], [], []), env, env | Parent parentModule -> let containerInfo = ModuleOrNamespaceContainerInfo parentModule @@ -5495,34 +5503,36 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let scopem = unionRanges m scopem let binds = binds |> List.map (fun bind -> RecDefnBindingInfo(containerInfo, NoNewSlots, ModuleOrMemberBinding, bind)) let binds, env, _ = TcLetrecBindings WarnOnOverrides cenv env tpenv (binds, m, scopem) - return ((fun e -> TMDefRec(true, [], [], binds |> List.map ModuleOrNamespaceBinding.Binding, m) :: e), []), env, env + let defn = TMDefRec(true, [], [], binds |> List.map ModuleOrNamespaceBinding.Binding, m) + return ([defn], [], []), env, env else - let binds, env, _ = TcLetBindings cenv env containerInfo ModuleOrMemberBinding tpenv (binds, m, scopem) - return ((fun e -> binds@e), []), env, env + let defns, env, _ = TcLetBindings cenv env containerInfo ModuleOrMemberBinding tpenv (binds, m, scopem) + return (defns, [], []), env, env - | SynModuleDecl.Expr _ -> return! failwith "unreachable" + | SynModuleDecl.Expr _ -> + return! failwith "unreachable" | SynModuleDecl.Attributes (Attributes synAttrs, _) -> let attrs, _ = TcAttributesWithPossibleTargets false cenv env AttributeTargets.Top synAttrs - return (id, attrs), env, env + return ([], [], attrs), env, env | SynModuleDecl.HashDirective _ -> - return (id, []), env, env + return ([], [], []), env, env - | SynModuleDecl.NestedModule(compInfo, isRec, mdefs, isContinuingModule, m, trivia) -> + | SynModuleDecl.NestedModule(compInfo, isRec, moduleDefs, isContinuingModule, m, trivia) -> // Treat 'module rec M = ...' as a single mutually recursive definition group 'module M = ...' if isRec then assert (not isContinuingModule) - let modDecl = SynModuleDecl.NestedModule(compInfo, false, mdefs, isContinuingModule, m, trivia) + let modDecl = SynModuleDecl.NestedModule(compInfo, false, moduleDefs, isContinuingModule, m, trivia) return! TcModuleOrNamespaceElementsMutRec cenv parent typeNames m env None [modDecl] else let (SynComponentInfo(Attributes attribs, _, _, longPath, xml, _, vis, im)) = compInfo let id = ComputeModuleName longPath let modAttrs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs - let modKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind g true typeNames modAttrs id.idText - let modName = EstablishTypeDefinitionCores.AdjustModuleName modKind id.idText + let moduleKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind g true typeNames modAttrs id.idText + let modName = EstablishTypeDefinitionCores.AdjustModuleName moduleKind id.idText CheckForDuplicateConcreteType env modName im CheckForDuplicateModule env id.idText id.idRange let vis, _ = ComputeAccessAndCompPath env None id.idRange vis None parent @@ -5532,24 +5542,24 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem CheckNamespaceModuleOrTypeName g id - let envForModule, modTyAcc = MakeInnerEnv true env id modKind + let envForModule, moduleTyAcc = MakeInnerEnv true env id moduleKind // Create the new module specification to hold the accumulated results of the type of the module // Also record this in the environment as the accumulator - let modTy = Construct.NewEmptyModuleOrNamespaceType modKind - let doc = xml.ToXmlDoc(true, Some []) - let modul = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id doc modAttrs (MaybeLazy.Strict modTy) + let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind + let xmlDoc = xml.ToXmlDoc(true, Some []) + let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy) // Now typecheck. - let! mexpr, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef modul)) endm envForModule xml None [] mdefs + let! moduleContents, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs // Get the inferred type of the decls and record it in the modul. - modul.entity_modul_contents <- MaybeLazy.Strict modTyAcc.Value - let modDefn = TMDefRec(false, [], [], [ModuleOrNamespaceBinding.Module(modul, mexpr)], m) + moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value + let moduleDef = TMDefRec(false, [], [], [ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents)], m) - PublishModuleDefn cenv env modul + PublishModuleDefn cenv env moduleEntity - let env = AddLocalSubModuleAndReport cenv.tcSink scopem g cenv.amap m env modul + let env = AddLocalSubModuleAndReport cenv.tcSink scopem g cenv.amap m env moduleEntity // isContinuingModule is true for all of the following // - the implicit module of a script @@ -5560,7 +5570,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem // but does contain the results of all the 'open' declarations and so on. let envAtEnd = (if isContinuingModule then envAtEnd else env) - return ((fun modDefs -> modDefn :: modDefs), topAttrsNew), env, envAtEnd + return ([ moduleDef ], [], topAttrsNew), env, envAtEnd | SynModuleDecl.NamespaceFragment(SynModuleOrNamespace(longId, isRec, kind, defs, xml, attribs, vis, m, _)) -> @@ -5585,24 +5595,24 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem else longId, defs - let envNS = LocateEnv cenv.topCcu env enclosingNamespacePath + let envNS = LocateEnv cenv.thisCcu env enclosingNamespacePath let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink g cenv.amap m enclosingNamespacePath envNS let modTyNS = envNS.eModuleOrNamespaceTypeAccumulator.Value let modTyRoot, modulNSs = BuildRootModuleType enclosingNamespacePath envNS.eCompPath modTyNS let modulNSOpt = List.tryHead modulNSs - modulNSs |> List.iter (fun modul -> - let modref = mkLocalModuleRef modul + modulNSs |> List.iter (fun moduleEntity -> + let modref = mkLocalModuleRef moduleEntity let item = Item.ModuleOrNamespaces [modref] - CallNameResolutionSink cenv.tcSink (modul.Range, env.NameEnv, item, emptyTyparInst, ItemOccurence.Binding, env.AccessRights)) + CallNameResolutionSink cenv.tcSink (moduleEntity.Range, env.NameEnv, item, emptyTyparInst, ItemOccurence.Binding, env.AccessRights)) // For 'namespace rec' and 'module rec' we add the thing being defined let envNS = if isRec then AddLocalRootModuleOrNamespace cenv.tcSink g cenv.amap m envNS modTyRoot else envNS let nsInfo = Some (modulNSOpt, envNS.eModuleOrNamespaceTypeAccumulator) let mutRecNSInfo = if isRec then nsInfo else None - let! modExpr, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs + let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo @@ -5623,17 +5633,19 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem CombineCcuContentFragments m [env.eModuleOrNamespaceTypeAccumulator.Value; modTyRoot] env, openDecls - let modExprRoot = BuildRootModuleExpr enclosingNamespacePath envNS.eCompPath modExpr + let moduleContentsRoot = BuildRootModuleContents enclosingNamespacePath envNS.eCompPath moduleContents + + let defns = + match openDecls with + | [] -> [ moduleContentsRoot ] + | _ -> [ TMDefOpens openDecls; moduleContentsRoot ] return - ((fun modExprs -> - match openDecls with - | [] -> modExprRoot :: modExprs - | _ -> TMDefOpens openDecls :: modExprRoot :: modExprs), topAttrs), env, envAtEnd + (defns, [], topAttrs), env, envAtEnd with exn -> errorRecovery exn synDecl.Range - return (id, []), env, env + return ([], [], []), env, env } /// The non-mutually recursive case for a sequence of declarations @@ -5691,8 +5703,8 @@ and TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial decls, (openOk, moduleAbbrevOk, attrs) | SynModuleDecl.Exception (SynExceptionDefn(repr, _, members, _), _m) -> - let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, doc, vis, m)) = repr - let compInfo = SynComponentInfo(synAttrs, None, [], [id], doc, false, vis, id.idRange) + let (SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _repr, xmlDoc, vis, m)) = repr + let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange) let decls = [ MutRecShape.Tycon(SynTypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, None, m, SynTypeDefnTrivia.Zero)) ] decls, (false, false, attrs) @@ -5720,12 +5732,11 @@ and TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs // Check the non-escaping condition as we build the list of module expressions on the way back up - let exprfWithEscapeCheck modExprs = + let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m + let escapeCheck () = TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial - let modExpr = TcMutRecDefsFinish cenv mutRecDefnsChecked m - modExpr :: modExprs - return (exprfWithEscapeCheck, attrs), envAfter, envAfter + return ([ moduleContents ], [ escapeCheck ], attrs), envAfter, envAfter } @@ -5746,42 +5757,45 @@ and TcMutRecDefsFinish cenv defs m = | MutRecShape.Tycon (_, binds) | MutRecShape.Lets binds -> binds |> List.map ModuleOrNamespaceBinding.Binding - | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(modTyAcc, modul), _), mdefs) -> - let mexpr = TcMutRecDefsFinish cenv mdefs m - modul.entity_modul_contents <- MaybeLazy.Strict modTyAcc.Value - [ ModuleOrNamespaceBinding.Module(modul, mexpr) ]) + | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(moduleTyAcc, moduleEntity), _), moduleDefs) -> + let moduleContents = TcMutRecDefsFinish cenv moduleDefs m + moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value + [ ModuleOrNamespaceBinding.Module(moduleEntity, moduleContents) ]) TMDefRec(true, opens, tycons, binds, m) -and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 defs = +and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls = cancellable { // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds if cenv.compilingCanonicalFslibModuleType then - let doc = xml.ToXmlDoc(true, Some []) - ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath doc + let xmlDoc = xml.ToXmlDoc(true, Some []) + ensureCcuHasModuleOrNamespaceAtPath cenv.thisCcu env.ePath env.eCompPath xmlDoc // Collect the type names so we can implicitly add the compilation suffix to module names - let typeNames = EstablishTypeDefinitionCores.TypeNamesInNonMutRecDecls cenv env defs + let typeNames = EstablishTypeDefinitionCores.TypeNamesInNonMutRecDecls cenv env synModuleDecls match mutRecNSInfo with | Some _ -> - let! (exprf, topAttrsNew), _, envAtEnd = TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo defs - // Apply the functions for each declaration to build the overall expression-builder - let mexpr = TMDefs(exprf []) - return (mexpr, topAttrsNew, envAtEnd) + let! (moduleDefs, escapeChecks, topAttrsNew), _, envAtEnd = TcModuleOrNamespaceElementsMutRec cenv parent typeNames endm env mutRecNSInfo synModuleDecls + let moduleContents = TMDefs(moduleDefs) + // Run the escape checks (for compat run in reverse order) + do + for escapeCheck in List.rev escapeChecks do + escapeCheck() + return (moduleContents, topAttrsNew, envAtEnd) | None -> - let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) defs + let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls // Apply the functions for each declaration to build the overall expression-builder - let mdefs = List.foldBack (fun (f, _) x -> f x) compiledDefs [] - let mdefs = match openDecls0 with [] -> mdefs | _ -> TMDefOpens openDecls0 :: mdefs - let mexpr = TMDefs mdefs + let moduleDefs = List.collect p13 compiledDefs + let moduleDefs = match openDecls0 with [] -> moduleDefs | _ -> TMDefOpens openDecls0 :: moduleDefs + let moduleContents = TMDefs moduleDefs // Collect up the attributes that are global to the file - let topAttrsNew = compiledDefs |> List.map snd |> List.concat - return (mexpr, topAttrsNew, envAtEnd) + let topAttrsNew = compiledDefs |> List.map p33 |> List.concat + return (moduleContents, topAttrsNew, envAtEnd) } @@ -5877,9 +5891,9 @@ let rec IterTyconsOfModuleOrNamespaceType f (mty: ModuleOrNamespaceType) = // Defaults get applied before the module signature is checked and before the implementation conditions on virtuals/overrides. // Defaults get applied in priority order. Defaults listed last get priority 0 (lowest), 2nd last priority 1 etc. -let ApplyDefaults (cenv: cenv) g denvAtEnd m mexpr extraAttribs = +let ApplyDefaults (cenv: cenv) g denvAtEnd m moduleContents extraAttribs = try - let unsolved = FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) + let unsolved = FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd moduleContents extraAttribs CanonicalizePartialInferenceProblem cenv.css denvAtEnd m unsolved @@ -5919,20 +5933,20 @@ let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig try check implFileTypePriorToSig with e -> errorRecovery e m -let SolveInternalUnknowns g (cenv: cenv) denvAtEnd mexpr extraAttribs = - let unsolved = FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) +let SolveInternalUnknowns g (cenv: cenv) denvAtEnd moduleContents extraAttribs = + let unsolved = FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd moduleContents extraAttribs for tp in unsolved do if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp -let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr = +let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig moduleContents = match rootSigOpt with | None -> // Deep copy the inferred type of the module let implFileTypePriorToSigCopied = copyModuleOrNamespaceType g CloneAll implFileTypePriorToSig - ModuleOrNamespaceContentsWithSig(implFileTypePriorToSigCopied, mexpr, m) + (implFileTypePriorToSigCopied, moduleContents) | Some sigFileType -> @@ -5957,21 +5971,21 @@ let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePrior with exn -> errorRecovery exn m - ModuleOrNamespaceContentsWithSig(sigFileType, mexpr, m) + (sigFileType, moduleContents) /// Make the initial type checking environment for a single file with an empty accumulator for the overall contents for the file let MakeInitialEnv env = // Note: here we allocate a new module type accumulator - let modTyAcc = ref (Construct.NewEmptyModuleOrNamespaceType Namespace) - { env with eModuleOrNamespaceTypeAccumulator = modTyAcc }, modTyAcc + let moduleTyAcc = ref (Construct.NewEmptyModuleOrNamespaceType Namespace) + { env with eModuleOrNamespaceTypeAccumulator = moduleTyAcc }, moduleTyAcc /// Check an entire implementation file /// Typecheck, then close the inference scope and then check the file meets its signature (if any) let CheckOneImplFile // checkForErrors: A function to help us stop reporting cascading errors (g, niceNameGen, amap, - topCcu, + thisCcu, openDecls0, checkForErrors, conditionalDefines, @@ -5986,18 +6000,18 @@ let CheckOneImplFile cancellable { let cenv = - cenv.Create (g, isScript, niceNameGen, amap, topCcu, false, Option.isSome rootSigOpt, + cenv.Create (g, isScript, niceNameGen, amap, thisCcu, false, Option.isSome rootSigOpt, conditionalDefines, tcSink, (LightweightTcValForUsingInBuildMethodCall g), isInternalTestSpanStackReferring, tcSequenceExpressionEntry=TcSequenceExpressionEntry, tcArrayOrListSequenceExpression=TcArrayOrListComputedExpression, tcComputationExpression=TcComputationExpression) - let envinner, modTyAcc = MakeInitialEnv env + let envinner, moduleTyAcc = MakeInitialEnv env let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ] - let! mexpr, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs + let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs - let implFileTypePriorToSig = modTyAcc.Value + let implFileTypePriorToSig = moduleTyAcc.Value let topAttrs = let mainMethodAttrs, others = topAttrs |> List.partition (fun (possTargets, _) -> possTargets &&& AttributeTargets.Method <> enum 0) @@ -6013,7 +6027,7 @@ let CheckOneImplFile let m = qualNameOfFile.Range // This is a fake module spec - let implFileSpecPriorToSig = wrapModuleOrNamespaceType qualNameOfFile.Id (compPathOfCcu topCcu) implFileTypePriorToSig + let implFileSpecPriorToSig = wrapModuleOrNamespaceType qualNameOfFile.Id (compPathOfCcu thisCcu) implFileTypePriorToSig let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs @@ -6026,14 +6040,18 @@ let CheckOneImplFile errorRecovery exn m conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) + ApplyDefaults cenv g denvAtEnd m moduleContents extraAttribs) // Check completion of all classes defined across this file. // NOTE: this is not a great technique if inner signatures are permitted to hide // virtual dispatch slots. conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - try implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope (cenv.infoReader, envAtEnd.NameEnv, cenv.tcSink, true, denvAtEnd)) - with exn -> errorRecovery exn m) + try + implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (fun tycon -> + FinalTypeDefinitionChecksAtEndOfInferenceScope (cenv.infoReader, envAtEnd.NameEnv, cenv.tcSink, true, denvAtEnd, tycon)) + + with exn -> + errorRecovery exn m) // Check the value restriction. Only checked if there is no signature. conditionallySuppressErrorReporting (checkForErrors()) (fun () -> @@ -6041,12 +6059,12 @@ let CheckOneImplFile // Solve unsolved internal type variables conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs) + SolveInternalUnknowns g cenv denvAtEnd moduleContents extraAttribs) // Check the module matches the signature - let implFileExprAfterSig = + let implFileTy, implFileContents = conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr) + CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig moduleContents) do conditionallySuppressErrorReporting (checkForErrors()) (fun () -> @@ -6066,10 +6084,10 @@ let CheckOneImplFile try let reportErrors = not (checkForErrors()) let tcVal = LightweightTcValForUsingInBuildMethodCall g - PostTypeCheckSemanticChecks.CheckTopImpl + PostTypeCheckSemanticChecks.CheckImplFile (g, cenv.amap, reportErrors, cenv.infoReader, - env.eInternalsVisibleCompPaths, cenv.topCcu, tcVal, envAtEnd.DisplayEnv, - implFileExprAfterSig, extraAttribs, isLastCompiland, + env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, + implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) with exn -> @@ -6096,7 +6114,7 @@ let CheckOneImplFile |> Array.map (fun (KeyValue(k,v)) -> (k,v)) |> Map - let implFile = TImplFile (qualNameOfFile, scopedPragmas, implFileExprAfterSig, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + let implFile = CheckedImplFile (qualNameOfFile, scopedPragmas, implFileTy, implFileContents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) return (topAttrs, implFile, implFileTypePriorToSig, envAtEnd, cenv.createsGeneratedProvidedTypes) } @@ -6104,25 +6122,27 @@ let CheckOneImplFile /// Check an entire signature file -let CheckOneSigFile (g, niceNameGen, amap, topCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring) tcEnv (ParsedSigFileInput (qualifiedNameOfFile = qualNameOfFile; modules = sigFileFrags)) = +let CheckOneSigFile (g, niceNameGen, amap, thisCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring) tcEnv (ParsedSigFileInput (qualifiedNameOfFile = qualNameOfFile; modules = sigFileFrags)) = cancellable { let cenv = cenv.Create - (g, false, niceNameGen, amap, topCcu, true, false, conditionalDefines, tcSink, + (g, false, niceNameGen, amap, thisCcu, true, false, conditionalDefines, tcSink, (LightweightTcValForUsingInBuildMethodCall g), isInternalTestSpanStackReferring, tcSequenceExpressionEntry=TcSequenceExpressionEntry, tcArrayOrListSequenceExpression=TcArrayOrListComputedExpression, tcComputationExpression=TcComputationExpression) - let envinner, modTyAcc = MakeInitialEnv tcEnv + let envinner, moduleTyAcc = MakeInitialEnv tcEnv let specs = [ for x in sigFileFrags -> SynModuleSigDecl.NamespaceFragment x ] let! tcEnv = TcSignatureElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None specs - let sigFileType = modTyAcc.Value + let sigFileType = moduleTyAcc.Value if not (checkForErrors()) then - try sigFileType |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope(cenv.infoReader, tcEnv.NameEnv, cenv.tcSink, false, tcEnv.DisplayEnv)) + try + sigFileType |> IterTyconsOfModuleOrNamespaceType (fun tycon -> + FinalTypeDefinitionChecksAtEndOfInferenceScope(cenv.infoReader, tcEnv.NameEnv, cenv.tcSink, false, tcEnv.DisplayEnv, tycon)) with exn -> errorRecovery exn qualNameOfFile.Range return (tcEnv, sigFileType, cenv.createsGeneratedProvidedTypes) diff --git a/src/Compiler/Checking/CheckDeclarations.fsi b/src/Compiler/Checking/CheckDeclarations.fsi index 40b485d060c..47bfbc6577f 100644 --- a/src/Compiler/Checking/CheckDeclarations.fsi +++ b/src/Compiler/Checking/CheckDeclarations.fsi @@ -44,7 +44,8 @@ val CombineTopAttrs: TopAttribs -> TopAttribs -> TopAttribs val TcOpenModuleOrNamespaceDecl: TcResultsSink -> TcGlobals -> ImportMap -> range -> TcEnv -> LongIdent * range -> TcEnv * OpenDeclaration list -val AddLocalSubModule: g: TcGlobals -> amap: ImportMap -> m: range -> env: TcEnv -> modul: ModuleOrNamespace -> TcEnv +val AddLocalSubModule: + g: TcGlobals -> amap: ImportMap -> m: range -> env: TcEnv -> moduleEntity: ModuleOrNamespace -> TcEnv val CheckOneImplFile: TcGlobals * @@ -59,7 +60,7 @@ val CheckOneImplFile: TcEnv * ModuleOrNamespaceType option * ParsedImplFileInput -> - Cancellable + Cancellable val CheckOneSigFile: TcGlobals * diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index bc91d6e8072..f575b6aa83e 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -166,7 +166,7 @@ type CtorInfo = /// ctor = 3 indicates about to type check "\arg. (body)", /// ctor = 2 indicates about to type check "body" /// ctor = 1 indicates actually type checking the body expression - /// 0 indicates everywhere else, including auxiliary expressions such e1 in "let x = e1 in { new ... }" + /// 0 indicates everywhere else, including auxiliary expressions such expr1 in "let x = expr1 in { new ... }" /// REVIEW: clean up this rather odd approach ... ctorShapeCounter: int @@ -396,9 +396,9 @@ type UnscopedTyparEnv = UnscopedTyparEnv of NameMap let emptyUnscopedTyparEnv: UnscopedTyparEnv = UnscopedTyparEnv Map.empty -let AddUnscopedTypar n p (UnscopedTyparEnv tab) = UnscopedTyparEnv (Map.add n p tab) +let AddUnscopedTypar name typar (UnscopedTyparEnv tab) = UnscopedTyparEnv (Map.add name typar tab) -let TryFindUnscopedTypar n (UnscopedTyparEnv tab) = Map.tryFind n tab +let TryFindUnscopedTypar name (UnscopedTyparEnv tab) = Map.tryFind name tab let HideUnscopedTypars typars (UnscopedTyparEnv tab) = UnscopedTyparEnv (List.fold (fun acc (tp: Typar) -> Map.remove tp.Name acc) tab typars) @@ -432,7 +432,7 @@ type TcFileState = /// Holds a reference to the component being compiled. /// This field is very rarely used (mainly when fixing up forward references to fslib. - topCcu: CcuThunk + thisCcu: CcuThunk /// Holds the current inference constraints css: ConstraintSolverState @@ -474,7 +474,7 @@ type TcFileState = /// Create a new compilation environment static member Create - (g, isScript, niceNameGen, amap, topCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring, + (g, isScript, niceNameGen, amap, thisCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring, tcSequenceExpressionEntry, tcArrayOrListSequenceExpression, tcComputationExpression) = let infoReader = InfoReader(g, amap) let instantiationGenerator m tpsorig = FreshenTypars m tpsorig @@ -484,7 +484,7 @@ type TcFileState = recUses = ValMultiMap<_>.Empty stackGuard = StackGuard(TcStackGuardDepth) createsGeneratedProvidedTypes = false - topCcu = topCcu + thisCcu = thisCcu isScript = isScript css = ConstraintSolverState.New(g, amap, infoReader, tcVal) infoReader = infoReader @@ -530,14 +530,17 @@ let UnifyOverallType cenv (env: TcEnv) m overallTy actualTy = else // try adhoc type-directed conversions let reqdTy2, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions cenv.infoReader env.eAccessRights isMethodArg false reqdTy actualTy m + match eqn with | Some (ty1, ty2, msg) -> UnifyTypes cenv env m ty1 ty2 msg env.DisplayEnv | None -> () + match usesTDC with | TypeDirectedConversionUsed.Yes warn -> warning(warn env.DisplayEnv) | TypeDirectedConversionUsed.No -> () + if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m reqdTy2 actualTy then let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes env.DisplayEnv reqdTy actualTy warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) @@ -562,26 +565,28 @@ let UnifyTypesAndRecover cenv env m expectedTy actualTy = errorRecovery exn m /// Make an environment suitable for a module or namespace. Does not create a new accumulator but uses one we already have/ -let MakeInnerEnvWithAcc addOpenToNameEnv env nm mtypeAcc modKind = +let MakeInnerEnvWithAcc addOpenToNameEnv env nm moduleTyAcc moduleKind = let path = env.ePath @ [nm] - let cpath = env.eCompPath.NestedCompPath nm.idText modKind + let cpath = env.eCompPath.NestedCompPath nm.idText moduleKind + let nenv = + if addOpenToNameEnv then + { env.NameEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } + else + env.NameEnv + let ad = ComputeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType { env with ePath = path eCompPath = cpath eAccessPath = cpath - eAccessRights = ComputeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType // update this computed field - eNameResEnv = - if addOpenToNameEnv then - { env.NameEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } - else - env.NameEnv - eModuleOrNamespaceTypeAccumulator = mtypeAcc } + eAccessRights = ad + eNameResEnv = nenv + eModuleOrNamespaceTypeAccumulator = moduleTyAcc } /// Make an environment suitable for a module or namespace, creating a new accumulator. -let MakeInnerEnv addOpenToNameEnv env nm modKind = +let MakeInnerEnv addOpenToNameEnv env nm moduleKind = // Note: here we allocate a new module type accumulator - let mtypeAcc = ref (Construct.NewEmptyModuleOrNamespaceType modKind) - MakeInnerEnvWithAcc addOpenToNameEnv env nm mtypeAcc modKind, mtypeAcc + let moduleTyAcc = ref (Construct.NewEmptyModuleOrNamespaceType moduleKind) + MakeInnerEnvWithAcc addOpenToNameEnv env nm moduleTyAcc moduleKind, moduleTyAcc /// Make an environment suitable for processing inside a type definition let MakeInnerEnvForTyconRef env tcref isExtrinsicExtension = @@ -722,7 +727,7 @@ let UnifyAnonRecdTypeAndInferCharacteristics contextInfo (cenv: cenv) denv m ty anonInfo, ptys | ValueNone -> // Note: no known anonymous record type - use our assembly - let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, mkTupInfo isExplicitStruct, unsortedNames) + let anonInfo = AnonRecdTypeInfo.Create(cenv.thisCcu, mkTupInfo isExplicitStruct, unsortedNames) anonInfo, NewInferenceTypes g (Array.toList anonInfo.SortedNames) let ty2 = TType_anon (anonInfo, ptys) AddCxTypeEqualsType contextInfo denv cenv.css m ty ty2 @@ -855,11 +860,11 @@ let ForNewConstructors tcSink (env: TcEnv) mObjTy methodName meths = let rec TcSynRationalConst c = match c with | SynRationalConst.Integer i -> intToRational i - | SynRationalConst.Negate c' -> NegRational (TcSynRationalConst c') + | SynRationalConst.Negate c2 -> NegRational (TcSynRationalConst c2) | SynRationalConst.Rational(p, q, _) -> DivRational (intToRational p) (intToRational q) /// Typecheck constant terms in expressions and patterns -let TcConst (cenv: cenv) (overallTy: TType) m env c = +let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let g = cenv.g let rec tcMeasure ms = match ms with @@ -885,9 +890,9 @@ let TcConst (cenv: cenv) (overallTy: TType) m env c = let unif expected = UnifyTypes cenv env m overallTy expected - let unifyMeasureArg iszero tcr c = + let unifyMeasureArg iszero tcr = let measureTy = - match c with + match synConst with | SynConst.Measure(_, _, SynMeasure.Anon _) -> (mkAppTy tcr [TType_measure (Measure.Var (NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No)))]) @@ -898,38 +903,98 @@ let TcConst (cenv: cenv) (overallTy: TType) m env c = let expandedMeasurablesEnabled = g.langVersion.SupportsFeature LanguageFeature.ExpandedMeasurables - match c with - | SynConst.Unit -> unif g.unit_ty; Const.Unit - | SynConst.Bool i -> unif g.bool_ty; Const.Bool i - | SynConst.Single f -> unif g.float32_ty; Const.Single f - | SynConst.Double f -> unif g.float_ty; Const.Double f - | SynConst.Decimal f -> unif (mkAppTy g.decimal_tcr []); Const.Decimal f - | SynConst.SByte i -> unif g.sbyte_ty; Const.SByte i - | SynConst.Int16 i -> unif g.int16_ty; Const.Int16 i - | SynConst.Int32 i -> unif g.int_ty; Const.Int32 i - | SynConst.Int64 i -> unif g.int64_ty; Const.Int64 i - | SynConst.IntPtr i -> unif g.nativeint_ty; Const.IntPtr i - | SynConst.Byte i -> unif g.byte_ty; Const.Byte i - | SynConst.UInt16 i -> unif g.uint16_ty; Const.UInt16 i - | SynConst.UInt32 i -> unif g.uint32_ty; Const.UInt32 i - | SynConst.UInt64 i -> unif g.uint64_ty; Const.UInt64 i - | SynConst.UIntPtr i -> unif g.unativeint_ty; Const.UIntPtr i - | SynConst.Measure(SynConst.Single f, _, _) -> unifyMeasureArg (f=0.0f) g.pfloat32_tcr c; Const.Single f - | SynConst.Measure(SynConst.Double f, _, _) -> unifyMeasureArg (f=0.0) g.pfloat_tcr c; Const.Double f - | SynConst.Measure(SynConst.Decimal f, _, _) -> unifyMeasureArg false g.pdecimal_tcr c; Const.Decimal f - | SynConst.Measure(SynConst.SByte i, _, _) -> unifyMeasureArg (i=0y) g.pint8_tcr c; Const.SByte i - | SynConst.Measure(SynConst.Int16 i, _, _) -> unifyMeasureArg (i=0s) g.pint16_tcr c; Const.Int16 i - | SynConst.Measure(SynConst.Int32 i, _, _) -> unifyMeasureArg (i=0) g.pint_tcr c; Const.Int32 i - | SynConst.Measure(SynConst.Int64 i, _, _) -> unifyMeasureArg (i=0L) g.pint64_tcr c; Const.Int64 i - | SynConst.Measure(SynConst.IntPtr i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0L) g.pnativeint_tcr c; Const.IntPtr i - | SynConst.Measure(SynConst.Byte i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0uy) g.puint8_tcr c; Const.Byte i - | SynConst.Measure(SynConst.UInt16 i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0us) g.puint16_tcr c; Const.UInt16 i - | SynConst.Measure(SynConst.UInt32 i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0u) g.puint_tcr c; Const.UInt32 i - | SynConst.Measure(SynConst.UInt64 i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0UL) g.puint64_tcr c; Const.UInt64 i - | SynConst.Measure(SynConst.UIntPtr i, _, _) when expandedMeasurablesEnabled -> unifyMeasureArg (i=0UL) g.punativeint_tcr c; Const.UIntPtr i - | SynConst.Char c -> unif g.char_ty; Const.Char c + match synConst with + | SynConst.Unit -> + unif g.unit_ty + Const.Unit + | SynConst.Bool i -> + unif g.bool_ty + Const.Bool i + | SynConst.Single f -> + unif g.float32_ty + Const.Single f + | SynConst.Double f -> + unif g.float_ty + Const.Double f + | SynConst.Decimal f -> + unif (mkAppTy g.decimal_tcr []) + Const.Decimal f + | SynConst.SByte i -> + unif g.sbyte_ty + Const.SByte i + | SynConst.Int16 i -> + unif g.int16_ty + Const.Int16 i + | SynConst.Int32 i -> + unif g.int_ty + Const.Int32 i + | SynConst.Int64 i -> + unif g.int64_ty + Const.Int64 i + | SynConst.IntPtr i -> + unif g.nativeint_ty + Const.IntPtr i + | SynConst.Byte i -> + unif g.byte_ty + Const.Byte i + | SynConst.UInt16 i -> + unif g.uint16_ty + Const.UInt16 i + | SynConst.UInt32 i -> + unif g.uint32_ty + Const.UInt32 i + | SynConst.UInt64 i -> + unif g.uint64_ty + Const.UInt64 i + | SynConst.UIntPtr i -> + unif g.unativeint_ty + Const.UIntPtr i + | SynConst.Measure(SynConst.Single f, _, _) -> + unifyMeasureArg (f=0.0f) g.pfloat32_tcr + Const.Single f + | SynConst.Measure(SynConst.Double f, _, _) -> + unifyMeasureArg (f=0.0) g.pfloat_tcr + Const.Double f + | SynConst.Measure(SynConst.Decimal f, _, _) -> + unifyMeasureArg false g.pdecimal_tcr + Const.Decimal f + | SynConst.Measure(SynConst.SByte i, _, _) -> + unifyMeasureArg (i=0y) g.pint8_tcr + Const.SByte i + | SynConst.Measure(SynConst.Int16 i, _, _) -> + unifyMeasureArg (i=0s) g.pint16_tcr + Const.Int16 i + | SynConst.Measure(SynConst.Int32 i, _, _) -> + unifyMeasureArg (i=0) g.pint_tcr + Const.Int32 i + | SynConst.Measure(SynConst.Int64 i, _, _) -> + unifyMeasureArg (i=0L) g.pint64_tcr + Const.Int64 i + | SynConst.Measure(SynConst.IntPtr i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0L) g.pnativeint_tcr + Const.IntPtr i + | SynConst.Measure(SynConst.Byte i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0uy) g.puint8_tcr + Const.Byte i + | SynConst.Measure(SynConst.UInt16 i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0us) g.puint16_tcr + Const.UInt16 i + | SynConst.Measure(SynConst.UInt32 i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0u) g.puint_tcr + Const.UInt32 i + | SynConst.Measure(SynConst.UInt64 i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0UL) g.puint64_tcr + Const.UInt64 i + | SynConst.Measure(SynConst.UIntPtr i, _, _) when expandedMeasurablesEnabled -> + unifyMeasureArg (i=0UL) g.punativeint_tcr + Const.UIntPtr i + | SynConst.Char c -> + unif g.char_ty + Const.Char c | SynConst.String (s, _, _) - | SynConst.SourceIdentifier (_, s, _) -> unif g.string_ty; Const.String s + | SynConst.SourceIdentifier (_, s, _) -> + unif g.string_ty + Const.String s | SynConst.UserNum _ -> error (InternalError(FSComp.SR.tcUnexpectedBigRationalConstant(), m)) | SynConst.Measure _ -> error (Error(FSComp.SR.tcInvalidTypeForUnitsOfMeasure(), m)) | SynConst.UInt16s _ -> error (InternalError(FSComp.SR.tcUnexpectedConstUint16Array(), m)) @@ -956,8 +1021,8 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData, retData) as sigMD) = sigMD /// The ValReprInfo for a value, except the number of typars is not yet inferred -type PartialValReprInfo = - | PartialValReprInfo of +type PrelimValReprInfo = + | PrelimValReprInfo of curriedArgInfos: ArgReprInfo list list * returnInfo: ArgReprInfo @@ -984,16 +1049,16 @@ let TranslateTopArgSynInfo isArg m tcAttributes (SynArgInfo(Attributes attrs, is ({ Attribs = attribs; Name = nm } : ArgReprInfo) /// Members have an arity inferred from their syntax. This "valSynData" is not quite the same as the arities -/// used in the middle and backends of the compiler ("topValInfo"). -/// "0" in a valSynData (see arity_of_pat) means a "unit" arg in a topValInfo +/// used in the middle and backends of the compiler ("valReprInfo"). +/// "0" in a valSynData (see arity_of_pat) means a "unit" arg in a valReprInfo /// Hence remove all "zeros" from arity and replace them with 1 here. /// Note we currently use the compiled form for choosing unique names, to distinguish overloads because this must match up /// between signature and implementation, and the signature just has "unit". -let TranslateTopValSynInfo m tcAttributes (SynValInfo(argsData, retData)) = - PartialValReprInfo (argsData |> List.mapSquared (TranslateTopArgSynInfo true m (tcAttributes AttributeTargets.Parameter)), +let TranslateSynValInfo m tcAttributes (SynValInfo(argsData, retData)) = + PrelimValReprInfo (argsData |> List.mapSquared (TranslateTopArgSynInfo true m (tcAttributes AttributeTargets.Parameter)), retData |> TranslateTopArgSynInfo false m (tcAttributes AttributeTargets.ReturnValue)) -let TranslatePartialArity tps (PartialValReprInfo (argsData, retData)) = +let TranslatePartialValReprInfo tps (PrelimValReprInfo (argsData, retData)) = ValReprInfo(ValReprInfo.InferTyparInfo tps, argsData, retData) //------------------------------------------------------------------------- @@ -1012,8 +1077,8 @@ let ComputeLogicalName (id: Ident) (memberFlags: SynMemberFlags) = | SynMemberKind.PropertyGet -> "get_" + id.idText | SynMemberKind.PropertySet -> "set_" + id.idText -type PreValMemberInfo = - | PreValMemberInfo of +type PrelimMemberInfo = + | PrelimMemberInfo of memberInfo: ValMemberInfo * logicalName: string * compiledName: string @@ -1021,9 +1086,11 @@ type PreValMemberInfo = /// Make the unique "name" for a member. // // optImplSlotTy = None (for classes) or Some ty (when implementing interface type ty) -let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optImplSlotTys, memberFlags, valSynData, id, isCompGen) = +let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, implSlotTys, memberFlags, valSynData, id, isCompGen) = let logicalName = ComputeLogicalName id memberFlags - let optIntfSlotTys = if optImplSlotTys |> List.forall (isInterfaceTy g) then optImplSlotTys else [] + + let intfSlotTys = if implSlotTys |> List.forall (isInterfaceTy g) then implSlotTys else [] + let memberInfo: ValMemberInfo = { ApparentEnclosingEntity=tcref MemberFlags=memberFlags @@ -1031,11 +1098,14 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optIm // NOTE: This value is initially only set for interface implementations and those overrides // where we manage to pre-infer which abstract is overridden by the method. It is filled in // properly when we check the allImplemented implementation checks at the end of the inference scope. - ImplementedSlotSigs=optImplSlotTys |> List.map (fun ity -> TSlotSig(logicalName, ity, [], [], [], None)) } + ImplementedSlotSigs=implSlotTys |> List.map (fun ity -> TSlotSig(logicalName, ity, [], [], [], None)) } + let isInstance = MemberIsCompiledAsInstance g tcref isExtrinsic memberInfo attrs - if (memberFlags.IsDispatchSlot || not (isNil optIntfSlotTys)) then + + if (memberFlags.IsDispatchSlot || not (isNil intfSlotTys)) then if not isInstance then errorR(VirtualAugmentationOnNullValuedType(id.idRange)) + elif not memberFlags.IsOverrideOrExplicitImpl && memberFlags.IsInstance then if not isExtrinsic && not isInstance then warning(NonVirtualAugmentationOnNullValuedType(id.idRange)) @@ -1047,13 +1117,13 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optIm let text = if memberFlags.MemberKind <> SynMemberKind.Constructor && memberFlags.MemberKind <> SynMemberKind.ClassConstructor && not memberFlags.IsInstance then text + ".Static" else text let text = if memberFlags.IsOverrideOrExplicitImpl then text + ".Override" else text text - else if not optIntfSlotTys.IsEmpty then + elif not intfSlotTys.IsEmpty then // interface implementation - if optIntfSlotTys.Length > 1 then - failwithf "unexpected: optIntfSlotTys.Length > 1 (== %i) in MakeMemberDataAndMangledNameForMemberVal for '%s'" optIntfSlotTys.Length logicalName - qualifiedInterfaceImplementationName g optIntfSlotTys.Head logicalName + if intfSlotTys.Length > 1 then + failwithf "unexpected: intfSlotTys.Length > 1 (== %i) in MakeMemberDataAndMangledNameForMemberVal for '%s'" intfSlotTys.Length logicalName + qualifiedInterfaceImplementationName g intfSlotTys.Head logicalName else - List.foldBack (fun x -> qualifiedMangledNameOfTyconRef (tcrefOfAppTy g x)) optIntfSlotTys logicalName + List.foldBack (fun x -> qualifiedMangledNameOfTyconRef (tcrefOfAppTy g x)) intfSlotTys logicalName if not isCompGen && IsMangledOpName id.idText && IsMangledInfixOperator id.idText then let m = id.idRange @@ -1070,7 +1140,7 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optIm if isExtrinsic && IsMangledOpName id.idText then warning(Error(FSComp.SR.tcMemberOperatorDefinitionInExtrinsic(), id.idRange)) - PreValMemberInfo(memberInfo, logicalName, compiledName) + PrelimMemberInfo(memberInfo, logicalName, compiledName) type OverridesOK = | OverridesOK @@ -1190,62 +1260,61 @@ type DeclKind = /// The results of preliminary pass over patterns to extract variables being declared. // We should make this a record for cleaner code -type PrelimValScheme1 = - | PrelimValScheme1 of +type PrelimVal1 = + | PrelimVal1 of id: Ident * explicitTyparInfo: ExplicitTyparInfo * - TType * - PartialValReprInfo option * - PreValMemberInfo option * - bool * - ValInline * - ValBaseOrThisInfo * - ArgAndRetAttribs * - SynAccess option * - bool + prelimType: TType * + prelimValReprInfo: PrelimValReprInfo option * + memberInfoOpt: PrelimMemberInfo option * + isMutable: bool * + inlineFlag: ValInline * + baseOrThisInfo: ValBaseOrThisInfo * + argAttribs: ArgAndRetAttribs * + visibility: SynAccess option * + isCompGen: bool - member x.Type = let (PrelimValScheme1(_, _, ty, _, _, _, _, _, _, _, _)) = x in ty + member x.Type = let (PrelimVal1(prelimType=ty)) = x in ty - member x.Ident = let (PrelimValScheme1(id, _, _, _, _, _, _, _, _, _, _)) = x in id + member x.Ident = let (PrelimVal1(id=id)) = x in id /// The results of applying let-style generalization after type checking. // We should make this a record for cleaner code -type PrelimValScheme2 = - PrelimValScheme2 of - Ident * - TypeScheme * - PartialValReprInfo option * - PreValMemberInfo option * - bool * - ValInline * - ValBaseOrThisInfo * - ArgAndRetAttribs * - SynAccess option * - bool * - bool (* hasDeclaredTypars *) - - -/// The results of applying arity inference to PrelimValScheme2 +type PrelimVal2 = + PrelimVal2 of + id: Ident * + prelimType: GeneralizedType * + prelimValReprInfo: PrelimValReprInfo option * + memberInfoOpt: PrelimMemberInfo option * + isMutable: bool * + inlineFlag: ValInline * + baseOrThisInfo: ValBaseOrThisInfo * + argAttribs: ArgAndRetAttribs * + visibility: SynAccess option * + isCompGen: bool * + hasDeclaredTypars: bool + +/// The results of applying arity inference to PrelimVal2 type ValScheme = | ValScheme of id: Ident * - typeScheme: TypeScheme * - topValInfo: ValReprInfo option * - memberInfo: PreValMemberInfo option * + typeScheme: GeneralizedType * + valReprInfo: ValReprInfo option * + memberInfo: PrelimMemberInfo option * isMutable: bool * inlineInfo: ValInline * baseOrThisInfo: ValBaseOrThisInfo * visibility: SynAccess option * - compgen: bool * + isCompGen: bool * isIncrClass: bool * isTyFunc: bool * hasDeclaredTypars: bool - member x.GeneralizedTypars = let (ValScheme(_, TypeScheme(gtps, _), _, _, _, _, _, _, _, _, _, _)) = x in gtps + member x.GeneralizedTypars = let (ValScheme(typeScheme=GeneralizedType(gtps, _))) = x in gtps - member x.TypeScheme = let (ValScheme(_, ts, _, _, _, _, _, _, _, _, _, _)) = x in ts + member x.GeneralizedType = let (ValScheme(typeScheme=ts)) = x in ts - member x.ValReprInfo = let (ValScheme(_, _, topValInfo, _, _, _, _, _, _, _, _, _)) = x in topValInfo + member x.ValReprInfo = let (ValScheme(valReprInfo=valReprInfo)) = x in valReprInfo /// Translation of patterns is split into three phases. The first collects names. /// The second is run after val_specs have been created for those names and inference @@ -1253,13 +1322,14 @@ type ValScheme = /// first phase. The input to the second phase is a List.map that gives the Val and type scheme /// for each value bound by the pattern. type TcPatPhase2Input = - | TcPatPhase2Input of (Val * TypeScheme) NameMap * bool + | TcPatPhase2Input of NameMap * bool + // Get an input indicating we are no longer on the left-most path through a disjunctive "or" pattern - member x.RightPath = (let (TcPatPhase2Input(a, _)) = x in TcPatPhase2Input(a, false)) + member x.WithRightPath() = (let (TcPatPhase2Input(a, _)) = x in TcPatPhase2Input(a, false)) /// The first phase of checking and elaborating a binding leaves a goop of information. /// This is a bit of a mess: much of this information is also carried on a per-value basis by the -/// "NameMap". +/// "NameMap". type CheckedBindingInfo = | CheckedBindingInfo of inlineFlag: ValInline * @@ -1267,25 +1337,27 @@ type CheckedBindingInfo = xmlDoc: XmlDoc * tcPatPhase2: (TcPatPhase2Input -> Pattern) * exlicitTyparInfo: ExplicitTyparInfo * - nameToPrelimValSchemeMap: NameMap * + nameToPrelimValSchemeMap: NameMap * rhsExprChecked: Expr * argAndRetAttribs: ArgAndRetAttribs * overallPatTy: TType * mBinding: range * - spBind: DebugPointAtBinding * + debugPoint: DebugPointAtBinding * isCompilerGenerated: bool * literalValue: Const option * isFixed: bool - member x.Expr = let (CheckedBindingInfo(_, _, _, _, _, _, expr, _, _, _, _, _, _, _)) = x in expr - member x.DebugPoint = let (CheckedBindingInfo(_, _, _, _, _, _, _, _, _, _, spBind, _, _, _)) = x in spBind + + member x.Expr = let (CheckedBindingInfo(rhsExprChecked=expr)) = x in expr + + member x.DebugPoint = let (CheckedBindingInfo(debugPoint=debugPoint)) = x in debugPoint /// Return the generalized type for a type scheme let GeneralizedTypeForTypeScheme typeScheme = - let (TypeScheme(generalizedTypars, tau)) = typeScheme + let (GeneralizedType(generalizedTypars, tau)) = typeScheme mkForallTyIfNeeded generalizedTypars tau /// Create a type scheme for something that is not generic -let NonGenericTypeScheme ty = TypeScheme([], ty) +let NonGenericTypeScheme ty = GeneralizedType([], ty) //------------------------------------------------------------------------- // Helpers related to publishing values, types and members into the @@ -1297,9 +1369,9 @@ let UpdateAccModuleOrNamespaceType cenv env f = // the compiler can be resolved ASAP. Not at all pretty but it's hard to // find good ways to do references from the compiler into a term graph. if cenv.compilingCanonicalFslibModuleType then - let nleref = mkNonLocalEntityRef cenv.topCcu (arrPathOfLid env.ePath) + let nleref = mkNonLocalEntityRef cenv.thisCcu (arrPathOfLid env.ePath) let modul = nleref.Deref - modul.entity_modul_contents <- MaybeLazy.Strict (f true modul.ModuleOrNamespaceType) + modul.entity_modul_type <- MaybeLazy.Strict (f true modul.ModuleOrNamespaceType) SetCurrAccumulatedModuleOrNamespaceType env (f false (GetCurrAccumulatedModuleOrNamespaceType env)) let PublishModuleDefn cenv env mspec = @@ -1414,11 +1486,11 @@ let CheckForAbnormalOperatorNames (cenv: cenv) (idRange: range) coreDisplayName warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes opName, idRange)) | Other -> () -let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, vscheme, attrs, doc, konst, isGeneratedEventVal) = +let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, valRecInfo, vscheme, attrs, xmlDoc, konst, isGeneratedEventVal) = let g = cenv.g - let (ValScheme(id, typeScheme, topValInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, compgen, isIncrClass, isTyFunc, hasDeclaredTypars)) = vscheme + let (ValScheme(id, typeScheme, valReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, isCompGen, isIncrClass, isTyFunc, hasDeclaredTypars)) = vscheme let ty = GeneralizedTypeForTypeScheme typeScheme @@ -1437,7 +1509,7 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, // Use the parent of the member if it's available // If it's an extrinsic extension member or not a member then use the containing module. match memberInfoOpt with - | Some (PreValMemberInfo(memberInfo, _, _)) when not isExtrinsic -> + | Some (PrelimMemberInfo(memberInfo, _, _)) when not isExtrinsic -> if memberInfo.ApparentEnclosingEntity.IsModuleOrNamespace then errorR(InternalError(FSComp.SR.tcExpectModuleOrNamespaceParent(id.idText), m)) @@ -1477,7 +1549,7 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, let compiledNameAttrib = TryFindFSharpStringAttribute g g.attrib_CompiledNameAttribute attrs if Option.isSome compiledNameAttrib then match memberInfoOpt with - | Some (PreValMemberInfo(memberInfo, _, _)) -> + | Some (PrelimMemberInfo(memberInfo, _, _)) -> if memberInfo.MemberFlags.IsDispatchSlot || memberInfo.MemberFlags.IsOverrideOrExplicitImpl then errorR(Error(FSComp.SR.tcCompiledNameAttributeMisused(), m)) | None -> @@ -1487,7 +1559,7 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, let compiledNameIsOnProp = match memberInfoOpt with - | Some (PreValMemberInfo(memberInfo, _, _)) -> + | Some (PrelimMemberInfo(memberInfo, _, _)) -> memberInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGet || memberInfo.MemberFlags.MemberKind = SynMemberKind.PropertySet || memberInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGetSet @@ -1499,21 +1571,21 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, | Some _ when not compiledNameIsOnProp -> compiledNameAttrib | _ -> match memberInfoOpt with - | Some (PreValMemberInfo(_, _, compiledName)) -> + | Some (PrelimMemberInfo(_, _, compiledName)) -> Some compiledName | None -> None let logicalName = match memberInfoOpt with - | Some (PreValMemberInfo(_, logicalName, _)) -> + | Some (PrelimMemberInfo(_, logicalName, _)) -> logicalName | None -> id.idText let memberInfoOpt = match memberInfoOpt with - | Some (PreValMemberInfo(memberInfo, _, _)) -> + | Some (PrelimMemberInfo(memberInfo, _, _)) -> Some memberInfo | None -> None @@ -1522,8 +1594,8 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, let vspec = Construct.NewVal (logicalName, id.idRange, compiledName, ty, mut, - compgen, topValInfo, vis, vrec, memberInfoOpt, baseOrThis, attrs, inlineFlag, - doc, isTopBinding, isExtrinsic, isIncrClass, isTyFunc, + isCompGen, valReprInfo, vis, valRecInfo, memberInfoOpt, baseOrThis, attrs, inlineFlag, + xmlDoc, isTopBinding, isExtrinsic, isIncrClass, isTyFunc, (hasDeclaredTypars || inSig), isGeneratedEventVal, konst, actualParent) @@ -1552,10 +1624,10 @@ let MakeAndPublishVal (cenv: cenv) env (altActualParent, inSig, declKind, vrec, vspec -let MakeAndPublishVals cenv env (altActualParent, inSig, declKind, vrec, valSchemes, attrs, doc, literalValue) = +let MakeAndPublishVals cenv env (altActualParent, inSig, declKind, valRecInfo, valSchemes, attrs, xmlDoc, literalValue) = Map.foldBack (fun name (valscheme: ValScheme) values -> - Map.add name (MakeAndPublishVal cenv env (altActualParent, inSig, declKind, vrec, valscheme, attrs, doc, literalValue, false), valscheme.TypeScheme) values) + Map.add name (MakeAndPublishVal cenv env (altActualParent, inSig, declKind, valRecInfo, valscheme, attrs, xmlDoc, literalValue, false), valscheme.GeneralizedType) values) valSchemes Map.empty @@ -1589,8 +1661,8 @@ let MakeAndPublishSafeThisVal (cenv: cenv) env (thisIdOpt: Ident option) thisTy /// Fixup the type instantiation at recursive references. Used after the bindings have been /// checked. The fixups are applied by using mutation. let AdjustAndForgetUsesOfRecValue cenv (vrefTgt: ValRef) (valScheme: ValScheme) = - let (TypeScheme(generalizedTypars, _)) = valScheme.TypeScheme - let valTy = GeneralizedTypeForTypeScheme valScheme.TypeScheme + let (GeneralizedType(generalizedTypars, _)) = valScheme.GeneralizedType + let valTy = GeneralizedTypeForTypeScheme valScheme.GeneralizedType let lvrefTgt = vrefTgt.Deref if not (isNil generalizedTypars) then // Find all the uses of this recursive binding and use mutation to adjust the expressions @@ -1617,17 +1689,17 @@ let AdjustAndForgetUsesOfRecValue cenv (vrefTgt: ValRef) (valScheme: ValScheme) /// Set the properties of recursive values that are only fully known after inference is complete let AdjustRecType (v: Val) vscheme = - let (ValScheme(typeScheme=typeScheme; topValInfo=topValInfo)) = vscheme + let (ValScheme(typeScheme=typeScheme; valReprInfo=valReprInfo)) = vscheme let valTy = GeneralizedTypeForTypeScheme typeScheme v.SetType valTy - v.SetValReprInfo topValInfo + v.SetValReprInfo valReprInfo v.SetValRec (ValInRecScope true) /// Record the generated value expression as a place where we will have to /// adjust using AdjustAndForgetUsesOfRecValue at a letrec point. Every use of a value /// under a letrec gets used at the _same_ type instantiation. -let RecordUseOfRecValue cenv vrec (vrefTgt: ValRef) vexp m = - match vrec with +let RecordUseOfRecValue cenv valRecInfo (vrefTgt: ValRef) vexp m = + match valRecInfo with | ValInRecScope isComplete -> let fixupPoint = ref vexp cenv.recUses <- cenv.recUses.Add (vrefTgt.Deref, (fixupPoint, m, isComplete)) @@ -1660,11 +1732,11 @@ let ChooseCanonicalDeclaredTyparsAfterInference g denv declaredTypars m = declaredTypars let ChooseCanonicalValSchemeAfterInference g denv vscheme m = - let (ValScheme(id, typeScheme, arityInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, compgen, isIncrClass, isTyFunc, hasDeclaredTypars)) = vscheme - let (TypeScheme(generalizedTypars, ty)) = typeScheme + let (ValScheme(id, typeScheme, arityInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, isCompGen, isIncrClass, isTyFunc, hasDeclaredTypars)) = vscheme + let (GeneralizedType(generalizedTypars, ty)) = typeScheme let generalizedTypars = ChooseCanonicalDeclaredTyparsAfterInference g denv generalizedTypars m - let typeScheme = TypeScheme(generalizedTypars, ty) - let valscheme = ValScheme(id, typeScheme, arityInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, compgen, isIncrClass, isTyFunc, hasDeclaredTypars) + let typeScheme = GeneralizedType(generalizedTypars, ty) + let valscheme = ValScheme(id, typeScheme, arityInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, isCompGen, isIncrClass, isTyFunc, hasDeclaredTypars) valscheme let PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars = @@ -1681,7 +1753,7 @@ let SetTyparRigid denv m (tp: Typar) = tp.SetRigidity TyparRigidity.Rigid let GeneralizeVal (cenv: cenv) denv enclosingDeclaredTypars generalizedTyparsForThisBinding - (PrelimValScheme1(id, explicitTyparInfo, ty, partialValReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, compgen)) = + (PrelimVal1(id, explicitTyparInfo, ty, prelimValReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, isCompGen)) = let g = cenv.g @@ -1713,20 +1785,20 @@ let GeneralizeVal (cenv: cenv) denv enclosingDeclaredTypars generalizedTyparsFor warning(Error(FSComp.SR.tcTypeParametersInferredAreNotStable(), m)) let hasDeclaredTypars = not (isNil declaredTypars) - // This is just about the only place we form a TypeScheme - let tyScheme = TypeScheme(generalizedTypars, ty) - PrelimValScheme2(id, tyScheme, partialValReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, compgen, hasDeclaredTypars) + // This is just about the only place we form a GeneralizedType + let tyScheme = GeneralizedType(generalizedTypars, ty) + PrelimVal2(id, tyScheme, prelimValReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, isCompGen, hasDeclaredTypars) let GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars types = NameMap.map (GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars) types let DontGeneralizeVals types = - let dontGeneralizeVal (PrelimValScheme1(id, _, ty, partialValReprInfoOpt, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, compgen)) = - PrelimValScheme2(id, NonGenericTypeScheme ty, partialValReprInfoOpt, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, compgen, false) + let dontGeneralizeVal (PrelimVal1(id, _, ty, partialValReprInfoOpt, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, isCompGen)) = + PrelimVal2(id, NonGenericTypeScheme ty, partialValReprInfoOpt, memberInfoOpt, isMutable, inlineFlag, baseOrThis, argAttribs, vis, isCompGen, false) NameMap.map dontGeneralizeVal types -let InferGenericArityFromTyScheme (TypeScheme(generalizedTypars, _)) partialValReprInfo = - TranslatePartialArity generalizedTypars partialValReprInfo +let InferGenericArityFromTyScheme (GeneralizedType(generalizedTypars, _)) prelimValReprInfo = + TranslatePartialValReprInfo generalizedTypars prelimValReprInfo let ComputeIsTyFunc(id: Ident, hasDeclaredTypars, arityInfo: ValReprInfo option) = hasDeclaredTypars && @@ -1734,9 +1806,9 @@ let ComputeIsTyFunc(id: Ident, hasDeclaredTypars, arityInfo: ValReprInfo option) | None -> error(Error(FSComp.SR.tcExplicitTypeParameterInvalid(), id.idRange)) | Some info -> info.NumCurriedArgs = 0) -let UseSyntacticArity declKind typeScheme partialValReprInfo = +let UseSyntacticArity declKind typeScheme prelimValReprInfo = if DeclKind.MustHaveArity declKind then - Some(InferGenericArityFromTyScheme typeScheme partialValReprInfo) + Some(InferGenericArityFromTyScheme typeScheme prelimValReprInfo) else None @@ -1774,10 +1846,10 @@ let UseSyntacticArity declKind typeScheme partialValReprInfo = // member x.M(v: unit) = () } // let CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme = - let (PrelimValScheme2(_, typeScheme, partialValReprInfoOpt, memberInfoOpt, isMutable, _, _, ArgAndRetAttribs(argAttribs, retAttribs), _, _, _)) = prelimScheme + let (PrelimVal2(_, typeScheme, partialValReprInfoOpt, memberInfoOpt, isMutable, _, _, ArgAndRetAttribs(argAttribs, retAttribs), _, _, _)) = prelimScheme match partialValReprInfoOpt, DeclKind.MustHaveArity declKind with | _, false -> None - | None, true -> Some(PartialValReprInfo([], ValReprInfo.unnamedRetVal)) + | None, true -> Some(PrelimValReprInfo([], ValReprInfo.unnamedRetVal)) // Don't use any expression information for members, where syntax dictates the arity completely | _ when memberInfoOpt.IsSome -> partialValReprInfoOpt @@ -1785,10 +1857,10 @@ let CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme = | _ when retAttribs.Length > 0 -> partialValReprInfoOpt | Some partialValReprInfoFromSyntax, true -> - let (PartialValReprInfo(curriedArgInfosFromSyntax, retInfoFromSyntax)) = partialValReprInfoFromSyntax + let (PrelimValReprInfo(curriedArgInfosFromSyntax, retInfoFromSyntax)) = partialValReprInfoFromSyntax let partialArityInfo = if isMutable then - PartialValReprInfo ([], retInfoFromSyntax) + PrelimValReprInfo ([], retInfoFromSyntax) else let (ValReprInfo (_, curriedArgInfosFromExpression, _)) = @@ -1811,19 +1883,19 @@ let CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme = | [], ais | ais, [] -> ais | h1 :: t1, h2 :: t2 -> choose h1 h2 :: loop t1 t2 let curriedArgInfos = loop curriedArgInfosFromSyntax curriedArgInfosFromExpression - PartialValReprInfo (curriedArgInfos, retInfoFromSyntax) + PrelimValReprInfo (curriedArgInfos, retInfoFromSyntax) Some partialArityInfo let BuildValScheme declKind partialArityInfoOpt prelimScheme = - let (PrelimValScheme2(id, typeScheme, _, memberInfoOpt, isMutable, inlineFlag, baseOrThis, _, vis, compgen, hasDeclaredTypars)) = prelimScheme - let topValInfo = + let (PrelimVal2(id, typeScheme, _, memberInfoOpt, isMutable, inlineFlag, baseOrThis, _, vis, isCompGen, hasDeclaredTypars)) = prelimScheme + let valReprInfo = if DeclKind.MustHaveArity declKind then Option.map (InferGenericArityFromTyScheme typeScheme) partialArityInfoOpt else None - let isTyFunc = ComputeIsTyFunc(id, hasDeclaredTypars, topValInfo) - ValScheme(id, typeScheme, topValInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, compgen, false, isTyFunc, hasDeclaredTypars) + let isTyFunc = ComputeIsTyFunc(id, hasDeclaredTypars, valReprInfo) + ValScheme(id, typeScheme, valReprInfo, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, isCompGen, false, isTyFunc, hasDeclaredTypars) let UseCombinedArity g declKind rhsExpr prelimScheme = let partialArityInfoOpt = CombineSyntacticAndInferredArities g declKind rhsExpr prelimScheme @@ -1963,11 +2035,11 @@ let FreshenAbstractSlot g amap m synTyparDecls absMethInfo = let retTyFromAbsSlot = retTy |> GetFSharpViewOfReturnType g |> instType typarInstFromAbsSlot typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot - //------------------------------------------------------------------------- // Helpers to typecheck expressions and patterns //------------------------------------------------------------------------- +/// Helper used to check record expressions and record patterns let BuildFieldMap (cenv: cenv) env isPartial ty flds m = let g = cenv.g let ad = env.eAccessRights @@ -1976,7 +2048,7 @@ let BuildFieldMap (cenv: cenv) env isPartial ty flds m = let fldCount = flds.Length - let frefSets = + let fldResolutions = let allFields = flds |> List.map (fun ((_, ident), _) -> ident) flds |> List.map (fun (fld, fldExpr) -> @@ -1984,11 +2056,15 @@ let BuildFieldMap (cenv: cenv) env isPartial ty flds m = fld, frefSet, fldExpr) let relevantTypeSets = - frefSets |> List.map (fun (_, frefSet, _) -> frefSet |> List.map (fun (FieldResolution(rfinfo, _)) -> rfinfo.TypeInst, rfinfo.TyconRef)) + fldResolutions |> List.map (fun (_, frefSet, _) -> + frefSet |> List.map (fun (FieldResolution(rfinfo, _)) -> + rfinfo.TypeInst, rfinfo.TyconRef)) let tinst, tcref = - match List.fold (ListSet.intersect (fun (_, tcref1) (_, tcref2) -> tyconRefEq g tcref1 tcref2)) (List.head relevantTypeSets) (List.tail relevantTypeSets) with - | [tinst, tcref] -> tinst, tcref + let first, rest = List.headAndTail relevantTypeSets + match (first, rest) ||> List.fold (ListSet.intersect (fun (_, tcref1) (_, tcref2) -> tyconRefEq g tcref1 tcref2)) with + | [ (tinst, tcref) ] -> + tinst, tcref | tcrefs -> if isPartial then warning (Error(FSComp.SR.tcFieldsDoNotDetermineUniqueRecordType(), m)) @@ -2000,12 +2076,12 @@ let BuildFieldMap (cenv: cenv) env isPartial ty flds m = // OK, there isn't a unique, good type dictated by the intersection for the field refs. // We're going to get an error of some kind below. // Just choose one field ref and let the error come later - let _, frefSet1, _ = List.head frefSets + let _, frefSet1, _ = List.head fldResolutions let (FieldResolution(rfinfo1, _)) = List.head frefSet1 rfinfo1.TypeInst, rfinfo1.TyconRef let fldsmap, rfldsList = - ((Map.empty, []), frefSets) ||> List.fold (fun (fs, rfldsList) (fld, frefs, fldExpr) -> + ((Map.empty, []), fldResolutions) ||> List.fold (fun (fs, rfldsList) (fld, frefs, fldExpr) -> match frefs |> List.filter (fun (FieldResolution(rfinfo2, _)) -> tyconRefEq g tcref rfinfo2.TyconRef) with | [FieldResolution(rfinfo2, showDeprecated)] -> @@ -2014,15 +2090,18 @@ let BuildFieldMap (cenv: cenv) env isPartial ty flds m = CallNameResolutionSink cenv.tcSink ((snd fld).idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ad) let fref2 = rfinfo2.RecdFieldRef + CheckRecdFieldAccessible cenv.amap m env.eAccessRights fref2 |> ignore + CheckFSharpAttributes g fref2.PropertyAttribs m |> CommitOperationResult + if Map.containsKey fref2.FieldName fs then errorR (Error(FSComp.SR.tcFieldAppearsTwiceInRecord(fref2.FieldName), m)) if showDeprecated then warning(Deprecated(FSComp.SR.nrRecordTypeNeedsQualifiedAccess(fref2.FieldName, fref2.Tycon.DisplayName) |> snd, m)) if not (tyconRefEq g tcref fref2.TyconRef) then - let _, frefSet1, _ = List.head frefSets + let _, frefSet1, _ = List.head fldResolutions let (FieldResolution(rfinfo1, _)) = List.head frefSet1 errorR (FieldsFromDifferentTypes(env.DisplayEnv, rfinfo1.RecdFieldRef, fref2, m)) fs, rfldsList @@ -2068,17 +2147,19 @@ let ApplyUnionCaseOrExnTypesForPat m cenv env overallTy c = let UnionCaseOrExnCheck (env: TcEnv) numArgTys numArgs m = if numArgs <> numArgTys then error (UnionCaseWrongArguments(env.DisplayEnv, numArgTys, numArgs, m)) -let TcUnionCaseOrExnField cenv (env: TcEnv) ty1 m c n funcs = +let TcUnionCaseOrExnField cenv (env: TcEnv) ty1 m longId fieldNum funcs = let ad = env.eAccessRights + let mkf, argTys, _argNames = - match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false m ad env.eNameResEnv TypeNameResolutionInfo.Default c with - | Item.UnionCase _ | Item.ExnCase _ as item -> - ApplyUnionCaseOrExn funcs m cenv env ty1 item - | _ -> error(Error(FSComp.SR.tcUnknownUnion(), m)) - let argstysLength = List.length argTys - if n >= argstysLength then - error (UnionCaseWrongNumberOfArgs(env.DisplayEnv, argstysLength, n, m)) - let ty2 = List.item n argTys + match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with + | Item.UnionCase _ | Item.ExnCase _ as item -> + ApplyUnionCaseOrExn funcs m cenv env ty1 item + | _ -> error(Error(FSComp.SR.tcUnknownUnion(), m)) + + if fieldNum >= argTys.Length then + error (UnionCaseWrongNumberOfArgs(env.DisplayEnv, argTys.Length, fieldNum, m)) + + let ty2 = List.item fieldNum argTys mkf, ty2 //------------------------------------------------------------------------- @@ -2094,6 +2175,7 @@ module GeneralizationHelpers = let ComputeUngeneralizableTypars env = let acc = List() + for item in env.eUngeneralizableItems do if not item.WillNeverHaveFreeTypars then let ftps = item.GetFreeTyvars().FreeTypars @@ -2132,8 +2214,8 @@ module GeneralizationHelpers = | Expr.Val (vref, _, m) -> not (isByrefLikeTy g m vref.Type) // Look through coercion nodes corresponding to introduction of subsumption - | Expr.Op (TOp.Coerce, [inputTy;actualTy], [e1], _) when isFunTy g actualTy && isFunTy g inputTy -> - IsGeneralizableValue g e1 + | Expr.Op (TOp.Coerce, [inputTy;actualTy], [expr1], _) when isFunTy g actualTy && isFunTy g inputTy -> + IsGeneralizableValue g expr1 | Expr.Op (op, _, args, _) -> @@ -2166,7 +2248,7 @@ module GeneralizationHelpers = | Expr.App (Expr.Val (vref, _, _), _, _, [], _) when vref.IsTypeFunction -> HasFSharpAttribute g g.attrib_GeneralizableValueAttribute vref.Attribs - | Expr.App (e1, _, _, [], _) -> IsGeneralizableValue g e1 + | Expr.App (expr1, _, _, [], _) -> IsGeneralizableValue g expr1 | Expr.TyChoose (_, b, _) -> IsGeneralizableValue g b | Expr.Obj (_, ty, _, _, _, _, _) -> isInterfaceTy g ty || isDelegateTy g ty | Expr.Link eref -> IsGeneralizableValue g eref.Value @@ -2269,8 +2351,9 @@ module GeneralizationHelpers = let condensationTypars, generalizedTypars = generalizedTypars |> List.partition IsCondensationTypar // Condensation solves type variables eagerly and removes them from the generalization set - condensationTypars |> List.iter (fun tp -> - ChooseTyparSolutionAndSolve cenv.css denv tp) + for tp in condensationTypars do + ChooseTyparSolutionAndSolve cenv.css denv tp + generalizedTypars let ComputeAndGeneralizeGenericTypars (cenv, @@ -2360,8 +2443,6 @@ module GeneralizationHelpers = | Parent tcref -> not tcref.IsFSharpDelegateTycon | _ -> true) // no generic parameters inferred for 'Invoke' method - - //------------------------------------------------------------------------- // ComputeInlineFlag //------------------------------------------------------------------------- @@ -2378,8 +2459,10 @@ let ComputeInlineFlag (memFlagsOption: SynMemberFlags option) isInline isMutable then ValInline.Never elif isInline then ValInline.Always else ValInline.Optional + if isInline && (inlineFlag <> ValInline.Always) then errorR(Error(FSComp.SR.tcThisValueMayNotBeInlined(), m)) + inlineFlag @@ -2425,9 +2508,9 @@ type NormalizedBindingRhs = returnTyOpt: SynBindingReturnInfo option * rhsExpr: SynExpr -let PushOnePatternToRhs (cenv: cenv) isMember p (NormalizedBindingRhs(spatsL, rtyOpt, rhsExpr)) = - let spats, rhsExpr = PushPatternToExpr cenv.synArgNameGenerator isMember p rhsExpr - NormalizedBindingRhs(spats :: spatsL, rtyOpt, rhsExpr) +let PushOnePatternToRhs (cenv: cenv) isMember synPat (NormalizedBindingRhs(simplePatsList, retTyOpt, rhsExpr)) = + let simplePats, rhsExpr = PushPatternToExpr cenv.synArgNameGenerator isMember synPat rhsExpr + NormalizedBindingRhs(simplePats :: simplePatsList, retTyOpt, rhsExpr) type NormalizedBindingPatternInfo = NormalizedBindingPat of SynPat * NormalizedBindingRhs * SynValData * SynValTyparDecls @@ -2492,13 +2575,21 @@ module BindingNormalization = let private NormalizeInstanceMemberBinding cenv (memberFlags: SynMemberFlags) valSynData thisId memberId (toolId: Ident option) vis typars args m rhsExpr = let (SynValData(_, valSynInfo, thisIdOpt)) = valSynData + if not memberFlags.IsInstance then // static method with adhoc "this" argument error(Error(FSComp.SR.tcStaticMemberShouldNotHaveThis(), m)) + match args, memberFlags.MemberKind with - | _, SynMemberKind.ClassConstructor -> error(Error(FSComp.SR.tcExplicitStaticInitializerSyntax(), m)) - | _, SynMemberKind.Constructor -> error(Error(FSComp.SR.tcExplicitObjectConstructorSyntax(), m)) - | _, SynMemberKind.PropertyGetSet -> error(Error(FSComp.SR.tcUnexpectedPropertySpec(), m)) + | _, SynMemberKind.ClassConstructor -> + error(Error(FSComp.SR.tcExplicitStaticInitializerSyntax(), m)) + + | _, SynMemberKind.Constructor -> + error(Error(FSComp.SR.tcExplicitObjectConstructorSyntax(), m)) + + | _, SynMemberKind.PropertyGetSet -> + error(Error(FSComp.SR.tcUnexpectedPropertySpec(), m)) + // Instance property declared using 'x.Member': transformed to methods taking a "this" and a "unit" argument // We push across the 'this' arg in mk_rec_binds | [], SynMemberKind.Member -> @@ -2510,16 +2601,19 @@ module BindingNormalization = SynValData(Some memberFlags, valSynInfo, thisIdOpt), typars) - | _ -> MakeNormalizedInstanceMemberBinding cenv thisId memberId toolId vis m typars args rhsExpr valSynData + | _ -> + MakeNormalizedInstanceMemberBinding cenv thisId memberId toolId vis m typars args rhsExpr valSynData - let private NormalizeBindingPattern cenv nameResolver isObjExprBinding (env: TcEnv) valSynData pat rhsExpr = + let private NormalizeBindingPattern cenv nameResolver isObjExprBinding (env: TcEnv) valSynData headPat rhsExpr = let ad = env.AccessRights let (SynValData(memberFlagsOpt, _, _)) = valSynData let rec normPattern pat = // One major problem with versions of F# prior to 1.9.x was that data constructors easily 'pollute' the namespace // of available items, to the point that you can't even define a function with the same name as an existing union case. match pat with - | SynPat.FromParseError(p, _) -> normPattern p + | SynPat.FromParseError(innerPat, _) -> + normPattern innerPat + | SynPat.LongIdent (SynLongIdent(longId, _, _), _, toolId, tyargs, SynArgPats.Pats args, vis, m) -> let typars = match tyargs with None -> inferredTyparDecls | Some typars -> typars match memberFlagsOpt with @@ -2547,7 +2641,8 @@ module BindingNormalization = NormalizeInstanceMemberBinding cenv memberFlags valSynData thisId memberId toolId vis typars args m rhsExpr else NormalizeStaticMemberBinding cenv memberFlags valSynData memberId vis typars args m rhsExpr - | _ -> NormalizedBindingPat(pat, rhsExpr, valSynData, typars) + | _ -> + NormalizedBindingPat(pat, rhsExpr, valSynData, typars) // Object constructors are normalized in TcLetrecBindings // Here we are normalizing member definitions with simple (not long) ids, @@ -2559,27 +2654,28 @@ module BindingNormalization = | Some memberFlags -> memberFlags.MemberKind <> SynMemberKind.Constructor && memberFlags.MemberKind <> SynMemberKind.ClassConstructor) -> + NormalizeStaticMemberBinding cenv (Option.get memberFlagsOpt) valSynData id vis inferredTyparDecls [] m rhsExpr - | SynPat.Typed(pat', x, y) -> - let (NormalizedBindingPat(pat'', e'', valSynData, typars)) = normPattern pat' - NormalizedBindingPat(SynPat.Typed(pat'', x, y), e'', valSynData, typars) + | SynPat.Typed(innerPat, x, y) -> + let (NormalizedBindingPat(innerPatR, rhsExpr, valSynData, typars)) = normPattern innerPat + NormalizedBindingPat(SynPat.Typed(innerPatR, x, y), rhsExpr, valSynData, typars) | SynPat.Attrib(_, _, m) -> error(Error(FSComp.SR.tcAttributesInvalidInPatterns(), m)) | _ -> NormalizedBindingPat(pat, rhsExpr, valSynData, inferredTyparDecls) - normPattern pat + normPattern headPat let NormalizeBinding isObjExprBinding cenv (env: TcEnv) binding = match binding with - | SynBinding (vis, bkind, isInline, isMutable, Attributes attrs, doc, valSynData, p, retInfo, rhsExpr, mBinding, spBind, _) -> + | SynBinding (vis, kind, isInline, isMutable, Attributes attrs, xmlDoc, valSynData, headPat, retInfo, rhsExpr, mBinding, debugPoint, _) -> let (NormalizedBindingPat(pat, rhsExpr, valSynData, typars)) = - NormalizeBindingPattern cenv cenv.nameResolver isObjExprBinding env valSynData p (NormalizedBindingRhs ([], retInfo, rhsExpr)) + NormalizeBindingPattern cenv cenv.nameResolver isObjExprBinding env valSynData headPat (NormalizedBindingRhs ([], retInfo, rhsExpr)) let paramNames = Some valSynData.SynValInfo.ArgNames - let doc = doc.ToXmlDoc(true, paramNames) - NormalizedBinding(vis, bkind, isInline, isMutable, attrs, doc, typars, valSynData, pat, rhsExpr, mBinding, spBind) + let xmlDoc = xmlDoc.ToXmlDoc(true, paramNames) + NormalizedBinding(vis, kind, isInline, isMutable, attrs, xmlDoc, typars, valSynData, pat, rhsExpr, mBinding, debugPoint) //------------------------------------------------------------------------- // input is: @@ -2628,13 +2724,14 @@ module EventDeclarationNormalization = let GenerateExtraBindings cenv (bindingAttribs, binding) = let g = cenv.g - let (NormalizedBinding(vis1, bindingKind, isInline, isMutable, _, bindingXmlDoc, _synTyparDecls, valSynData, declPattern, bindingRhs, mBinding, spBind)) = binding + let (NormalizedBinding(vis1, bindingKind, isInline, isMutable, _, bindingXmlDoc, _synTyparDecls, valSynData, declPattern, bindingRhs, mBinding, debugPoint)) = binding if CompileAsEvent g bindingAttribs then let MakeOne (prefix, target) = let declPattern = RenameBindingPattern (fun s -> prefix + s) declPattern let argName = "handler" + // modify the rhs and argument data let bindingRhs, valSynData = let (NormalizedBindingRhs(_, _, rhsExpr)) = bindingRhs @@ -2658,14 +2755,12 @@ module EventDeclarationNormalization = error(BadEventTransformation m) // reconstitute the binding - NormalizedBinding(vis1, bindingKind, isInline, isMutable, [], bindingXmlDoc, noInferredTypars, valSynData, declPattern, bindingRhs, mBinding, spBind) + NormalizedBinding(vis1, bindingKind, isInline, isMutable, [], bindingXmlDoc, noInferredTypars, valSynData, declPattern, bindingRhs, mBinding, debugPoint) [ MakeOne ("add_", "AddHandler"); MakeOne ("remove_", "RemoveHandler") ] else [] - - /// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable. /// Also adjust the "this" type to take into account whether the type is a struct. let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars = @@ -2688,8 +2783,8 @@ let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars = mkByrefTy g objTy else objTy - tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy + tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy // The early generalization rule of F# 2.0 can be unsound for members in generic types (Bug DevDiv2 10649). // It gives rise to types like "Forall T. ?X -> ?Y" where ?X and ?Y are later discovered to involve T. @@ -2715,44 +2810,45 @@ let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars = // be accepted). As a result, we deal with this unsoundness by an adhoc post-type-checking // consistency check for recursive uses of "A" with explicit instantiations within the recursive // scope of "A". -let TcValEarlyGeneralizationConsistencyCheck cenv (env: TcEnv) (v: Val, vrec, tinst, vty, tau, m) = +let TcValEarlyGeneralizationConsistencyCheck cenv (env: TcEnv) (v: Val, valRecInfo, tinst, vTy, tau, m) = let g = cenv.g - match vrec with + match valRecInfo with | ValInRecScope isComplete when isComplete && not (isNil tinst) -> cenv.css.PushPostInferenceCheck (preDefaults=false, check=fun () -> - let tpsorig, tau2 = tryDestForallTy g vty + let tpsorig, tau2 = tryDestForallTy g vTy if not (isNil tpsorig) then let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference g tpsorig let tau3 = instType (mkTyparInst tpsorig tinst) tau2 if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau tau3) then - let txt = bufs (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv cenv.infoReader buf (mkLocalValRef v)) + let txt = buildString (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv cenv.infoReader buf (mkLocalValRef v)) error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt), m))) | _ -> () -/// TcVal. "Use" a value, normally at a fresh type instance (unless optInst is -/// given). optInst is set when an explicit type instantiation is given, e.g. +/// TcVal. "Use" a value, normally at a fresh type instance (unless instantiationInfoOpt is +/// given). instantiationInfoOpt is set when an explicit type instantiation is given, e.g. /// Seq.empty -/// In this case the vrefFlags inside optInst are just NormalValUse. +/// In this case the vrefFlags inside instantiationInfoOpt are just NormalValUse. /// -/// optInst is is also set when building the final call for a reference to an -/// F# object model member, in which case the optInst is the type instantiation -/// inferred by member overload resolution, and vrefFlags indicate if the -/// member is being used in a special way, i.e. may be one of: -/// | CtorValUsedAsSuperInit "inherit Panel()" -/// | CtorValUsedAsSelfInit "new() = new OwnType(3)" -/// | VSlotDirectCall "base.OnClick(eventArgs)" -let TcVal checkAttributes (cenv: cenv) env tpenv (vref: ValRef) optInst optAfterResolution m = +/// instantiationInfoOpt is is also set when building the final call for a reference to an +/// F# object model member, in which case the instantiationInfoOpt is the type instantiation +/// inferred by member overload resolution. +let TcVal checkAttributes (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiationInfoOpt optAfterResolution m = let g = cenv.g + let tpsorig, _, _, _, tinst, _ as res = let v = vref.Deref - let vrec = v.RecursiveValInfo + let valRecInfo = v.RecursiveValInfo v.SetHasBeenReferenced() + CheckValAccessible m env.eAccessRights vref + if checkAttributes then CheckValAttributes g vref m |> CommitOperationResult + let vTy = vref.Type + // byref-typed values get dereferenced if isByrefTy g vTy then let isSpecial = true @@ -2782,15 +2878,15 @@ let TcVal checkAttributes (cenv: cenv) env tpenv (vref: ValRef) optInst optAfter // Instantiate the value let tpsorig, vrefFlags, tinst, tau, tpenv = // Have we got an explicit instantiation? - match optInst with + match instantiationInfoOpt with // No explicit instantiation (the normal case) | None -> if HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute v.Attribs then errorR(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(v.DisplayName), m)) - match vrec with + match valRecInfo with | ValInRecScope false -> - let tpsorig, tau = vref.TypeScheme + let tpsorig, tau = vref.GeneralizedType let tinst = tpsorig |> List.map mkTyparTy tpsorig, NormalValUse, tinst, tau, tpenv | ValInRecScope true @@ -2803,29 +2899,37 @@ let TcVal checkAttributes (cenv: cenv) env tpenv (vref: ValRef) optInst optAfter let checkInst (tinst: TypeInst) = if not v.IsMember && not v.PermitsExplicitTypeInstantiation && not (List.isEmpty tinst) && not (List.isEmpty v.Typars) then warning(Error(FSComp.SR.tcDoesNotAllowExplicitTypeArguments(v.DisplayName), m)) - match vrec with + match valRecInfo with | ValInRecScope false -> - let tpsorig, tau = vref.TypeScheme + let tpsorig, tau = vref.GeneralizedType let (tinst: TypeInst), tpenv = checkTys tpenv (tpsorig |> List.map (fun tp -> tp.Kind)) + checkInst tinst + if tpsorig.Length <> tinst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tpsorig.Length, tinst.Length), m)) + let tau2 = instType (mkTyparInst tpsorig tinst) tau + (tpsorig, tinst) ||> List.iter2 (fun tp ty -> try UnifyTypes cenv env m (mkTyparTy tp) ty with _ -> error (Recursion(env.DisplayEnv, v.Id, tau2, tau, m))) + tpsorig, vrefFlags, tinst, tau2, tpenv + | ValInRecScope true | ValNotInRecScope -> - let tpsorig, tps, tptys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vTy - //dprintfn "After Freshen: tau = %s" (LayoutRender.showL (typeL tau)) + let tpsorig, tps, tpTys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vTy + let (tinst: TypeInst), tpenv = checkTys tpenv (tps |> List.map (fun tp -> tp.Kind)) + checkInst tinst - //dprintfn "After Check: tau = %s" (LayoutRender.showL (typeL tau)) - if tptys.Length <> tinst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, tinst.Length), m)) - List.iter2 (UnifyTypes cenv env m) tptys tinst - TcValEarlyGeneralizationConsistencyCheck cenv env (v, vrec, tinst, vTy, tau, m) - //dprintfn "After Unify: tau = %s" (LayoutRender.showL (typeL tau)) + if tpTys.Length <> tinst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, tinst.Length), m)) + + List.iter2 (UnifyTypes cenv env m) tpTys tinst + + TcValEarlyGeneralizationConsistencyCheck cenv env (v, valRecInfo, tinst, vTy, tau, m) + tpsorig, vrefFlags, tinst, tau, tpenv let exprForVal = Expr.Val (vref, vrefFlags, m) @@ -2835,7 +2939,7 @@ let TcVal checkAttributes (cenv: cenv) env tpenv (vref: ValRef) optInst optAfter valRefEq g vref g.splice_expr_vref || valRefEq g vref g.splice_raw_expr_vref - let exprForVal = RecordUseOfRecValue cenv vrec vref exprForVal m + let exprForVal = RecordUseOfRecValue cenv valRecInfo vref exprForVal m tpsorig, exprForVal, isSpecial, tau, tinst, tpenv @@ -2848,26 +2952,29 @@ let TcVal checkAttributes (cenv: cenv) env tpenv (vref: ValRef) optInst optAfter /// this function is used on typechecking step for making calls to provided methods and on optimization step (for the same purpose). let LightweightTcValForUsingInBuildMethodCall g (vref: ValRef) vrefFlags (vrefTypeInst: TTypes) m = let v = vref.Deref - let vty = vref.Type + let vTy = vref.Type // byref-typed values get dereferenced - if isByrefTy g vty then - mkAddrGet m vref, destByrefTy g vty + if isByrefTy g vTy then + mkAddrGet m vref, destByrefTy g vTy else - match v.LiteralValue with - | Some c -> - let _, _, _, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty - Expr.Const (c, m, tau), tau - | None -> - // Instantiate the value - let tau = - // If we have got an explicit instantiation then use that - let _, tps, tptys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty - if tptys.Length <> vrefTypeInst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, vrefTypeInst.Length), m)) - instType (mkTyparInst tps vrefTypeInst) tau + match v.LiteralValue with + | Some literalConst -> + let _, _, _, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vTy + Expr.Const (literalConst, m, tau), tau + + | None -> + // Instantiate the value + let tau = + // If we have got an explicit instantiation then use that + let _, tps, tpTys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vTy + + if tpTys.Length <> vrefTypeInst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, vrefTypeInst.Length), m)) - let exprForVal = Expr.Val (vref, vrefFlags, m) - let exprForVal = mkTyAppExpr m (exprForVal, vty) vrefTypeInst - exprForVal, tau + instType (mkTyparInst tps vrefTypeInst) tau + + let exprForVal = Expr.Val (vref, vrefFlags, m) + let exprForVal = mkTyAppExpr m (exprForVal, vTy) vrefTypeInst + exprForVal, tau /// Mark points where we decide whether an expression will support automatic /// decondensation or not. @@ -2881,29 +2988,31 @@ type ApplicableExpr = isFirst: bool member x.Range = - match x with - | ApplicableExpr (_, e, _) -> e.Range + let (ApplicableExpr (_, expr, _)) = x + expr.Range member x.Type = match x with - | ApplicableExpr (cenv, e, _) -> tyOfExpr cenv.g e + | ApplicableExpr (cenv, expr, _) -> tyOfExpr cenv.g expr - member x.SupplyArgument(e2, m) = - let (ApplicableExpr (cenv, fe, first)) = x + member x.SupplyArgument(expr2, m) = + let (ApplicableExpr (cenv, funcExpr, first)) = x let g = cenv.g + let combinedExpr = - match fe with - | Expr.App (e1, e1ty, tyargs1, args1, e1m) when - (not first || isNil args1) && - (not (isForallTy g e1ty) || isFunTy g (applyTys g e1ty (tyargs1, args1))) -> - Expr.App (e1, e1ty, tyargs1, args1@[e2], unionRanges e1m m) + match funcExpr with + | Expr.App (funcExpr0, funcExpr0Ty, tyargs0, args0, m0) when + (not first || isNil args0) && + (not (isForallTy g funcExpr0Ty) || isFunTy g (applyTys g funcExpr0Ty (tyargs0, args0))) -> + Expr.App (funcExpr0, funcExpr0Ty, tyargs0, args0@[expr2], unionRanges m0 m) | _ -> - Expr.App (fe, tyOfExpr g fe, [], [e2], m) + Expr.App (funcExpr, tyOfExpr g funcExpr, [], [expr2], m) + ApplicableExpr(cenv, combinedExpr, false) member x.Expr = - match x with - | ApplicableExpr(_, e, _) -> e + let (ApplicableExpr (_, expr, _)) = x + expr let MakeApplicableExprNoFlex cenv expr = ApplicableExpr (cenv, expr, true) @@ -2939,32 +3048,32 @@ let MakeApplicableExprNoFlex cenv expr = /// This "special" node is immediately eliminated by the use of IteratedFlexibleAdjustArityOfLambdaBody as soon as we /// first transform the tree (currently in optimization) +let isNonFlexibleTy g ty = isSealedTy g ty + let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = let g = cenv.g let exprTy = tyOfExpr g expr let m = expr.Range - let isNonFlexibleType ty = isSealedTy g ty - let argTys, retTy = stripFunTy g exprTy - let curriedActualTypes = argTys |> List.map (tryDestRefTupleTy g) - if (curriedActualTypes.IsEmpty || - curriedActualTypes |> List.exists (List.exists (isByrefTy g)) || - curriedActualTypes |> List.forall (List.forall isNonFlexibleType)) then + let curriedActualTys = argTys |> List.map (tryDestRefTupleTy g) + if (curriedActualTys.IsEmpty || + curriedActualTys |> List.exists (List.exists (isByrefTy g)) || + curriedActualTys |> List.forall (List.forall (isNonFlexibleTy g))) then ApplicableExpr (cenv, expr, true) else - let curriedFlexibleTypes = - curriedActualTypes |> List.mapSquared (fun actualType -> - if isNonFlexibleType actualType then - actualType + let curriedFlexibleTys = + curriedActualTys |> List.mapSquared (fun actualTy -> + if isNonFlexibleTy g actualTy then + actualTy else - let flexibleType = NewInferenceType g - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType - flexibleType) + let flexibleTy = NewInferenceType g + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualTy flexibleTy + flexibleTy) // Create a coercion to represent the expansion of the application - let expr = mkCoerceExpr (expr, mkIteratedFunTy g (List.map (mkRefTupledTy g) curriedFlexibleTypes) retTy, m, exprTy) + let expr = mkCoerceExpr (expr, mkIteratedFunTy g (List.map (mkRefTupledTy g) curriedFlexibleTys) retTy, m, exprTy) ApplicableExpr (cenv, expr, true) /// Checks, warnings and constraint assertions for downcasts @@ -2991,10 +3100,11 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgtTy srcTy = else error(Error(FSComp.SR.tcTypeTestErased(NicePrint.minimalStringOfType denv tgtTy, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g tgtTy)), m)) else - getErasedTypes g tgtTy |> - List.iter (fun ety -> if isMeasureTy g ety - then warning(Error(FSComp.SR.tcTypeTestLosesMeasures(NicePrint.minimalStringOfType denv ety), m)) - else warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g ety)), m))) + for ety in getErasedTypes g tgtTy do + if isMeasureTy g ety then + warning(Error(FSComp.SR.tcTypeTestLosesMeasures(NicePrint.minimalStringOfType denv ety), m)) + else + warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g ety)), m)) /// Checks, warnings and constraint assertions for upcasts let TcStaticUpcast cenv denv m tgtTy srcTy = @@ -3027,7 +3137,7 @@ let BuildPossiblyConditionalMethodCall (cenv: cenv) env isMutable m isProp minfo if shouldEraseCall then // Methods marked with 'Conditional' must return 'unit' - UnifyTypes cenv env m g.unit_ty (minfo.GetFSharpReturnTy(cenv.amap, m, minst)) + UnifyTypes cenv env m g.unit_ty (minfo.GetFSharpReturnType(cenv.amap, m, minst)) mkUnit g m, g.unit_ty else #if !NO_TYPEPROVIDERS @@ -3037,14 +3147,15 @@ let BuildPossiblyConditionalMethodCall (cenv: cenv) env isMutable m isProp minfo // and uses TcVal to do this. However we don't want to check attributes again for provided references to values, // so we pass 'false' for 'checkAttributes'. let tcVal = LightweightTcValForUsingInBuildMethodCall g - let _, retExpt, retTy = ProvidedMethodCalls.BuildInvokerExpressionForProvidedMethodCall tcVal (g, cenv.amap, mi, objArgs, isMutable, isProp, valUseFlags, args, m) - retExpt, retTy + let _, retExpr, retTy = ProvidedMethodCalls.BuildInvokerExpressionForProvidedMethodCall tcVal (g, cenv.amap, mi, objArgs, isMutable, isProp, valUseFlags, args, m) + retExpr, retTy | _ -> #endif let tcVal valref valUse ttypes m = - let _, a, _, b, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m - a, b + let _, exprForVal, _, tau, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m + exprForVal, tau + BuildMethodCall tcVal g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args @@ -3061,7 +3172,7 @@ let TryFindFSharpSignatureInstanceGetterProperty (cenv: cenv) (env: TcEnv) m nm | [] -> false | argTysList -> - let argTys = (argTysList |> List.reduce (@)) @ [ propInfo.GetterMethod.GetFSharpReturnTy(cenv.amap, m, []) ] in + let argTys = (argTysList |> List.reduce (@)) @ [ propInfo.GetterMethod.GetFSharpReturnType(cenv.amap, m, []) ] in if argTys.Length <> sigTys.Length then false else @@ -3095,8 +3206,8 @@ let BuildDisposableCleanup (cenv: cenv) env m (v: Val) = else let disposeObjVar, disposeObjExpr = mkCompGenLocal m "objectToDispose" g.system_IDisposable_ty let disposeExpr, _ = BuildPossiblyConditionalMethodCall cenv env PossiblyMutates m false disposeMethod NormalValUse [] [disposeObjExpr] [] - let inpe = mkCoerceExpr(exprForVal v.Range v, g.obj_ty, m, v.Type) - mkIsInstConditional g m g.system_IDisposable_ty inpe disposeObjVar disposeExpr (mkUnit g m) + let inputExpr = mkCoerceExpr(exprForVal v.Range v, g.obj_ty, m, v.Type) + mkIsInstConditional g m g.system_IDisposable_ty inputExpr disposeObjVar disposeExpr (mkUnit g m) /// Build call to get_OffsetToStringData as part of 'fixed' let BuildOffsetToStringData cenv env m = @@ -3113,8 +3224,8 @@ let BuildOffsetToStringData cenv env m = let BuildILFieldGet g amap m objExpr (finfo: ILFieldInfo) = let fref = finfo.ILFieldRef - let isValueType = finfo.IsValueType - let valu = if isValueType then AsValue else AsObject + let isStruct = finfo.IsValueType + let boxity = if isStruct then AsValue else AsObject let tinst = finfo.TypeInst let fieldType = finfo.FieldType (amap, m) #if !NO_TYPEPROVIDERS @@ -3129,11 +3240,11 @@ let BuildILFieldGet g amap m objExpr (finfo: ILFieldInfo) = Expr.Const (TcFieldInit m lit, m, fieldType) | _ -> #endif - let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g isValueType false NeverMutates objExpr None m + let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g isStruct false NeverMutates objExpr None m // The empty instantiation on the AbstractIL fspec is OK, since we make the correct fspec in IlxGen.GenAsm // This ensures we always get the type instantiation right when doing this from // polymorphic code, after inlining etc. * - let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) + let fspec = mkILFieldSpec(fref, mkILNamedTy boxity fref.DeclaringTypeRef []) // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr. wrap (mkAsmExpr (([ mkNormalLdfld fspec ] @ (if finfo.IsInitOnly then [ AI_nop ] else [])), tinst, [objExpr], [fieldType], m)) @@ -3151,34 +3262,34 @@ let private CheckFieldLiteralArg (finfo: ILFieldInfo) argExpr m = let BuildILFieldSet g m objExpr (finfo: ILFieldInfo) argExpr = let fref = finfo.ILFieldRef - let isValueType = finfo.IsValueType - let valu = if isValueType then AsValue else AsObject + let isStruct = finfo.IsValueType + let boxity = if isStruct then AsValue else AsObject let tinst = finfo.TypeInst // The empty instantiation on the AbstractIL fspec is OK, since we make the correct fspec in IlxGen.GenAsm // This ensures we always get the type instantiation right when doing this from // polymorphic code, after inlining etc. * - let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) + let fspec = mkILFieldSpec(fref, mkILNamedTy boxity fref.DeclaringTypeRef []) CheckFieldLiteralArg finfo argExpr m - let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g isValueType false DefinitelyMutates objExpr None m + let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g isStruct false DefinitelyMutates objExpr None m wrap (mkAsmExpr ([ mkNormalStfld fspec ], tinst, [objExpr; argExpr], [], m)) let BuildILStaticFieldSet m (finfo: ILFieldInfo) argExpr = let fref = finfo.ILFieldRef - let isValueType = finfo.IsValueType - let valu = if isValueType then AsValue else AsObject + let isStruct = finfo.IsValueType + let boxity = if isStruct then AsValue else AsObject let tinst = finfo.TypeInst // The empty instantiation on the AbstractIL fspec is OK, since we make the correct fspec in IlxGen.GenAsm // This ensures we always get the type instantiation right when doing this from // polymorphic code, after inlining etc. - let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) + let fspec = mkILFieldSpec(fref, mkILNamedTy boxity fref.DeclaringTypeRef []) CheckFieldLiteralArg finfo argExpr m mkAsmExpr ([ mkNormalStsfld fspec ], tinst, [argExpr], [], m) let BuildRecdFieldSet g m objExpr (rfinfo: RecdFieldInfo) argExpr = let tgtTy = rfinfo.DeclaringType - let valu = isStructTy g tgtTy - let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgtTy, m, tyOfExpr g objExpr) - let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g valu false DefinitelyMutates objExpr None m + let boxity = isStructTy g tgtTy + let objExpr = if boxity then objExpr else mkCoerceExpr(objExpr, tgtTy, m, tyOfExpr g objExpr) + let wrap, objExpr, _readonly, _writeonly = mkExprAddrOfExpr g boxity false DefinitelyMutates objExpr None m wrap (mkRecdFieldSetViaExprAddr (objExpr, rfinfo.RecdFieldRef, rfinfo.TypeInst, argExpr, m) ) //------------------------------------------------------------------------- @@ -3237,23 +3348,23 @@ let GetMethodArgs arg = // Helpers dealing with pattern match compilation //------------------------------------------------------------------------- -let CompilePatternForMatch cenv (env: TcEnv) mExpr matchm warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy = +let CompilePatternForMatch cenv (env: TcEnv) mExpr mMatch warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy = let g = cenv.g - let dtree, targets = CompilePattern g env.DisplayEnv cenv.amap (LightweightTcValForUsingInBuildMethodCall g) cenv.infoReader mExpr matchm warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy - mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr matchm resultTy dtree targets + let dtree, targets = CompilePattern g env.DisplayEnv cenv.amap (LightweightTcValForUsingInBuildMethodCall g) cenv.infoReader mExpr mMatch warnOnUnused actionOnFailure (inputVal, generalizedTypars, inputExprOpt) clauses inputTy resultTy + mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy dtree targets /// Compile a pattern -let CompilePatternForMatchClauses cenv env mExpr matchm warnOnUnused actionOnFailure inputExprOpt inputTy resultTy tclauses = +let CompilePatternForMatchClauses cenv env mExpr mMatch warnOnUnused actionOnFailure inputExprOpt inputTy resultTy tclauses = // Avoid creating a dummy in the common cases where we are about to bind a name for the expression // CLEANUP: avoid code duplication with code further below, i.e.all callers should call CompilePatternForMatch match tclauses with - | [TClause(TPat_as (pat1, PBind (asVal, TypeScheme(generalizedTypars, _)), _), None, TTarget(vs, e, _), m2)] -> + | [MatchClause(TPat_as (pat1, PatternValBinding (asVal, GeneralizedType(generalizedTypars, _)), _), None, TTarget(vs, targetExpr, _), m2)] -> let vs2 = ListSet.remove valEq asVal vs - let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (asVal, generalizedTypars, None) [TClause(pat1, None, TTarget(vs2, e, None), m2)] inputTy resultTy + let expr = CompilePatternForMatch cenv env mExpr mMatch warnOnUnused actionOnFailure (asVal, generalizedTypars, None) [MatchClause(pat1, None, TTarget(vs2, targetExpr, None), m2)] inputTy resultTy asVal, expr | _ -> let matchValueTmp, _ = mkCompGenLocal mExpr "matchValue" inputTy - let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (matchValueTmp, [], inputExprOpt) tclauses inputTy resultTy + let expr = CompilePatternForMatch cenv env mExpr mMatch warnOnUnused actionOnFailure (matchValueTmp, [], inputExprOpt) tclauses inputTy resultTy matchValueTmp, expr //------------------------------------------------------------------------- @@ -3291,7 +3402,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr | Result getEnumerator_minfo -> let getEnumerator_minst = FreshenMethInfo m getEnumerator_minfo - let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnTy(cenv.amap, m, getEnumerator_minst) + let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnType(cenv.amap, m, getEnumerator_minst) if hasArgs getEnumerator_minfo getEnumerator_minst then err true tyToSearchForGetEnumeratorAndItem else match findMethInfo false m "MoveNext" retTypeOfGetEnumerator with @@ -3299,7 +3410,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr | Result moveNext_minfo -> let moveNext_minst = FreshenMethInfo m moveNext_minfo - let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnTy(cenv.amap, m, moveNext_minst) + let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnType(cenv.amap, m, moveNext_minst) if not (typeEquiv g g.bool_ty retTypeOfMoveNext) then err false retTypeOfGetEnumerator else if hasArgs moveNext_minfo moveNext_minst then err false retTypeOfGetEnumerator else @@ -3309,7 +3420,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr let get_Current_minst = FreshenMethInfo m get_Current_minfo if hasArgs get_Current_minfo get_Current_minst then err false retTypeOfGetEnumerator else - let enumElemTy = get_Current_minfo.GetFSharpReturnTy(cenv.amap, m, get_Current_minst) + let enumElemTy = get_Current_minfo.GetFSharpReturnType(cenv.amap, m, get_Current_minst) // Compute the element type of the strongly typed enumerator // @@ -3324,8 +3435,8 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr if isObjTy g enumElemTy then // Look for an 'Item' property, or a set of these with consistent return types let allEquivReturnTypes (minfo: MethInfo) (others: MethInfo list) = - let returnTy = minfo.GetFSharpReturnTy(cenv.amap, m, []) - others |> List.forall (fun other -> typeEquiv g (other.GetFSharpReturnTy(cenv.amap, m, [])) returnTy) + let returnTy = minfo.GetFSharpReturnType(cenv.amap, m, []) + others |> List.forall (fun other -> typeEquiv g (other.GetFSharpReturnType(cenv.amap, m, [])) returnTy) let isInt32OrObjectIndexer (minfo: MethInfo) = match minfo.GetParamTypes(cenv.amap, m, []) with @@ -3339,7 +3450,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AllResults cenv env m ad "get_Item" tyToSearchForGetEnumeratorAndItem with | minfo :: others when (allEquivReturnTypes minfo others && List.exists isInt32OrObjectIndexer (minfo :: others)) -> - minfo.GetFSharpReturnTy(cenv.amap, m, []) + minfo.GetFSharpReturnType(cenv.amap, m, []) | _ -> @@ -3347,7 +3458,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AllResults cenv env m ad "Item" tyToSearchForGetEnumeratorAndItem with | minfo :: others when (allEquivReturnTypes minfo others && List.exists isInt32OrObjectIndexer (minfo :: others)) -> - minfo.GetFSharpReturnTy(cenv.amap, m, []) + minfo.GetFSharpReturnType(cenv.amap, m, []) | _ -> enumElemTy else @@ -3541,18 +3652,18 @@ let EliminateInitializationGraphs | Expr.Match (_, _, pt, targets, _, _) -> CheckDecisionTree (strict st) pt Array.iter (CheckDecisionTreeTarget (strict st)) targets - | Expr.App (e1, _, _, args, _) -> - CheckExpr (strict st) e1 + | Expr.App (expr1, _, _, args, _) -> + CheckExpr (strict st) expr1 List.iter (CheckExpr (strict st)) args // Binary expressions - | Expr.Sequential (e1, e2, _, _) - | Expr.StaticOptimization (_, e1, e2, _) -> - CheckExpr (strict st) e1; CheckExpr (strict st) e2 + | Expr.Sequential (expr1, expr2, _, _) + | Expr.StaticOptimization (_, expr1, expr2, _) -> + CheckExpr (strict st) expr1; CheckExpr (strict st) expr2 // n-ary expressions | Expr.Op (op, _, args, m) -> CheckExprOp st op m; List.iter (CheckExpr (strict st)) args // misc | Expr.Link eref -> CheckExpr st eref.Value - | Expr.DebugPoint (_, e2) -> CheckExpr st e2 + | Expr.DebugPoint (_, expr2) -> CheckExpr st expr2 | Expr.TyChoose (_, b, _) -> CheckExpr st b | Expr.Quote _ -> () | Expr.WitnessArg (_witnessInfo, _m) -> () @@ -3561,7 +3672,7 @@ let EliminateInitializationGraphs and CheckDecisionTree st dt = match dt with - | TDSwitch(e1, csl, dflt, _) -> CheckExpr st e1; List.iter (fun (TCase(_, d)) -> CheckDecisionTree st d) csl; Option.iter (CheckDecisionTree st) dflt + | TDSwitch(expr1, csl, dflt, _) -> CheckExpr st expr1; List.iter (fun (TCase(_, d)) -> CheckDecisionTree st d) csl; Option.iter (CheckDecisionTree st) dflt | TDSuccess (es, _) -> es |> List.iter (CheckExpr st) | TDBind(bind, e) -> CheckBinding st bind; CheckDecisionTree st e @@ -3630,17 +3741,17 @@ let EliminateInitializationGraphs | _ -> let ty = v.Type let m = v.Range - let vty = mkLazyTy g ty + let vTy = mkLazyTy g ty let fty = mkFunTy g g.unit_ty ty let flazy, felazy = mkCompGenLocal m v.LogicalName fty let frhs = mkUnitDelayLambda g m e if mustHaveArity then flazy.SetValReprInfo (Some(InferArityOfExpr g AllowTypeDirectedDetupling.Yes fty [] [] frhs)) - let vlazy, velazy = mkCompGenLocal m v.LogicalName vty + let vlazy, velazy = mkCompGenLocal m v.LogicalName vTy let vrhs = (mkLazyDelayed g m ty felazy) - if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g AllowTypeDirectedDetupling.Yes vty [] [] vrhs)) + if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g AllowTypeDirectedDetupling.Yes vTy [] [] vrhs)) for (fixupPoint, _) in fixupPoints do fixupPoint.Value <- mkLazyForce g fixupPoint.Value.Range ty velazy @@ -3715,9 +3826,9 @@ let CheckAndRewriteObjectCtor g env (ctorLambdaExpr: Expr) = | Expr.Let (bind, body, m, _) -> mkLetBind m bind (checkAndRewrite body) // The constructor is a sequence "let pat = expr in " - | Expr.Match (spBind, a, b, targets, c, d) -> + | Expr.Match (debugPoint, a, b, targets, c, d) -> let targets = targets |> Array.map (fun (TTarget(vs, body, flags)) -> TTarget(vs, checkAndRewrite body, flags)) - Expr.Match (spBind, a, b, targets, c, d) + Expr.Match (debugPoint, a, b, targets, c, d) // = "let rec binds in " | Expr.LetRec (a, body, _, _) -> @@ -3907,7 +4018,7 @@ type CheckConstraints = type MemberOrValContainerInfo = | MemberOrValContainerInfo of tcref: TyconRef * - optIntfSlotTy: (TType * SlotImplSet) option * + intfSlotTyOpt: (TType * SlotImplSet) option * baseValOpt: Val option * safeInitInfo: SafeInitData * declaredTyconTypars: Typars @@ -3936,12 +4047,12 @@ type NormalizedRecBindingDefn = type ValSpecResult = | ValSpecResult of altActualParent: ParentRef * - memberInfoOpt: PreValMemberInfo option * + memberInfoOpt: PrelimMemberInfo option * id: Ident * enclosingDeclaredTypars: Typars * declaredTypars: Typars * ty: TType * - partialValReprInfo: PartialValReprInfo * + prelimValReprInfo: PrelimValReprInfo * declKind: DeclKind type DecodedIndexArg = @@ -3967,8 +4078,8 @@ type RecursiveBindingInfo = inlineFlag: ValInline * vspec: Val * explicitTyparInfo: ExplicitTyparInfo * - partialValReprInfo: PartialValReprInfo * - memberInfoOpt: PreValMemberInfo option * + prelimValReprInfo: PrelimValReprInfo * + memberInfoOpt: PrelimMemberInfo option * baseValOpt: Val option * safeThisValOpt: Val option * safeInitInfo: SafeInitData * @@ -4029,18 +4140,18 @@ let GetInstanceMemberThisVariable (vspec: Val, expr) = // Checking types and type constraints //------------------------------------------------------------------------- /// Check specifications of constraints on type parameters -let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = +let rec TcTyparConstraint ridx cenv newOk checkConstraints occ (env: TcEnv) tpenv c = let g = cenv.g match c with | SynTypeConstraint.WhereTyparDefaultsToType(tp, ty, m) -> - let tyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty + let tyR, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv ty let tpR, tpenv = TcTypar cenv env newOk tpenv tp AddCxTyparDefaultsTo env.DisplayEnv cenv.css m env.eContextInfo tpR ridx tyR tpenv | SynTypeConstraint.WhereTyparSubtypeOfType(tp, ty, m) -> - let tyR, tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv ty + let tyR, tpenv = TcTypeAndRecover cenv newOk checkConstraints ItemOccurence.UseInType env tpenv ty let tpR, tpenv = TcTypar cenv env newOk tpenv tp if newOk = NoNewTypars && isSealedTy g tyR then errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(), m)) @@ -4065,66 +4176,76 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | SynTypeConstraint.WhereTyparIsUnmanaged(tp, m) -> TcSimpleTyparConstraint cenv env newOk tpenv tp m AddCxTypeIsUnmanaged - | SynTypeConstraint.WhereTyparIsEnum(tp, tyargs, m) -> - let tpR, tpenv = TcTypar cenv env newOk tpenv tp - let tpenv = - match tyargs with - | [underlying] -> - let underlying', tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv underlying - AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tpR) underlying' - tpenv - | _ -> - errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) - tpenv - tpenv + | SynTypeConstraint.WhereTyparIsEnum(tp, synUnderlingTys, m) -> + TcConstraintWhereTyparIsEnum cenv env newOk checkConstraints tpenv tp synUnderlingTys m - | SynTypeConstraint.WhereTyparIsDelegate(tp, tyargs, m) -> - let tpR, tpenv = TcTypar cenv env newOk tpenv tp - match tyargs with - | [a;b] -> - let a', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv a - let b', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv b - AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tpR) a' b' + | SynTypeConstraint.WhereTyparIsDelegate(tp, synTys, m) -> + TcConstraintWhereTyparIsDelegate cenv env newOk checkConstraints occ tpenv tp synTys m + + | SynTypeConstraint.WhereTyparSupportsMember(synSupportTys, synMemberSig, m) -> + TcConstraintWhereTyparSupportsMember cenv env newOk tpenv synSupportTys synMemberSig m + +and TcConstraintWhereTyparIsEnum cenv env newOk checkConstraints tpenv tp synUnderlingTys m = + let tpR, tpenv = TcTypar cenv env newOk tpenv tp + let tpenv = + match synUnderlingTys with + | [synUnderlyingTy] -> + let underlyingTy, tpenv = TcTypeAndRecover cenv newOk checkConstraints ItemOccurence.UseInType env tpenv synUnderlyingTy + AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tpR) underlyingTy tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) tpenv + tpenv - | SynTypeConstraint.WhereTyparSupportsMember(tps, memSpfn, m) -> - let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env tps tpenv memSpfn m - match traitInfo with - | TTrait(objtys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = SynMemberKind.Constructor -> - match objtys, argTys with - | [ty], [] when typeEquiv g ty (GetFSharpViewOfReturnType g returnTy) -> - AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty - tpenv - | _ -> - errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) - tpenv +and TcConstraintWhereTyparIsDelegate cenv env newOk checkConstraints occ tpenv tp synTys m = + let tpR, tpenv = TcTypar cenv env newOk tpenv tp + match synTys with + | [a;b] -> + let a', tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv a + let b', tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv b + AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tpR) a' b' + tpenv + | _ -> + errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) + tpenv + +and TcConstraintWhereTyparSupportsMember cenv env newOk tpenv synSupportTys synMemberSig m = + let g = cenv.g + let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env synSupportTys tpenv synMemberSig m + match traitInfo with + | TTrait(objTys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = SynMemberKind.Constructor -> + match objTys, argTys with + | [ty], [] when typeEquiv g ty (GetFSharpViewOfReturnType g returnTy) -> + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty + tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) tpenv + | _ -> + AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + tpenv and TcSimpleTyparConstraint cenv env newOk tpenv tp m constraintAdder = let tpR, tpenv = TcTypar cenv env newOk tpenv tp constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tpR) tpenv -and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = +and TcPseudoMemberSpec cenv newOk env synTypes tpenv synMemberSig m = let g = cenv.g let tys, tpenv = List.mapFold (TcTypeAndRecover cenv newOk CheckCxs ItemOccurence.UseInType env) tpenv synTypes - match memSpfn with - | SynMemberSig.Member (valSpfn, memberFlags, m) -> + match synMemberSig with + | SynMemberSig.Member (synValSig, memberFlags, m) -> // REVIEW: Test pseudo constraints cannot refer to polymorphic methods. // REVIEW: Test pseudo constraints cannot be curried. - let members, tpenv = TcValSpec cenv env ModuleOrMemberBinding newOk ExprContainerInfo (Some memberFlags) (Some (List.head tys)) tpenv valSpfn [] + let members, tpenv = TcValSpec cenv env ModuleOrMemberBinding newOk ExprContainerInfo (Some memberFlags) (Some (List.head tys)) tpenv synValSig [] match members with - | [ValSpecResult(_, _, id, _, _, memberConstraintTy, partialValReprInfo, _)] -> + | [ValSpecResult(_, _, id, _, _, memberConstraintTy, prelimValReprInfo, _)] -> let memberConstraintTypars, _ = tryDestForallTy g memberConstraintTy - let topValInfo = TranslatePartialArity memberConstraintTypars partialValReprInfo - let _, _, curriedArgInfos, returnTy, _ = GetTopValTypeInCompiledForm g topValInfo 0 memberConstraintTy m + let valReprInfo = TranslatePartialValReprInfo memberConstraintTypars prelimValReprInfo + let _, _, curriedArgInfos, returnTy, _ = GetTopValTypeInCompiledForm g valReprInfo 0 memberConstraintTy m //if curriedArgInfos.Length > 1 then error(Error(FSComp.SR.tcInvalidConstraint(), m)) let argTys = List.concat curriedArgInfos let argTys = List.map fst argTys @@ -4134,14 +4255,15 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.AccessRights) TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None), tpenv + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) - | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) /// Check a value specification, e.g. in a signature, interface declaration or a constraint -and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv valSpfn attrs = +and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv synValSig attrs = let g = cenv.g - let (SynValSig(ident=SynIdent(id,_); explicitValDecls=ValTyparDecls (synTypars, synTyparConstraints, _); synType=ty; arity=valSynInfo; range=m)) = valSpfn + let (SynValSig(ident=SynIdent(id,_); explicitTypeParams=ValTyparDecls (synTypars, synTyparConstraints, _); synType=ty; arity=valSynInfo; range=m)) = synValSig let declaredTypars = TcTyparDecls cenv env synTypars let (ContainerInfo(altActualParent, tcrefContainerInfo)) = containerInfo @@ -4149,18 +4271,20 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv match tcrefContainerInfo with | Some(MemberOrValContainerInfo(tcref, _, _, _, declaredTyconTypars)) -> let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, _, thisTy = + FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + // An implemented interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. - // let optIntfSlotTy = Option.map (instType renaming) optIntfSlotTy in enclosingDeclaredTypars, Some tcref, Some thisTy, declKind + | None -> [], None, thisTyOpt, ModuleOrMemberBinding let allDeclaredTypars = enclosingDeclaredTypars @ declaredTypars let envinner = AddDeclaredTypars NoCheckForDuplicateTypars allDeclaredTypars env - let checkCxs = CheckCxs - let tpenv = TcTyparConstraints cenv newOk checkCxs ItemOccurence.UseInType envinner tpenv synTyparConstraints + let checkConstraints = CheckCxs + let tpenv = TcTyparConstraints cenv newOk checkConstraints ItemOccurence.UseInType envinner tpenv synTyparConstraints // Treat constraints at the "end" of the type as if they are declared. // This is by far the most convenient place to locate the constraints. @@ -4168,15 +4292,16 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv // val FastGenericComparer<'T>: IComparer<'T> when 'T: comparison let tpenv = match ty with - | SynType.WithGlobalConstraints(_, wcs, _) -> - TcTyparConstraints cenv newOk checkCxs ItemOccurence.UseInType envinner tpenv wcs + | SynType.WithGlobalConstraints(_, synConstraints, _) -> + TcTyparConstraints cenv newOk checkConstraints ItemOccurence.UseInType envinner tpenv synConstraints | _ -> tpenv // Enforce "no undeclared constraints allowed on declared typars" allDeclaredTypars |> List.iter (SetTyparRigid env.DisplayEnv m) + // Process the type, including any constraints - let declaredTy, tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType envinner tpenv ty + let declaredTy, tpenv = TcTypeAndRecover cenv newOk checkConstraints ItemOccurence.UseInType envinner tpenv ty match memFlagsOpt, thisTyOpt with | Some memberFlags, Some thisTy -> @@ -4220,8 +4345,8 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv tyR, valSynInfo let reallyGenerateOneMember(id: Ident, valSynInfo, tyR, memberFlags) = - let PartialValReprInfo(argsData, _) as partialValReprInfo = - TranslateTopValSynInfo id.idRange (TcAttributes cenv env) valSynInfo + let PrelimValReprInfo(argsData, _) as prelimValReprInfo = + TranslateSynValInfo id.idRange (TcAttributes cenv env) valSynInfo // Fold in the optional argument information @@ -4250,7 +4375,7 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv | None -> None - ValSpecResult(altActualParent, memberInfoOpt, id, enclosingDeclaredTypars, declaredTypars, tyR, partialValReprInfo, declKind) + ValSpecResult(altActualParent, memberInfoOpt, id, enclosingDeclaredTypars, declaredTypars, tyR, prelimValReprInfo, declKind) [ yield reallyGenerateOneMember(id, valSynInfo, tyR, memberFlags) if CompileAsEvent g attrs then @@ -4277,20 +4402,20 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv yield! generateOneMember({memberFlags with MemberKind=SynMemberKind.PropertySet}) ], tpenv | _ -> let valSynInfo = AdjustValSynInfoInSignature g declaredTy valSynInfo - let partialValReprInfo = TranslateTopValSynInfo id.idRange (TcAttributes cenv env) valSynInfo - [ ValSpecResult(altActualParent, None, id, enclosingDeclaredTypars, declaredTypars, declaredTy, partialValReprInfo, declKind) ], tpenv + let prelimValReprInfo = TranslateSynValInfo id.idRange (TcAttributes cenv env) valSynInfo + [ ValSpecResult(altActualParent, None, id, enclosingDeclaredTypars, declaredTypars, declaredTy, prelimValReprInfo, declKind) ], tpenv //------------------------------------------------------------------------- // Bind types //------------------------------------------------------------------------- /// Check and elaborate a type or measure parameter occurrence -/// If optKind=Some kind, then this is the kind we're expecting (we're in *analysis* mode) -/// If optKind=None, we need to determine the kind (we're in *synthesis* mode) +/// If kindOpt=Some kind, then this is the kind we're expecting (we're in *analysis* mode) +/// If kindOpt=None, we need to determine the kind (we're in *synthesis* mode) /// -and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (SynTypar(id, _, _) as tp) = +and TcTypeOrMeasureParameter kindOpt cenv (env: TcEnv) newOk tpenv (SynTypar(id, _, _) as tp) = let checkRes (res: Typar) = - match optKind, res.Kind with + match kindOpt, res.Kind with | Some TyparKind.Measure, TyparKind.Type -> error (Error(FSComp.SR.tcExpectedUnitOfMeasureMarkWithAttribute(), id.idRange)); res, tpenv | Some TyparKind.Type, TyparKind.Measure -> error (Error(FSComp.SR.tcExpectedTypeParameter(), id.idRange)); res, tpenv | _, _ -> @@ -4298,12 +4423,19 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (SynTypar(id, _, _ CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.UseInType, env.AccessRights) res, tpenv let key = id.idText + + // Check if it has been declared match env.eNameResEnv.eTypars.TryGetValue key with | true, res -> checkRes res | _ -> + + // Check if it is already in the implicitly scoped environment match TryFindUnscopedTypar key tpenv with | Some res -> checkRes res | None -> + + // Otherwise, it is a new implicitly scoped type variable. Check if these + // are allowed. if newOk = NoNewTypars then let suggestTypeParameters (addToBuffer: string -> unit) = for p in env.eNameResEnv.eTypars do @@ -4319,18 +4451,19 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (SynTypar(id, _, _ // OK, this is an implicit declaration of a type parameter // The kind defaults to Type - let kind = match optKind with None -> TyparKind.Type | Some kind -> kind + let kind = match kindOpt with None -> TyparKind.Type | Some kind -> kind let tpR = Construct.NewTypar (kind, TyparRigidity.WarnIfNotRigid, tp, false, TyparDynamicReq.Yes, [], false, false) let item = Item.TypeVar(id.idText, tpR) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.UseInType, env.AccessRights) + tpR, AddUnscopedTypar key tpR tpenv and TcTypar cenv env newOk tpenv tp = - TcTyparOrMeasurePar (Some TyparKind.Type) cenv env newOk tpenv tp + TcTypeOrMeasureParameter (Some TyparKind.Type) cenv env newOk tpenv tp and TcTyparDecl cenv env synTyparDecl = let g = cenv.g - let (SynTyparDecl(Attributes synAttrs, synTypar)) = synTyparDecl let (SynTypar(id, _, _)) = synTypar @@ -4348,158 +4481,65 @@ and TcTyparDecl cenv env synTyparDecl = | None -> () let item = Item.TypeVar(id.idText, tp) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.UseInType, env.eAccessRights) - tp + tp -and TcTyparDecls cenv env synTypars = List.map (TcTyparDecl cenv env) synTypars +and TcTyparDecls cenv env synTypars = + List.map (TcTyparDecl cenv env) synTypars -/// Check and elaborate a syntactic type or measure -/// If optKind=Some kind, then this is the kind we're expecting (we're in *analysis* mode) -/// If optKind=None, we need to determine the kind (we're in *synthesis* mode) +/// Check and elaborate a syntactic type or unit-of-measure /// -and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) ty = +/// If kindOpt=Some kind, then this is the kind we're expecting (we're doing kind checking) +/// If kindOpt=None, we need to determine the kind (we're doing kind inference) +/// +and TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ env (tpenv: UnscopedTyparEnv) synTy = let g = cenv.g - match ty with + match synTy with | SynType.LongIdent(SynLongIdent([], _, _)) -> // special case when type name is absent - i.e. empty inherit part in type declaration g.obj_ty, tpenv - | SynType.LongIdent(SynLongIdent(tc, _, _) as lidwd) -> - let m = lidwd.Range - let ad = env.eAccessRights - let tinstEnclosing, tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver occ OpenQualified env.NameEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) - match optKind, tcref.TypeOrMeasureKind with - | Some TyparKind.Type, TyparKind.Measure -> - error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) - NewErrorType (), tpenv - | Some TyparKind.Measure, TyparKind.Type -> - error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) - TType_measure (NewErrorMeasure ()), tpenv - | _, TyparKind.Measure -> - TType_measure (Measure.Con tcref), tpenv - | _, TyparKind.Type -> - TcTypeApp cenv newOk checkCxs occ env tpenv m tcref tinstEnclosing [] - - | SynType.App (StripParenTypes (SynType.LongIdent(SynLongIdent(tc, _, _))), _, args, _commas, _, postfix, m) -> - let ad = env.eAccessRights - - let tinstEnclosing, tcref = - let tyResInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length - ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameResEnv ad tc tyResInfo PermitDirectReferenceToGeneratedType.No - |> ForceRaise - - match optKind, tcref.TypeOrMeasureKind with - | Some TyparKind.Type, TyparKind.Measure -> - error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) - NewErrorType (), tpenv + | SynType.LongIdent synLongId -> + TcLongIdent kindOpt cenv newOk checkConstraints occ env tpenv synLongId - | Some TyparKind.Measure, TyparKind.Type -> - error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) - TType_measure (NewErrorMeasure ()), tpenv - - | _, TyparKind.Type -> - if postfix && tcref.Typars m |> List.exists (fun tp -> match tp.Kind with TyparKind.Measure -> true | _ -> false) - then error(Error(FSComp.SR.tcInvalidUnitsOfMeasurePrefix(), m)) - TcTypeApp cenv newOk checkCxs occ env tpenv m tcref tinstEnclosing args - | _, TyparKind.Measure -> - match args, postfix with - | [arg], true -> - let ms, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv arg m - TType_measure (Measure.Prod(Measure.Con tcref, ms)), tpenv - - | _, _ -> - errorR(Error(FSComp.SR.tcUnitsOfMeasureInvalidInTypeConstructor(), m)) - NewErrorType (), tpenv - - | SynType.LongIdentApp (ltyp, SynLongIdent(longId, _, _), _, args, _commas, _, m) -> - let ad = env.eAccessRights - let ltyp, tpenv = TcType cenv newOk checkCxs occ env tpenv ltyp - match ltyp with - | AppTy g (tcref, tinst) -> - let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameResEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length)) ad m tcref longId - TcTypeApp cenv newOk checkCxs occ env tpenv m tcref tinst args - | _ -> error(Error(FSComp.SR.tcTypeHasNoNestedTypes(), m)) + | SynType.App (StripParenTypes (SynType.LongIdent longId), _, args, _, _, postfix, m) -> + TcLongIdentAppType kindOpt cenv newOk checkConstraints occ env tpenv longId postfix args m + + | SynType.LongIdentApp (synLeftTy, synLongId, _, args, _commas, _, m) -> + TcNestedAppType cenv newOk checkConstraints occ env tpenv synLeftTy synLongId args m | SynType.Tuple(isStruct, args, m) -> - let tupInfo = mkTupInfo isStruct - if isStruct then - let args',tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m - TType_tuple(tupInfo,args'),tpenv - else - let isMeasure = match optKind with Some TyparKind.Measure -> true | None -> List.exists (fun (isquot,_) -> isquot) args | _ -> false - if isMeasure then - let ms,tpenv = TcMeasuresAsTuple cenv newOk checkCxs occ env tpenv args m - TType_measure ms,tpenv - else - let args',tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m - TType_tuple(tupInfo,args'),tpenv + TcTupleType kindOpt cenv newOk checkConstraints occ env tpenv isStruct args m | SynType.AnonRecd(_, [],m) -> error(Error((FSComp.SR.tcAnonymousTypeInvalidInDeclaration()), m)) | SynType.AnonRecd(isStruct, args, m) -> - - let tupInfo = mkTupInfo isStruct - let args',tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv (args |> List.map snd |> List.map (fun x -> (false,x))) m - let unsortedFieldIds = args |> List.map fst |> List.toArray - let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, tupInfo, unsortedFieldIds) - - // Sort into canonical order - let sortedFieldTys, sortedCheckedArgTys = List.zip args args' |> List.indexed |> List.sortBy (fun (i,_) -> unsortedFieldIds[i].idText) |> List.map snd |> List.unzip - - sortedFieldTys |> List.iteri (fun i (x,_) -> - let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange) - CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,emptyTyparInst,ItemOccurence.UseInType,env.eAccessRights)) - - TType_anon(anonInfo, sortedCheckedArgTys),tpenv + TcAnonRecdType cenv newOk checkConstraints occ env tpenv isStruct args m | SynType.Fun(domainTy, resultTy, _) -> - let domainTyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv domainTy - let resultTyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv resultTy - let tyR = mkFunTy g domainTyR resultTyR - tyR, tpenv + TcFunctionType cenv newOk checkConstraints occ env tpenv domainTy resultTy - | SynType.Array (n, elemTy, m) -> - let elemTy, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv elemTy - mkArrayTy g n elemTy m, tpenv + | SynType.Array (rank , elemTy, m) -> + TcElementType cenv newOk checkConstraints occ env tpenv rank elemTy m | SynType.Var (tp, _) -> - let tpR, tpenv = TcTyparOrMeasurePar optKind cenv env newOk tpenv tp - match tpR.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var tpR), tpenv - | TyparKind.Type -> mkTyparTy tpR, tpenv + TcTypeParameter kindOpt cenv env newOk tpenv tp - // _ types | SynType.Anon m -> - let tp: Typar = TcAnonTypeOrMeasure optKind cenv TyparRigidity.Anon TyparDynamicReq.No newOk m - match tp.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var tp), tpenv - | TyparKind.Type -> mkTyparTy tp, tpenv - - | SynType.WithGlobalConstraints(ty, wcs, _) -> - let cty, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - let tpenv = TcTyparConstraints cenv newOk checkCxs occ env tpenv wcs - cty, tpenv - - // #typ - | SynType.HashConstraint(ty, m) -> - let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m - let tyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace tyR (mkTyparTy tp) - tp.AsType, tpenv - - | SynType.StaticConstant (c, m) -> - match c, optKind with - | _, Some TyparKind.Type -> - errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) - NewErrorType (), tpenv - | SynConst.Int32 1, _ -> - TType_measure Measure.One, tpenv - | _ -> - errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) - NewErrorType (), tpenv + TcAnonType kindOpt cenv newOk tpenv m + + | SynType.WithGlobalConstraints(synInnerTy, synConstraints, _) -> + TcTypeWithConstraints cenv env newOk checkConstraints occ tpenv synInnerTy synConstraints + + | SynType.HashConstraint(synInnerTy, m) -> + TcTypeHashConstraint cenv env newOk checkConstraints occ tpenv synInnerTy m + + | SynType.StaticConstant (synConst, m) -> + TcTypeStaticConstant kindOpt tpenv synConst m | SynType.StaticConstantNamed (_, _, m) | SynType.StaticConstantExpr (_, m) -> @@ -4507,100 +4547,268 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv NewErrorType (), tpenv | SynType.MeasurePower(ty, exponent, m) -> - match optKind with - | Some TyparKind.Type -> - errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("^"), m)) - NewErrorType (), tpenv - | _ -> - let ms, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv ty m - TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent)), tpenv + TcTypeMeasurePower kindOpt cenv newOk checkConstraints occ env tpenv ty exponent m | SynType.MeasureDivide(typ1, typ2, m) -> - match optKind with - | Some TyparKind.Type -> - errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("/"), m)) + TcTypeMeasureDivide kindOpt cenv newOk checkConstraints occ env tpenv typ1 typ2 m + + | SynType.App(arg1, _, args, _, _, postfix, m) -> + TcTypeMeasureApp kindOpt cenv newOk checkConstraints occ env tpenv arg1 args postfix m + + | SynType.Paren(innerType, _) -> + TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ env tpenv innerType + +and TcLongIdent kindOpt cenv newOk checkConstraints occ env tpenv synLongId = + let (SynLongIdent(tc, _, _)) = synLongId + let m = synLongId.Range + let ad = env.eAccessRights + let tinstEnclosing, tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver occ OpenQualified env.NameEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) + match kindOpt, tcref.TypeOrMeasureKind with + | Some TyparKind.Type, TyparKind.Measure -> + error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) + NewErrorType (), tpenv + | Some TyparKind.Measure, TyparKind.Type -> + error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) + TType_measure (NewErrorMeasure ()), tpenv + | _, TyparKind.Measure -> + TType_measure (Measure.Con tcref), tpenv + | _, TyparKind.Type -> + TcTypeApp cenv newOk checkConstraints occ env tpenv m tcref tinstEnclosing [] + +/// Some.Long.TypeName +/// ty1 SomeLongTypeName +and TcLongIdentAppType kindOpt cenv newOk checkConstraints occ env tpenv longId postfix args m = + let (SynLongIdent(tc, _, _)) = longId + let ad = env.eAccessRights + + let tinstEnclosing, tcref = + let tyResInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length + ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameResEnv ad tc tyResInfo PermitDirectReferenceToGeneratedType.No + |> ForceRaise + + match kindOpt, tcref.TypeOrMeasureKind with + | Some TyparKind.Type, TyparKind.Measure -> + error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) + NewErrorType (), tpenv + + | Some TyparKind.Measure, TyparKind.Type -> + error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) + TType_measure (NewErrorMeasure ()), tpenv + + | _, TyparKind.Type -> + if postfix && tcref.Typars m |> List.exists (fun tp -> match tp.Kind with TyparKind.Measure -> true | _ -> false) then + error(Error(FSComp.SR.tcInvalidUnitsOfMeasurePrefix(), m)) + TcTypeApp cenv newOk checkConstraints occ env tpenv m tcref tinstEnclosing args + + | _, TyparKind.Measure -> + match args, postfix with + | [arg], true -> + let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg m + TType_measure (Measure.Prod(Measure.Con tcref, ms)), tpenv + + | _, _ -> + errorR(Error(FSComp.SR.tcUnitsOfMeasureInvalidInTypeConstructor(), m)) NewErrorType (), tpenv - | _ -> - let ms1, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv typ1 m - let ms2, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv typ2 m - TType_measure (Measure.Prod(ms1, Measure.Inv ms2)), tpenv - | SynType.App(StripParenTypes (SynType.Var(_, m1) | SynType.MeasurePower(_, _, m1)) as arg1, _, args, _commas, _, postfix, m) -> - match optKind, args, postfix with +and TcNestedAppType cenv newOk checkConstraints occ env tpenv synLeftTy synLongId args m = + let g = cenv.g + let ad = env.eAccessRights + let (SynLongIdent(longId, _, _)) = synLongId + let leftTy, tpenv = TcType cenv newOk checkConstraints occ env tpenv synLeftTy + match leftTy with + | AppTy g (tcref, tinst) -> + let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameResEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length)) ad m tcref longId + TcTypeApp cenv newOk checkConstraints occ env tpenv m tcref tinst args + | _ -> + error(Error(FSComp.SR.tcTypeHasNoNestedTypes(), m)) + +and TcTupleType kindOpt cenv newOk checkConstraints occ env tpenv isStruct args m = + + let tupInfo = mkTupInfo isStruct + if isStruct then + let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m + TType_tuple(tupInfo, argsR), tpenv + else + let isMeasure = + match kindOpt with + | Some TyparKind.Measure -> true + | None -> List.exists (fun (isquot,_) -> isquot) args | _ -> false + + if isMeasure then + let ms,tpenv = TcMeasuresAsTuple cenv newOk checkConstraints occ env tpenv args m + TType_measure ms,tpenv + else + let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m + TType_tuple(tupInfo, argsR), tpenv + +and TcAnonRecdType cenv newOk checkConstraints occ env tpenv isStruct args m = + let tupInfo = mkTupInfo isStruct + let tup = args |> List.map snd |> List.map (fun x -> (false, x)) + let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv tup m + let unsortedFieldIds = args |> List.map fst |> List.toArray + let anonInfo = AnonRecdTypeInfo.Create(cenv.thisCcu, tupInfo, unsortedFieldIds) + + // Sort into canonical order + let sortedFieldTys, sortedCheckedArgTys = List.zip args argsR |> List.indexed |> List.sortBy (fun (i,_) -> unsortedFieldIds[i].idText) |> List.map snd |> List.unzip + + sortedFieldTys |> List.iteri (fun i (x,_) -> + let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange) + CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,emptyTyparInst,ItemOccurence.UseInType,env.eAccessRights)) + + TType_anon(anonInfo, sortedCheckedArgTys),tpenv + +and TcFunctionType cenv newOk checkConstraints occ env tpenv domainTy resultTy = + let g = cenv.g + let domainTyR, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv domainTy + let resultTyR, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv resultTy + let tyR = mkFunTy g domainTyR resultTyR + tyR, tpenv + +and TcElementType cenv newOk checkConstraints occ env tpenv rank elemTy m = + let g = cenv.g + let elemTy, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv elemTy + let tyR = mkArrayTy g rank elemTy m + tyR, tpenv + +and TcTypeParameter kindOpt cenv env newOk tpenv tp = + let tpR, tpenv = TcTypeOrMeasureParameter kindOpt cenv env newOk tpenv tp + match tpR.Kind with + | TyparKind.Measure -> TType_measure (Measure.Var tpR), tpenv + | TyparKind.Type -> mkTyparTy tpR, tpenv + +// _ types +and TcAnonType kindOpt cenv newOk tpenv m = + let tp: Typar = TcAnonTypeOrMeasure kindOpt cenv TyparRigidity.Anon TyparDynamicReq.No newOk m + match tp.Kind with + | TyparKind.Measure -> TType_measure (Measure.Var tp), tpenv + | TyparKind.Type -> mkTyparTy tp, tpenv + +and TcTypeWithConstraints cenv env newOk checkConstraints occ tpenv synTy synConstraints = + let ty, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv synTy + let tpenv = TcTyparConstraints cenv newOk checkConstraints occ env tpenv synConstraints + ty, tpenv + +// #typ +and TcTypeHashConstraint cenv env newOk checkConstraints occ tpenv synTy m = + let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m + let ty, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv synTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty (mkTyparTy tp) + tp.AsType, tpenv + +and TcTypeStaticConstant kindOpt tpenv c m = + match c, kindOpt with + | _, Some TyparKind.Type -> + errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) + NewErrorType (), tpenv + | SynConst.Int32 1, _ -> + TType_measure Measure.One, tpenv + | _ -> + errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) + NewErrorType (), tpenv + +and TcTypeMeasurePower kindOpt cenv newOk checkConstraints occ env tpenv ty exponent m = + match kindOpt with + | Some TyparKind.Type -> + errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("^"), m)) + NewErrorType (), tpenv + | _ -> + let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m + TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent)), tpenv + +and TcTypeMeasureDivide kindOpt cenv newOk checkConstraints occ env tpenv typ1 typ2 m = + match kindOpt with + | Some TyparKind.Type -> + errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("/"), m)) + NewErrorType (), tpenv + | _ -> + let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv typ1 m + let ms2, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv typ2 m + TType_measure (Measure.Prod(ms1, Measure.Inv ms2)), tpenv + +and TcTypeMeasureApp kindOpt cenv newOk checkConstraints occ env tpenv arg1 args postfix m = + match arg1 with + | StripParenTypes (SynType.Var(_, m1) | SynType.MeasurePower(_, _, m1)) -> + match kindOpt, args, postfix with | (None | Some TyparKind.Measure), [arg2], true -> - let ms1, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv arg1 m1 - let ms2, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv arg2 m + let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg1 m1 + let ms2, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg2 m TType_measure (Measure.Prod(ms1, ms2)), tpenv | _ -> errorR(Error(FSComp.SR.tcTypeParameterInvalidAsTypeConstructor(), m)) NewErrorType (), tpenv - - | SynType.App(_, _, _, _, _, _, m) -> + | _ -> errorR(Error(FSComp.SR.tcIllegalSyntaxInTypeExpression(), m)) NewErrorType (), tpenv - | SynType.Paren(innerType, _) -> - TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) innerType - -and TcType cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) ty = - TcTypeOrMeasure (Some TyparKind.Type) cenv newOk checkCxs occ env tpenv ty +and TcType cenv newOk checkConstraints occ env (tpenv: UnscopedTyparEnv) ty = + TcTypeOrMeasure (Some TyparKind.Type) cenv newOk checkConstraints occ env tpenv ty -and TcMeasure cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) (StripParenTypes ty) m = +and TcMeasure cenv newOk checkConstraints occ env (tpenv: UnscopedTyparEnv) (StripParenTypes ty) m = match ty with | SynType.Anon m -> error(Error(FSComp.SR.tcAnonymousUnitsOfMeasureCannotBeNested(), m)) NewErrorMeasure (), tpenv | _ -> - match TcTypeOrMeasure (Some TyparKind.Measure) cenv newOk checkCxs occ env tpenv ty with + match TcTypeOrMeasure (Some TyparKind.Measure) cenv newOk checkConstraints occ env tpenv ty with | TType_measure ms, tpenv -> ms, tpenv | _ -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) NewErrorMeasure (), tpenv -and TcAnonTypeOrMeasure optKind _cenv rigid dyn newOk m = +and TcAnonTypeOrMeasure kindOpt _cenv rigid dyn newOk m = if newOk = NoNewTypars then errorR (Error(FSComp.SR.tcAnonymousTypeInvalidInDeclaration(), m)) - let rigid = (if rigid = TyparRigidity.Anon && newOk = NewTyparsOKButWarnIfNotRigid then TyparRigidity.WarnIfNotRigid else rigid) - let kind = match optKind with Some TyparKind.Measure -> TyparKind.Measure | _ -> TyparKind.Type + + let rigid = + if rigid = TyparRigidity.Anon && newOk = NewTyparsOKButWarnIfNotRigid then + TyparRigidity.WarnIfNotRigid + else + rigid + + let kind = + match kindOpt with + | Some TyparKind.Measure -> TyparKind.Measure + | _ -> TyparKind.Type + NewAnonTypar (kind, m, rigid, TyparStaticReq.None, dyn) -and TcTypes cenv newOk checkCxs occ env tpenv args = - List.mapFold (TcTypeAndRecover cenv newOk checkCxs occ env) tpenv args +and TcTypes cenv newOk checkConstraints occ env tpenv args = + List.mapFold (TcTypeAndRecover cenv newOk checkConstraints occ env) tpenv args -and TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m = +and TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m = match args with | [] -> error(InternalError("empty tuple type", m)) - | [(_, ty)] -> let ty, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty in [ty], tpenv + | [(_, ty)] -> let ty, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv ty in [ty], tpenv | (isquot, ty) :: args -> - let ty, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - let tys, tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv args m + let ty, tpenv = TcTypeAndRecover cenv newOk checkConstraints occ env tpenv ty + let tys, tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m if isquot then errorR(Error(FSComp.SR.tcUnexpectedSlashInType(), m)) ty :: tys, tpenv // Type-check a list of measures separated by juxtaposition, * or / -and TcMeasuresAsTuple cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) args m = +and TcMeasuresAsTuple cenv newOk checkConstraints occ env (tpenv: UnscopedTyparEnv) args m = let rec gather args tpenv isquot acc = match args with | [] -> acc, tpenv | (nextisquot, ty) :: args -> - let ms1, tpenv = TcMeasure cenv newOk checkCxs occ env tpenv ty m + let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m gather args tpenv nextisquot (if isquot then Measure.Prod(acc, Measure.Inv ms1) else Measure.Prod(acc, ms1)) gather args tpenv false Measure.One -and TcTypesOrMeasures optKinds cenv newOk checkCxs occ env tpenv args m = +and TcTypesOrMeasures optKinds cenv newOk checkConstraints occ env tpenv args m = match optKinds with | None -> - List.mapFold (TcTypeOrMeasure None cenv newOk checkCxs occ env) tpenv args + List.mapFold (TcTypeOrMeasure None cenv newOk checkConstraints occ env) tpenv args | Some kinds -> if List.length kinds = List.length args then - List.mapFold (fun tpenv (arg, kind) -> TcTypeOrMeasure (Some kind) cenv newOk checkCxs occ env tpenv arg) tpenv (List.zip args kinds) + List.mapFold (fun tpenv (arg, kind) -> TcTypeOrMeasure (Some kind) cenv newOk checkConstraints occ env tpenv arg) tpenv (List.zip args kinds) elif isNil kinds then error(Error(FSComp.SR.tcUnexpectedTypeArguments(), m)) else error(Error(FSComp.SR.tcTypeParameterArityMismatch((List.length kinds), (List.length args)), m)) -and TcTyparConstraints cenv newOk checkCxs occ env tpenv synConstraints = +and TcTyparConstraints cenv newOk checkConstraints occ env tpenv synConstraints = // Mark up default constraints with a priority in reverse order: last gets 0, second // last gets 1 etc. See comment on TyparConstraint.DefaultsTo - let _, tpenv = List.fold (fun (ridx, tpenv) tc -> ridx - 1, TcTyparConstraint ridx cenv newOk checkCxs occ env tpenv tc) (List.length synConstraints - 1, tpenv) synConstraints + let _, tpenv = List.fold (fun (ridx, tpenv) tc -> ridx - 1, TcTyparConstraint ridx cenv newOk checkConstraints occ env tpenv tc) (List.length synConstraints - 1, tpenv) synConstraints tpenv #if !NO_TYPEPROVIDERS @@ -4667,9 +4875,9 @@ and TcStaticConstantParameter cenv (env: TcEnv) tpenv kind (StripParenTypes v) i | _ -> error(Error(FSComp.SR.tcInvalidConstantExpression(), v.Range)) v, tpenv' - | SynType.LongIdent lidwd -> - let m = lidwd.Range - TcStaticConstantParameter cenv env tpenv kind (SynType.StaticConstantExpr(SynExpr.LongIdent (false, lidwd, None, m), m)) idOpt container + | SynType.LongIdent synLongId -> + let m = synLongId.Range + TcStaticConstantParameter cenv env tpenv kind (SynType.StaticConstantExpr(SynExpr.LongIdent (false, synLongId, None, m), m)) idOpt container | _ -> fail() @@ -4726,7 +4934,7 @@ and CrackStaticConstantArgs cenv env tpenv (staticParameters: Tainted info.ProvidedType @@ -4739,7 +4947,7 @@ and TcProvidedTypeAppToStaticConstantArgs cenv env optGeneratedTypePath tpenv (t // Take the static arguments (as SynType's) and convert them to objects of the appropriate type, based on the expected kind. let providedTypeAfterStaticArguments, checkTypeName = - match TryApplyProvidedType(typeBeforeArguments, optGeneratedTypePath, argsInStaticParameterOrderIncludingDefaults, m) with + match TryApplyProvidedType(typeBeforeArguments, generatedTypePathOpt, argsInStaticParameterOrderIncludingDefaults, m) with | None -> error(Error(FSComp.SR.etErrorApplyingStaticArgumentsToType(), m)) | Some (ty, checkTypeName) -> (ty, checkTypeName) @@ -4790,9 +4998,9 @@ and TcProvidedTypeApp cenv env tpenv tcref args m = /// Typecheck an application of a generic type to type arguments. /// /// Note that the generic type may be a nested generic type List.ListEnumerator. -/// In this case, 'args' is only the instantiation of the suffix type arguments, and pathTypeArgs gives +/// In this case, 'argsR is only the instantiation of the suffix type arguments, and pathTypeArgs gives /// the prefix of type arguments. -and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: SynType list) = +and TcTypeApp cenv newOk checkConstraints occ env tpenv m tcref pathTypeArgs (synArgTys: SynType list) = let g = cenv.g CheckTyconAccessible cenv.amap m env.AccessRights tcref |> ignore CheckEntityAttributes g tcref m |> CommitOperationResult @@ -4807,7 +5015,7 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just // clear the constraint lists of the freshly generated type variables. A little ugly but fairly localized. - if checkCxs = NoCheckCxs then tps |> List.iter (fun tp -> tp.SetConstraints []) + if checkConstraints = NoCheckCxs then tps |> List.iter (fun tp -> tp.SetConstraints []) let synArgTysLength = synArgTys.Length let pathTypeArgsLength = pathTypeArgs.Length if tinst.Length <> pathTypeArgsLength + synArgTysLength then @@ -4817,12 +5025,12 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: // Get the suffix of typars let tpsForArgs = List.skip (tps.Length - synArgTysLength) tps let kindsForArgs = tpsForArgs |> List.map (fun tp -> tp.Kind) - TcTypesOrMeasures (Some kindsForArgs) cenv newOk checkCxs occ env tpenv synArgTys m + TcTypesOrMeasures (Some kindsForArgs) cenv newOk checkConstraints occ env tpenv synArgTys m // Add the types of the enclosing class for a nested type let actualArgTys = pathTypeArgs @ argTys - if checkCxs = CheckCxs then + if checkConstraints = CheckCxs then List.iter2 (UnifyTypes cenv env m) tinst actualArgTys // Try to decode System.Tuple --> F~ tuple types etc. @@ -4830,15 +5038,15 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: ty, tpenv -and TcTypeOrMeasureAndRecover optKind cenv newOk checkCxs occ env tpenv ty = +and TcTypeOrMeasureAndRecover kindOpt cenv newOk checkConstraints occ env tpenv ty = let g = cenv.g try - TcTypeOrMeasure optKind cenv newOk checkCxs occ env tpenv ty + TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ env tpenv ty with e -> errorRecovery e ty.Range let recoveryTy = - match optKind, newOk with + match kindOpt, newOk with | Some TyparKind.Measure, NoNewTypars -> TType_measure Measure.One | Some TyparKind.Measure, _ -> TType_measure (NewErrorMeasure ()) | _, NoNewTypars -> g.obj_ty @@ -4846,10 +5054,10 @@ and TcTypeOrMeasureAndRecover optKind cenv newOk checkCxs occ env tpenv ty = recoveryTy, tpenv -and TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty = - TcTypeOrMeasureAndRecover (Some TyparKind.Type) cenv newOk checkCxs occ env tpenv ty +and TcTypeAndRecover cenv newOk checkConstraints occ env tpenv ty = + TcTypeOrMeasureAndRecover (Some TyparKind.Type) cenv newOk checkConstraints occ env tpenv ty -and TcNestedTypeApplication cenv newOk checkCxs occ env tpenv mWholeTypeApp ty pathTypeArgs tyargs = +and TcNestedTypeApplication cenv newOk checkConstraints occ env tpenv mWholeTypeApp ty pathTypeArgs tyargs = let g = cenv.g let ty = convertToTypeWithMetadataIfPossible g ty @@ -4859,8 +5067,9 @@ and TcNestedTypeApplication cenv newOk checkCxs occ env tpenv mWholeTypeApp ty p match ty with | TType_app(tcref, _, _) -> - TcTypeApp cenv newOk checkCxs occ env tpenv mWholeTypeApp tcref pathTypeArgs tyargs - | _ -> error(InternalError("TcNestedTypeApplication: expected type application", mWholeTypeApp)) + TcTypeApp cenv newOk checkConstraints occ env tpenv mWholeTypeApp tcref pathTypeArgs tyargs + | _ -> + error(InternalError("TcNestedTypeApplication: expected type application", mWholeTypeApp)) and TryAdjustHiddenVarNameToCompGenName cenv env (id: Ident) altNameRefCellOpt = match altNameRefCellOpt with @@ -4877,45 +5086,45 @@ and TryAdjustHiddenVarNameToCompGenName cenv env (id: Ident) altNameRefCellOpt = | None -> None /// Bind the patterns used in a lambda. Not clear why we don't use TcPat. -and TcSimplePat optArgsOK checkCxs cenv ty env (tpenv, names, takenNames) p = +and TcSimplePat optionalArgsOK checkConstraints cenv ty env (tpenv, names, takenNames) p = let g = cenv.g match p with - | SynSimplePat.Id (id, altNameRefCellOpt, compgen, isMemberThis, isOpt, m) -> + | SynSimplePat.Id (id, altNameRefCellOpt, isCompGen, isMemberThis, isOpt, m) -> // Check to see if pattern translation decides to use an alternative identifier. match TryAdjustHiddenVarNameToCompGenName cenv env id altNameRefCellOpt with | Some altId -> - TcSimplePat optArgsOK checkCxs cenv ty env (tpenv, names, takenNames) (SynSimplePat.Id (altId, None, compgen, isMemberThis, isOpt, m) ) + TcSimplePat optionalArgsOK checkConstraints cenv ty env (tpenv, names, takenNames) (SynSimplePat.Id (altId, None, isCompGen, isMemberThis, isOpt, m) ) | None -> if isOpt then - if not optArgsOK then + if not optionalArgsOK then errorR(Error(FSComp.SR.tcOptionalArgsOnlyOnMembers(), m)) let tyarg = NewInferenceType g UnifyTypes cenv env m ty (mkOptionTy g tyarg) - let _, names, takenNames = TcPatBindingName cenv env id ty isMemberThis None None (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, compgen) (names, takenNames) + let _, names, takenNames = TcPatBindingName cenv env id ty isMemberThis None None (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, isCompGen) (names, takenNames) id.idText, (tpenv, names, takenNames) | SynSimplePat.Typed (p, cty, m) -> - let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK checkCxs ItemOccurence.UseInType env tpenv cty + let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK checkConstraints ItemOccurence.UseInType env tpenv cty match p with // Optional arguments on members | SynSimplePat.Id(_, _, _, _, true, _) -> UnifyTypes cenv env m ty (mkOptionTy g ctyR) | _ -> UnifyTypes cenv env m ty ctyR - TcSimplePat optArgsOK checkCxs cenv ty env (tpenv, names, takenNames) p + TcSimplePat optionalArgsOK checkConstraints cenv ty env (tpenv, names, takenNames) p | SynSimplePat.Attrib (p, _, _) -> - TcSimplePat optArgsOK checkCxs cenv ty env (tpenv, names, takenNames) p + TcSimplePat optionalArgsOK checkConstraints cenv ty env (tpenv, names, takenNames) p // raise an error if any optional args precede any non-optional args -and ValidateOptArgOrder (spats: SynSimplePats) = +and ValidateOptArgOrder (synSimplePats: SynSimplePats) = - let rec getPats spats = - match spats with + let rec getPats synSimplePats = + match synSimplePats with | SynSimplePats.SimplePats(p, m) -> p, m | SynSimplePats.Typed(p, _, _) -> getPats p @@ -4925,7 +5134,7 @@ and ValidateOptArgOrder (spats: SynSimplePats) = | SynSimplePat.Typed (p, _, _) -> isOptArg p | SynSimplePat.Attrib (p, _, _) -> isOptArg p - let pats, m = getPats spats + let pats, m = getPats synSimplePats let mutable hitOptArg = false @@ -4933,7 +5142,7 @@ and ValidateOptArgOrder (spats: SynSimplePats) = /// Bind the patterns used in argument position for a function, method or lambda. -and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames: Set<_>) p = +and TcSimplePats cenv optionalArgsOK checkConstraints ty env (tpenv, names, takenNames: Set<_>) p = let g = cenv.g @@ -4956,12 +5165,12 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames: Set<_ [id.idText], (tpenv, names, takenNames) | SynSimplePats.SimplePats ([p], _) -> - let v, (tpenv, names, takenNames) = TcSimplePat optArgsOK checkCxs cenv ty env (tpenv, names, takenNames) p + let v, (tpenv, names, takenNames) = TcSimplePat optionalArgsOK checkConstraints cenv ty env (tpenv, names, takenNames) p [v], (tpenv, names, takenNames) | SynSimplePats.SimplePats (ps, m) -> let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps - let ps', (tpenv, names, takenNames) = List.mapFold (fun tpenv (ty, e) -> TcSimplePat optArgsOK checkCxs cenv ty env tpenv e) (tpenv, names, takenNames) (List.zip ptys ps) + let ps', (tpenv, names, takenNames) = List.mapFold (fun tpenv (ty, e) -> TcSimplePat optionalArgsOK checkConstraints cenv ty env tpenv e) (tpenv, names, takenNames) (List.zip ptys ps) ps', (tpenv, names, takenNames) | SynSimplePats.Typed (p, cty, m) -> @@ -4972,21 +5181,25 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames: Set<_ | SynSimplePats.SimplePats([SynSimplePat.Id(_, _, _, _, true, _)], _) -> UnifyTypes cenv env m ty (mkOptionTy g ctyR) | _ -> UnifyTypes cenv env m ty ctyR - TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames) p + TcSimplePats cenv optionalArgsOK checkConstraints ty env (tpenv, names, takenNames) p -and TcSimplePatsOfUnknownType cenv optArgsOK checkCxs env tpenv spats = +and TcSimplePatsOfUnknownType cenv optionalArgsOK checkConstraints env tpenv synSimplePats = let g = cenv.g let argTy = NewInferenceType g - TcSimplePats cenv optArgsOK checkCxs argTy env (tpenv, NameMap.empty, Set.empty) spats + TcSimplePats cenv optionalArgsOK checkConstraints argTy env (tpenv, NameMap.empty, Set.empty) synSimplePats -and TcPatBindingName cenv env id ty isMemberThis vis1 topValInfo (inlineFlag, declaredTypars, argAttribs, isMutable, vis2, compgen) (names, takenNames: Set) = +and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (inlineFlag, declaredTypars, argAttribs, isMutable, vis2, isCompGen) (names, takenNames: Set) = let vis = if Option.isSome vis1 then vis1 else vis2 + if takenNames.Contains id.idText then errorR (VarBoundTwice id) - let compgen = compgen || IsCompilerGeneratedName id.idText + + let isCompGen = isCompGen || IsCompilerGeneratedName id.idText let baseOrThis = if isMemberThis then MemberThisVal else NormalVal - let names = Map.add id.idText (PrelimValScheme1(id, declaredTypars, ty, topValInfo, None, isMutable, inlineFlag, baseOrThis, argAttribs, vis, compgen)) names + let prelimVal = PrelimVal1(id, declaredTypars, ty, valReprInfo, None, isMutable, inlineFlag, baseOrThis, argAttribs, vis, isCompGen) + let names = Map.add id.idText prelimVal names let takenNames = Set.add id.idText takenNames - (fun (TcPatPhase2Input (values, isLeftMost)) -> + + let phase2 (TcPatPhase2Input (values, isLeftMost)) = let vspec, typeScheme = let name = id.idText match values.TryGetValue name with @@ -5006,18 +5219,19 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 topValInfo (inlineFlag, de let item = Item.Value(mkLocalValRef vspec) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Binding, env.AccessRights) - PBind(vspec, typeScheme)), - names, takenNames + PatternValBinding(vspec, typeScheme) + + phase2, names, takenNames -and TcPatAndRecover warnOnUpper cenv (env: TcEnv) topValInfo vFlags (tpenv, names, takenNames) ty (pat: SynPat) = +and TcPatAndRecover warnOnUpper cenv (env: TcEnv) valReprInfo vFlags (tpenv, names, takenNames) ty (synPat: SynPat) = try - TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty pat + TcPat warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty synPat with e -> // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error - let m = pat.Range + let m = synPat.Range errorRecovery e m - //solveTypAsError cenv env.DisplayEnv m ty + //SolveTypeAsError cenv env.DisplayEnv m ty (fun _ -> TPat_error m), (tpenv, names, takenNames) /// Typecheck a pattern. Patterns are type-checked in three phases: @@ -5028,150 +5242,73 @@ and TcPatAndRecover warnOnUpper cenv (env: TcEnv) topValInfo vFlags (tpenv, name /// variables are to be generalized. The caller hands this information to /// the second-phase function in terms of a List.map from names to actual /// value specifications. -and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty pat = +and TcPat warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty synPat = let g = cenv.g let ad = env.AccessRights - match pat with - | SynPat.As(_, SynPat.Named _, _) -> () + match synPat with + | SynPat.As (_, SynPat.Named _, _) -> () | SynPat.As (_, _, m) -> checkLanguageFeatureError g.langVersion LanguageFeature.NonVariablePatternsToRightOfAsPatterns m | _ -> () - match pat with - | SynPat.Const (c, m) -> - match c with - | SynConst.Bytes (bytes, _, m) -> - UnifyTypes cenv env m ty (mkByteArrayTy g) - TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty (SynPat.ArrayOrList (true, [ for b in bytes -> SynPat.Const(SynConst.Byte b, m) ], m)) - - | SynConst.UserNum _ -> - errorR (Error (FSComp.SR.tcInvalidNonPrimitiveLiteralInPatternMatch (), m)) - (fun _ -> TPat_error m), (tpenv, names, takenNames) - - | _ -> - try - let c' = TcConst cenv ty m env c - (fun _ -> TPat_const (c', m)), (tpenv, names, takenNames) - with e -> - errorRecovery e m - (fun _ -> TPat_error m), (tpenv, names, takenNames) + match synPat with + | SynPat.Const (synConst, m) -> + TcConstPat warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty synConst m | SynPat.Wild m -> (fun _ -> TPat_wild m), (tpenv, names, takenNames) - | SynPat.IsInst(cty, m) - | SynPat.As (SynPat.IsInst(cty, m), _, _) -> - let srcTy = ty - let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgtTy srcTy - match pat with - | SynPat.IsInst(_, m) -> - (fun _ -> TPat_isinst (srcTy, tgtTy, None, m)), (tpenv, names, takenNames) - | SynPat.As (SynPat.IsInst _, p, m) -> - let pat, acc = TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) tgtTy p - (fun values -> TPat_isinst (srcTy, tgtTy, Some (pat values), m)), acc - | _ -> failwith "TcPat" - - | SynPat.As (p, SynPat.Named (SynIdent(id,_), isMemberThis, vis, m), _) - | SynPat.As (SynPat.Named (SynIdent(id,_), isMemberThis, vis, m), p, _) -> - let bindf, names, takenNames = TcPatBindingName cenv env id ty isMemberThis vis topValInfo vFlags (names, takenNames) - let pat', acc = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty p - (fun values -> TPat_as (pat' values, bindf values, m)), - acc + | SynPat.IsInst (synTargetTy, m) + | SynPat.As (SynPat.IsInst(synTargetTy, m), _, _) -> + TcPatIsInstance warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty synPat synTargetTy m + + | SynPat.As (synInnerPat, SynPat.Named (SynIdent(id,_), isMemberThis, vis, m), _) + | SynPat.As (SynPat.Named (SynIdent(id,_), isMemberThis, vis, m), synInnerPat, _) -> + TcPatNamedAs warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty synInnerPat id isMemberThis vis m | SynPat.As (pat1, pat2, m) -> - let pats = [pat1; pat2] - let pats', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> ty) pats) pats - (fun values -> TPat_conjs(List.map (fun f -> f values) pats', m)), acc + TcPatUnnamedAs warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pat1 pat2 m | SynPat.Named (SynIdent(id,_), isMemberThis, vis, m) -> - let bindf, names, takenNames = TcPatBindingName cenv env id ty isMemberThis vis topValInfo vFlags (names, takenNames) - let pat', acc = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty (SynPat.Wild m) - (fun values -> TPat_as (pat' values, bindf values, m)), - acc + TcPatNamed warnOnUpper cenv env vFlags (tpenv, names, takenNames) id ty isMemberThis vis valReprInfo m | SynPat.OptionalVal (id, m) -> errorR (Error (FSComp.SR.tcOptionalArgsOnlyOnMembers (), m)) - let bindf, names, takenNames = TcPatBindingName cenv env id ty false None topValInfo vFlags (names, takenNames) + let bindf, names, takenNames = TcPatBindingName cenv env id ty false None valReprInfo vFlags (names, takenNames) (fun values -> TPat_as (TPat_wild m, bindf values, m)), (tpenv, names, takenNames) | SynPat.Typed (p, cty, m) -> let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty UnifyTypes cenv env m ty ctyR - TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p + TcPat warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty p - | SynPat.Attrib (p, attrs, _) -> - errorR (Error (FSComp.SR.tcAttributesInvalidInPatterns (), rangeOfNonNilAttrs attrs)) - for attrList in attrs do - TcAttributes cenv env Unchecked.defaultof<_> attrList.Attributes |> ignore - TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty p + | SynPat.Attrib (innerPat, attrs, _) -> + TcPatAttributed warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty innerPat attrs | SynPat.Or (pat1, pat2, m, _) -> - let pat1', (tpenv, names1, takenNames1) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat1 - let pat2', (tpenv, names2, takenNames2) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat2 - if not (takenNames1 = takenNames2) then - errorR (UnionPatternsBindDifferentNames m) - - names1 |> Map.iter (fun _ (PrelimValScheme1 (id1, _, ty1, _, _, _, _, _, _, _, _)) -> - match names2.TryGetValue id1.idText with - | true, PrelimValScheme1 (id2, _, ty2, _, _, _, _, _, _, _, _) -> - try UnifyTypes cenv env id2.idRange ty1 ty2 - with e -> errorRecovery e m - | _ -> ()) - - let names = NameMap.layer names1 names2 - let takenNames = Set.union takenNames1 takenNames2 - (fun values -> TPat_disjs ([pat1' values; pat2' values.RightPath], m)), (tpenv, names, takenNames) + TcPatOr warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pat1 pat2 m | SynPat.Ands (pats, m) -> - let pats', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> ty) pats) pats - (fun values -> TPat_conjs(List.map (fun f -> f values) pats', m)), acc + TcPatAnds warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pats m | SynPat.LongIdent (longDotId=longDotId; typarDecls=tyargs; argPats=args; accessibility=vis; range=m) -> - TcPatLongIdent warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, takenNames) ty (longDotId, tyargs, args, vis, m) + TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (tpenv, names, takenNames) ty (longDotId, tyargs, args, vis, m) | SynPat.QuoteExpr(_, m) -> errorR (Error(FSComp.SR.tcInvalidPattern(), m)) (fun _ -> TPat_error m), (tpenv, names, takenNames) | SynPat.Tuple (isExplicitStruct, args, m) -> - try - let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m ty isExplicitStruct args - let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args - (fun values -> TPat_tuple(tupInfo, List.map (fun f -> f values) args', argTys, m)), acc - with e -> - errorRecovery e m - let _, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (NewInferenceTypes g args) args - (fun _ -> TPat_error m), acc + TcPatTuple warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty isExplicitStruct args m | SynPat.Paren (p, _) -> TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty p | SynPat.ArrayOrList (isArray, args, m) -> - let argTy = NewInferenceType g - UnifyTypes cenv env m ty (if isArray then mkArrayType g argTy else mkListTy g argTy) - let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> argTy) args) args - (fun values -> - let args' = List.map (fun f -> f values) args' - if isArray then TPat_array(args', argTy, m) - else List.foldBack (mkConsListPat g argTy) args' (mkNilListPat g m argTy)), acc + TcPatArrayOrList warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty isArray args m | SynPat.Record (flds, m) -> - let flds = List.map (fun (f, _, p) -> f,p) flds - let tinst, tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty flds m - // REVIEW: use _fldsList to type check pattern in code order not field defn order - let gtyp = mkAppTy tcref tinst - let inst = List.zip (tcref.Typars m) tinst - UnifyTypes cenv env m ty gtyp - let fields = tcref.TrueInstanceFieldsAsList - let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) - let fldsmap', acc = - ((tpenv, names, takenNames), ftys) ||> List.mapFold (fun s (ty, fsp) -> - match fldsmap.TryGetValue fsp.rfield_id.idText with - | true, v -> TcPat warnOnUpper cenv env None vFlags s ty v - | _ -> (fun _ -> TPat_wild m), s) - (fun values -> TPat_recd (tcref, tinst, List.map (fun f -> f values) fldsmap', m)), - acc + TcRecordPat warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty flds m | SynPat.DeprecatedCharRange (c1, c2, m) -> errorR(Deprecated(FSComp.SR.tcUseWhenPatternGuard(), m)) @@ -5179,16 +5316,146 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (fun _ -> TPat_range(c1, c2, m)), (tpenv, names, takenNames) | SynPat.Null m -> - try AddCxTypeUseSupportsNull env.DisplayEnv cenv.css m NoTrace ty - with e -> errorRecovery e m - (fun _ -> TPat_null m), (tpenv, names, takenNames) + TcNullPat cenv env (tpenv, names, takenNames) ty m - | SynPat.InstanceMember (_, _, _, _, m) -> - errorR(Error(FSComp.SR.tcIllegalPattern(), pat.Range)) + | SynPat.InstanceMember (range=m) -> + errorR(Error(FSComp.SR.tcIllegalPattern(), synPat.Range)) (fun _ -> TPat_wild m), (tpenv, names, takenNames) | SynPat.FromParseError (pat, _) -> - suppressErrorReporting (fun () -> TcPatAndRecover warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) (NewErrorType()) pat) + suppressErrorReporting (fun () -> TcPatAndRecover warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) (NewErrorType()) pat) + +and TcConstPat warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty synConst m = + let g = cenv.g + match synConst with + | SynConst.Bytes (bytes, _, m) -> + UnifyTypes cenv env m ty (mkByteArrayTy g) + let synReplacementExpr = SynPat.ArrayOrList (true, [ for b in bytes -> SynPat.Const(SynConst.Byte b, m) ], m) + TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty synReplacementExpr + + | SynConst.UserNum _ -> + errorR (Error (FSComp.SR.tcInvalidNonPrimitiveLiteralInPatternMatch (), m)) + (fun _ -> TPat_error m), (tpenv, names, takenNames) + + | _ -> + try + let c = TcConst cenv ty m env synConst + (fun _ -> TPat_const (c, m)), (tpenv, names, takenNames) + with e -> + errorRecovery e m + (fun _ -> TPat_error m), (tpenv, names, takenNames) + +and TcPatNamedAs warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) ty synInnerPat id isMemberThis vis m = + let bindf, names, takenNames = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames) + let innerPat, acc = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty synInnerPat + let phase2 values = TPat_as (innerPat values, bindf values, m) + phase2, acc + +and TcPatUnnamedAs warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pat1 pat2 m = + let pats = [pat1; pat2] + let patsR, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> ty) pats) pats + let phase2 values = TPat_conjs(List.map (fun f -> f values) patsR, m) + phase2, acc + +and TcPatNamed warnOnUpper cenv env vFlags (tpenv, names, takenNames) id ty isMemberThis vis valReprInfo m = + let bindf, names, takenNames = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames) + let pat', acc = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty (SynPat.Wild m) + let phase2 values = TPat_as (pat' values, bindf values, m) + phase2, acc + +and TcPatIsInstance warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) srcTy synPat synTargetTy m = + let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv synTargetTy + TcRuntimeTypeTest false true cenv env.DisplayEnv m tgtTy srcTy + match synPat with + | SynPat.IsInst(_, m) -> + (fun _ -> TPat_isinst (srcTy, tgtTy, None, m)), (tpenv, names, takenNames) + | SynPat.As (SynPat.IsInst _, p, m) -> + let pat, acc = TcPat warnOnUpper cenv env valReprInfo vFlags (tpenv, names, takenNames) tgtTy p + (fun values -> TPat_isinst (srcTy, tgtTy, Some (pat values), m)), acc + | _ -> failwith "TcPat" + +and TcPatAttributed warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty innerPat attrs = + errorR (Error (FSComp.SR.tcAttributesInvalidInPatterns (), rangeOfNonNilAttrs attrs)) + for attrList in attrs do + TcAttributes cenv env Unchecked.defaultof<_> attrList.Attributes |> ignore + TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty innerPat + +and TcPatOr warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pat1 pat2 m = + let pat1R, (tpenv, names1, takenNames1) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat1 + let pat2R, (tpenv, names2, takenNames2) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat2 + + if not (takenNames1 = takenNames2) then + errorR (UnionPatternsBindDifferentNames m) + + names1 |> Map.iter (fun _ (PrelimVal1 (id=id1; prelimType=ty1)) -> + match names2.TryGetValue id1.idText with + | true, PrelimVal1 (id=id2; prelimType=ty2) -> + try UnifyTypes cenv env id2.idRange ty1 ty2 + with exn -> errorRecovery exn m + | _ -> ()) + + let names = NameMap.layer names1 names2 + let takenNames = Set.union takenNames1 takenNames2 + let phase2 values = TPat_disjs ([pat1R values; pat2R (values.WithRightPath())], m) + phase2, (tpenv, names, takenNames) + +and TcPatAnds warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty pats m = + let patsR, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> ty) pats) pats + let phase2 values = TPat_conjs(List.map (fun f -> f values) patsR, m) + phase2, acc + +and TcPatTuple warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty isExplicitStruct args m = + let g = cenv.g + try + let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m ty isExplicitStruct args + let argsR, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args + let phase2 values = TPat_tuple(tupInfo, List.map (fun f -> f values) argsR, argTys, m) + phase2, acc + with e -> + errorRecovery e m + let _, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (NewInferenceTypes g args) args + let phase2 _ = TPat_error m + phase2, acc + +and TcPatArrayOrList warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty isArray args m = + let g = cenv.g + let argTy = NewInferenceType g + UnifyTypes cenv env m ty (if isArray then mkArrayType g argTy else mkListTy g argTy) + let argsR, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> argTy) args) args + let phase2 values = + let argsR = List.map (fun f -> f values) argsR + if isArray then TPat_array(argsR, argTy, m) + else List.foldBack (mkConsListPat g argTy) argsR (mkNilListPat g m argTy) + phase2, acc + +and TcRecordPat warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty fieldPats m = + let fieldPats = fieldPats |> List.map (fun (fieldId, _, fieldPat) -> fieldId, fieldPat) + let tinst, tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty fieldPats m + let gtyp = mkAppTy tcref tinst + let inst = List.zip (tcref.Typars m) tinst + + UnifyTypes cenv env m ty gtyp + + let fields = tcref.TrueInstanceFieldsAsList + let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) + + let fieldPats, acc = + ((tpenv, names, takenNames), ftys) ||> List.mapFold (fun s (ty, fsp) -> + match fldsmap.TryGetValue fsp.rfield_id.idText with + | true, v -> TcPat warnOnUpper cenv env None vFlags s ty v + | _ -> (fun _ -> TPat_wild m), s) + + let phase2 values = + TPat_recd (tcref, tinst, List.map (fun f -> f values) fieldPats, m) + + phase2, acc + +and TcNullPat cenv env (tpenv, names, takenNames) ty m = + try + AddCxTypeUseSupportsNull env.DisplayEnv cenv.css m NoTrace ty + with exn -> + errorRecovery exn m + (fun _ -> TPat_null m), (tpenv, names, takenNames) and CheckNoArgsForLiteral args m = match args with @@ -5211,26 +5478,46 @@ and TcArgPats warnOnUpper cenv env vFlags (tpenv, names, takenNames) args = /// /// Note we parse arguments to parameterized pattern labels as patterns, not expressions. /// This means the range of syntactic expression forms that can be used here is limited. -and ConvSynPatToSynExpr x = - match x with - | SynPat.FromParseError(p, _) -> ConvSynPatToSynExpr p - | SynPat.Const (c, m) -> SynExpr.Const (c, m) - | SynPat.Named (SynIdent(id,_), _, None, _) -> SynExpr.Ident id - | SynPat.Typed (p, cty, m) -> SynExpr.Typed (ConvSynPatToSynExpr p, cty, m) - | SynPat.LongIdent (longDotId=SynLongIdent(longId, dotms, trivia) as lidwd; argPats=args; accessibility=None; range=m) -> +and ConvSynPatToSynExpr synPat = + match synPat with + | SynPat.FromParseError(p, _) -> + ConvSynPatToSynExpr p + + | SynPat.Const (c, m) -> + SynExpr.Const (c, m) + + | SynPat.Named (SynIdent(id,_), _, None, _) -> + SynExpr.Ident id + + | SynPat.Typed (p, cty, m) -> + SynExpr.Typed (ConvSynPatToSynExpr p, cty, m) + + | SynPat.LongIdent (longDotId=SynLongIdent(longId, dotms, trivia) as synLongId; argPats=args; accessibility=None; range=m) -> let args = match args with SynArgPats.Pats args -> args | _ -> failwith "impossible: active patterns can be used only with SynConstructorArgs.Pats" let e = if dotms.Length = longId.Length then let e = SynExpr.LongIdent (false, SynLongIdent(longId, List.truncate (dotms.Length - 1) dotms, trivia), None, m) SynExpr.DiscardAfterMissingQualificationAfterDot (e, unionRanges e.Range (List.last dotms)) - else SynExpr.LongIdent (false, lidwd, None, m) + else SynExpr.LongIdent (false, synLongId, None, m) List.fold (fun f x -> mkSynApp1 f (ConvSynPatToSynExpr x) m) e args - | SynPat.Tuple (isStruct, args, m) -> SynExpr.Tuple (isStruct, List.map ConvSynPatToSynExpr args, [], m) - | SynPat.Paren (p, _) -> ConvSynPatToSynExpr p - | SynPat.ArrayOrList (isArray, args, m) -> SynExpr.ArrayOrList (isArray,List.map ConvSynPatToSynExpr args, m) - | SynPat.QuoteExpr (e,_) -> e - | SynPat.Null m -> SynExpr.Null m - | _ -> error(Error(FSComp.SR.tcInvalidArgForParameterizedPattern(), x.Range)) + + | SynPat.Tuple (isStruct, args, m) -> + SynExpr.Tuple (isStruct, List.map ConvSynPatToSynExpr args, [], m) + + | SynPat.Paren (p, _) -> + ConvSynPatToSynExpr p + + | SynPat.ArrayOrList (isArray, args, m) -> + SynExpr.ArrayOrList (isArray,List.map ConvSynPatToSynExpr args, m) + + | SynPat.QuoteExpr (e,_) -> + e + + | SynPat.Null m -> + SynExpr.Null m + + | _ -> + error(Error(FSComp.SR.tcInvalidArgForParameterizedPattern(), synPat.Range)) and IsNameOf (cenv: cenv) (env: TcEnv) ad m (id: Ident) = let g = cenv.g @@ -5242,7 +5529,7 @@ and IsNameOf (cenv: cenv) (env: TcEnv) ad m (id: Ident) = with _ -> false /// Check a long identifier in a pattern -and TcPatLongIdent warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, takenNames) ty (longDotId, tyargs, args, vis, m) = +and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (tpenv, names, takenNames) ty (longDotId, tyargs, args, vis, m) = let (SynLongIdent(longId, _, _)) = longDotId if tyargs.IsSome then errorR(Error(FSComp.SR.tcInvalidTypeArgumentUsage(), m)) @@ -5256,7 +5543,7 @@ and TcPatLongIdent warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, take match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.NameEnv TypeNameResolutionInfo.Default longId with | Item.NewDef id -> - TcPatLongIdentNewDef warnOnUpperForId warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, takenNames) ty (vis, id, args, m) + TcPatLongIdentNewDef warnOnUpperForId warnOnUpper cenv env ad valReprInfo vFlags (tpenv, names, takenNames) ty (vis, id, args, m) | Item.ActivePatternCase apref as item -> TcPatLongIdentActivePatternCase warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty (lidRange, item, apref, args, m) @@ -5276,12 +5563,12 @@ and TcPatLongIdent warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, take | _ -> error (Error(FSComp.SR.tcRequireVarConstRecogOrLiteral(), m)) /// Check a long identifier in a pattern that has been not been resolved to anything else and represents a new value, or nameof -and TcPatLongIdentNewDef warnOnUpperForId warnOnUpper cenv env ad topValInfo vFlags (tpenv, names, takenNames) ty (vis, id, args, m) = +and TcPatLongIdentNewDef warnOnUpperForId warnOnUpper cenv env ad valReprInfo vFlags (tpenv, names, takenNames) ty (vis, id, args, m) = let g = cenv.g match GetSynArgPatterns args with | [] -> - TcPat warnOnUpperForId cenv env topValInfo vFlags (tpenv, names, takenNames) ty (mkSynPatVar vis id) + TcPat warnOnUpperForId cenv env valReprInfo vFlags (tpenv, names, takenNames) ty (mkSynPatVar vis id) | [arg] when g.langVersion.SupportsFeature LanguageFeature.NameOf && IsNameOf cenv env ad m id -> @@ -5294,7 +5581,7 @@ and TcPatLongIdentNewDef warnOnUpperForId warnOnUpper cenv env ad topValInfo vFl errorR (UndefinedName (0, FSComp.SR.undefinedNamePatternDiscriminator, id, NoSuggestions)) (fun _ -> TPat_error m), acc -/// Check a long identifier 'Case' or 'Case args' that has been resolved to an active pattern case +/// Check a long identifier 'Case' or 'Case argsR that has been resolved to an active pattern case and TcPatLongIdentActivePatternCase warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty (lidRange, item, apref, args, m) = let g = cenv.g @@ -5353,7 +5640,7 @@ and TcPatLongIdentActivePatternCase warnOnUpper cenv env vFlags (tpenv, names, t (fun values -> TPat_query((activePatExpr, activePatResTys, isStructRetTy, activePatIdentity, idx, apinfo), arg' values, m)), acc -/// Check a long identifier 'Case' or 'Case args' that has been resolved to a union case or F# exception constructor +/// Check a long identifier 'Case' or 'Case argsR that has been resolved to a union case or F# exception constructor and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags (tpenv, names, takenNames) ty (lidRange, item, args, m) = let g = cenv.g @@ -5455,9 +5742,9 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags (tpenv, name args, extraPatterns @ remaining let extraPatterns = extraPatterns @ extraPatternsFromNames - let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args + let argsR, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args let _, acc = TcPatterns warnOnUpper cenv env vFlags acc (NewInferenceTypes g extraPatterns) extraPatterns - (fun values -> mkf m (List.map (fun f -> f values) args')), acc + (fun values -> mkf m (List.map (fun f -> f values) argsR)), acc /// Check a long identifier that has been resolved to an IL field - valid if a literal and TcPatLongIdentILField warnOnUpper cenv env vFlags (tpenv, names, takenNames) ty (lidRange, finfo, args, m) = @@ -5523,43 +5810,33 @@ and TcPatterns warnOnUpper cenv env vFlags s argTys args = assert (List.length args = List.length argTys) List.mapFold (fun s (ty, pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argTys args) -and solveTypAsError cenv denv m ty = SolveTypeAsError denv cenv.css m ty - -and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = +and RecordNameAndTypeResolutions cenv env tpenv expr = // This function is motivated by cases like // query { for ... join(for x in f(). } // where there is incomplete code in a query, and we are current just dropping a piece of the AST on the floor (above, the bit inside the 'join'). // // The problem with dropping the AST on the floor is that we get no captured resolutions, which means no Intellisense/QuickInfo/ParamHelp. // - // The idea behind the fix is to semi-typecheck this AST-fragment, just to get resolutions captured. - // - // The tricky bit is to not also have any other effects from typechecking, namely producing error diagnostics (which may be spurious) or having - // side-effects on the typecheck environment. - // - // REVIEW: We are yet to deal with the tricky bit. As it stands, we turn off error logging, but still have typechecking environment effects. As a result, - // at the very least, you cannot call this function unless you're already reported a typechecking error (the 'worst' possible outcome would be - // to incorrectly solve typecheck constraints as a result of effects in this function, and then have the code compile successfully and behave - // in some weird way; so ensure the code can't possibly compile before calling this function as an expedient way to get better IntelliSense). + // The fix is to semi-typecheck this AST-fragment, just to get resolutions captured. suppressErrorReporting (fun () -> try ignore(TcExprOfUnknownType cenv env tpenv expr) with e -> ()) -and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed = +and RecordNameAndTypeResolutionsDelayed cenv env tpenv delayed = let rec dummyCheckedDelayed delayed = match delayed with | DelayedApp (_hpa, _, _, arg, _mExprAndArg) :: otherDelayed -> - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv arg + RecordNameAndTypeResolutions cenv env tpenv arg dummyCheckedDelayed otherDelayed | _ -> () dummyCheckedDelayed delayed -and TcExprOfUnknownType cenv env tpenv expr = +and TcExprOfUnknownType cenv env tpenv synExpr = let g = cenv.g let exprTy = NewInferenceType g - let expr', tpenv = TcExpr cenv (MustEqual exprTy) env tpenv expr - expr', exprTy, tpenv + let expr, tpenv = TcExpr cenv (MustEqual exprTy) env tpenv synExpr + expr, exprTy, tpenv // This is the old way of introducing flexibility via subtype constraints, still active // for compat reasons. @@ -5582,7 +5859,7 @@ and TcExprFlex cenv flex compat (desiredTy: TType) (env: TcEnv) tpenv (synExpr: and TcExprFlex2 cenv desiredTy env isMethodArg tpenv synExpr = TcExpr cenv (MustConvertTo (isMethodArg, desiredTy)) env tpenv synExpr -and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = +and TcExpr cenv ty (env: TcEnv) tpenv (synExpr: SynExpr) = let g = cenv.g @@ -5593,16 +5870,16 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Note the try/with can lead to tail-recursion problems for iterated constructs, e.g. let... in... // So be careful! try - TcExprNoRecover cenv ty env tpenv expr - with e -> - let m = expr.Range + TcExprNoRecover cenv ty env tpenv synExpr + with exn -> + let m = synExpr.Range // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error - errorRecovery e m - solveTypAsError cenv env.DisplayEnv m ty.Commit + errorRecovery exn m + SolveTypeAsError env.DisplayEnv cenv.css m ty.Commit mkThrow m ty.Commit (mkOne g m), tpenv -and TcExprNoRecover cenv (ty: OverallTy) (env: TcEnv) tpenv (expr: SynExpr) = +and TcExprNoRecover cenv (ty: OverallTy) (env: TcEnv) tpenv (synExpr: SynExpr) = // Count our way through the expression shape that makes up an object constructor // See notes at definition of "ctor" re. object model constructors. @@ -5610,50 +5887,50 @@ and TcExprNoRecover cenv (ty: OverallTy) (env: TcEnv) tpenv (expr: SynExpr) = if GetCtorShapeCounter env > 0 then AdjustCtorShapeCounter (fun x -> x - 1) env else env - TcExprThen cenv ty env tpenv false expr [] + TcExprThen cenv ty env tpenv false synExpr [] // This recursive entry is only used from one callsite (DiscardAfterMissingQualificationAfterDot) // and has been added relatively late in F# 4.0 to preserve the structure of previous code. It pushes a 'delayed' parameter // through TcExprOfUnknownType, TcExpr and TcExprNoRecover -and TcExprOfUnknownTypeThen cenv env tpenv expr delayed = +and TcExprOfUnknownTypeThen cenv env tpenv synExpr delayed = let g = cenv.g let exprTy = NewInferenceType g - let expr', tpenv = + let expr, tpenv = try - TcExprThen cenv (MustEqual exprTy) env tpenv false expr delayed + TcExprThen cenv (MustEqual exprTy) env tpenv false synExpr delayed with exn -> - let m = expr.Range + let m = synExpr.Range errorRecovery exn m - solveTypAsError cenv env.DisplayEnv m exprTy + SolveTypeAsError env.DisplayEnv cenv.css m exprTy mkThrow m exprTy (mkOne g m), tpenv - expr', exprTy, tpenv + expr, exprTy, tpenv /// This is used to typecheck legitimate 'main body of constructor' expressions -and TcExprThatIsCtorBody safeInitInfo cenv overallTy env tpenv expr = +and TcExprThatIsCtorBody safeInitInfo cenv overallTy env tpenv synExpr = let g = cenv.g let env = {env with eCtorInfo = Some (InitialExplicitCtorInfo safeInitInfo) } - let expr, tpenv = TcExpr cenv overallTy env tpenv expr + let expr, tpenv = TcExpr cenv overallTy env tpenv synExpr let expr = CheckAndRewriteObjectCtor g env expr expr, tpenv /// This is used to typecheck all ordinary expressions including constituent /// parts of ctor. -and TcExprThatCanBeCtorBody cenv overallTy env tpenv expr = +and TcExprThatCanBeCtorBody cenv overallTy env tpenv synExpr = let env = if AreWithinCtorShape env then AdjustCtorShapeCounter (fun x -> x + 1) env else env - TcExpr cenv overallTy env tpenv expr + TcExpr cenv overallTy env tpenv synExpr /// This is used to typecheck legitimate 'non-main body of object constructor' expressions -and TcExprThatCantBeCtorBody cenv overallTy env tpenv expr = +and TcExprThatCantBeCtorBody cenv overallTy env tpenv synExpr = let env = if AreWithinCtorShape env then ExitCtorShapeRegion env else env - TcExpr cenv overallTy env tpenv expr + TcExpr cenv overallTy env tpenv synExpr /// This is used to typecheck legitimate 'non-main body of object constructor' expressions -and TcStmtThatCantBeCtorBody cenv env tpenv expr = +and TcStmtThatCantBeCtorBody cenv env tpenv synExpr = let env = if AreWithinCtorShape env then ExitCtorShapeRegion env else env - TcStmt cenv env tpenv expr + TcStmt cenv env tpenv synExpr and TcStmt cenv env tpenv synExpr = let g = cenv.g @@ -5674,7 +5951,7 @@ and TryTcStmt cenv env tpenv synExpr = /// During checking of expressions of the form (x(y)).z(w1, w2) /// keep a stack of things on the right. This lets us recognize /// method applications and other item-based syntax. -and TcExprThen cenv (overallTy: OverallTy) env tpenv isArg synExpr delayed = +and TcExprThen cenv overallTy env tpenv isArg synExpr delayed = let g = cenv.g match synExpr with @@ -5731,30 +6008,30 @@ and TcExprThen cenv (overallTy: OverallTy) env tpenv isArg synExpr delayed = | SynExpr.TypeApp (func, _, typeArgs, _, _, mTypeArgs, mFuncAndTypeArgs) -> TcExprThen cenv overallTy env tpenv false func ((DelayedTypeApp (typeArgs, mTypeArgs, mFuncAndTypeArgs)) :: delayed) - // e1.id1 - // e1.id1.id2 + // expr1.id1 + // expr1.id1.id2 // etc. - | SynExpr.DotGet (e1, _, SynLongIdent(longId, _, _), _) -> + | SynExpr.DotGet (expr1, _, SynLongIdent(longId, _, _), _) -> TcNonControlFlowExpr env <| fun env -> - TcExprThen cenv overallTy env tpenv false e1 ((DelayedDotLookup (longId, synExpr.RangeWithoutAnyExtraDot)) :: delayed) + TcExprThen cenv overallTy env tpenv false expr1 ((DelayedDotLookup (longId, synExpr.RangeWithoutAnyExtraDot)) :: delayed) - // e1.[e2] - // e1.[e21, ..., e2n] + // expr1.[expr2] + // expr1.[e21, ..., e2n] // etc. - | SynExpr.DotIndexedGet (e1, IndexerArgs indexArgs, mDot, mWholeExpr) -> + | SynExpr.DotIndexedGet (expr1, IndexerArgs indexArgs, mDot, mWholeExpr) -> TcNonControlFlowExpr env <| fun env -> if not isArg && g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then informationalWarning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) - TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv None e1 indexArgs delayed + TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv None expr1 indexArgs delayed - // e1.[e2] <- e3 - // e1.[e21, ..., e2n] <- e3 + // expr1.[expr2] <- expr3 + // expr1.[e21, ..., e2n] <- expr3 // etc. - | SynExpr.DotIndexedSet (e1, IndexerArgs indexArgs, e3, mOfLeftOfSet, mDot, mWholeExpr) -> + | SynExpr.DotIndexedSet (expr1, IndexerArgs indexArgs, expr3, mOfLeftOfSet, mDot, mWholeExpr) -> TcNonControlFlowExpr env <| fun env -> if g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then warning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) - TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv (Some (e3, mOfLeftOfSet)) e1 indexArgs delayed + TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv (Some (expr3, mOfLeftOfSet)) expr1 indexArgs delayed | _ -> match delayed with @@ -5777,11 +6054,7 @@ and CheckSuperInit cenv objTy m = errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(), m)) | _ -> () -//------------------------------------------------------------------------- -// TcExprUndelayed -//------------------------------------------------------------------------- - -and TcExprUndelayedNoType cenv env tpenv synExpr: Expr * TType * _ = +and TcExprUndelayedNoType cenv env tpenv synExpr = let g = cenv.g let overallTy = NewInferenceType g let expr, tpenv = TcExprUndelayed cenv (MustEqual overallTy) env tpenv synExpr @@ -5875,7 +6148,6 @@ and TcNonPropagatingExprLeafThenConvert cenv (overallTy: OverallTy) (env: TcEnv) expr2, tpenv and TcAdjustExprForTypeDirectedConversions cenv (overallTy: OverallTy) actualTy (env: TcEnv) (* canAdhoc *) m expr = - let g = cenv.g match overallTy with @@ -5905,7 +6177,7 @@ and TcNonControlFlowExpr (env: TcEnv) f = | NotedSourceConstruct.DelayOrQuoteOrRun -> res, tpenv | NotedSourceConstruct.None -> - // Skip outer debug point for "e1 && e2" and "e1 || e2" + // Skip outer debug point for "expr1 && expr2" and "expr1 || expr2" let res2 = match res with | IfThenElseExpr _ -> res @@ -5920,8 +6192,8 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = match synExpr with // ( * ) - | SynExpr.Paren(SynExpr.IndexRange (None, opm, None, _m1, _m2, _), _, _, _) -> - let replacementExpr = SynExpr.Ident(ident(CompileOpName "*", opm)) + | SynExpr.Paren (SynExpr.IndexRange (None, mOperator, None, _m1, _m2, _), _, _, _) -> + let replacementExpr = SynExpr.Ident(ident(CompileOpName "*", mOperator)) TcExpr cenv overallTy env tpenv replacementExpr | SynExpr.Paren (expr2, _, _, mWholeExprIncludingParentheses) -> @@ -5954,15 +6226,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = TcIteratedLambdas cenv true env overallTy Set.empty tpenv synExpr | SynExpr.Match (spMatch, synInputExpr, synClauses, _m, _trivia) -> - - let inputExpr, inputTy, tpenv = - let env = { env with eIsControlFlow = false } - TcExprOfUnknownType cenv env tpenv synInputExpr - let mInputExpr = synInputExpr.Range - let env = { env with eIsControlFlow = true } - let matchVal, matchExpr, tpenv = TcAndPatternCompileMatchClauses mInputExpr mInputExpr ThrowIncompleteMatchException cenv (Some inputExpr) inputTy overallTy env tpenv synClauses - let overallExpr = mkLet spMatch mInputExpr matchVal inputExpr matchExpr - overallExpr, tpenv + TcExprMatch cenv overallTy env tpenv synInputExpr spMatch synClauses | SynExpr.MatchLambda (isExnMatch, mArg, clauses, spMatch, m) -> TcExprMatchLambda cenv overallTy env tpenv (isExnMatch, mArg, clauses, spMatch, m) @@ -5991,9 +6255,9 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = // SynExpr.AddressOf is noted in the syntax ast in order to recognize it as concrete type information // during type checking, in particular prior to resolving overloads. This helps distinguish // its use at method calls from the use of the conflicting 'ref' mechanism for passing byref parameters - | SynExpr.AddressOf (byref, synInnerExpr, opm, m) -> + | SynExpr.AddressOf (byref, synInnerExpr, mOperator, m) -> TcNonControlFlowExpr env <| fun env -> - TcExpr cenv overallTy env tpenv (mkSynPrefixPrim opm m (if byref then "~&" else "~&&") synInnerExpr) + TcExpr cenv overallTy env tpenv (mkSynPrefixPrim mOperator m (if byref then "~&" else "~&&") synInnerExpr) | SynExpr.Upcast (synInnerExpr, _, m) | SynExpr.InferredUpcast (synInnerExpr, m) -> TcNonControlFlowExpr env <| fun env -> @@ -6016,10 +6280,10 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = TcNonControlFlowExpr env <| fun env -> TcExprTuple cenv overallTy env tpenv (isExplicitStruct, args, m) - | SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) -> + | SynExpr.AnonRecd (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr) -> TcNonControlFlowExpr env <| fun env -> TcPossiblyPropogatingExprLeafThenConvert (fun ty -> isAnonRecdTy g ty || isTyparTy g ty) cenv overallTy env mWholeExpr (fun overallTy -> - TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) + TcAnonRecdExpr cenv overallTy env tpenv (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr) ) | SynExpr.ArrayOrList (isArray, args, m) -> @@ -6039,9 +6303,9 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = let binds = unionBindingAndMembers binds members TcExprObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, mNewExpr, m) - | SynExpr.Record (inherits, optOrigExpr, flds, mWholeExpr) -> + | SynExpr.Record (inherits, withExprOpt, synRecdFields, mWholeExpr) -> TcNonControlFlowExpr env <| fun env -> - TcExprRecord cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) + TcExprRecord cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) | SynExpr.While (spWhile, synGuardExpr, synBodyExpr, m) -> TcExprWhileLoop cenv overallTy env tpenv (spWhile, synGuardExpr, synBodyExpr, m) @@ -6050,13 +6314,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = TcExprIntegerForLoop cenv overallTy env tpenv (spFor, spTo, id, start, dir, finish, body, m) | SynExpr.ForEach (spFor, spIn, SeqExprOnly seqExprOnly, isFromSource, pat, synEnumExpr, synBodyExpr, m) -> - assert isFromSource - if seqExprOnly then warning (Error(FSComp.SR.tcExpressionRequiresSequence(), m)) - let synEnumExpr = - match RewriteRangeExpr synEnumExpr with - | Some e -> e - | None -> synEnumExpr - TcForEachExpr cenv overallTy env tpenv (pat, synEnumExpr, synBodyExpr, m, spFor, spIn) + TcForEachExpr cenv overallTy env tpenv (seqExprOnly, isFromSource, pat, synEnumExpr, synBodyExpr, m, spFor, spIn, m) | SynExpr.ComputationExpr (hasSeqBuilder, comp, m) -> let env = ExitFamilyRegion env @@ -6077,20 +6335,20 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = | SynExpr.TryFinally (synBodyExpr, synFinallyExpr, mTryToLast, spTry, spFinally, _trivia) -> TcExprTryFinally cenv overallTy env tpenv (synBodyExpr, synFinallyExpr, mTryToLast, spTry, spFinally) - | SynExpr.JoinIn (e1, mInToken, e2, mAll) -> - TcExprJoinIn cenv overallTy env tpenv (e1, mInToken, e2, mAll) + | SynExpr.JoinIn (expr1, mInToken, expr2, mAll) -> + TcExprJoinIn cenv overallTy env tpenv (expr1, mInToken, expr2, mAll) | SynExpr.ArbitraryAfterError (_debugStr, m) -> - //solveTypAsError cenv env.DisplayEnv m overallTy + //SolveTypeAsError cenv env.DisplayEnv m overallTy mkDefault(m, overallTy.Commit), tpenv - | SynExpr.DiscardAfterMissingQualificationAfterDot (e1, m) -> - let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownTypeThen cenv env tpenv e1 [DelayedDot]) + | SynExpr.DiscardAfterMissingQualificationAfterDot (expr1, m) -> + let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownTypeThen cenv env tpenv expr1 [DelayedDot]) mkDefault(m, overallTy.Commit), tpenv - | SynExpr.FromParseError (e1, m) -> - //solveTypAsError cenv env.DisplayEnv m overallTy - let _, tpenv = suppressErrorReporting (fun () -> TcExpr cenv overallTy env tpenv e1) + | SynExpr.FromParseError (expr1, m) -> + //SolveTypeAsError cenv env.DisplayEnv m overallTy + let _, tpenv = suppressErrorReporting (fun () -> TcExpr cenv overallTy env tpenv expr1) mkDefault(m, overallTy.Commit), tpenv | SynExpr.Sequential (sp, dir, synExpr1, synExpr2, m) -> @@ -6108,45 +6366,45 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = TcLinearExprs (TcExprThatCanBeCtorBody cenv) cenv env overallTy tpenv false synExpr (fun x -> x) // This is for internal use in the libraries only - | SynExpr.LibraryOnlyStaticOptimization (constraints, e2, e3, m) -> + | SynExpr.LibraryOnlyStaticOptimization (constraints, expr2, expr3, m) -> TcNonControlFlowExpr env <| fun env -> - TcExprStaticOptimization cenv overallTy env tpenv (constraints, e2, e3, m) + TcExprStaticOptimization cenv overallTy env tpenv (constraints, expr2, expr3, m) - // e1.longId <- e2 - | SynExpr.DotSet (e1, lidwd, e2, mStmt) -> + // synExpr1.longId <- expr2 + | SynExpr.DotSet (synExpr1, synLongId, synExpr2, mStmt) -> TcNonControlFlowExpr env <| fun env -> - TcExprDotSet cenv overallTy env tpenv (e1, lidwd, e2, mStmt) + TcExprDotSet cenv overallTy env tpenv (synExpr1, synLongId, synExpr2, mStmt) - // e1 <- e2 - | SynExpr.Set (e1, e2, mStmt) -> + // synExpr1 <- synExpr2 + | SynExpr.Set (synExpr1, synExpr2, mStmt) -> TcNonControlFlowExpr env <| fun env -> - TcExprThen cenv overallTy env tpenv false e1 [MakeDelayedSet(e2, mStmt)] + TcExprThen cenv overallTy env tpenv false synExpr1 [MakeDelayedSet(synExpr2, mStmt)] - // e1.longId(e2) <- e3, very rarely used named property setters - | SynExpr.DotNamedIndexedPropertySet (e1, lidwd, e2, e3, mStmt) -> + // synExpr1.longId(synExpr2) <- expr3, very rarely used named property setters + | SynExpr.DotNamedIndexedPropertySet (synExpr1, synLongId, synExpr2, expr3, mStmt) -> TcNonControlFlowExpr env <| fun env -> - TcExprDotNamedIndexedPropertySet cenv overallTy env tpenv (e1, lidwd, e2, e3, mStmt) + TcExprDotNamedIndexedPropertySet cenv overallTy env tpenv (synExpr1, synLongId, synExpr2, expr3, mStmt) - | SynExpr.LongIdentSet (lidwd, e2, m) -> + | SynExpr.LongIdentSet (synLongId, synExpr2, m) -> TcNonControlFlowExpr env <| fun env -> - TcExprLongIdentSet cenv overallTy env tpenv (lidwd, e2, m) + TcExprLongIdentSet cenv overallTy env tpenv (synLongId, synExpr2, m) - // Type.Items(e1) <- e2 - | SynExpr.NamedIndexedPropertySet (lidwd, e1, e2, mStmt) -> + // Type.Items(synExpr1) <- synExpr2 + | SynExpr.NamedIndexedPropertySet (synLongId, synExpr1, synExpr2, mStmt) -> TcNonControlFlowExpr env <| fun env -> - TcExprNamedIndexPropertySet cenv overallTy env tpenv (lidwd, e1, e2, mStmt) + TcExprNamedIndexPropertySet cenv overallTy env tpenv (synLongId, synExpr1, synExpr2, mStmt) - | SynExpr.TraitCall (tps, memSpfn, arg, m) -> + | SynExpr.TraitCall (tps, synMemberSig, arg, m) -> TcNonControlFlowExpr env <| fun env -> - TcExprTraitCall cenv overallTy env tpenv (tps, memSpfn, arg, m) + TcExprTraitCall cenv overallTy env tpenv (tps, synMemberSig, arg, m) - | SynExpr.LibraryOnlyUnionCaseFieldGet (e1, c, n, m) -> + | SynExpr.LibraryOnlyUnionCaseFieldGet (synExpr1, longId, fieldNum, m) -> TcNonControlFlowExpr env <| fun env -> - TcExprUnionCaseFieldGet cenv overallTy env tpenv (e1, c, n, m) + TcExprUnionCaseFieldGet cenv overallTy env tpenv (synExpr1, longId, fieldNum, m) - | SynExpr.LibraryOnlyUnionCaseFieldSet (e1, c, n, e2, m) -> + | SynExpr.LibraryOnlyUnionCaseFieldSet (synExpr1, longId, fieldNum, synExpr2, m) -> TcNonControlFlowExpr env <| fun env -> - TcExprUnionCaseFieldSet cenv overallTy env tpenv (e1, c, n, e2, m) + TcExprUnionCaseFieldSet cenv overallTy env tpenv (synExpr1, longId, fieldNum, synExpr2, m) | SynExpr.LibraryOnlyILAssembly (s, tyargs, args, rtys, m) -> TcNonControlFlowExpr env <| fun env -> @@ -6181,6 +6439,16 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = | SynExpr.IndexRange (range=m) -> error(Error(FSComp.SR.tcInvalidIndexerExpression(), m)) +and TcExprMatch cenv overallTy env tpenv synInputExpr spMatch synClauses = + let inputExpr, inputTy, tpenv = + let env = { env with eIsControlFlow = false } + TcExprOfUnknownType cenv env tpenv synInputExpr + let mInputExpr = synInputExpr.Range + let env = { env with eIsControlFlow = true } + let matchVal, matchExpr, tpenv = TcAndPatternCompileMatchClauses mInputExpr mInputExpr ThrowIncompleteMatchException cenv (Some inputExpr) inputTy overallTy env tpenv synClauses + let overallExpr = mkLet spMatch mInputExpr matchVal inputExpr matchExpr + overallExpr, tpenv + // (function[spMatch] pat1 -> expr1 ... | patN -> exprN) // // --> @@ -6243,7 +6511,8 @@ and TcExprDowncast cenv overallTy env tpenv (synExpr, synInnerExpr, m) = tgtTy, tpenv, true | SynExpr.InferredDowncast _ -> overallTy.Commit, tpenv, false | _ -> failwith "downcast" - TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgtTy srcTy + + TcRuntimeTypeTest true isOperator cenv env.DisplayEnv m tgtTy srcTy // TcRuntimeTypeTest ensures tgtTy is a nominal type. Hence we can insert a check here // based on the nullness semantics of the nominal type. @@ -6266,8 +6535,8 @@ and TcExprTuple cenv overallTy env tpenv (isExplicitStruct, args, m) = let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m overallTy isExplicitStruct args let flexes = argTys |> List.map (fun _ -> false) - let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args - let expr = mkAnyTupled g m tupInfo args' argTys + let argsR, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args + let expr = mkAnyTupled g m tupInfo argsR argTys expr, tpenv ) @@ -6283,7 +6552,7 @@ and TcExprArrayOrList cenv overallTy env tpenv (isArray, args, m) = // Consider also the case where there is no relation but an op_Implicit is enabled from List<_> to C // let x : C = [ B(); B() ] - TcPropagatingExprLeafThenConvert cenv overallTy actualTy env (* canAdhoc *) m (fun () -> + TcPropagatingExprLeafThenConvert cenv overallTy actualTy env m (fun () -> // Always allow subsumption if a nominal type is known prior to type checking any arguments let flex = not (isTyparTy g argTy) @@ -6295,11 +6564,11 @@ and TcExprArrayOrList cenv overallTy env tpenv (isArray, args, m) = else { env with eContextInfo = ContextInfo.CollectionElement (isArray, m) } - let args', tpenv = List.mapFold (fun tpenv (x: SynExpr) -> TcExprFlex cenv flex false argTy (getInitEnv x.Range) tpenv x) tpenv args + let argsR, tpenv = List.mapFold (fun tpenv (x: SynExpr) -> TcExprFlex cenv flex false argTy (getInitEnv x.Range) tpenv x) tpenv args let expr = - if isArray then Expr.Op (TOp.Array, [argTy], args', m) - else List.foldBack (mkCons g argTy) args' (mkNil g m argTy) + if isArray then Expr.Op (TOp.Array, [argTy], argsR, m) + else List.foldBack (mkCons g argTy) argsR (mkNil g m argTy) expr, tpenv ) @@ -6338,13 +6607,13 @@ and TcExprObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImp TcObjectExpr cenv env tpenv (objTy, realObjTy, argopt, binds, extraImpls, mObjTy, mNewExpr, m) ) -and TcExprRecord cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) = +and TcExprRecord cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) = let g = cenv.g CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy.Commit, env.AccessRights) let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors let haveCtor = Option.isSome inherits TcPossiblyPropogatingExprLeafThenConvert (fun ty -> requiresCtor || haveCtor || isRecdTy g ty || isTyparTy g ty) cenv overallTy env mWholeExpr (fun overallTy -> - TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) + TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) ) and TcExprWhileLoop cenv overallTy env tpenv (spWhile, synGuardExpr, synBodyExpr, m) = @@ -6393,9 +6662,9 @@ and TcExprTryWith cenv overallTy env tpenv (synBodyExpr, synWithClauses, mWithTo // Compile the pattern twice, once as a List.filter with all succeeding targets returning "1", and once as a proper catch block. let filterClauses = synWithClauses |> List.map (fun clause -> - let (SynMatchClause(pat, optWhenExpr, _, m, _, trivia)) = clause + let (SynMatchClause(pat, synWhenExprOpt, _, m, _, trivia)) = clause let oneExpr = SynExpr.Const (SynConst.Int32 1, m) - SynMatchClause(pat, optWhenExpr, oneExpr, m, DebugPointAtTarget.No, trivia)) + SynMatchClause(pat, synWhenExprOpt, oneExpr, m, DebugPointAtTarget.No, trivia)) let checkedFilterClauses, tpenv = TcMatchClauses cenv g.exn_ty (MustEqual g.int_ty) env tpenv filterClauses let checkedHandlerClauses, tpenv = TcMatchClauses cenv g.exn_ty overallTy env tpenv synWithClauses @@ -6410,10 +6679,10 @@ and TcExprTryFinally cenv overallTy env tpenv (synBodyExpr, synFinallyExpr, mTry let finallyExpr, tpenv = TcStmt cenv env tpenv synFinallyExpr mkTryFinally g (bodyExpr, finallyExpr, mTryToLast, overallTy.Commit, spTry, spFinally), tpenv -and TcExprJoinIn cenv overallTy env tpenv (e1, mInToken, e2, mAll) = +and TcExprJoinIn cenv overallTy env tpenv (synExpr1, mInToken, synExpr2, mAll) = errorR(Error(FSComp.SR.parsUnfinishedExpression("in"), mInToken)) - let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv e1) - let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv e2) + let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv synExpr1) + let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv synExpr2) mkDefault(mAll, overallTy.Commit), tpenv and TcExprSequential cenv overallTy env tpenv (synExpr, _sp, dir, synExpr1, synExpr2, m) = @@ -6429,9 +6698,11 @@ and TcExprSequential cenv overallTy env tpenv (synExpr, _sp, dir, synExpr1, synE Expr.Sequential (expr1, expr2, ThenDoSeq, m), tpenv and TcExprSequentialOrImplicitYield cenv overallTy env tpenv (sp, synExpr1, synExpr2, otherExpr, m) = + let isStmt, expr1, tpenv = let env1 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } TryTcStmt cenv env1 tpenv synExpr1 + if isStmt then let env2 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressStmt -> true | _ -> false) } let env2 = ShrinkContext env2 m synExpr2.Range @@ -6443,62 +6714,62 @@ and TcExprSequentialOrImplicitYield cenv overallTy env tpenv (sp, synExpr1, synE // this will type-check the first expression over again. TcExpr cenv overallTy env tpenv otherExpr -and TcExprStaticOptimization cenv overallTy env tpenv (constraints, e2, e3, m) = - let constraints', tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints +and TcExprStaticOptimization cenv overallTy env tpenv (constraints, synExpr2, expr3, m) = + let constraintsR, tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints // Do not force the types of the two expressions to be equal // This means uses of this construct have to be very carefully written - let e2', _, tpenv = TcExprOfUnknownType cenv env tpenv e2 - let e3', tpenv = TcExpr cenv overallTy env tpenv e3 - Expr.StaticOptimization (constraints', e2', e3', m), tpenv + let expr2, _, tpenv = TcExprOfUnknownType cenv env tpenv synExpr2 + let expr3, tpenv = TcExpr cenv overallTy env tpenv expr3 + Expr.StaticOptimization (constraintsR, expr2, expr3, m), tpenv -/// e1.longId <- e2 -and TcExprDotSet cenv overallTy env tpenv (e1, lidwd, e2, mStmt) = - let (SynLongIdent(longId, _, _)) = lidwd +/// synExpr1.longId <- synExpr2 +and TcExprDotSet cenv overallTy env tpenv (synExpr1, synLongId, synExpr2, mStmt) = + let (SynLongIdent(longId, _, _)) = synLongId - if lidwd.ThereIsAnExtraDotAtTheEnd then + if synLongId.ThereIsAnExtraDotAtTheEnd then // just drop rhs on the floor - let mExprAndDotLookup = unionRanges e1.Range (rangeOfLid longId) - TcExprThen cenv overallTy env tpenv false e1 [DelayedDotLookup(longId, mExprAndDotLookup)] + let mExprAndDotLookup = unionRanges synExpr1.Range (rangeOfLid longId) + TcExprThen cenv overallTy env tpenv false synExpr1 [DelayedDotLookup(longId, mExprAndDotLookup)] else - let mExprAndDotLookup = unionRanges e1.Range (rangeOfLid longId) - TcExprThen cenv overallTy env tpenv false e1 [DelayedDotLookup(longId, mExprAndDotLookup); MakeDelayedSet(e2, mStmt)] + let mExprAndDotLookup = unionRanges synExpr1.Range (rangeOfLid longId) + TcExprThen cenv overallTy env tpenv false synExpr1 [DelayedDotLookup(longId, mExprAndDotLookup); MakeDelayedSet(synExpr2, mStmt)] -/// e1.longId(e2) <- e3, very rarely used named property setters -and TcExprDotNamedIndexedPropertySet cenv overallTy env tpenv (e1, lidwd, e2, e3, mStmt) = - let (SynLongIdent(longId, _, _)) = lidwd - if lidwd.ThereIsAnExtraDotAtTheEnd then +/// synExpr1.longId(synExpr2) <- expr3, very rarely used named property setters +and TcExprDotNamedIndexedPropertySet cenv overallTy env tpenv (synExpr1, synLongId, synExpr2, expr3, mStmt) = + let (SynLongIdent(longId, _, _)) = synLongId + if synLongId.ThereIsAnExtraDotAtTheEnd then // just drop rhs on the floor - let mExprAndDotLookup = unionRanges e1.Range (rangeOfLid longId) - TcExprThen cenv overallTy env tpenv false e1 [DelayedDotLookup(longId, mExprAndDotLookup)] + let mExprAndDotLookup = unionRanges synExpr1.Range (rangeOfLid longId) + TcExprThen cenv overallTy env tpenv false synExpr1 [DelayedDotLookup(longId, mExprAndDotLookup)] else - let mExprAndDotLookup = unionRanges e1.Range (rangeOfLid longId) - TcExprThen cenv overallTy env tpenv false e1 + let mExprAndDotLookup = unionRanges synExpr1.Range (rangeOfLid longId) + TcExprThen cenv overallTy env tpenv false synExpr1 [ DelayedDotLookup(longId, mExprAndDotLookup); - DelayedApp(ExprAtomicFlag.Atomic, false, None, e2, mStmt) - MakeDelayedSet(e3, mStmt)] + DelayedApp(ExprAtomicFlag.Atomic, false, None, synExpr2, mStmt) + MakeDelayedSet(expr3, mStmt)] -and TcExprLongIdentSet cenv overallTy env tpenv (lidwd, e2, m) = - if lidwd.ThereIsAnExtraDotAtTheEnd then +and TcExprLongIdentSet cenv overallTy env tpenv (synLongId, synExpr2, m) = + if synLongId.ThereIsAnExtraDotAtTheEnd then // just drop rhs on the floor - TcLongIdentThen cenv overallTy env tpenv lidwd [ ] + TcLongIdentThen cenv overallTy env tpenv synLongId [ ] else - TcLongIdentThen cenv overallTy env tpenv lidwd [ MakeDelayedSet(e2, m) ] + TcLongIdentThen cenv overallTy env tpenv synLongId [ MakeDelayedSet(synExpr2, m) ] -// Type.Items(e1) <- e2 -and TcExprNamedIndexPropertySet cenv overallTy env tpenv (lidwd, e1, e2, mStmt) = - if lidwd.ThereIsAnExtraDotAtTheEnd then +// Type.Items(synExpr1) <- synExpr2 +and TcExprNamedIndexPropertySet cenv overallTy env tpenv (synLongId, synExpr1, synExpr2, mStmt) = + if synLongId.ThereIsAnExtraDotAtTheEnd then // just drop rhs on the floor - TcLongIdentThen cenv overallTy env tpenv lidwd [ ] + TcLongIdentThen cenv overallTy env tpenv synLongId [ ] else - TcLongIdentThen cenv overallTy env tpenv lidwd - [ DelayedApp(ExprAtomicFlag.Atomic, false, None, e1, mStmt) - MakeDelayedSet(e2, mStmt) ] + TcLongIdentThen cenv overallTy env tpenv synLongId + [ DelayedApp(ExprAtomicFlag.Atomic, false, None, synExpr1, mStmt) + MakeDelayedSet(synExpr2, mStmt) ] -and TcExprTraitCall cenv overallTy env tpenv (tps, memSpfn, arg, m) = +and TcExprTraitCall cenv overallTy env tpenv (tps, synMemberSig, arg, m) = let g = cenv.g TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> let synTypes = tps |> List.map (fun tp -> SynType.Var(tp, m)) - let traitInfo, tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m + let traitInfo, tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv synMemberSig m if BakedInTraitConstraintNames.Contains traitInfo.MemberName then warning(BakedInMemberConstraintName(traitInfo.MemberName, m)) @@ -6508,53 +6779,53 @@ and TcExprTraitCall cenv overallTy env tpenv (tps, memSpfn, arg, m) = if not (isNil namedCallerArgs) then errorR(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInMemberTraits(), m)) // Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type let flexes = argTys |> List.map (isTyparTy g >> not) - let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args + let argsR, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo - Expr.Op (TOp.TraitCall traitInfo, [], args', m), returnTy, tpenv + Expr.Op (TOp.TraitCall traitInfo, [], argsR, m), returnTy, tpenv ) -and TcExprUnionCaseFieldGet cenv overallTy env tpenv (e1, c, n, m) = +and TcExprUnionCaseFieldGet cenv overallTy env tpenv (synExpr1, longId, fieldNum, m) = let g = cenv.g TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> - let e1', ty1, tpenv = TcExprOfUnknownType cenv env tpenv e1 + let expr1, ty1, tpenv = TcExprOfUnknownType cenv env tpenv synExpr1 let mkf, ty2 = - TcUnionCaseOrExnField cenv env ty1 m c n - ((fun (a, b) n -> mkUnionCaseFieldGetUnproven g (e1', a, b, n, m)), - (fun a n -> mkExnCaseFieldGet(e1', a, n, m))) - mkf n, ty2, tpenv + TcUnionCaseOrExnField cenv env ty1 m longId fieldNum + ((fun (a, b) n -> mkUnionCaseFieldGetUnproven g (expr1, a, b, n, m)), + (fun a n -> mkExnCaseFieldGet(expr1, a, n, m))) + mkf fieldNum, ty2, tpenv ) -and TcExprUnionCaseFieldSet cenv overallTy env tpenv (e1, c, n, e2, m) = +and TcExprUnionCaseFieldSet cenv overallTy env tpenv (synExpr1, longId, fieldNum, synExpr2, m) = let g = cenv.g UnifyTypes cenv env m overallTy.Commit g.unit_ty - let e1', ty1, tpenv = TcExprOfUnknownType cenv env tpenv e1 + let expr1, ty1, tpenv = TcExprOfUnknownType cenv env tpenv synExpr1 let mkf, ty2 = - TcUnionCaseOrExnField cenv env ty1 m c n - ((fun (a, b) n e2' -> + TcUnionCaseOrExnField cenv env ty1 m longId fieldNum + ((fun (a, b) n expr2R -> if not (isUnionCaseFieldMutable g a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(), m)) - mkUnionCaseFieldSet(e1', a, b, n, e2', m)), - (fun a n e2' -> + mkUnionCaseFieldSet(expr1, a, b, n, expr2R, m)), + (fun a n expr2R -> if not (isExnFieldMutable a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(), m)) - mkExnCaseFieldSet(e1', a, n, e2', m))) - let e2', tpenv = TcExpr cenv (MustEqual ty2) env tpenv e2 - mkf n e2', tpenv + mkExnCaseFieldSet(expr1, a, n, expr2R, m))) + let expr2, tpenv = TcExpr cenv (MustEqual ty2) env tpenv synExpr2 + mkf fieldNum expr2, tpenv -and TcExprILAssembly cenv overallTy env tpenv (s, tyargs, args, rtys, m) = +and TcExprILAssembly cenv overallTy env tpenv (ilInstrs, synTyArgs, synArgs, synRetTys, m) = let g = cenv.g - let s = (s :?> ILInstr[]) - let argTys = NewInferenceTypes g args - let tyargs', tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tyargs + let ilInstrs = (ilInstrs :?> ILInstr[]) + let argTys = NewInferenceTypes g synArgs + let tyargs, tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synTyArgs // No subsumption at uses of IL assembly code let flexes = argTys |> List.map (fun _ -> false) - let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args - let rtys', tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv rtys + let args, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synArgs + let retTys, tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synRetTys let returnTy = - match rtys' with + match retTys with | [] -> g.unit_ty | [ returnTy ] -> returnTy | _ -> error(InternalError("Only zero or one pushed items are permitted in IL assembly code", m)) UnifyTypes cenv env m overallTy.Commit returnTy - mkAsmExpr (Array.toList s, tyargs', args', rtys', m), tpenv + mkAsmExpr (Array.toList ilInstrs, tyargs, args, retTys, m), tpenv // Converts 'a..b' to a call to the '(..)' operator in FSharp.Core // Converts 'a..b..c' to a call to the '(.. ..)' operator in FSharp.Core @@ -6563,15 +6834,15 @@ and TcExprILAssembly cenv overallTy env tpenv (s, tyargs, args, rtys, m) = // [| 1..4 |] // becomes [| for i in (..) 1 4 do yield i |] // instead of generating the array directly from the ranges -and RewriteRangeExpr expr = - match expr with +and RewriteRangeExpr synExpr = + match synExpr with // a..b..c (parsed as (a..b)..c ) - | SynExpr.IndexRange(Some (SynExpr.IndexRange(Some expr1, _, Some synStepExpr, _, _, _)), _, Some expr2, _m1, _m2, wholem) -> - Some (mkSynTrifix wholem ".. .." expr1 synStepExpr expr2) + | SynExpr.IndexRange(Some (SynExpr.IndexRange(Some synExpr1, _, Some synStepExpr, _, _, _)), _, Some synExpr2, _m1, _m2, wholem) -> + Some (mkSynTrifix wholem ".. .." synExpr1 synStepExpr synExpr2) // a..b - | SynExpr.IndexRange (Some expr1, opm, Some expr2, _m1, _m2, wholem) -> + | SynExpr.IndexRange (Some synExpr1, mOperator, Some synExpr2, _m1, _m2, wholem) -> let otherExpr = - match mkSynInfix opm expr1 ".." expr2 with + match mkSynInfix mOperator synExpr1 ".." synExpr2 with | SynExpr.App (a, b, c, d, _) -> SynExpr.App (a, b, c, d, wholem) | _ -> failwith "impossible" Some otherExpr @@ -6581,9 +6852,13 @@ and RewriteRangeExpr expr = and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = let g = cenv.g match e with - | SynExpr.Lambda (isMember, isSubsequent, spats, bodyExpr, _, m, _) when isMember || isFirst || isSubsequent -> + | SynExpr.Lambda (isMember, isSubsequent, synSimplePats, bodyExpr, _, m, _) when isMember || isFirst || isSubsequent -> + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy.Commit - let vs, (tpenv, names, takenNames) = TcSimplePats cenv isMember CheckCxs domainTy env (tpenv, Map.empty, takenNames) spats + + let vs, (tpenv, names, takenNames) = + TcSimplePats cenv isMember CheckCxs domainTy env (tpenv, Map.empty, takenNames) synSimplePats + let envinner, _, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy g v.Type, v) let envinner = if isMember then envinner else ExitFamilyRegion envinner @@ -6602,6 +6877,7 @@ and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = | [] -> envinner let bodyExpr, tpenv = TcIteratedLambdas cenv false envinner (MustConvertTo (false, resultTy)) takenNames tpenv bodyExpr + // See bug 5758: Non-monotonicity in inference: need to ensure that parameters are never inferred to have byref type, instead it is always declared byrefs |> Map.iter (fun _ (orig, v) -> if not orig && isByrefTy g v.Type then errorR(Error(FSComp.SR.tcParameterInferredByref v.DisplayName, v.Range))) @@ -6617,7 +6893,7 @@ and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = and (|IndexArgOptionalFromEnd|) indexArg = match indexArg with | SynExpr.IndexFromEnd (a, m) -> (a, true, m) - | expr -> (expr, false, expr.Range) + | _ -> (indexArg, false, indexArg.Range) and DecodeIndexArg indexArg = match indexArg with @@ -6628,30 +6904,28 @@ and DecodeIndexArg indexArg = | None -> None let info2 = match info2 with - | Some (IndexArgOptionalFromEnd (expr2, isFromEnd2, _)) -> Some (expr2, isFromEnd2) + | Some (IndexArgOptionalFromEnd (synExpr2, isFromEnd2, _)) -> Some (synExpr2, isFromEnd2) | None -> None IndexArgRange (info1, info2, m1, m2) | IndexArgOptionalFromEnd (expr, isFromEnd, m) -> IndexArgItem(expr, isFromEnd, m) -and (|IndexerArgs|) e = - match e with - | SynExpr.IndexRange _ -> [e] - | SynExpr.IndexFromEnd _ -> [e] - | SynExpr.Tuple (false, args, _, _) -> args - | e -> [e] +and (|IndexerArgs|) expr = + match expr with + | SynExpr.Tuple (false, argExprs, _, _) -> argExprs + | _ -> [expr] and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv (setInfo: _ option) synLeftExpr indexArgs delayed = - let leftExpr, e1ty, tpenv = TcExprOfUnknownType cenv env tpenv synLeftExpr + let leftExpr, leftExprTy, tpenv = TcExprOfUnknownType cenv env tpenv synLeftExpr let expandedIndexArgs = ExpandIndexArgs (Some synLeftExpr) indexArgs - TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo (Some synLeftExpr) leftExpr e1ty expandedIndexArgs indexArgs delayed + TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo (Some synLeftExpr) leftExpr leftExprTy expandedIndexArgs indexArgs delayed // Eliminate GetReverseIndex from index args and ExpandIndexArgs (synLeftExprOpt: SynExpr option) indexArgs = // xs.GetReverseIndex rank offset - 1 let rewriteReverseExpr (rank: int) (offset: SynExpr) (range: range) = - let rankExpr = SynExpr.Const(SynConst.Int32(rank), range) + let rankExpr = SynExpr.Const(SynConst.Int32 rank, range) let sliceArgs = SynExpr.Paren(SynExpr.Tuple(false, [rankExpr; offset], [], range), range, Some range, range) match synLeftExprOpt with | None -> error(Error(FSComp.SR.tcInvalidUseOfReverseIndex(), range)) @@ -6694,11 +6968,11 @@ and ExpandIndexArgs (synLeftExprOpt: SynExpr option) indexArgs = expandedIndexArgs // Check expr.[idx] -// This is a little over complicated for my liking. Basically we want to interpret e1.[idx] as e1.Item(idx). +// This is a little over complicated for my liking. Basically we want to interpret expr1.[idx] as expr1.Item(idx). // However it's not so simple as all that. First "Item" can have a different name according to an attribute in // .NET metadata. This means we manually typecheck 'expr and look to see if it has a nominal type. We then // do the right thing in each case. -and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprOpt expr e1ty expandedIndexArgs indexArgs delayed = +and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprOpt expr exprTy expandedIndexArgs indexArgs delayed = let g = cenv.g let ad = env.AccessRights @@ -6723,14 +6997,14 @@ and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprO cenv.amap mWholeExpr AllowMultiIntfInstantiations.Yes - e1ty + exprTy None else Some "GetSlice" - let isNominal = isAppTy g e1ty + let isNominal = isAppTy g exprTy - let isArray = isArrayTy g e1ty - let isString = typeEquiv g g.string_ty e1ty + let isArray = isArrayTy g exprTy + let isString = typeEquiv g g.string_ty exprTy let idxRange = indexArgs |> List.map (fun e -> e.Range) |> List.reduce unionRanges @@ -6753,22 +7027,22 @@ and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprO | [IndexArgItem _; IndexArgItem _; IndexArgItem _;], None -> Some (indexOpPath, "GetArray3D", expandedIndexArgs) | [IndexArgItem _; IndexArgItem _; IndexArgItem _; IndexArgItem _], None -> Some (indexOpPath, "GetArray4D", expandedIndexArgs) | [IndexArgItem _], None -> Some (indexOpPath, "GetArray", expandedIndexArgs) - | [IndexArgItem _; IndexArgItem _], Some (e3, _) -> Some (indexOpPath, "SetArray2D", (expandedIndexArgs @ [e3])) - | [IndexArgItem _; IndexArgItem _; IndexArgItem _;], Some (e3, _) -> Some (indexOpPath, "SetArray3D", (expandedIndexArgs @ [e3])) - | [IndexArgItem _; IndexArgItem _; IndexArgItem _; IndexArgItem _], Some (e3, _) -> Some (indexOpPath, "SetArray4D", (expandedIndexArgs @ [e3])) - | [IndexArgItem _], Some (e3, _) -> Some (indexOpPath, "SetArray", (expandedIndexArgs @ [e3])) + | [IndexArgItem _; IndexArgItem _], Some (expr3, _) -> Some (indexOpPath, "SetArray2D", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _; IndexArgItem _; IndexArgItem _;], Some (expr3, _) -> Some (indexOpPath, "SetArray3D", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _; IndexArgItem _; IndexArgItem _; IndexArgItem _], Some (expr3, _) -> Some (indexOpPath, "SetArray4D", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _], Some (expr3, _) -> Some (indexOpPath, "SetArray", (expandedIndexArgs @ [expr3])) | [IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice", expandedIndexArgs) | [IndexArgItem _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice2DFixed1", expandedIndexArgs) | [IndexArgRange _;IndexArgItem _], None -> Some (sliceOpPath, "GetArraySlice2DFixed2", expandedIndexArgs) | [IndexArgRange _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice2D", expandedIndexArgs) | [IndexArgRange _;IndexArgRange _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice3D", expandedIndexArgs) | [IndexArgRange _;IndexArgRange _;IndexArgRange _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice4D", expandedIndexArgs) - | [IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice2D", (expandedIndexArgs @ [e3])) - | [IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice2DFixed1", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice2DFixed2", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3D", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4D", (expandedIndexArgs @ [e3])) + | [IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice2D", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice2DFixed1", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice2DFixed2", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3D", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4D", (expandedIndexArgs @ [expr3])) | _ when fixedIndex3d4dEnabled -> match indexArgs, setInfo with | [IndexArgItem _;IndexArgRange _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice3DFixedSingle1", expandedIndexArgs) @@ -6791,26 +7065,26 @@ and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprO | [IndexArgItem _;IndexArgRange _;IndexArgItem _;IndexArgItem _], None -> Some (sliceOpPath, "GetArraySlice4DFixedTriple2", expandedIndexArgs) | [IndexArgItem _;IndexArgItem _;IndexArgRange _;IndexArgItem _], None -> Some (sliceOpPath, "GetArraySlice4DFixedTriple3", expandedIndexArgs) | [IndexArgItem _;IndexArgItem _;IndexArgItem _;IndexArgRange _], None -> Some (sliceOpPath, "GetArraySlice4DFixedTriple4", expandedIndexArgs) - | [IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle1", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle2", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle3", (expandedIndexArgs @ [e3])) - | [IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble1", (expandedIndexArgs @ [e3])) - | [IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble2", (expandedIndexArgs @ [e3])) - | [IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble3", (expandedIndexArgs @ [e3])) - | [IndexArgItem _;IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle1", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle2", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle3", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle4", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble1", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble2", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble3", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble4", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble5", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble6", expandedIndexArgs @ [e3]) - | [IndexArgRange _;IndexArgItem _;IndexArgItem _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple1", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple2", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple3", expandedIndexArgs @ [e3]) - | [IndexArgItem _;IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (e3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple4", expandedIndexArgs @ [e3]) + | [IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle1", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle2", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedSingle3", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble1", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble2", (expandedIndexArgs @ [expr3])) + | [IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice3DFixedDouble3", (expandedIndexArgs @ [expr3])) + | [IndexArgItem _;IndexArgRange _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle1", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle2", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle3", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedSingle4", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgItem _;IndexArgRange _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble1", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgRange _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble2", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgRange _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble3", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble4", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble5", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedDouble6", expandedIndexArgs @ [expr3]) + | [IndexArgRange _;IndexArgItem _;IndexArgItem _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple1", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgRange _;IndexArgItem _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple2", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgItem _;IndexArgRange _;IndexArgItem _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple3", expandedIndexArgs @ [expr3]) + | [IndexArgItem _;IndexArgItem _;IndexArgItem _;IndexArgRange _], Some (expr3, _) -> Some (sliceOpPath, "SetArraySlice4DFixedTriple4", expandedIndexArgs @ [expr3]) | _ -> None | _ -> None @@ -6828,7 +7102,7 @@ and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprO let operPath = mkSynLidGet (mDot.MakeSynthetic()) path functionName let f, fty, tpenv = TcExprOfUnknownType cenv env tpenv operPath let domainTy, resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty - UnifyTypes cenv env mWholeExpr domainTy e1ty + UnifyTypes cenv env mWholeExpr domainTy exprTy let f', resultTy = buildApp cenv (MakeApplicableExprNoFlex cenv f) resultTy expr mWholeExpr let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic, true, None, idx, mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz Some (PropagateThenTcDelayed cenv overallTy env tpenv mWholeExpr f' resultTy ExprAtomicFlag.Atomic delayed ) @@ -6842,24 +7116,25 @@ and TcIndexingThen cenv env overallTy mWholeExpr mDot tpenv setInfo synLeftExprO | Some nm -> nm let delayed = match setInfo with - // e1.[e2] + // expr1.[expr2] | None -> [ DelayedDotLookup([ ident(nm, mWholeExpr)], mWholeExpr) DelayedApp(ExprAtomicFlag.Atomic, true, synLeftExprOpt, MakeIndexParam None, mWholeExpr) yield! delayed ] - // e1.[e2] <- e3 --> e1.Item(e2) <- e3 - | Some (e3, mOfLeftOfSet) -> + + // expr1.[expr2] <- expr3 --> expr1.Item(expr2) <- expr3 + | Some (expr3, mOfLeftOfSet) -> if isIndex then [ DelayedDotLookup([ident(nm, mOfLeftOfSet)], mOfLeftOfSet) DelayedApp(ExprAtomicFlag.Atomic, true, synLeftExprOpt, MakeIndexParam None, mOfLeftOfSet) - MakeDelayedSet(e3, mWholeExpr) + MakeDelayedSet(expr3, mWholeExpr) yield! delayed ] else [ DelayedDotLookup([ident("SetSlice", mOfLeftOfSet)], mOfLeftOfSet) - DelayedApp(ExprAtomicFlag.Atomic, true, synLeftExprOpt, MakeIndexParam (Some e3), mWholeExpr) + DelayedApp(ExprAtomicFlag.Atomic, true, synLeftExprOpt, MakeIndexParam (Some expr3), mWholeExpr) yield! delayed ] - PropagateThenTcDelayed cenv overallTy env tpenv mDot (MakeApplicableExprNoFlex cenv expr) e1ty ExprAtomicFlag.Atomic delayed + PropagateThenTcDelayed cenv overallTy env tpenv mDot (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.Atomic delayed | _ -> // deprecated constrained lookup @@ -6931,7 +7206,7 @@ and TcCtorCall isNaked cenv env tpenv (overallTy: OverallTy) objTy mObjTyOpt ite error(Error(FSComp.SR.tcSyntaxCanOnlyBeUsedToCreateObjectTypes(if superInit then "inherit" else "new"), mWholeCall)) // Check a record construction expression -and TcRecordConstruction cenv (overallTy: TType) env tpenv optOrigExprInfo objTy fldsList m = +and TcRecordConstruction cenv (overallTy: TType) env tpenv withExprInfoOpt objTy fldsList m = let g = cenv.g let tcref, tinst = destAppTy g objTy @@ -6965,15 +7240,16 @@ and TcRecordConstruction cenv (overallTy: TType) env tpenv optOrigExprInfo objTy // Add rebindings for unbound field when an "old value" is available // Effect order: mutable fields may get modified by other bindings... let oldFldsList = - match optOrigExprInfo with + match withExprInfoOpt with | None -> [] - | Some (_, _, oldvaddre) -> - let fieldNameUnbound nom = List.forall (fun (name, _) -> name <> nom) fldsList + | Some (_, _, withExprAddrValExpr) -> + let fieldNameUnbound name2 = fldsList |> List.forall (fun (name, _) -> name <> name2) let flds = fspecs |> List.choose (fun rfld -> - if fieldNameUnbound rfld.LogicalName && not rfld.IsZeroInit - then Some(rfld.LogicalName, mkRecdFieldGetViaExprAddr (oldvaddre, tcref.MakeNestedRecdFieldRef rfld, tinst, m)) - else None) + if fieldNameUnbound rfld.LogicalName && not rfld.IsZeroInit then + Some(rfld.LogicalName, mkRecdFieldGetViaExprAddr (withExprAddrValExpr, tcref.MakeNestedRecdFieldRef rfld, tinst, m)) + else + None) flds let fldsList = fldsList @ oldFldsList @@ -6990,7 +7266,7 @@ and TcRecordConstruction cenv (overallTy: TType) env tpenv optOrigExprInfo objTy let ns1 = NameSet.ofList (List.map fst fldsList) let ns2 = NameSet.ofList (List.map (fun x -> x.rfield_id.idText) fspecs) - if optOrigExprInfo.IsNone && not (Zset.subset ns2 ns1) then + if withExprInfoOpt.IsNone && not (Zset.subset ns2 ns1) then error (MissingFields(Zset.elements (Zset.diff ns2 ns1), m)) if not (Zset.subset ns1 ns2) then @@ -7010,16 +7286,16 @@ and TcRecordConstruction cenv (overallTy: TType) env tpenv optOrigExprInfo objTy let expr = mkRecordExpr g (GetRecdInfo env, tcref, tinst, rfrefs, args, m) let expr = - match optOrigExprInfo with + match withExprInfoOpt with | None -> // '{ recd fields }'. // expr - | Some (old, oldvaddr, _) -> + | Some (withExpr, withExprAddrVal, _) -> // '{ recd with fields }'. // Assign the first object to a tmp and then construct - let wrap, oldaddr, _readonly, _writeonly = mkExprAddrOfExpr g tycon.IsStructOrEnumTycon false NeverMutates old None m - wrap (mkCompGenLet m oldvaddr oldaddr expr) + let wrap, oldaddr, _readonly, _writeonly = mkExprAddrOfExpr g tycon.IsStructOrEnumTycon false NeverMutates withExpr None m + wrap (mkCompGenLet m withExprAddrVal oldaddr expr) expr, tpenv @@ -7061,7 +7337,7 @@ and FreshenObjExprAbstractSlot cenv (env: TcEnv) (implTy: TType) virtNameAndArit let g = cenv.g - let (NormalizedBinding (_, _, _, _, _, _, synTyparDecls, _, _, _, mBinding, _)) = bind + let (NormalizedBinding (typars=synTyparDecls; mBinding=mBinding)) = bind match absSlots with | [] when not (CompileAsEvent g bindAttribs) -> @@ -7087,21 +7363,23 @@ and FreshenObjExprAbstractSlot cenv (env: TcEnv) (implTy: TType) virtNameAndArit |> Seq.exists (fun kv -> kv.Value |> List.exists (fun valRef -> valRef.DisplayName = bindName)) let suggestVirtualMembers (addToBuffer: string -> unit) = - for (x,_),_ in virtNameAndArityPairs do + for (x, _), _ in virtNameAndArityPairs do addToBuffer x if containsNonAbstractMemberWithSameName then errorR(ErrorWithSuggestions(FSComp.SR.tcMemberFoundIsNotAbstractOrVirtual(tcref.DisplayName, bindName), mBinding, bindName, suggestVirtualMembers)) else errorR(ErrorWithSuggestions(FSComp.SR.tcNoAbstractOrVirtualMemberFound bindName, mBinding, bindName, suggestVirtualMembers)) - | [(_, absSlot: MethInfo)] -> + + | [ (_, absSlot: MethInfo) ] -> errorR(Error(FSComp.SR.tcArgumentArityMismatch(bindName, List.sum absSlot.NumArgs, arity, getSignature absSlot, getDetails absSlot), mBinding)) - | (_, absSlot: MethInfo) :: _ -> + + | (_, absSlot) :: _ -> errorR(Error(FSComp.SR.tcArgumentArityMismatchOneOverload(bindName, List.sum absSlot.NumArgs, arity, getSignature absSlot, getDetails absSlot), mBinding)) None - | [(_, absSlot)] -> + | [ (_, absSlot) ] -> let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = FreshenAbstractSlot g cenv.amap mBinding synTyparDecls absSlot @@ -7118,7 +7396,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implTy tpenv (absSlotInfo, bind) = let g = cenv.g - let (NormalizedBinding(vis, bkind, isInline, isMutable, attrs, doc, synTyparDecls, valSynData, p, bindingRhs, mBinding, spBind)) = bind + let (NormalizedBinding(vis, kind, isInline, isMutable, attrs, xmlDoc, synTyparDecls, valSynData, headPat, bindingRhs, mBinding, debugPoint)) = bind let (SynValData(memberFlagsOpt, _, _)) = valSynData // 4a2. adjust the binding, especially in the "member" case, a subset of the logic of AnalyzeAndMakeAndPublishRecursiveValue @@ -7139,8 +7417,8 @@ and TcObjectExprBinding cenv (env: TcEnv) implTy tpenv (absSlotInfo, bind) = bindingRhs, logicalMethId, memberFlags | _ -> error(InternalError("unexpected member binding", mBinding)) - lookPat p - let bind = NormalizedBinding (vis, bkind, isInline, isMutable, attrs, doc, synTyparDecls, valSynData, mkSynPatVar vis logicalMethId, bindingRhs, mBinding, spBind) + lookPat headPat + let bind = NormalizedBinding (vis, kind, isInline, isMutable, attrs, xmlDoc, synTyparDecls, valSynData, mkSynPatVar vis logicalMethId, bindingRhs, mBinding, debugPoint) // 4b. typecheck the binding let bindingTy = @@ -7157,7 +7435,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implTy tpenv (absSlotInfo, bind) = // 4c. generalize the binding - only relevant when implementing a generic virtual method match NameMap.range nameToPrelimValSchemeMap with - | [PrelimValScheme1(id, _, _, _, _, _, _, _, _, _, _)] -> + | [ PrelimVal1(id=id) ] -> let denv = env.DisplayEnv let declaredTypars = @@ -7238,9 +7516,9 @@ and ComputeObjectExprOverrides cenv (env: TcEnv) tpenv impls = // Convert the syntactic info to actual info let overrides = (overrides, bindNameAndSynInfoPairs) ||> List.map2 (fun (id: Ident, memberFlags, ty, bindingAttribs, bindingBody) (_, valSynData) -> - let partialValInfo = TranslateTopValSynInfo id.idRange (TcAttributes cenv env) valSynData + let partialValInfo = TranslateSynValInfo id.idRange (TcAttributes cenv env) valSynData let tps, _ = tryDestForallTy g ty - let valInfo = TranslatePartialArity tps partialValInfo + let valInfo = TranslatePartialValReprInfo tps partialValInfo DispatchSlotChecking.GetObjectExprOverrideInfo g cenv.amap (implTy, id, memberFlags, ty, valInfo, bindingAttribs, bindingBody)) (m, implTy, reqdSlots, dispatchSlotsKeyed, availPriorOverrides, overrides), tpenv) @@ -7343,14 +7621,16 @@ and TcObjectExpr cenv env tpenv (objTy, realObjTy, argopt, binds, extraImpls, mO overridesAndVirts |> List.map (fun (m, implTy, _, dispatchSlotsKeyed, _, overrides) -> let overrides' = [ for overrideMeth in overrides do - let Override(_, _, id, (mtps, _), _, _, isFakeEventProperty, _) as ovinfo, (_, thisVal, methodVars, bindingAttribs, bindingBody) = overrideMeth + let overrideInfo, (_, thisVal, methodVars, bindingAttribs, bindingBody) = overrideMeth + let (Override(_, _, id, mtps, _, _, _, isFakeEventProperty, _)) = overrideInfo + if not isFakeEventProperty then let searchForOverride = dispatchSlotsKeyed |> NameMultiMap.find id.idText |> List.tryPick (fun reqdSlot -> let virt = reqdSlot.MethodInfo - if DispatchSlotChecking.IsExactMatch g cenv.amap m virt ovinfo then + if DispatchSlotChecking.IsExactMatch g cenv.amap m virt overrideInfo then Some virt else None) @@ -7685,36 +7965,36 @@ and TcAssertExpr cenv overallTy env (m: range) tpenv x = TcExpr cenv overallTy env tpenv callDiagnosticsExpr -and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, optOrigExpr, flds, mWholeExpr) = +and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) = let g = cenv.g let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors let haveCtor = Option.isSome inherits - let optOrigExpr, tpenv = - match optOrigExpr with + let withExprOpt, tpenv = + match withExprOpt with | None -> None, tpenv | Some (origExpr, _) -> match inherits with | Some (_, _, mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(), mInherits)) | None -> - let olde, tpenv = TcExpr cenv (MustEqual overallTy) env tpenv origExpr - Some olde, tpenv + let withExpr, tpenv = TcExpr cenv (MustEqual overallTy) env tpenv origExpr + Some withExpr, tpenv - let hasOrigExpr = optOrigExpr.IsSome + let hasOrigExpr = withExprOpt.IsSome let fldsList = let flds = [ // if we met at least one field that is not syntactically correct - raise ReportedError to transfer control to the recovery routine - for SynExprRecordField(fieldName=(lidwd, isOk); expr=v) in flds do + for SynExprRecordField(fieldName=(synLongId, isOk); expr=v) in synRecdFields do if not isOk then // raising ReportedError None transfers control to the closest errorRecovery point but do not make any records into log // we assume that parse errors were already reported raise (ReportedError None) - yield (List.frontAndBack lidwd.LongIdent, v) + yield (List.frontAndBack synLongId.LongIdent, v) ] match flds with @@ -7729,12 +8009,12 @@ and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, optOrigExpr, flds, m | Some v -> yield n, v | None -> () ] - let optOrigExprInfo = - match optOrigExpr with + let withExprInfoOpt = + match withExprOpt with | None -> None - | Some(olde) -> - let oldvaddr, oldvaddre = mkCompGenLocal mWholeExpr "inputRecord" (if isStructTy g overallTy then mkByrefTy g overallTy else overallTy) - Some(olde, oldvaddr, oldvaddre) + | Some withExpr -> + let withExprAddrVal, withExprAddrValExpr = mkCompGenLocal mWholeExpr "inputRecord" (if isStructTy g overallTy then mkByrefTy g overallTy else overallTy) + Some(withExpr, withExprAddrVal, withExprAddrValExpr) if hasOrigExpr && not (isRecdTy g overallTy) then errorR(Error(FSComp.SR.tcExpressionFormRequiresRecordTypes(), mWholeExpr)) @@ -7746,7 +8026,7 @@ and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, optOrigExpr, flds, m if not requiresCtor then errorR(Error(FSComp.SR.tcObjectConstructionExpressionCanOnlyImplementConstructorsInObjectModelTypes(), mWholeExpr)) else - if isNil flds then + if isNil synRecdFields then let errorInfo = if hasOrigExpr then FSComp.SR.tcEmptyCopyAndUpdateRecordInvalid() else FSComp.SR.tcEmptyRecordInvalid() error(Error(errorInfo, mWholeExpr)) @@ -7769,7 +8049,7 @@ and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, optOrigExpr, flds, m errorR(InternalError("Unexpected failure in getting super type", mWholeExpr)) None, tpenv - let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv optOrigExprInfo overallTy fldsList mWholeExpr + let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv withExprInfoOpt overallTy fldsList mWholeExpr let expr = match superInitExprOpt with @@ -7932,10 +8212,18 @@ and TcCopyAndUpdateAnonRecdExpr cenv (overallTy: TType) env tpenv (isStruct, ori let expr = mkCompGenLet mOrigExpr oldv origExprChecked expr expr, tpenv -and TcForEachExpr cenv overallTy env tpenv (synPat, synEnumExpr, synBodyExpr, mWholeExpr, spFor, spIn) = +and TcForEachExpr cenv overallTy env tpenv (seqExprOnly, isFromSource, synPat, synEnumExpr, synBodyExpr, mWholeExpr, spFor, spIn, m) = let g = cenv.g + assert isFromSource + if seqExprOnly then warning (Error(FSComp.SR.tcExpressionRequiresSequence(), m)) + + let synEnumExpr = + match RewriteRangeExpr synEnumExpr with + | Some e -> e + | None -> synEnumExpr + let tryGetOptimizeSpanMethodsAux g m ty isReadOnlySpan = match (if isReadOnlySpan then tryDestReadOnlySpanTy g m ty else tryDestSpanTy g m ty) with | Some(_, destTy) -> @@ -8028,12 +8316,12 @@ and TcForEachExpr cenv overallTy env tpenv (synPat, synEnumExpr, synBodyExpr, mW let pat, _, vspecs, envinner, tpenv = let env = { env with eIsControlFlow = false } - TcMatchPattern cenv enumElemTy env tpenv (synPat, None) + TcMatchPattern cenv enumElemTy env tpenv synPat None let elemVar, pat = // nice: don't introduce awful temporary for r.h.s. in the 99% case where we know what we're binding it to match pat with - | TPat_as (pat1, PBind(v, TypeScheme([], _)), _) -> + | TPat_as (pat1, PatternValBinding(v, GeneralizedType([], _)), _) -> v, pat1 | _ -> let tmp, _ = mkCompGenLocal pat.Range "forLoopVar" enumElemTy @@ -8049,7 +8337,7 @@ and TcForEachExpr cenv overallTy env tpenv (synPat, synEnumExpr, synBodyExpr, mW let valsDefinedByMatching = ListSet.remove valEq elemVar vspecs CompilePatternForMatch cenv env synEnumExpr.Range pat.Range false IgnoreWithWarning (elemVar, [], None) - [TClause(pat, None, TTarget(valsDefinedByMatching, bodyExpr, None), mIn)] + [MatchClause(pat, None, TTarget(valsDefinedByMatching, bodyExpr, None), mIn)] enumElemTy overallTy.Commit @@ -8191,7 +8479,7 @@ and Propagate cenv (overallTy: OverallTy) (env: TcEnv) tpenv (expr: ApplicableEx // This is the error path. The error we give depends on what's enabled. // // First, 'delayed' is about to be dropped on the floor, do rudimentary checking to get name resolutions in its body - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed + RecordNameAndTypeResolutionsDelayed cenv env tpenv delayed let vName = match expr.Expr with | Expr.Val (d, _, _) -> Some d.DisplayName @@ -8221,7 +8509,7 @@ and Propagate cenv (overallTy: OverallTy) (env: TcEnv) tpenv (expr: ApplicableEx // f x (where 'f' is not a function) | _ -> // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed + RecordNameAndTypeResolutionsDelayed cenv env tpenv delayed error (NotAFunction(denv, overallTy.Commit, mExpr, mArg)) propagate false delayed expr.Range exprTy @@ -8268,10 +8556,10 @@ and TcDelayed cenv (overallTy: OverallTy) env tpenv mExpr expr exprTy (atomicFla UnifyTypes cenv env mExpr overallTy.Commit g.unit_ty let expr = expr.Expr let _wrap, exprAddress, _readonly, _writeonly = mkExprAddrOfExpr g true false DefinitelyMutates expr None mExpr - let vty = tyOfExpr g expr + let vTy = tyOfExpr g expr // Always allow subsumption on assignment to fields - let expr2, tpenv = TcExprFlex cenv true false vty env tpenv synExpr2 - let v, _ve = mkCompGenLocal mExpr "addr" (mkByrefTy g vty) + let expr2, tpenv = TcExprFlex cenv true false vTy env tpenv synExpr2 + let v, _ve = mkCompGenLocal mExpr "addr" (mkByrefTy g vTy) mkCompGenLet mStmt v exprAddress (mkAddrSet mStmt (mkLocalValRef v) expr2), tpenv /// Convert the delayed identifiers to a dot-lookup. @@ -8471,8 +8759,8 @@ and TcApplicationThen cenv (overallTy: OverallTy) env tpenv mExprAndArg synLeftE let arg, tpenv = // treat left and right of '||' and '&&' as control flow, so for example - // f e1 && g e2 - // will have debug points on "f e1" and "g e2" + // f expr1 && g expr2 + // will have debug points on "f expr1" and "g expr2" let env = match leftExpr with | ApplicableExpr(_, Expr.Val (vf, _, _), _) @@ -8503,7 +8791,7 @@ and TcApplicationThen cenv (overallTy: OverallTy) env tpenv mExprAndArg synLeftE let expandedIndexArgs = ExpandIndexArgs synLeftExprOpt indexArgs let setInfo, delayed = match delayed with - | DelayedSet(e3, _) :: rest -> Some (e3, unionRanges leftExpr.Range synArg.Range), rest + | DelayedSet(expr3, _) :: rest -> Some (expr3, unionRanges leftExpr.Range synArg.Range), rest | _ -> None, delayed TcIndexingThen cenv env overallTy mExprAndArg m tpenv setInfo synLeftExprOpt leftExpr.Expr exprTy expandedIndexArgs indexArgs delayed @@ -8591,7 +8879,7 @@ and TcItemThen cenv (overallTy: OverallTy) env tpenv (tinstEnclosing, item, mIte | Item.CustomOperation (nm, usageTextOpt, _) -> // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed + RecordNameAndTypeResolutionsDelayed cenv env tpenv delayed match usageTextOpt() with | None -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly nm, mItem)) | Some usageText -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly2(nm, usageText), mItem)) @@ -8716,8 +9004,8 @@ and TcUnionCaseOrExnCaseOrActivePatternResultItemThen cenv overallTy env item tp assert (Seq.forall (box >> ((<>) null) ) fittedArgs) List.ofArray fittedArgs - let args', tpenv = TcExprsWithFlexes cenv env mExprAndArg tpenv flexes argTys args - PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg args')) ucaseAppTy atomicFlag otherDelayed + let argsR, tpenv = TcExprsWithFlexes cenv env mExprAndArg tpenv flexes argTys args + PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg argsR)) ucaseAppTy atomicFlag otherDelayed | DelayedTypeApp (_x, mTypeArgs, _mExprAndTypeArgs) :: _delayed' -> error(Error(FSComp.SR.tcUnexpectedTypeArguments(), mTypeArgs)) @@ -9018,30 +9306,30 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed let g = cenv.g match delayed with // Mutable value set: 'v <- e' - | DelayedSet(e2, mStmt) :: otherDelayed -> + | DelayedSet(expr2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty vref.Deref.SetHasBeenReferenced() CheckValAccessible mItem env.AccessRights vref CheckValAttributes g vref mItem |> CommitOperationResult - let vty = vref.Type + let vTy = vref.Type let vty2 = - if isByrefTy g vty then - destByrefTy g vty + if isByrefTy g vTy then + destByrefTy g vTy else if not vref.IsMutable then errorR (ValNotMutable (env.DisplayEnv, vref, mStmt)) - vty + vTy // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false vty2 env tpenv e2 + let expr2R, tpenv = TcExprFlex cenv true false vty2 env tpenv expr2 let vexp = - if isInByrefTy g vty then + if isInByrefTy g vTy then errorR(Error(FSComp.SR.writeToReadOnlyByref(), mStmt)) - mkAddrSet mStmt vref e2' - elif isByrefTy g vty then - mkAddrSet mStmt vref e2' + mkAddrSet mStmt vref expr2R + elif isByrefTy g vTy then + mkAddrSet mStmt vref expr2R else - mkValSet mStmt vref e2' + mkValSet mStmt vref expr2R PropagateThenTcDelayed cenv overallTy env tpenv mStmt (MakeApplicableExprNoFlex cenv vexp) (tyOfExpr g vexp) ExprAtomicFlag.NonAtomic otherDelayed @@ -9056,7 +9344,7 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed | _ when isNameOfValRef g vref && g.langVersion.SupportsFeature LanguageFeature.NameOf -> match tys with | [SynType.Var(SynTypar(id, _, false) as tp, _m)] -> - let _tpR, tpenv = TcTyparOrMeasurePar None cenv env ImplicitlyBoundTyparsAllowed.NoNewTypars tpenv tp + let _tpR, tpenv = TcTypeOrMeasureParameter None cenv env ImplicitlyBoundTyparsAllowed.NoNewTypars tpenv tp let vexp = TcNameOfExprResult cenv id mExprAndTypeArgs let vexpFlex = MakeApplicableExprNoFlex cenv vexp PropagateThenTcDelayed cenv overallTy env tpenv mExprAndTypeArgs vexpFlex g.string_ty ExprAtomicFlag.Atomic otherDelayed @@ -9098,7 +9386,7 @@ and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem afterResolution error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItem)) match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> + | DelayedSet(expr2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) // Static Property Set (possibly indexer) @@ -9121,7 +9409,7 @@ and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem afterResolution if isNil meths then errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItem)) // Note: static calls never mutate a struct object argument - TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt [] mStmt mItem nm ad NeverMutates true meths afterResolution NormalValUse (args@[e2]) ExprAtomicFlag.NonAtomic otherDelayed + TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt [] mStmt mItem nm ad NeverMutates true meths afterResolution NormalValUse (args@[expr2]) ExprAtomicFlag.NonAtomic otherDelayed | _ -> // Static Property Get (possibly indexer) let meths = pinfos |> GettersOfPropInfos @@ -9136,12 +9424,13 @@ and TcILFieldItemThen cenv overallTy env finfo tpenv mItem delayed = let fref = finfo.ILFieldRef let exprTy = finfo.FieldType(cenv.amap, mItem) match delayed with - | DelayedSet(e2, mStmt) :: _delayed' -> + | DelayedSet(expr2, mStmt) :: _delayed' -> UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false exprTy env tpenv e2 - let expr = BuildILStaticFieldSet mStmt finfo e2' + let expr2R, tpenv = TcExprFlex cenv true false exprTy env tpenv expr2 + let expr = BuildILStaticFieldSet mStmt finfo expr2R expr, tpenv + | _ -> // Get static IL field let expr = @@ -9149,16 +9438,21 @@ and TcILFieldItemThen cenv overallTy env finfo tpenv mItem delayed = | Some lit -> Expr.Const (TcFieldInit mItem lit, mItem, exprTy) | None -> - let isValueType = finfo.IsValueType - let valu = if isValueType then AsValue else AsObject + let isStruct = finfo.IsValueType + let boxity = if isStruct then AsValue else AsObject + + // The empty instantiation on the fspec is OK, since we make the correct fspec in IlxGen.GenAsm + // This ensures we always get the type instantiation right when doing this from + // polymorphic code, after inlining etc. + let fspec = mkILFieldSpec(fref, mkILNamedTy boxity fref.DeclaringTypeRef []) + + let ilInstrs = + [ mkNormalLdsfld fspec + // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr. + if finfo.IsInitOnly then AI_nop ] - // The empty instantiation on the fspec is OK, since we make the correct fspec in IlxGen.GenAsm - // This ensures we always get the type instantiation right when doing this from - // polymorphic code, after inlining etc. - let fspec = mkILFieldSpec(fref, mkILNamedTy valu fref.DeclaringTypeRef []) + mkAsmExpr (ilInstrs, finfo.TypeInst, [], [exprTy], mItem) - // Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr. - mkAsmExpr ([ mkNormalLdsfld fspec ] @ (if finfo.IsInitOnly then [ AI_nop ] else []), finfo.TypeInst, [], [exprTy], mItem) PropagateThenTcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprWithFlex cenv env expr) exprTy ExprAtomicFlag.Atomic delayed and TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem delayed = @@ -9171,7 +9465,7 @@ and TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem delayed = let fref = rfinfo.RecdFieldRef let fieldTy = rfinfo.FieldType match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> + | DelayedSet(expr2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) // Set static F# field @@ -9179,8 +9473,8 @@ and TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem delayed = UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty let fieldTy = rfinfo.FieldType // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 - let expr = mkStaticRecdFieldSet (rfinfo.RecdFieldRef, rfinfo.TypeInst, e2', mStmt) + let expr2R, tpenv = TcExprFlex cenv true false fieldTy env tpenv expr2 + let expr = mkStaticRecdFieldSet (rfinfo.RecdFieldRef, rfinfo.TypeInst, expr2R, mStmt) expr, tpenv | _ -> let exprTy = fieldTy @@ -9277,7 +9571,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> + | DelayedSet(expr2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) // Instance property setter UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty @@ -9293,7 +9587,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela else let args = if pinfo.IsIndexer then args else [] let mut = (if isStructTy g (tyOfExpr g objExpr) then DefinitelyMutates else PossiblyMutates) - TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt objArgs mStmt mItem nm ad mut true meths afterResolution NormalValUse (args @ [e2]) atomicFlag [] + TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt objArgs mStmt mItem nm ad mut true meths afterResolution NormalValUse (args @ [expr2]) atomicFlag [] | _ -> // Instance property getter let meths = GettersOfPropInfos pinfos @@ -9304,19 +9598,19 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Get or set instance F# field or literal RecdFieldInstanceChecks g cenv.amap ad mItem rfinfo let tgtTy = rfinfo.DeclaringType - let valu = isStructTy g tgtTy + let boxity = isStructTy g tgtTy AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgtTy objExprTy - let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgtTy, mExprAndItem, objExprTy) + let objExpr = if boxity then objExpr else mkCoerceExpr(objExpr, tgtTy, mExprAndItem, objExprTy) let fieldTy = rfinfo.FieldType match delayed with - | DelayedSet(e2, mStmt) :: otherDelayed -> + | DelayedSet(expr2, mStmt) :: otherDelayed -> // Mutable value set: 'v <- e' if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mItem)) CheckRecdFieldMutation mItem env.DisplayEnv rfinfo UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 - BuildRecdFieldSet g mStmt objExpr rfinfo e2', tpenv + let expr2R, tpenv = TcExprFlex cenv true false fieldTy env tpenv expr2 + BuildRecdFieldSet g mStmt objExpr rfinfo expr2R, tpenv | _ -> @@ -9343,11 +9637,11 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela match delayed with // Set instance IL field - | DelayedSet(e2, mStmt) :: _delayed' -> + | DelayedSet(expr2, mStmt) :: _delayed' -> UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty // Always allow subsumption on assignment to fields - let e2', tpenv = TcExprFlex cenv true false exprTy env tpenv e2 - let expr = BuildILFieldSet g mStmt objExpr finfo e2' + let expr2R, tpenv = TcExprFlex cenv true false exprTy env tpenv expr2 + let expr = BuildILFieldSet g mStmt objExpr finfo expr2R expr, tpenv | _ -> let expr = BuildILFieldGet g cenv.amap mExprAndItem objExpr finfo @@ -9967,9 +10261,9 @@ and TcMethodApplication // Handle byref returns let callExpr1, exprTy = // byref-typed returns get implicitly dereferenced - let vty = tyOfExpr g callExpr0 - if isByrefTy g vty then - mkDerefAddrExpr mMethExpr callExpr0 mMethExpr vty, destByrefTy g vty + let vTy = tyOfExpr g callExpr0 + if isByrefTy g vTy then + mkDerefAddrExpr mMethExpr callExpr0 mMethExpr vTy, destByrefTy g vTy else callExpr0, exprTy @@ -10227,20 +10521,20 @@ and CheckRecursiveBindingIds binds = /// Process a sequence of sequentials mixed with iterated lets "let ... in let ... in ..." in a tail recursive way /// This avoids stack overflow on really large "let" and "letrec" lists -and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = +and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr synExpr cont = let g = cenv.g - match expr with - | SynExpr.Sequential (sp, true, e1, e2, m) when not isCompExpr -> - let e1', _ = + match synExpr with + | SynExpr.Sequential (sp, true, expr1, expr2, m) when not isCompExpr -> + let expr1R, _ = let env1 = { env with eIsControlFlow = (match sp with | DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } - TcStmtThatCantBeCtorBody cenv env1 tpenv e1 + TcStmtThatCantBeCtorBody cenv env1 tpenv expr1 let env2 = { env with eIsControlFlow = (match sp with | DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressStmt -> true | _ -> false) } - let env2 = ShrinkContext env2 m e2.Range + let env2 = ShrinkContext env2 m expr2.Range // tailcall - TcLinearExprs bodyChecker cenv env2 overallTy tpenv isCompExpr e2 (fun (e2', tpenv) -> - cont (Expr.Sequential (e1', e2', NormalSeq, m), tpenv)) + TcLinearExprs bodyChecker cenv env2 overallTy tpenv isCompExpr expr2 (fun (expr2R, tpenv) -> + cont (Expr.Sequential (expr1R, expr2R, NormalSeq, m), tpenv)) | SynExpr.LetOrUse (isRec, isUse, binds, body, m, _) when not (isUse && isCompExpr) -> if isRec then @@ -10297,29 +10591,29 @@ and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = cont (resExpr, tpenv)) | _ -> - cont (bodyChecker overallTy env tpenv expr) + cont (bodyChecker overallTy env tpenv synExpr) /// Typecheck and compile pattern-matching constructs -and TcAndPatternCompileMatchClauses mExpr matchm actionOnFailure cenv inputExprOpt inputTy resultTy env tpenv synClauses = +and TcAndPatternCompileMatchClauses mExpr mMatch actionOnFailure cenv inputExprOpt inputTy resultTy env tpenv synClauses = let clauses, tpenv = TcMatchClauses cenv inputTy resultTy env tpenv synClauses - let matchVal, expr = CompilePatternForMatchClauses cenv env mExpr matchm true actionOnFailure inputExprOpt inputTy resultTy.Commit clauses + let matchVal, expr = CompilePatternForMatchClauses cenv env mExpr mMatch true actionOnFailure inputExprOpt inputTy resultTy.Commit clauses matchVal, expr, tpenv -and TcMatchPattern cenv inputTy env tpenv (pat: SynPat, optWhenExpr: SynExpr option) = +and TcMatchPattern cenv inputTy env tpenv (synPat: SynPat) (synWhenExprOpt: SynExpr option) = let g = cenv.g - let m = pat.Range - let patf', (tpenv, names, _) = TcPat WarnOnUpperCase cenv env None (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, false) (tpenv, Map.empty, Set.empty) inputTy pat + let m = synPat.Range + let patf', (tpenv, names, _) = TcPat WarnOnUpperCase cenv env None (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, false) (tpenv, Map.empty, Set.empty) inputTy synPat let envinner, values, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names - let optWhenExprR, tpenv = - match optWhenExpr with - | Some whenExpr -> - let guardEnv = { envinner with eContextInfo = ContextInfo.PatternMatchGuard whenExpr.Range } - let whenExprR, tpenv = TcExpr cenv (MustEqual g.bool_ty) guardEnv tpenv whenExpr + let whenExprOpt, tpenv = + match synWhenExprOpt with + | Some synWhenExpr -> + let guardEnv = { envinner with eContextInfo = ContextInfo.PatternMatchGuard synWhenExpr.Range } + let whenExprR, tpenv = TcExpr cenv (MustEqual g.bool_ty) guardEnv tpenv synWhenExpr Some whenExprR, tpenv | None -> None, tpenv - patf' (TcPatPhase2Input (values, true)), optWhenExprR, NameMap.range vspecMap, envinner, tpenv + patf' (TcPatPhase2Input (values, true)), whenExprOpt, NameMap.range vspecMap, envinner, tpenv and TcMatchClauses cenv inputTy (resultTy: OverallTy) env tpenv clauses = let mutable first = true @@ -10327,12 +10621,23 @@ and TcMatchClauses cenv inputTy (resultTy: OverallTy) env tpenv clauses = List.mapFold (fun clause -> TcMatchClause cenv inputTy resultTy env (isFirst()) clause) tpenv clauses and TcMatchClause cenv inputTy (resultTy: OverallTy) env isFirst tpenv synMatchClause = - let (SynMatchClause(pat, optWhenExpr, e, patm, spTgt, _)) = synMatchClause - let pat', optWhenExprR, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv (pat, optWhenExpr) - let resultEnv = if isFirst then envinner else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause e.Range } - let resultEnv = match spTgt with DebugPointAtTarget.Yes -> { resultEnv with eIsControlFlow = true } | DebugPointAtTarget.No -> resultEnv - let e', tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv e - TClause(pat', optWhenExprR, TTarget(vspecs, e', None), patm), tpenv + let (SynMatchClause(synPat, synWhenExprOpt, synResultExpr, patm, spTgt, _)) = synMatchClause + let pat, whenExprOpt, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv synPat synWhenExprOpt + + let resultEnv = + if isFirst then envinner + else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause synResultExpr.Range } + + let resultEnv = + match spTgt with + | DebugPointAtTarget.Yes -> { resultEnv with eIsControlFlow = true } + | DebugPointAtTarget.No -> resultEnv + + let resultExpr, tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv synResultExpr + + let target = TTarget(vspecs, resultExpr, None) + + MatchClause(pat, whenExprOpt, target, patm), tpenv and TcStaticOptimizationConstraint cenv env tpenv c = let g = cenv.g @@ -10439,11 +10744,11 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let envinner = AddDeclaredTypars NoCheckForDuplicateTypars (enclosingDeclaredTypars@declaredTypars) env match bind with - | NormalizedBinding(vis, bkind, isInline, isMutable, attrs, doc, _, valSynData, pat, NormalizedBindingRhs(spatsL, rtyOpt, rhsExpr), mBinding, spBind) -> + | NormalizedBinding(vis, kind, isInline, isMutable, attrs, xmlDoc, _, valSynData, pat, NormalizedBindingRhs(spatsL, rtyOpt, rhsExpr), mBinding, debugPoint) -> let (SynValData(memberFlagsOpt, _, _)) = valSynData let callerName = - match declKind, bkind, pat with + match declKind, kind, pat with | ExpressionBinding, _, _ -> envinner.eCallerMemberName | _, _, (SynPat.Named(SynIdent(name,_), _, _, _) | SynPat.As(_, SynPat.Named(SynIdent(name,_), _, _, _), _)) -> match memberFlagsOpt with @@ -10573,20 +10878,20 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt else isInline - let compgen = false + let isCompGen = false // Use the syntactic arity if we're defining a function let (SynValData(_, valSynInfo, _)) = valSynData - let partialValReprInfo = TranslateTopValSynInfo mBinding (TcAttributes cenv env) valSynInfo + let prelimValReprInfo = TranslateSynValInfo mBinding (TcAttributes cenv env) valSynInfo // Check the pattern of the l.h.s. of the binding let tcPatPhase2, (tpenv, nameToPrelimValSchemeMap, _) = - TcPat AllIdsOK cenv envinner (Some partialValReprInfo) (inlineFlag, explicitTyparInfo, argAndRetAttribs, isMutable, vis, compgen) (tpenv, NameMap.empty, Set.empty) overallPatTy pat + TcPat AllIdsOK cenv envinner (Some prelimValReprInfo) (inlineFlag, explicitTyparInfo, argAndRetAttribs, isMutable, vis, isCompGen) (tpenv, NameMap.empty, Set.empty) overallPatTy pat // Add active pattern result names to the environment let apinfoOpt = match NameMap.range nameToPrelimValSchemeMap with - | [PrelimValScheme1(id, _, ty, _, _, _, _, _, _, _, _) ] -> + | [PrelimVal1(id, _, ty, _, _, _, _, _, _, _, _) ] -> match ActivePatternInfoOfValName id.idText id.idRange with | Some apinfo -> Some (apinfo, ty, id.idRange) | None -> None @@ -10623,7 +10928,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt conditionallySuppressErrorReporting atTopNonLambdaDefn (fun () -> // Save the arginfos away to match them up in the lambda - let (PartialValReprInfo(argInfos, _)) = partialValReprInfo + let (PrelimValReprInfo(argInfos, _)) = prelimValReprInfo // The right-hand-side is control flow (has an implicit debug point) in any situation where we // haven't extended the debug point to include the 'let', that is, there is a debug point noted @@ -10640,7 +10945,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt | SynPat.Const (SynConst.Unit, _) | SynPat.Paren (SynPat.Const (SynConst.Unit, _), _) -> true | _ -> - match spBind with + match debugPoint with | DebugPointAtBinding.Yes _ -> false | _ -> true @@ -10649,7 +10954,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt if isCtor then TcExprThatIsCtorBody (safeThisValOpt, safeInitInfo) cenv (MustEqual overallExprTy) envinner tpenv rhsExpr else TcExprThatCantBeCtorBody cenv (MustConvertTo (false, overallExprTy)) envinner tpenv rhsExpr) - if bkind = SynBindingKind.StandaloneExpression && not cenv.isScript then + if kind = SynBindingKind.StandaloneExpression && not cenv.isScript then UnifyUnitType cenv env mBinding overallPatTy rhsExprChecked |> ignore // Fix up the r.h.s. expression for 'fixed' @@ -10687,7 +10992,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt if not (isNil declaredTypars) then errorR(Error(FSComp.SR.tcLiteralCannotHaveGenericParameters(), mBinding)) - CheckedBindingInfo(inlineFlag, valAttribs, doc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExprChecked, argAndRetAttribs, overallPatTy, mBinding, spBind, compgen, literalValue, isFixed), tpenv + CheckedBindingInfo(inlineFlag, valAttribs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExprChecked, argAndRetAttribs, overallPatTy, mBinding, debugPoint, isCompGen, literalValue, isFixed), tpenv and TcLiteral cenv overallTy env tpenv (attrs, synLiteralValExpr) = @@ -10840,8 +11145,12 @@ and TcAttributeEx canFail cenv (env: TcEnv) attrTgt attrEx (synAttr: SynAttribut match ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty with | Exception _ when canFail -> [ ], true | res -> + let item = ForceRaise res - if not (ExistsHeadTypeInEntireHierarchy g cenv.amap mAttr ty g.tcref_System_Attribute) then warning(Error(FSComp.SR.tcTypeDoesNotInheritAttribute(), mAttr)) + + if not (ExistsHeadTypeInEntireHierarchy g cenv.amap mAttr ty g.tcref_System_Attribute) then + warning(Error(FSComp.SR.tcTypeDoesNotInheritAttribute(), mAttr)) + let attrib = match item with | Item.CtorGroup(methodName, minfos) -> @@ -10972,7 +11281,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // Generalize the bindings... (((fun x -> x), env, tpenv), checkedBinds) ||> List.fold (fun (buildExpr, env, tpenv) tbinfo -> - let (CheckedBindingInfo(inlineFlag, attrs, doc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExpr, _, tauTy, m, spBind, _, literalValue, isFixed)) = tbinfo + let (CheckedBindingInfo(inlineFlag, attrs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExpr, _, tauTy, m, debugPoint, _, literalValue, isFixed)) = tbinfo let enclosingDeclaredTypars = [] let (ExplicitTyparInfo(_, declaredTypars, canInferTypars)) = explicitTyparInfo let allDeclaredTypars = enclosingDeclaredTypars @ declaredTypars @@ -10998,7 +11307,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // on all other paths. let tpenv = HideUnscopedTypars generalizedTypars tpenv let valSchemes = NameMap.map (UseCombinedArity g declKind rhsExpr) prelimValSchemes2 - let values = MakeAndPublishVals cenv env (altActualParent, false, declKind, ValNotInRecScope, valSchemes, attrs, doc, literalValue) + let values = MakeAndPublishVals cenv env (altActualParent, false, declKind, ValNotInRecScope, valSchemes, attrs, xmlDoc, literalValue) let checkedPat = tcPatPhase2 (TcPatPhase2Input (values, true)) let prelimRecValues = NameMap.map fst values @@ -11019,7 +11328,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // We don't introduce a temporary for the case // let v = expr - | TPat_as (pat, PBind(v, TypeScheme(generalizedTypars', _)), _) + | TPat_as (pat, PatternValBinding(v, GeneralizedType(generalizedTypars', _)), _) when List.lengthsEqAndForall2 typarRefEq generalizedTypars generalizedTypars' -> v, pat @@ -11052,7 +11361,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // Add the bind "let patternInputTmp = rhsExpr" to the bodyExpr we get from mkPatBind let mkRhsBind (bodyExpr, bodyExprTy) = - let letExpr = mkLet spBind m patternInputTmp rhsExpr bodyExpr + let letExpr = mkLet debugPoint m patternInputTmp rhsExpr bodyExpr letExpr, bodyExprTy let allValsDefinedByPattern = NameMap.range prelimRecValues @@ -11060,10 +11369,16 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // Add the compilation of the pattern to the bodyExpr we get from mkCleanup let mkPatBind (bodyExpr, bodyExprTy) = let valsDefinedByMatching = ListSet.remove valEq patternInputTmp allValsDefinedByPattern - let clauses = [TClause(checkedPat2, None, TTarget(valsDefinedByMatching, bodyExpr, None), m)] - let matchx = CompilePatternForMatch cenv env m m true ThrowIncompleteMatchException (patternInputTmp, generalizedTypars, Some rhsExpr) clauses tauTy bodyExprTy - let matchx = if (DeclKind.ConvertToLinearBindings declKind) then LinearizeTopMatch g altActualParent matchx else matchx - matchx, bodyExprTy + let clauses = [MatchClause(checkedPat2, None, TTarget(valsDefinedByMatching, bodyExpr, None), m)] + let matchExpr = CompilePatternForMatch cenv env m m true ThrowIncompleteMatchException (patternInputTmp, generalizedTypars, Some rhsExpr) clauses tauTy bodyExprTy + + let matchExpr = + if DeclKind.ConvertToLinearBindings declKind then + LinearizeTopMatch g altActualParent matchExpr + else + matchExpr + + matchExpr, bodyExprTy // Add the dispose of any "use x = ..." to bodyExpr let mkCleanup (bodyExpr, bodyExprTy) = @@ -11100,19 +11415,19 @@ and TcLetBindings cenv env containerInfo declKind tpenv (binds, bindsm, scopem) let rec stripLets acc expr = match stripDebugPoints expr with | Expr.Let (bind, body, m, _) -> stripLets (TMDefLet(bind, m) :: acc) body - | Expr.Sequential (e1, e2, NormalSeq, m) -> stripLets (TMDefDo(e1, m) :: acc) e2 + | Expr.Sequential (expr1, expr2, NormalSeq, m) -> stripLets (TMDefDo(expr1, m) :: acc) expr2 | Expr.Const (Const.Unit, _, _) -> List.rev acc | _ -> failwith "TcLetBindings: let sequence is non linear. Maybe a LHS pattern was not linearised?" let binds = stripLets [] expr binds, env, tpenv -and CheckMemberFlags optIntfSlotTy newslotsOK overridesOK memberFlags m = +and CheckMemberFlags intfSlotTyOpt newslotsOK overridesOK memberFlags m = if newslotsOK = NoNewSlots && memberFlags.IsDispatchSlot then errorR(Error(FSComp.SR.tcAbstractMembersIllegalInAugmentation(), m)) if overridesOK = ErrorOnOverrides && memberFlags.MemberKind = SynMemberKind.Constructor then errorR(Error(FSComp.SR.tcConstructorsIllegalInAugmentation(), m)) - if overridesOK = WarnOnOverrides && memberFlags.IsOverrideOrExplicitImpl && Option.isNone optIntfSlotTy then + if overridesOK = WarnOnOverrides && memberFlags.IsOverrideOrExplicitImpl && Option.isNone intfSlotTyOpt then warning(OverrideInIntrinsicAugmentation m) if overridesOK = ErrorOnOverrides && memberFlags.IsOverrideOrExplicitImpl then error(Error(FSComp.SR.tcMethodOverridesIllegalHere(), m)) @@ -11121,7 +11436,7 @@ and CheckMemberFlags optIntfSlotTy newslotsOK overridesOK memberFlags m = /// the _body_ of the binding. For example, in a letrec we may assume this knowledge /// for each binding in the letrec prior to any type inference. This might, for example, /// tell us the type of the arguments to a recursive function. -and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, NormalizedBindingRhs (pushedPats, retInfoOpt, e), memberFlagsOpt: SynMemberFlags option) = +and ApplyTypesFromArgumentPatterns (cenv, env, optionalArgsOK, ty, m, tpenv, NormalizedBindingRhs (pushedPats, retInfoOpt, e), memberFlagsOpt: SynMemberFlags option) = let g = cenv.g @@ -11142,8 +11457,8 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty // We apply the type information from the patterns by type checking the // "simple" patterns against 'domainTyR'. They get re-typechecked later. - ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv, Map.empty, Set.empty) pushedPat) - ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, resultTy, m, tpenv, NormalizedBindingRhs (morePushedPats, retInfoOpt, e), memberFlagsOpt) + ignore (TcSimplePats cenv optionalArgsOK CheckCxs domainTy env (tpenv, Map.empty, Set.empty) pushedPat) + ApplyTypesFromArgumentPatterns (cenv, env, optionalArgsOK, resultTy, m, tpenv, NormalizedBindingRhs (morePushedPats, retInfoOpt, e), memberFlagsOpt) /// Check if the type annotations and inferred type information in a value give a /// full and complete generic type for a value. If so, enable generic recursion. @@ -11155,13 +11470,13 @@ and ComputeIsComplete enclosingDeclaredTypars declaredTypars ty = /// Determine if a uniquely-identified-abstract-slot exists for an override member (or interface member implementation) based on the information available /// at the syntactic definition of the member (i.e. prior to type inference). If so, we know the expected signature of the override, and the full slotsig /// it implements. Apply the inferred slotsig. -and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, _objTy, optIntfSlotTy, valSynData, memberFlags: SynMemberFlags, attribs) = +and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, _objTy, intfSlotTyOpt, valSynData, memberFlags: SynMemberFlags, attribs) = let g = cenv.g let ad = envinner.eAccessRights let typToSearchForAbstractMembers = - match optIntfSlotTy with + match intfSlotTyOpt with | Some (ty, abstractSlots) -> // The interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. @@ -11228,7 +11543,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn // This type must be in terms of the enclosing type's formal type parameters, hence the application of revRenaming let optInferredImplSlotTys = - match optIntfSlotTy with + match intfSlotTyOpt with | Some (x, _) -> [x] | None -> uniqueAbstractMethSigs |> List.map (fun x -> x.ApparentEnclosingType) @@ -11236,7 +11551,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn | SynMemberKind.PropertyGet | SynMemberKind.PropertySet as k -> - let dispatchSlots = GetAbstractPropInfosForSynPropertyDecl(cenv.infoReader, ad, memberId, m, typToSearchForAbstractMembers, k, valSynData) + let dispatchSlots = GetAbstractPropInfosForSynPropertyDecl(cenv.infoReader, ad, memberId, m, typToSearchForAbstractMembers) // Only consider those abstract slots where the get/set flags match the value we're defining let dispatchSlots = @@ -11291,14 +11606,14 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn // This type must be in terms of the enclosing type's formal type parameters, hence the application of revRenaming. let optInferredImplSlotTys = - match optIntfSlotTy with + match intfSlotTyOpt with | Some (x, _) -> [ x ] | None -> uniqueAbstractPropSigs |> List.map (fun pinfo -> pinfo.ApparentEnclosingType) optInferredImplSlotTys, declaredTypars | _ -> - match optIntfSlotTy with + match intfSlotTyOpt with | Some (x, _) -> [x], declaredTypars | None -> [], declaredTypars @@ -11349,8 +11664,8 @@ and AnalyzeRecursiveStaticMemberOrValDecl // name for the member and the information about which type it is augmenting match tcrefContainerInfo, memberFlagsOpt with - | Some(MemberOrValContainerInfo(tcref, optIntfSlotTy, baseValOpt, _safeInitInfo, declaredTyconTypars)), Some memberFlags -> - assert (Option.isNone optIntfSlotTy) + | Some(MemberOrValContainerInfo(tcref, intfSlotTyOpt, baseValOpt, _safeInitInfo, declaredTyconTypars)), Some memberFlags -> + assert (Option.isNone intfSlotTyOpt) CheckMemberFlags None newslotsOK overridesOK memberFlags id.idRange CheckForNonAbstractInterface declKind tcref memberFlags id.idRange @@ -11434,9 +11749,9 @@ and AnalyzeRecursiveInstanceMemberDecl let (ExplicitTyparInfo(_, declaredTypars, infer)) = explicitTyparInfo match tcrefContainerInfo, memberFlagsOpt with // Normal instance members. - | Some(MemberOrValContainerInfo(tcref, optIntfSlotTy, baseValOpt, _safeInitInfo, declaredTyconTypars)), Some memberFlags -> + | Some(MemberOrValContainerInfo(tcref, intfSlotTyOpt, baseValOpt, _safeInitInfo, declaredTyconTypars)), Some memberFlags -> - CheckMemberFlags optIntfSlotTy newslotsOK overridesOK memberFlags mBinding + CheckMemberFlags intfSlotTyOpt newslotsOK overridesOK memberFlags mBinding if Option.isSome vis && memberFlags.IsOverrideOrExplicitImpl then errorR(Error(FSComp.SR.tcOverridesCannotHaveVisibilityDeclarations(), memberId.idRange)) @@ -11465,7 +11780,7 @@ and AnalyzeRecursiveInstanceMemberDecl // at the member signature. If so, we know the type of this member, and the full slotsig // it implements. Apply the inferred slotsig. let optInferredImplSlotTys, declaredTypars = - ApplyAbstractSlotInference cenv envinner (bindingTy, mBinding, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, objTy, optIntfSlotTy, valSynInfo, memberFlags, bindingAttribs) + ApplyAbstractSlotInference cenv envinner (bindingTy, mBinding, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, objTy, intfSlotTyOpt, valSynInfo, memberFlags, bindingAttribs) // Update the ExplicitTyparInfo to reflect the declaredTypars inferred from the abstract slot let explicitTyparInfo = ExplicitTyparInfo(declaredTypars, declaredTypars, infer) @@ -11512,8 +11827,8 @@ and AnalyzeRecursiveDecl bindingRhs, mBinding) = - let rec analyzeRecursiveDeclPat tpenv p = - match p with + let rec analyzeRecursiveDeclPat tpenv pat = + match pat with | SynPat.FromParseError(pat', _) -> analyzeRecursiveDeclPat tpenv pat' | SynPat.Typed(pat', cty, _) -> let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType envinner tpenv cty @@ -11573,7 +11888,7 @@ and AnalyzeAndMakeAndPublishRecursiveValue let g = cenv.g // Pull apart the inputs - let (NormalizedBinding(vis1, bindingKind, isInline, isMutable, bindingSynAttribs, bindingXmlDoc, synTyparDecls, valSynData, declPattern, bindingRhs, mBinding, spBind)) = binding + let (NormalizedBinding(vis1, bindingKind, isInline, isMutable, bindingSynAttribs, bindingXmlDoc, synTyparDecls, valSynData, declPattern, bindingRhs, mBinding, debugPoint)) = binding let (NormalizedBindingRhs(_, _, bindingExpr)) = bindingRhs let (SynValData(memberFlagsOpt, valSynInfo, thisIdOpt)) = valSynData let (ContainerInfo(altActualParent, tcrefContainerInfo)) = containerInfo @@ -11602,10 +11917,10 @@ and AnalyzeAndMakeAndPublishRecursiveValue newslotsOK, overridesOK, vis1, declPattern, bindingAttribs, tcrefContainerInfo, memberFlagsOpt, ty, bindingRhs, mBinding) - let optArgsOK = Option.isSome memberFlagsOpt + let optionalArgsOK = Option.isSome memberFlagsOpt // Assert the types given in the argument patterns - ApplyTypesFromArgumentPatterns(cenv, envinner, optArgsOK, ty, mBinding, tpenv, bindingRhs, memberFlagsOpt) + ApplyTypesFromArgumentPatterns(cenv, envinner, optionalArgsOK, ty, mBinding, tpenv, bindingRhs, memberFlagsOpt) // Do the type annotations give the full and complete generic type? // If so, generic recursion can be used when using this type. @@ -11613,11 +11928,11 @@ and AnalyzeAndMakeAndPublishRecursiveValue // NOTE: The type scheme here is normally not 'complete'!!!! The type is more or less just a type variable at this point. // NOTE: top arity, type and typars get fixed-up after inference - let prelimTyscheme = TypeScheme(enclosingDeclaredTypars@declaredTypars, ty) - let partialValReprInfo = TranslateTopValSynInfo mBinding (TcAttributes cenv envinner) valSynInfo - let topValInfo = UseSyntacticArity declKind prelimTyscheme partialValReprInfo + let prelimTyscheme = GeneralizedType(enclosingDeclaredTypars@declaredTypars, ty) + let prelimValReprInfo = TranslateSynValInfo mBinding (TcAttributes cenv envinner) valSynInfo + let valReprInfo = UseSyntacticArity declKind prelimTyscheme prelimValReprInfo let hasDeclaredTypars = not (List.isEmpty declaredTypars) - let prelimValScheme = ValScheme(bindingId, prelimTyscheme, topValInfo, memberInfoOpt, false, inlineFlag, NormalVal, vis, false, false, false, hasDeclaredTypars) + let prelimValScheme = ValScheme(bindingId, prelimTyscheme, valReprInfo, memberInfoOpt, false, inlineFlag, NormalVal, vis, false, false, false, hasDeclaredTypars) // Check the literal r.h.s., if any let _, literalValue = TcLiteral cenv ty envinner tpenv (bindingAttribs, bindingExpr) @@ -11642,7 +11957,7 @@ and AnalyzeAndMakeAndPublishRecursiveValue let mangledId = ident(vspec.LogicalName, vspec.Range) // Reconstitute the binding with the unique name - let revisedBinding = NormalizedBinding (vis1, bindingKind, isInline, isMutable, bindingSynAttribs, bindingXmlDoc, synTyparDecls, valSynData, mkSynPatVar vis2 mangledId, bindingRhs, mBinding, spBind) + let revisedBinding = NormalizedBinding (vis1, bindingKind, isInline, isMutable, bindingSynAttribs, bindingXmlDoc, synTyparDecls, valSynData, mkSynPatVar vis2 mangledId, bindingRhs, mBinding, debugPoint) // Create the RecursiveBindingInfo to use in later phases let rbinfo = @@ -11651,7 +11966,7 @@ and AnalyzeAndMakeAndPublishRecursiveValue | Some(MemberOrValContainerInfo(_, _, _, safeInitInfo, _)) -> safeInitInfo | _ -> NoSafeInitInfo - RecursiveBindingInfo(recBindIdx, containerInfo, enclosingDeclaredTypars, inlineFlag, vspec, explicitTyparInfo, partialValReprInfo, memberInfoOpt, baseValOpt, safeThisValOpt, safeInitInfo, vis, ty, declKind) + RecursiveBindingInfo(recBindIdx, containerInfo, enclosingDeclaredTypars, inlineFlag, vspec, explicitTyparInfo, prelimValReprInfo, memberInfoOpt, baseValOpt, safeThisValOpt, safeInitInfo, vis, ty, declKind) let recBindIdx = recBindIdx + 1 @@ -11983,25 +12298,24 @@ and TcLetrecComputeSupportForBinding cenv (pgrbind: PreGeneralizationRecursiveBi and TcLetrecGeneralizeBinding cenv denv generalizedTypars (pgrbind: PreGeneralizationRecursiveBinding) : PostGeneralizationRecursiveBinding = let g = cenv.g - let (RecursiveBindingInfo(_, _, enclosingDeclaredTypars, _, vspec, explicitTyparInfo, partialValReprInfo, memberInfoOpt, _, _, _, vis, _, declKind)) = pgrbind.RecBindingInfo - let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, argAttribs, _, _, _, compgen, _, isFixed)) = pgrbind.CheckedBinding + let (RecursiveBindingInfo(_, _, enclosingDeclaredTypars, _, vspec, explicitTyparInfo, prelimValReprInfo, memberInfoOpt, _, _, _, vis, _, declKind)) = pgrbind.RecBindingInfo + let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, argAttribs, _, _, _, isCompGen, _, isFixed)) = pgrbind.CheckedBinding if isFixed then errorR(Error(FSComp.SR.tcFixedNotAllowed(), expr.Range)) - let _, tau = vspec.TypeScheme + let _, tau = vspec.GeneralizedType - let pvalscheme1 = PrelimValScheme1(vspec.Id, explicitTyparInfo, tau, Some partialValReprInfo, memberInfoOpt, false, inlineFlag, NormalVal, argAttribs, vis, compgen) - let pvalscheme2 = GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars pvalscheme1 + let prelimVal1 = PrelimVal1(vspec.Id, explicitTyparInfo, tau, Some prelimValReprInfo, memberInfoOpt, false, inlineFlag, NormalVal, argAttribs, vis, isCompGen) + let prelimVal2 = GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars prelimVal1 - let valscheme = UseCombinedArity g declKind expr pvalscheme2 + let valscheme = UseCombinedArity g declKind expr prelimVal2 AdjustRecType vspec valscheme { ValScheme = valscheme CheckedBinding = pgrbind.CheckedBinding RecBindingInfo = pgrbind.RecBindingInfo } - and TcLetrecComputeCtorSafeThisValBind cenv safeThisValOpt = let g = cenv.g match safeThisValOpt with @@ -12049,8 +12363,9 @@ and TcLetrecAdjustMemberForSpecialVals cenv (pgrbind: PostGeneralizationRecursiv let g = cenv.g let (RecursiveBindingInfo(_, _, _, _, vspec, _, _, _, baseValOpt, safeThisValOpt, safeInitInfo, _, _, _)) = pgrbind.RecBindingInfo let expr = pgrbind.CheckedBinding.Expr - let spBind = pgrbind.CheckedBinding.DebugPoint + let debugPoint = pgrbind.CheckedBinding.DebugPoint + // Add the safe-init check for access to 'this' to the member if necessary let expr = match TcLetrecComputeCtorSafeThisValBind cenv safeThisValOpt with | None -> expr @@ -12077,6 +12392,7 @@ and TcLetrecAdjustMemberForSpecialVals cenv (pgrbind: PostGeneralizationRecursiv else expr + // Add the base value to the lambda if necessary let expr = match baseValOpt with | None -> expr @@ -12086,11 +12402,11 @@ and TcLetrecAdjustMemberForSpecialVals cenv (pgrbind: PostGeneralizationRecursiv mkMemberLambdas g m tps None baseValOpt vsl (body, returnTy) { ValScheme = pgrbind.ValScheme - Binding = TBind(vspec, expr, spBind) } + Binding = TBind(vspec, expr, debugPoint) } and FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock (bind: PostSpecialValsRecursiveBinding) = let g = cenv.g - let (TBind(vspec, expr, spBind)) = bind.Binding + let (TBind(vspec, expr, debugPoint)) = bind.Binding // Check coherence of generalization of variables for memberInfo members in generic classes match vspec.MemberInfo with @@ -12111,10 +12427,12 @@ and FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock (bind: PostSpec AdjustAndForgetUsesOfRecValue cenv (mkLocalValRef vspec) bind.ValScheme - let expr = mkGenericBindRhs g vspec.Range generalizedTyparsForRecursiveBlock bind.ValScheme.TypeScheme expr + let expr = mkGenericBindRhs g vspec.Range generalizedTyparsForRecursiveBlock bind.ValScheme.GeneralizedType expr + + let finalBinding = TBind(vspec, expr, debugPoint) { FixupPoints = fixupPoints - Binding = TBind(vspec, expr, spBind) } + Binding = finalBinding } //------------------------------------------------------------------------- // TcLetrecBindings - for both expressions and class-let-rec-declarations @@ -12127,8 +12445,9 @@ and TcLetrecBindings overridesOK cenv env tpenv (binds, bindsm, scopem) = let g = cenv.g // Create prelimRecValues for the recursive items (includes type info from LHS of bindings) *) - let binds = binds |> List.map (fun (RecDefnBindingInfo(a, b, c, bind)) -> NormalizedRecBindingDefn(a, b, c, BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env bind)) - let uncheckedRecBinds, prelimRecValues, (tpenv, _) = AnalyzeAndMakeAndPublishRecursiveValues overridesOK cenv env tpenv binds + let normalizedBinds = binds |> List.map (fun (RecDefnBindingInfo(a, b, c, bind)) -> NormalizedRecBindingDefn(a, b, c, BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env bind)) + + let uncheckedRecBinds, prelimRecValues, (tpenv, _) = AnalyzeAndMakeAndPublishRecursiveValues overridesOK cenv env tpenv normalizedBinds let envRec = AddLocalVals g cenv.tcSink scopem prelimRecValues env @@ -12149,7 +12468,6 @@ and TcLetrecBindings overridesOK cenv env tpenv (binds, bindsm, scopem) = |> List.map (fun pgrbind -> pgrbind.GeneralizedTypars) |> unionGeneralizedTypars - let vxbinds = generalizedRecBinds |> List.map (TcLetrecAdjustMemberForSpecialVals cenv) // Now that we know what we've generalized we can adjust the recursive references @@ -12182,13 +12500,15 @@ and TcLetrecBindings overridesOK cenv env tpenv (binds, bindsm, scopem) = // Bind specifications of values //------------------------------------------------------------------------- -let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memFlagsOpt, tpenv, valSpfn) = +let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memFlagsOpt, tpenv, synValSig) = let g = cenv.g - let (SynValSig (attributes=Attributes synAttrs; explicitValDecls=ValTyparDecls (synTypars, _, synCanInferTypars); isInline=isInline; isMutable=mutableFlag; xmlDoc=doc; accessibility=vis; synExpr=literalExprOpt; range=m)) = valSpfn + let (SynValSig (attributes=Attributes synAttrs; explicitTypeParams=explicitTypeParams; isInline=isInline; isMutable=mutableFlag; xmlDoc=xmlDoc; accessibility=vis; synExpr=literalExprOpt; range=m)) = synValSig + let (ValTyparDecls (synTypars, _, synCanInferTypars)) = explicitTypeParams GeneralizationHelpers.CheckDeclaredTyparsPermitted(memFlagsOpt, synTypars, m) + let canInferTypars = GeneralizationHelpers.ComputeCanInferExtraGeneralizableTypars (containerInfo.ParentRef, synCanInferTypars, memFlagsOpt) let attrTgt = DeclKind.AllowedAttribTargets memFlagsOpt declKind @@ -12196,14 +12516,14 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let attrs = TcAttributes cenv env attrTgt synAttrs let newOk = if canInferTypars then NewTyparsOK else NoNewTypars - let valinfos, tpenv = TcValSpec cenv env declKind newOk containerInfo memFlagsOpt None tpenv valSpfn attrs + let valinfos, tpenv = TcValSpec cenv env declKind newOk containerInfo memFlagsOpt None tpenv synValSig attrs let denv = env.DisplayEnv (tpenv, valinfos) ||> List.mapFold (fun tpenv valSpecResult -> - let (ValSpecResult (altActualParent, memberInfoOpt, id, enclosingDeclaredTypars, declaredTypars, ty, partialValReprInfo, declKind)) = valSpecResult + let (ValSpecResult (altActualParent, memberInfoOpt, id, enclosingDeclaredTypars, declaredTypars, ty, prelimValReprInfo, declKind)) = valSpecResult - let inlineFlag = ComputeInlineFlag (memberInfoOpt |> Option.map (fun (PreValMemberInfo(memberInfo, _, _)) -> memberInfo.MemberFlags)) isInline mutableFlag m + let inlineFlag = ComputeInlineFlag (memberInfoOpt |> Option.map (fun (PrelimMemberInfo(memberInfo, _, _)) -> memberInfo.MemberFlags)) isInline mutableFlag m let freeInType = freeInTypeLeftToRight g false ty @@ -12216,13 +12536,13 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars, freeInType, ty, false) - let valscheme1 = PrelimValScheme1(id, explicitTyparInfo, ty, Some partialValReprInfo, memberInfoOpt, mutableFlag, inlineFlag, NormalVal, noArgOrRetAttribs, vis, false) + let valscheme1 = PrelimVal1(id, explicitTyparInfo, ty, Some prelimValReprInfo, memberInfoOpt, mutableFlag, inlineFlag, NormalVal, noArgOrRetAttribs, vis, false) let valscheme2 = GeneralizeVal cenv denv enclosingDeclaredTypars generalizedTypars valscheme1 let tpenv = HideUnscopedTypars generalizedTypars tpenv - let valscheme = BuildValScheme declKind (Some partialValReprInfo) valscheme2 + let valscheme = BuildValScheme declKind (Some prelimValReprInfo) valscheme2 let literalValue = match literalExprOpt with @@ -12241,10 +12561,10 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let paramNames = match valscheme.ValReprInfo with | None -> None - | Some topValInfo -> Some topValInfo.ArgNames + | Some valReprInfo -> Some valReprInfo.ArgNames - let doc = doc.ToXmlDoc(true, paramNames) - let vspec = MakeAndPublishVal cenv env (altActualParent, true, declKind, ValNotInRecScope, valscheme, attrs, doc, literalValue, false) + let xmlDoc = xmlDoc.ToXmlDoc(true, paramNames) + let vspec = MakeAndPublishVal cenv env (altActualParent, true, declKind, ValNotInRecScope, valscheme, attrs, xmlDoc, literalValue, false) assert(vspec.InlineInfo = inlineFlag) diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index d2513565511..2a4c44c1d5f 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -249,7 +249,7 @@ type TcFileState = /// Holds a reference to the component being compiled. /// This field is very rarely used (mainly when fixing up forward references to fslib. - topCcu: CcuThunk + thisCcu: CcuThunk /// Holds the current inference constraints css: ConstraintSolverState @@ -310,7 +310,7 @@ type TcFileState = isScript: bool * niceNameGen: NiceNameGenerator * amap: ImportMap * - topCcu: CcuThunk * + thisCcu: CcuThunk * isSig: bool * haveSig: bool * conditionalDefines: string list option * @@ -326,7 +326,7 @@ type TcFileState = type MemberOrValContainerInfo = | MemberOrValContainerInfo of tcref: TyconRef * - optIntfSlotTy: (TType * SlotImplSet) option * + intfSlotTyOpt: (TType * SlotImplSet) option * baseValOpt: Val option * safeInitInfo: SafeInitData * declaredTyconTypars: Typars @@ -415,21 +415,21 @@ type RecDefnBindingInfo = synBinding: SynBinding /// Represents the ValReprInfo for a value, before the typars are fully inferred -type PartialValReprInfo = PartialValReprInfo of curriedArgInfos: ArgReprInfo list list * returnInfo: ArgReprInfo +type PrelimValReprInfo = PrelimValReprInfo of curriedArgInfos: ArgReprInfo list list * returnInfo: ArgReprInfo /// Holds the initial ValMemberInfo and other information before it is fully completed -type PreValMemberInfo = PreValMemberInfo of memberInfo: ValMemberInfo * logicalName: string * compiledName: string +type PrelimMemberInfo = PrelimMemberInfo of memberInfo: ValMemberInfo * logicalName: string * compiledName: string /// The result of checking a value or member signature type ValSpecResult = | ValSpecResult of altActualParent: ParentRef * - memberInfoOpt: PreValMemberInfo option * + memberInfoOpt: PrelimMemberInfo option * id: Ident * enclosingDeclaredTypars: Typars * declaredTypars: Typars * ty: TType * - partialValReprInfo: PartialValReprInfo * + prelimValReprInfo: PrelimValReprInfo * declKind: DeclKind /// An empty environment of type variables with implicit scope @@ -475,8 +475,8 @@ type RecursiveBindingInfo = inlineFlag: ValInline * vspec: Val * explicitTyparInfo: ExplicitTyparInfo * - partialValReprInfo: PartialValReprInfo * - memberInfoOpt: PreValMemberInfo option * + prelimValReprInfo: PrelimValReprInfo * + memberInfoOpt: PrelimMemberInfo option * baseValOpt: Val option * safeThisValOpt: Val option * safeInitInfo: SafeInitData * @@ -490,7 +490,7 @@ type RecursiveBindingInfo = /// Represents the results of the first phase of preparing simple values from a pattern [] -type PrelimValScheme1 = +type PrelimVal1 = member Ident: Ident member Type: TType @@ -502,14 +502,14 @@ type CheckedBindingInfo type ValScheme = | ValScheme of id: Ident * - typeScheme: TypeScheme * - topValInfo: ValReprInfo option * - memberInfo: PreValMemberInfo option * + typeScheme: GeneralizedType * + valReprInfo: ValReprInfo option * + memberInfo: PrelimMemberInfo option * isMutable: bool * inlineInfo: ValInline * baseOrThisInfo: ValBaseOrThisInfo * visibility: SynAccess option * - compgen: bool * + isCompGen: bool * isIncrClass: bool * isTyFunc: bool * hasDeclaredTypars: bool @@ -597,7 +597,7 @@ val CheckForNonAbstractInterface: /// Check the flags on a member definition for consistency val CheckMemberFlags: - optIntfSlotTy: 'a option -> + intfSlotTyOpt: 'a option -> newslotsOK: NewSlotsOK -> overridesOK: OverridesOK -> memberFlags: SynMemberFlags -> @@ -644,13 +644,13 @@ val CompilePatternForMatchClauses: cenv: TcFileState -> env: TcEnv -> mExpr: range -> - matchm: range -> + mMatch: range -> warnOnUnused: bool -> actionOnFailure: ActionOnFailure -> inputExprOpt: Expr option -> inputTy: TType -> resultTy: TType -> - tclauses: TypedMatchClause list -> + tclauses: MatchClause list -> Val * Expr /// Process recursive bindings so that initialization is through laziness and is checked. @@ -684,7 +684,7 @@ val FreshenObjectArgType: tcref: TyconRef -> isExtrinsic: bool -> declaredTyconTypars: Typar list -> - TType * Typar list * TyparInst * TType * TType + TType * Typar list * TyparInstantiation * TType * TType /// Get the accumulated module/namespace type for the current module/namespace being processed. val GetCurrAccumulatedModuleOrNamespaceType: env: TcEnv -> ModuleOrNamespaceType @@ -693,7 +693,7 @@ val GetCurrAccumulatedModuleOrNamespaceType: env: TcEnv -> ModuleOrNamespaceType val GetInstanceMemberThisVariable: vspec: Val * expr: Expr -> Val option /// Build the full ValReprInfo one type inference is complete. -val InferGenericArityFromTyScheme: TypeScheme -> partialValReprInfo: PartialValReprInfo -> ValReprInfo +val InferGenericArityFromTyScheme: GeneralizedType -> prelimValReprInfo: PrelimValReprInfo -> ValReprInfo /// Locate the environment within a particular namespace path, used to process a /// 'namespace' declaration. @@ -710,10 +710,10 @@ val MakeAndPublishVal: altActualParent: ParentRef * inSig: bool * declKind: DeclKind * - vrec: ValRecursiveScopeInfo * + valRecInfo: ValRecursiveScopeInfo * vscheme: ValScheme * attrs: Attribs * - doc: XmlDoc * + xmlDoc: XmlDoc * konst: Const option * isGeneratedEventVal: bool -> Val @@ -723,7 +723,7 @@ val MakeAndPublishBaseVal: cenv: TcFileState -> env: TcEnv -> Ident option -> TT /// Make simple values (which are not recursive nor members) val MakeAndPublishSimpleVals: - cenv: TcFileState -> env: TcEnv -> names: NameMap -> NameMap * NameMap + cenv: TcFileState -> env: TcEnv -> names: NameMap -> NameMap * NameMap /// Make an initial implicit safe initialization value val MakeAndPublishSafeThisVal: cenv: TcFileState -> env: TcEnv -> thisIdOpt: Ident option -> thisTy: TType -> Val option @@ -734,12 +734,12 @@ val MakeMemberDataAndMangledNameForMemberVal: tcref: TyconRef * isExtrinsic: bool * attrs: Attribs * - optImplSlotTys: TType list * + implSlotTys: TType list * memberFlags: SynMemberFlags * valSynData: SynValInfo * id: Ident * isCompGen: bool -> - PreValMemberInfo + PrelimMemberInfo /// Return a new environment suitable for processing declarations in the interior of a type definition val MakeInnerEnvForTyconRef: env: TcEnv -> tcref: TyconRef -> isExtrinsicExtension: bool -> TcEnv @@ -750,7 +750,7 @@ val MakeInnerEnv: addOpenToNameEnv: bool -> env: TcEnv -> nm: Ident -> - modKind: ModuleOrNamespaceKind -> + moduleKind: ModuleOrNamespaceKind -> TcEnv * ModuleOrNamespaceType ref /// Return a new environment suitable for processing declarations in the interior of a module definition @@ -759,13 +759,13 @@ val MakeInnerEnvWithAcc: addOpenToNameEnv: bool -> env: TcEnv -> nm: Ident -> - mtypeAcc: ModuleOrNamespaceType ref -> - modKind: ModuleOrNamespaceKind -> + moduleTyAcc: ModuleOrNamespaceType ref -> + moduleKind: ModuleOrNamespaceKind -> TcEnv /// Produce a post-generalization type scheme for a simple type where no type inference generalization /// is appplied. -val NonGenericTypeScheme: ty: TType -> TypeScheme +val NonGenericTypeScheme: ty: TType -> GeneralizedType /// Publish a module definition to the module/namespace type accumulator. val PublishModuleDefn: cenv: TcFileState -> env: TcEnv -> mspec: ModuleOrNamespace -> unit @@ -789,7 +789,7 @@ val TcAndPublishValSpec: declKind: DeclKind * memFlagsOpt: SynMemberFlags option * tpenv: UnscopedTyparEnv * - valSpfn: SynValSig -> + synValSig: SynValSig -> Val list * UnscopedTyparEnv /// Check a set of attributes @@ -816,7 +816,7 @@ val TcAttributesWithPossibleTargets: (AttributeTargets * Attrib) list * bool /// Check a constant value, e.g. a literal -val TcConst: cenv: TcFileState -> overallTy: TType -> m: range -> env: TcEnv -> c: SynConst -> Const +val TcConst: cenv: TcFileState -> overallTy: TType -> m: range -> env: TcEnv -> synConst: SynConst -> Const /// Check a syntactic expression and convert it to a typed tree expression val TcExpr: @@ -824,16 +824,16 @@ val TcExpr: ty: OverallTy -> env: TcEnv -> tpenv: UnscopedTyparEnv -> - expr: SynExpr -> + synExpr: SynExpr -> Expr * UnscopedTyparEnv /// Converts 'a..b' to a call to the '(..)' operator in FSharp.Core /// Converts 'a..b..c' to a call to the '(.. ..)' operator in FSharp.Core -val RewriteRangeExpr: expr: SynExpr -> SynExpr option +val RewriteRangeExpr: synExpr: SynExpr -> SynExpr option /// Check a syntactic expression and convert it to a typed tree expression val TcExprOfUnknownType: - cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> expr: SynExpr -> Expr * TType * UnscopedTyparEnv + cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> synExpr: SynExpr -> Expr * TType * UnscopedTyparEnv /// Check a syntactic expression and convert it to a typed tree expression. Possibly allow for subsumption flexibility /// and insert a coercion if necessary. @@ -861,7 +861,7 @@ val TcPropagatingExprLeafThenConvert: /// Check a syntactic statement and convert it to a typed tree expression. val TcStmtThatCantBeCtorBody: - cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> expr: SynExpr -> Expr * UnscopedTyparEnv + cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> synExpr: SynExpr -> Expr * UnscopedTyparEnv /// Check a syntactic expression and convert it to a typed tree expression val TcExprUndelayed: @@ -882,7 +882,7 @@ val TcLinearExprs: overallTy: OverallTy -> tpenv: UnscopedTyparEnv -> isCompExpr: bool -> - expr: SynExpr -> + synExpr: SynExpr -> cont: (Expr * UnscopedTyparEnv -> Expr * UnscopedTyparEnv) -> Expr * UnscopedTyparEnv @@ -896,7 +896,8 @@ val TcMatchPattern: inputTy: TType -> env: TcEnv -> tpenv: UnscopedTyparEnv -> - pat: SynPat * optWhenExpr: SynExpr option -> + synPat: SynPat -> + synWhenExprOpt: SynExpr option -> Pattern * Expr option * Val list * TcEnv * UnscopedTyparEnv val (|BinOpExpr|_|): SynExpr -> (Ident * SynExpr * SynExpr) option @@ -963,7 +964,7 @@ val TcNewExpr: val TcProvidedTypeAppToStaticConstantArgs: cenv: TcFileState -> env: TcEnv -> - optGeneratedTypePath: string list option -> + generatedTypePathOpt: string list option -> tpenv: UnscopedTyparEnv -> tcref: TyconRef -> args: SynType list -> @@ -974,18 +975,18 @@ val TcProvidedTypeAppToStaticConstantArgs: /// Check a set of simple patterns, e.g. the declarations of parameters for an implicit constructor. val TcSimplePatsOfUnknownType: cenv: TcFileState -> - optArgsOK: bool -> - checkCxs: CheckConstraints -> + optionalArgsOK: bool -> + checkConstraints: CheckConstraints -> env: TcEnv -> tpenv: UnscopedTyparEnv -> - spats: SynSimplePats -> - string list * (UnscopedTyparEnv * NameMap * Set) + synSimplePats: SynSimplePats -> + string list * (UnscopedTyparEnv * NameMap * Set) /// Check a set of explicitly declared constraints on type parameters val TcTyparConstraints: cenv: TcFileState -> newOk: ImplicitlyBoundTyparsAllowed -> - checkCxs: CheckConstraints -> + checkConstraints: CheckConstraints -> occ: ItemOccurence -> env: TcEnv -> tpenv: UnscopedTyparEnv -> @@ -999,7 +1000,7 @@ val TcTyparDecls: cenv: TcFileState -> env: TcEnv -> synTypars: SynTyparDecl lis val TcType: cenv: TcFileState -> newOk: ImplicitlyBoundTyparsAllowed -> - checkCxs: CheckConstraints -> + checkConstraints: CheckConstraints -> occ: ItemOccurence -> env: TcEnv -> tpenv: UnscopedTyparEnv -> @@ -1008,10 +1009,10 @@ val TcType: /// Check a syntactic type or unit of measure val TcTypeOrMeasureAndRecover: - optKind: TyparKind option -> + kindOpt: TyparKind option -> cenv: TcFileState -> newOk: ImplicitlyBoundTyparsAllowed -> - checkCxs: CheckConstraints -> + checkConstraints: CheckConstraints -> occ: ItemOccurence -> env: TcEnv -> tpenv: UnscopedTyparEnv -> @@ -1022,7 +1023,7 @@ val TcTypeOrMeasureAndRecover: val TcTypeAndRecover: cenv: TcFileState -> newOk: ImplicitlyBoundTyparsAllowed -> - checkCxs: CheckConstraints -> + checkConstraints: CheckConstraints -> occ: ItemOccurence -> env: TcEnv -> tpenv: UnscopedTyparEnv -> @@ -1032,13 +1033,13 @@ val TcTypeAndRecover: /// Check a specification of a value or member in a signature or an abstract member val TcValSpec: cenv: TcFileState -> - TcEnv -> - DeclKind -> - ImplicitlyBoundTyparsAllowed -> - ContainerInfo -> - SynMemberFlags option -> + env: TcEnv -> + declKind: DeclKind -> + newOk: ImplicitlyBoundTyparsAllowed -> + containerInfo: ContainerInfo -> + memFlagsOpt: SynMemberFlags option -> thisTyOpt: TType option -> - UnscopedTyparEnv -> + tpenv: UnscopedTyparEnv -> SynValSig -> Attrib list -> ValSpecResult list * UnscopedTyparEnv @@ -1046,15 +1047,15 @@ val TcValSpec: /// Given the declaration of a function or member, process it to produce the ValReprInfo /// giving the names and attributes relevant to arguments and return, but before type /// parameters have been fully inferred via generalization. -val TranslateTopValSynInfo: +val TranslateSynValInfo: range -> tcAttributes: (AttributeTargets -> SynAttribute list -> Attrib list) -> synValInfo: SynValInfo -> - PartialValReprInfo + PrelimValReprInfo /// Given the declaration of a function or member, complete the processing of its ValReprInfo /// once type parameters have been fully inferred via generalization. -val TranslatePartialArity: tps: Typar list -> PartialValReprInfo -> ValReprInfo +val TranslatePartialValReprInfo: tps: Typar list -> PrelimValReprInfo -> ValReprInfo /// Constrain two types to be equal within this type checking context val UnifyTypes: cenv: TcFileState -> env: TcEnv -> m: range -> actualTy: TType -> expectedTy: TType -> unit diff --git a/src/Compiler/Checking/CheckFormatStrings.fs b/src/Compiler/Checking/CheckFormatStrings.fs index 5d24e1050d9..fb4b4cec03a 100644 --- a/src/Compiler/Checking/CheckFormatStrings.fs +++ b/src/Compiler/Checking/CheckFormatStrings.fs @@ -48,7 +48,16 @@ let newInfo () = addZeros = false precision = false} -let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) isInterpolated isFormattableString (context: FormatStringCheckContext option) fmt printerArgTy printerResidueTy = +let parseFormatStringInternal + (m: range) + (fragRanges: range list) + (g: TcGlobals) + isInterpolated + isFormattableString + (context: FormatStringCheckContext option) + fmt + printerArgTy + printerResidueTy = // As background: the F# compiler tokenizes strings on the assumption that the only thing you need from // them is the actual corresponding text, e.g. of a string literal. This means many different textual input strings @@ -200,7 +209,7 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) if acc |> List.forall (fun (p, _) -> p = None) then // without positional specifiers acc |> List.map snd |> List.rev else - failwithf "%s" <| FSComp.SR.forPositionalSpecifiersNotPermitted() + failwith (FSComp.SR.forPositionalSpecifiersNotPermitted()) argTys elif System.Char.IsSurrogatePair(fmt,i) then appendToDotnetFormatString fmt[i..i+1] @@ -212,65 +221,65 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) let startFragCol = fragCol let fragCol = fragCol+1 let i = i+1 - if i >= len then failwithf "%s" <| FSComp.SR.forMissingFormatSpecifier() + if i >= len then failwith (FSComp.SR.forMissingFormatSpecifier()) let info = newInfo() let rec flags i = - if i >= len then failwithf "%s" <| FSComp.SR.forMissingFormatSpecifier() + if i >= len then failwith (FSComp.SR.forMissingFormatSpecifier()) match fmt[i] with | '-' -> - if info.leftJustify then failwithf "%s" <| FSComp.SR.forFlagSetTwice("-") + if info.leftJustify then failwith (FSComp.SR.forFlagSetTwice("-")) info.leftJustify <- true flags(i+1) | '+' -> - if info.numPrefixIfPos <> None then failwithf "%s" <| FSComp.SR.forPrefixFlagSpacePlusSetTwice() + if info.numPrefixIfPos <> None then failwith (FSComp.SR.forPrefixFlagSpacePlusSetTwice()) info.numPrefixIfPos <- Some '+' flags(i+1) | '0' -> - if info.addZeros then failwithf "%s" <| FSComp.SR.forFlagSetTwice("0") + if info.addZeros then failwith (FSComp.SR.forFlagSetTwice("0")) info.addZeros <- true flags(i+1) | ' ' -> - if info.numPrefixIfPos <> None then failwithf "%s" <| FSComp.SR.forPrefixFlagSpacePlusSetTwice() + if info.numPrefixIfPos <> None then failwith (FSComp.SR.forPrefixFlagSpacePlusSetTwice()) info.numPrefixIfPos <- Some ' ' flags(i+1) - | '#' -> failwithf "%s" <| FSComp.SR.forHashSpecifierIsInvalid() + | '#' -> failwith (FSComp.SR.forHashSpecifierIsInvalid()) | _ -> i let rec digitsPrecision i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) match fmt[i] with | c when System.Char.IsDigit c -> digitsPrecision (i+1) | _ -> i let precision i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadWidth() + if i >= len then failwith (FSComp.SR.forBadWidth()) match fmt[i] with | c when System.Char.IsDigit c -> info.precision <- true; false,digitsPrecision (i+1) | '*' -> info.precision <- true; true,(i+1) - | _ -> failwithf "%s" <| FSComp.SR.forPrecisionMissingAfterDot() + | _ -> failwith (FSComp.SR.forPrecisionMissingAfterDot()) let optionalDotAndPrecision i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) match fmt[i] with | '.' -> precision (i+1) | _ -> false,i let rec digitsWidthAndPrecision n i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) match fmt[i] with | c when System.Char.IsDigit c -> digitsWidthAndPrecision (n*10 + int c - int '0') (i+1) | _ -> Some n, optionalDotAndPrecision i let widthAndPrecision i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) match fmt[i] with | c when System.Char.IsDigit c -> false,digitsWidthAndPrecision 0 i | '*' -> true, (None, optionalDotAndPrecision (i+1)) | _ -> false, (None, optionalDotAndPrecision i) let rec digitsPosition n i = - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) match fmt[i] with | c when System.Char.IsDigit c -> digitsPosition (n*10 + int c - int '0') (i+1) | '$' -> Some n, i+1 @@ -295,21 +304,21 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) let widthArg,(widthValue, (precisionArg,i)) = widthAndPrecision i let fragCol = fragCol + i - oldI - if i >= len then failwithf "%s" <| FSComp.SR.forBadPrecision() + if i >= len then failwith (FSComp.SR.forBadPrecision()) let acc = if precisionArg then (Option.map ((+)1) posi, g.int_ty) :: acc else acc let acc = if widthArg then (Option.map ((+)1) posi, g.int_ty) :: acc else acc let checkNoPrecision c = - if info.precision then failwithf "%s" <| FSComp.SR.forFormatDoesntSupportPrecision(c.ToString()) + if info.precision then failwith (FSComp.SR.forFormatDoesntSupportPrecision(c.ToString())) let checkNoZeroFlag c = - if info.addZeros then failwithf "%s" <| FSComp.SR.forDoesNotSupportZeroFlag(c.ToString()) + if info.addZeros then failwith (FSComp.SR.forDoesNotSupportZeroFlag(c.ToString())) let checkNoNumericPrefix c = match info.numPrefixIfPos with - | Some n -> failwithf "%s" <| FSComp.SR.forDoesNotSupportPrefixFlag(c.ToString(), n.ToString()) + | Some n -> failwith (FSComp.SR.forDoesNotSupportPrefixFlag(c.ToString(), n.ToString())) | None -> () let checkOtherFlags c = @@ -324,12 +333,12 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) let i = i + 2 if i+1 < len && fmt[i] = '(' && fmt[i+1] = ')' then if isFormattableString then - failwithf "%s" <| FSComp.SR.forFormatInvalidForInterpolated4() + failwith (FSComp.SR.forFormatInvalidForInterpolated4()) i + 2 else - failwithf "%s" <| FSComp.SR.forFormatInvalidForInterpolated2() + failwith (FSComp.SR.forFormatInvalidForInterpolated2()) else - failwithf "%s" <| FSComp.SR.forFormatInvalidForInterpolated() + failwith (FSComp.SR.forFormatInvalidForInterpolated()) else i // Implicitly typed holes in interpolated strings are translated to '... %P(...)...' in the @@ -338,7 +347,7 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) if i < len && fmt[i] = '(' then let i2 = fmt.IndexOf(")", i+1) if i2 = -1 then - failwithf "%s" <| FSComp.SR.forFormatInvalidForInterpolated3() + failwith (FSComp.SR.forFormatInvalidForInterpolated3()) else let dotnetAlignment = match widthValue with None -> "" | Some w -> "," + (if info.leftJustify then "-" else "") + string w let dotnetNumberFormat = match fmt[i+1..i2-1] with "" -> "" | s -> ":" + s @@ -346,7 +355,7 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) dotnetFormatStringInterpolationHoleCount <- dotnetFormatStringInterpolationHoleCount + 1 i2+1 else - failwithf "%s" <| FSComp.SR.forFormatInvalidForInterpolated3() + failwith (FSComp.SR.forFormatInvalidForInterpolated3()) let collectSpecifierLocation fragLine fragCol numStdArgs = match context with @@ -368,30 +377,30 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) | 'd' | 'i' | 'u' | 'B' | 'o' | 'x' | 'X' -> if ch = 'B' then DiagnosticsLogger.checkLanguageFeatureError g.langVersion Features.LanguageFeature.PrintfBinaryFormat m - if info.precision then failwithf "%s" <| FSComp.SR.forFormatDoesntSupportPrecision(ch.ToString()) + if info.precision then failwith (FSComp.SR.forFormatDoesntSupportPrecision(ch.ToString())) collectSpecifierLocation fragLine fragCol 1 let i = skipPossibleInterpolationHole (i+1) parseLoop ((posi, mkFlexibleIntFormatTypar g m) :: acc) (i, fragLine, fragCol+1) fragments | 'l' | 'L' -> - if info.precision then failwithf "%s" <| FSComp.SR.forFormatDoesntSupportPrecision(ch.ToString()) + if info.precision then failwith (FSComp.SR.forFormatDoesntSupportPrecision(ch.ToString())) let fragCol = fragCol+1 let i = i+1 // "bad format specifier ... In F# code you can use %d, %x, %o or %u instead ..." if i >= len then - raise (Failure (FSComp.SR.forBadFormatSpecifier())) + failwith (FSComp.SR.forBadFormatSpecifier()) // Always error for %l and %Lx - failwithf "%s" <| FSComp.SR.forLIsUnnecessary() + failwith (FSComp.SR.forLIsUnnecessary()) match fmt[i] with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> collectSpecifierLocation fragLine fragCol 1 let i = skipPossibleInterpolationHole (i+1) parseLoop ((posi, mkFlexibleIntFormatTypar g m) :: acc) (i, fragLine, fragCol+1) fragments - | _ -> failwithf "%s" <| FSComp.SR.forBadFormatSpecifier() + | _ -> failwith (FSComp.SR.forBadFormatSpecifier()) | 'h' | 'H' -> - failwithf "%s" <| FSComp.SR.forHIsUnnecessary() + failwith (FSComp.SR.forHIsUnnecessary()) | 'M' -> collectSpecifierLocation fragLine fragCol 1 @@ -443,7 +452,8 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) let xty = NewInferenceType g percentATys.Add(xty) parseLoop ((posi, xty) :: acc) (i, fragLine, fragCol+1) fragments - | Some n -> failwithf "%s" <| FSComp.SR.forDoesNotSupportPrefixFlag(ch.ToString(), n.ToString()) + | Some n -> + failwith (FSComp.SR.forDoesNotSupportPrefixFlag(ch.ToString(), n.ToString())) | 'a' -> checkOtherFlags ch @@ -459,7 +469,7 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) let i = skipPossibleInterpolationHole (i+1) parseLoop ((posi, mkFunTy g printerArgTy printerResidueTy) :: acc) (i, fragLine, fragCol+1) fragments - | c -> failwithf "%s" <| FSComp.SR.forBadFormatSpecifierGeneral(String.make 1 c) + | c -> failwith (FSComp.SR.forBadFormatSpecifierGeneral(String.make 1 c)) | '\n' -> appendToDotnetFormatString fmt[i..i] @@ -472,7 +482,8 @@ let parseFormatStringInternal (m: range) (fragRanges: range list) (g: TcGlobals) results, Seq.toList specifierLocations, dotnetFormatString.ToString(), percentATys.ToArray() let ParseFormatString m fragmentRanges g isInterpolated isFormattableString formatStringCheckContext fmt printerArgTy printerResidueTy printerResultTy = - let argTys, specifierLocations, dotnetFormatString, percentATys = parseFormatStringInternal m fragmentRanges g isInterpolated isFormattableString formatStringCheckContext fmt printerArgTy printerResidueTy + let argTys, specifierLocations, dotnetFormatString, percentATys = + parseFormatStringInternal m fragmentRanges g isInterpolated isFormattableString formatStringCheckContext fmt printerArgTy printerResidueTy let printerTy = List.foldBack (mkFunTy g) argTys printerResultTy let printerTupleTy = mkRefTupledTy g argTys argTys, printerTy, printerTupleTy, percentATys, specifierLocations, dotnetFormatString diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 293ce77491e..7d7097dc25a 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -2842,10 +2842,14 @@ and ResolveOverloading let g = csenv.g let infoReader = csenv.InfoReader let m = csenv.m - let denv = csenv.DisplayEnv - let isOpConversion = methodName = "op_Explicit" || methodName = "op_Implicit" + + let isOpConversion = + (methodName = "op_Explicit") || + (methodName = "op_Implicit") + // See what candidates we have based on name and arity let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m, ad)) + let calledMethOpt, errors, calledMethTrace = match calledMethGroup, candidates with @@ -2877,18 +2881,18 @@ and ResolveOverloading // and exact matches of argument types. let exactMatchCandidates = candidates |> FilterEachThenUndo (fun newTrace calledMeth -> - let csenv = { csenv with IsSpeculativeForMethodOverloading = true } - let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent - (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert - (ArgsEquivOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome) // args exact - reqdRetTyOpt - calledMeth) + let csenv = { csenv with IsSpeculativeForMethodOverloading = true } + let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert + (ArgsEquivOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome) // args exact + reqdRetTyOpt + calledMeth) match exactMatchCandidates with | [(calledMeth, warns, _, _usesTDC)] -> @@ -2912,24 +2916,6 @@ and ResolveOverloading reqdRetTyOpt candidate) - let failOverloading overloadResolutionFailure = - // Try to extract information to give better error for ambiguous op_Explicit and op_Implicit - let convOpData = - if isOpConversion then - match calledMethGroup, reqdRetTyOpt with - | h :: _, Some reqdRetTy -> - Some (h.Method.ApparentEnclosingType, reqdRetTy) - | _ -> None - else - None - - match convOpData with - | Some (fromTy, toTy) -> - UnresolvedConversionOperator (denv, fromTy, toTy.Commit, m) - | None -> - // Otherwise pass the overload resolution failure for error printing in CompileOps - UnresolvedOverloading (denv, callerArgs, overloadResolutionFailure, m) - match applicable with | [] -> // OK, we failed. Collect up the errors from overload resolution and the possible overloads @@ -2953,200 +2939,15 @@ and ResolveOverloading | ErrorResult(_warnings, exn) -> Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) - None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))), NoTrace + let err = FailOverloading csenv calledMethGroup reqdRetTyOpt isOpConversion callerArgs (NoOverloadsFound (methodName, errors, cx)) m + + None, ErrorD err, NoTrace | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t | applicableMeths -> - - /// Compare two things by the given predicate. - /// If the predicate returns true for x1 and false for x2, then x1 > x2 - /// If the predicate returns false for x1 and true for x2, then x1 < x2 - /// Otherwise x1 = x2 - - // Note: Relies on 'compare' respecting true > false - let compareCond (p: 'T -> 'T -> bool) x1 x2 = - compare (p x1 x2) (p x2 x1) - - /// Compare types under the feasibly-subsumes ordering - let compareTypes ty1 ty2 = - (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) - - /// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule - let compareArg (calledArg1: CalledArg) (calledArg2: CalledArg) = - let c = compareTypes calledArg1.CalledArgumentType calledArg2.CalledArgumentType - if c <> 0 then c else - - let c = - (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> - - // Func<_> is always considered better than any other delegate type - match tryTcrefOfAppTy csenv.g ty1 with - | ValueSome tcref1 when - tcref1.DisplayName = "Func" && - (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && - isDelegateTy g ty1 && - isDelegateTy g ty2 -> true - - // T is always better than inref - | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> - true - - // T is always better than Nullable from F# 5.0 onwards - | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && - isNullableTy csenv.g ty2 && - typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> - true - - | _ -> false) - - if c <> 0 then c else - 0 - - /// Check whether one overload is better than another - let better (candidate: CalledMeth<_>, candidateWarnings, _, usesTDC1) (other: CalledMeth<_>, otherWarnings, _, usesTDC2) = - let candidateWarnCount = List.length candidateWarnings - let otherWarnCount = List.length otherWarnings - - // Prefer methods that don't use type-directed conversion - let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) - if c <> 0 then c else - - // Prefer methods that don't give "this code is less generic" warnings - // Note: Relies on 'compare' respecting true > false - let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) - if c <> 0 then c else - - // Prefer methods that don't use param array arg - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) - if c <> 0 then c else - - // Prefer methods with more precise param array arg type - let c = - if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then - compareTypes (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) - else - 0 - if c <> 0 then c else - - // Prefer methods that don't use out args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) - if c <> 0 then c else - - // Prefer methods that don't use optional args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOptArgs) (not other.HasOptArgs) - if c <> 0 then c else - - // check regular unnamed args. The argument counts will only be different if one is using param args - let c = - if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then - // For extension members, we also include the object argument type, if any in the comparison set - // This matches C#, where all extension members are treated and resolved as "static" methods calls - let cs = - (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - let objArgTys1 = candidate.CalledObjArgTys(m) - let objArgTys2 = other.CalledObjArgTys(m) - if objArgTys1.Length = objArgTys2.Length then - List.map2 compareTypes objArgTys1 objArgTys2 - else - [] - else - []) @ - ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 compareArg) - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - // prefer non-extension methods - let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) - if c <> 0 then c else - - // between extension methods, prefer most recently opened - let c = - if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority - else - 0 - if c <> 0 then c else - - // Prefer non-generic methods - // Note: Relies on 'compare' respecting true > false - let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty - if c <> 0 then c else - - // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken - // into account when comparing overloads. So adding a name to an argument might mean - // overloads ould no longer be distinguished. We thus look at *all* arguments (whether - // optional or not) as an additional comparison technique. - let c = - if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then - let cs = - let args1 = candidate.AllCalledArgs |> List.concat - let args2 = other.AllCalledArgs |> List.concat - if args1.Length = args2.Length then - (args1, args2) ||> List.map2 compareArg - else - [] - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - 0 - - let bestMethods = - let indexedApplicableMeths = applicableMeths |> List.indexed - indexedApplicableMeths |> List.choose (fun (i, candidate) -> - if indexedApplicableMeths |> List.forall (fun (j, other) -> - i = j || - let res = better candidate other - res > 0) then - Some candidate - else - None) - match bestMethods with - | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t - | bestMethods -> - let methods = - let getMethodSlotsAndErrors methodSlot errors = - [ match errors with - | [] -> yield { methodSlot = methodSlot; error = Unchecked.defaultof; infoReader = infoReader } - | errors -> for error in errors do yield { methodSlot = methodSlot; error = error; infoReader = infoReader } ] - - // use the most precise set - // - if after filtering bestMethods still contains something - use it - // - otherwise use applicableMeths or initial set of candidate methods - [ match bestMethods with - | [] -> - match applicableMeths with - | [] -> for methodSlot in candidates do yield getMethodSlotsAndErrors methodSlot [] - | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors - | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] - - let methods = List.concat methods - - None, ErrorD (failOverloading (PossibleCandidates(methodName, methods,cx))), NoTrace + GetMostApplicableOverload csenv ndeep candidates applicableMeths calledMethGroup reqdRetTyOpt isOpConversion callerArgs methodName cx m // If we've got a candidate solution: make the final checks - no undo here! // Allow subsumption on arguments. Include the return type. @@ -3157,7 +2958,7 @@ and ResolveOverloading // Static IL interfaces methods are not supported in lower F# versions. if calledMeth.Method.IsILMethod && not calledMeth.Method.IsInstance && isInterfaceTy g calledMeth.Method.ApparentEnclosingType then checkLanguageFeatureRuntimeErrorRecover csenv.InfoReader LanguageFeature.DefaultInterfaceMemberConsumption m - checkLanguageFeatureErrorRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m + checkLanguageFeatureAndRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m calledMethOpt, trackErrors { @@ -3203,6 +3004,223 @@ and ResolveOverloading | None -> None, errors +and FailOverloading csenv calledMethGroup reqdRetTyOpt isOpConversion callerArgs overloadResolutionFailure m = + let denv = csenv.DisplayEnv + // Try to extract information to give better error for ambiguous op_Explicit and op_Implicit + let convOpData = + if isOpConversion then + match calledMethGroup, reqdRetTyOpt with + | h :: _, Some reqdRetTy -> + Some (h.Method.ApparentEnclosingType, reqdRetTy) + | _ -> None + else + None + + match convOpData with + | Some (fromTy, toTy) -> + UnresolvedConversionOperator (denv, fromTy, toTy.Commit, m) + | None -> + // Otherwise pass the overload resolution failure for error printing in CompileOps + UnresolvedOverloading (denv, callerArgs, overloadResolutionFailure, m) + +and GetMostApplicableOverload csenv ndeep candidates applicableMeths calledMethGroup reqdRetTyOpt isOpConversion callerArgs methodName cx m = + let g = csenv.g + let infoReader = csenv.InfoReader + /// Compare two things by the given predicate. + /// If the predicate returns true for x1 and false for x2, then x1 > x2 + /// If the predicate returns false for x1 and true for x2, then x1 < x2 + /// Otherwise x1 = x2 + + // Note: Relies on 'compare' respecting true > false + let compareCond (p: 'T -> 'T -> bool) x1 x2 = + compare (p x1 x2) (p x2 x1) + + /// Compare types under the feasibly-subsumes ordering + let compareTypes ty1 ty2 = + (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) + + /// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule + let compareArg (calledArg1: CalledArg) (calledArg2: CalledArg) = + let c = compareTypes calledArg1.CalledArgumentType calledArg2.CalledArgumentType + if c <> 0 then c else + + let c = + (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> + + // Func<_> is always considered better than any other delegate type + match tryTcrefOfAppTy csenv.g ty1 with + | ValueSome tcref1 when + tcref1.DisplayName = "Func" && + (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && + isDelegateTy g ty1 && + isDelegateTy g ty2 -> true + + // T is always better than inref + | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> + true + + // T is always better than Nullable from F# 5.0 onwards + | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && + isNullableTy csenv.g ty2 && + typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> + true + + | _ -> false) + + if c <> 0 then c else + 0 + + /// Check whether one overload is better than another + let better (candidate: CalledMeth<_>, candidateWarnings, _, usesTDC1) (other: CalledMeth<_>, otherWarnings, _, usesTDC2) = + let candidateWarnCount = List.length candidateWarnings + let otherWarnCount = List.length otherWarnings + + // Prefer methods that don't use type-directed conversion + let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) + if c <> 0 then c else + + // Prefer methods that don't give "this code is less generic" warnings + // Note: Relies on 'compare' respecting true > false + let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) + if c <> 0 then c else + + // Prefer methods that don't use param array arg + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) + if c <> 0 then c else + + // Prefer methods with more precise param array arg type + let c = + if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then + compareTypes (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) + else + 0 + if c <> 0 then c else + + // Prefer methods that don't use out args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) + if c <> 0 then c else + + // Prefer methods that don't use optional args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOptionalArgs) (not other.HasOptionalArgs) + if c <> 0 then c else + + // check regular unnamed args. The argument counts will only be different if one is using param args + let c = + if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then + // For extension members, we also include the object argument type, if any in the comparison set + // This matches C#, where all extension members are treated and resolved as "static" methods calls + let cs = + (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + let objArgTys1 = candidate.CalledObjArgTys(m) + let objArgTys2 = other.CalledObjArgTys(m) + if objArgTys1.Length = objArgTys2.Length then + List.map2 compareTypes objArgTys1 objArgTys2 + else + [] + else + []) @ + ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 compareArg) + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + // prefer non-extension methods + let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) + if c <> 0 then c else + + // between extension methods, prefer most recently opened + let c = + if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority + else + 0 + if c <> 0 then c else + + // Prefer non-generic methods + // Note: Relies on 'compare' respecting true > false + let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty + if c <> 0 then c else + + // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken + // into account when comparing overloads. So adding a name to an argument might mean + // overloads ould no longer be distinguished. We thus look at *all* arguments (whether + // optional or not) as an additional comparison technique. + let c = + if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then + let cs = + let args1 = candidate.AllCalledArgs |> List.concat + let args2 = other.AllCalledArgs |> List.concat + if args1.Length = args2.Length then + (args1, args2) ||> List.map2 compareArg + else + [] + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + 0 + + let bestMethods = + let indexedApplicableMeths = applicableMeths |> List.indexed + indexedApplicableMeths |> List.choose (fun (i, candidate) -> + if indexedApplicableMeths |> List.forall (fun (j, other) -> + i = j || + let res = better candidate other + res > 0) then + Some candidate + else + None) + + match bestMethods with + | [(calledMeth, warns, t, _)] -> + Some calledMeth, OkResult (warns, ()), WithTrace t + + | bestMethods -> + let methods = + let getMethodSlotsAndErrors methodSlot errors = + [ match errors with + | [] -> + { methodSlot = methodSlot; error = Unchecked.defaultof; infoReader = infoReader } + | errors -> + for error in errors do + { methodSlot = methodSlot; error = error; infoReader = infoReader } ] + + // use the most precise set + // - if after filtering bestMethods still contains something - use it + // - otherwise use applicableMeths or initial set of candidate methods + [ match bestMethods with + | [] -> + match applicableMeths with + | [] -> for methodSlot in candidates do yield getMethodSlotsAndErrors methodSlot [] + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] + + let methods = List.concat methods + + let err = FailOverloading csenv calledMethGroup reqdRetTyOpt isOpConversion callerArgs (PossibleCandidates(methodName, methods,cx)) m + None, ErrorD err, NoTrace + let ResolveOverloadingForCall denv css m methodName callerArgs ad calledMethGroup permitOptArgs reqdRetTy = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv ResolveOverloading csenv NoTrace methodName 0 None callerArgs ad calledMethGroup permitOptArgs (Some reqdRetTy) diff --git a/src/Compiler/Checking/ConstraintSolver.fsi b/src/Compiler/Checking/ConstraintSolver.fsi index 353f0aab107..7891763dd44 100644 --- a/src/Compiler/Checking/ConstraintSolver.fsi +++ b/src/Compiler/Checking/ConstraintSolver.fsi @@ -31,16 +31,37 @@ val NewErrorType: unit -> TType val NewErrorMeasure: unit -> Measure /// Create a list of inference type variables, one for each element in the input list -val NewInferenceTypes: TcGlobals -> 'a list -> TType list +val NewInferenceTypes: TcGlobals -> 'T list -> TType list /// Given a set of formal type parameters and their constraints, make new inference type variables for /// each and ensure that the constraints on the new type variables are adjusted to refer to these. -val FreshenAndFixupTypars: range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list - -val FreshenTypeInst: range -> Typars -> Typars * TyparInst * TType list - +/// +/// Returns +/// 1. the new type parameters +/// 2. the instantiation mapping old type parameters to inference variables +/// 3. the inference type variables as a list of types. +val FreshenAndFixupTypars: + m: range -> rigid: TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInstantiation * TType list + +/// Given a set of type parameters, make new inference type variables for +/// each and ensure that the constraints on the new type variables are adjusted. +/// +/// Returns +/// 1. the new type parameters +/// 2. the instantiation mapping old type parameters to inference variables +/// 3. the inference type variables as a list of types. +val FreshenTypeInst: range -> Typars -> Typars * TyparInstantiation * TType list + +/// Given a set of type parameters, make new inference type variables for +/// each and ensure that the constraints on the new type variables are adjusted. +/// +/// Returns the inference type variables as a list of types. val FreshenTypars: range -> Typars -> TType list +/// Given a method, which may be generic, make new inference type variables for +/// its generic parameters, and ensure that the constraints the new type variables are adjusted. +/// +/// Returns the inference type variables as a list of types. val FreshenMethInfo: range -> MethInfo -> TType list /// Information about the context of a type equation. diff --git a/src/Compiler/Checking/FindUnsolved.fs b/src/Compiler/Checking/FindUnsolved.fs index 508ef4d9e3f..76fb746ca4f 100644 --- a/src/Compiler/Checking/FindUnsolved.fs +++ b/src/Compiler/Checking/FindUnsolved.fs @@ -255,11 +255,7 @@ let accTycon cenv env (tycon:Tycon) = let accTycons cenv env tycons = List.iter (accTycon cenv env) tycons -let rec accModuleOrNamespaceContents cenv env x = - match x with - | ModuleOrNamespaceContentsWithSig(_mty, def, _m) -> accModuleOrNamespaceDef cenv env def - -and accModuleOrNamespaceDefs cenv env defs = +let rec accModuleOrNamespaceDefs cenv env defs = List.iter (accModuleOrNamespaceDef cenv env) defs and accModuleOrNamespaceDef cenv env def = @@ -270,8 +266,7 @@ and accModuleOrNamespaceDef cenv env def = | TMDefLet(bind, _m) -> accBind cenv env bind | TMDefDo(e, _m) -> accExpr cenv env e | TMDefOpens _ -> () - | TMWithSig(def) -> accModuleOrNamespaceContents cenv env def - | TMDefs(defs) -> accModuleOrNamespaceDefs cenv env defs + | TMDefs defs -> accModuleOrNamespaceDefs cenv env defs and accModuleOrNamespaceBinds cenv env xs = List.iter (accModuleOrNamespaceBind cenv env) xs @@ -284,7 +279,7 @@ and accModuleOrNamespaceBind cenv env x = accTycon cenv env mspec accModuleOrNamespaceDef cenv env rhs -let UnsolvedTyparsOfModuleDef g amap denv (mdef, extraAttribs) = +let UnsolvedTyparsOfModuleDef g amap denv mdef extraAttribs = let cenv = { g =g amap=amap diff --git a/src/Compiler/Checking/FindUnsolved.fsi b/src/Compiler/Checking/FindUnsolved.fsi index 8b6e0816654..01d84c8807f 100644 --- a/src/Compiler/Checking/FindUnsolved.fsi +++ b/src/Compiler/Checking/FindUnsolved.fsi @@ -12,5 +12,6 @@ val UnsolvedTyparsOfModuleDef: g: TcGlobals -> amap: ImportMap -> denv: DisplayEnv -> - mdef: ModuleOrNamespaceContents * extraAttribs: Attrib list -> + mdef: ModuleOrNamespaceContents -> + extraAttribs: Attrib list -> Typar list diff --git a/src/Compiler/Checking/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index da69bbbbc0a..75a4e9aa897 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -931,7 +931,7 @@ let GetSigOfFunctionForDelegate (infoReader: InfoReader) delty m ad = | [] -> [g.unit_ty] | _ -> delArgTys - let delRetTy = delInvokeMeth.GetFSharpReturnTy(amap, m, minst) + let delRetTy = delInvokeMeth.GetFSharpReturnType(amap, m, minst) CheckMethInfoAttributes g m None delInvokeMeth |> CommitOperationResult diff --git a/src/Compiler/Checking/MethodCalls.fs b/src/Compiler/Checking/MethodCalls.fs index e4b4251178d..f4338d311df 100644 --- a/src/Compiler/Checking/MethodCalls.fs +++ b/src/Compiler/Checking/MethodCalls.fs @@ -207,7 +207,7 @@ let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualT (match minfo.GetParamTypes(amap, m, []) with | [[a]] -> typeEquiv g a actualTy | _ -> false) && - (let retTy = minfo.GetFSharpReturnTy(amap, m, []) + (let retTy = minfo.GetFSharpReturnType(amap, m, []) typeEquiv g retTy reqdTy2) ) @@ -506,7 +506,7 @@ type CalledMeth<'T> tyargsOpt: TType option) = let g = infoReader.g - let methodRetTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs) + let methodRetTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnType(infoReader.amap, m, calledTyArgs) let fullCurriedCalledArgs = MakeCalledArgs infoReader.amap m minfo calledTyArgs do assert (fullCurriedCalledArgs.Length = fullCurriedCalledArgs.Length) @@ -726,7 +726,7 @@ type CalledMeth<'T> member x.NumArgSets = x.ArgSets.Length - member x.HasOptArgs = not (isNil x.UnnamedCalledOptArgs) + member x.HasOptionalArgs = not (isNil x.UnnamedCalledOptArgs) member x.HasOutArgs = not (isNil x.UnnamedCalledOutArgs) @@ -946,19 +946,19 @@ let TakeObjAddrForMethodCall g amap (minfo: MethInfo) isMutable m objArgs f = /// Build an expression node that is a call to a .NET method. let BuildILMethInfoCall g amap m isProp (minfo: ILMethInfo) valUseFlags minst direct args = - let valu = isStructTy g minfo.ApparentEnclosingType + let isStruct = isStructTy g minfo.ApparentEnclosingType let ctor = minfo.IsConstructor if minfo.IsClassConstructor then error (InternalError (minfo.ILName+": cannot call a class constructor", m)) let useCallvirt = - not valu && not direct && minfo.IsVirtual + not isStruct && not direct && minfo.IsVirtual let isProtected = minfo.IsProtectedAccessibility let ilMethRef = minfo.ILMethodRef let newobj = ctor && (match valUseFlags with NormalValUse -> true | _ -> false) - let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst) + let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnType(amap, m, minst) let retTy = if not ctor && (stripILModifiedFromTy ilMethRef.ReturnType) = ILType.Void then [] else [exprTy] let isDllImport = minfo.IsDllImport g - Expr.Op (TOp.ILCall (useCallvirt, isProtected, valu, newobj, valUseFlags, isProp, isDllImport, ilMethRef, minfo.DeclaringTypeInst, minst, retTy), [], args, m), + Expr.Op (TOp.ILCall (useCallvirt, isProtected, isStruct, newobj, valUseFlags, isProp, isDllImport, ilMethRef, minfo.DeclaringTypeInst, minst, retTy), [], args, m), exprTy @@ -998,7 +998,7 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = let BuildFSharpMethodCall g m (ty, vref: ValRef) valUseFlags minst args = let vexp = Expr.Val (vref, valUseFlags, m) let vexpty = vref.Type - let tpsorig, tau = vref.TypeScheme + let tpsorig, tau = vref.GeneralizedType let vtinst = argsOfAppTy g ty @ minst if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch", m)) let expr = mkTyAppExpr m (vexp, vexpty) vtinst @@ -1029,12 +1029,12 @@ let MakeMethInfoCall amap m minfo minst args = let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant let ilMethodRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m mi let isConstructor = mi.PUntaint((fun c -> c.IsConstructor), m) - let valu = mi.PUntaint((fun c -> c.DeclaringType.IsValueType), m) + let isStruct = mi.PUntaint((fun c -> c.DeclaringType.IsValueType), m) let actualTypeInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here let actualMethInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here - let ilReturnTys = Option.toList (minfo.GetCompiledReturnTy(amap, m, [])) // GENERIC TYPE PROVIDERS: for generics, we would have more here + let ilReturnTys = Option.toList (minfo.GetCompiledReturnType(amap, m, [])) // GENERIC TYPE PROVIDERS: for generics, we would have more here // REVIEW: Should we allow protected calls? - Expr.Op (TOp.ILCall (false, false, valu, isConstructor, valUseFlags, isProp, false, ilMethodRef, actualTypeInst, actualMethInst, ilReturnTys), [], args, m) + Expr.Op (TOp.ILCall (false, false, isStruct, isConstructor, valUseFlags, isProp, false, ilMethodRef, actualTypeInst, actualMethInst, ilReturnTys), [], args, m) #endif @@ -1100,13 +1100,13 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA if isArrayTy g enclTy then let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(minfo.DisplayName), providedMeth.TypeProviderDesignation, m) error tpe - let valu = isStructTy g enclTy + let isStruct = isStructTy g enclTy let isCtor = minfo.IsConstructor if minfo.IsClassConstructor then error (InternalError (minfo.LogicalName + ": cannot call a class constructor", m)) - let useCallvirt = not valu && not direct && minfo.IsVirtual + let useCallvirt = not isStruct && not direct && minfo.IsVirtual let isProtected = minfo.IsProtectedAccessibility - let exprTy = if isCtor then enclTy else minfo.GetFSharpReturnTy(amap, m, minst) + let exprTy = if isCtor then enclTy else minfo.GetFSharpReturnType(amap, m, minst) match TryImportProvidedMethodBaseAsLibraryIntrinsic (amap, m, providedMeth) with | Some fsValRef -> //reraise() calls are converted to TOp.Reraise in the type checker. So if a provided expression includes a reraise call @@ -1126,7 +1126,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA let actualMethInst = minst let retTy = if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy] let noTailCall = false - let expr = Expr.Op (TOp.ILCall (useCallvirt, isProtected, valu, isNewObj, valUseFlags, isProp, noTailCall, ilMethRef, actualTypeInst, actualMethInst, retTy), [], allArgs, m) + let expr = Expr.Op (TOp.ILCall (useCallvirt, isProtected, isStruct, isNewObj, valUseFlags, isProp, noTailCall, ilMethRef, actualTypeInst, actualMethInst, retTy), [], allArgs, m) expr, exprTy #endif @@ -1156,7 +1156,7 @@ let ILFieldStaticChecks g amap infoReader ad m (finfo : ILFieldInfo) = // Static IL interfaces fields are not supported in lower F# versions. if isInterfaceTy g finfo.ApparentEnclosingType then checkLanguageFeatureRuntimeErrorRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m - checkLanguageFeatureErrorRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m + checkLanguageFeatureAndRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m CheckILFieldAttributes g finfo m diff --git a/src/Compiler/Checking/MethodCalls.fsi b/src/Compiler/Checking/MethodCalls.fsi index b8fe0a53560..8eaa3c3a8f8 100644 --- a/src/Compiler/Checking/MethodCalls.fsi +++ b/src/Compiler/Checking/MethodCalls.fsi @@ -244,11 +244,11 @@ type CalledMeth<'T> = /// Return type after tupling of out args is taken into account member CalledReturnTypeAfterOutArgTupling: TType - /// The instantiation of the method we're attempting to call + /// The generic instantiation of the method we're attempting to call member CalledTyArgs: TType list /// The instantiation of the method we're attempting to call - member CalledTyparInst: TypedTreeOps.TyparInst + member CalledTyparInst: TyparInstantiation /// The types of the actual object arguments, if any member CallerObjArgTys: TType list @@ -260,7 +260,7 @@ type CalledMeth<'T> = member HasCorrectGenericArity: bool - member HasOptArgs: bool + member HasOptionalArgs: bool member HasOutArgs: bool diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index 9da0e71f765..9d3e6c50153 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -35,19 +35,36 @@ type OverrideCanImplement = /// The overall information about a method implementation in a class or object expression type OverrideInfo = - | Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * TType list list * TType option * bool * bool - member x.CanImplement = let (Override(a, _, _, _, _, _, _, _)) = x in a - member x.BoundingTyconRef = let (Override(_, ty, _, _, _, _, _, _)) = x in ty - member x.LogicalName = let (Override(_, _, id, _, _, _, _, _)) = x in id.idText - member x.Range = let (Override(_, _, id, _, _, _, _, _)) = x in id.idRange - member x.IsFakeEventProperty = let (Override(_, _, _, _, _, _, b, _)) = x in b - member x.ArgTypes = let (Override(_, _, _, _, b, _, _, _)) = x in b - member x.ReturnType = let (Override(_, _, _, _, _, b, _, _)) = x in b - member x.IsCompilerGenerated = let (Override(_, _, _, _, _, _, _, b)) = x in b + | Override of + canImplement: OverrideCanImplement * + boundingTyconRef: TyconRef * + id: Ident * + methTypars: Typars * + memberToParentInstantiation: TyparInstantiation * + argTypes: TType list list * + returnType: TType option * + isFakeEventProperty: bool * + isCompilerGenerated: bool + + member x.CanImplement = let (Override(canImplement=a)) = x in a + + member x.BoundingTyconRef = let (Override(boundingTyconRef=ty)) = x in ty + + member x.LogicalName = let (Override(id=id)) = x in id.idText + + member x.Range = let (Override(id=id)) = x in id.idRange + + member x.IsFakeEventProperty = let (Override(isFakeEventProperty=b)) = x in b + + member x.ArgTypes = let (Override(argTypes=b)) = x in b + + member x.ReturnType = let (Override(returnType=b)) = x in b + + member x.IsCompilerGenerated = let (Override(isCompilerGenerated=b)) = x in b type RequiredSlot = - | RequiredSlot of MethInfo * isOptional: bool - | DefaultInterfaceImplementationSlot of MethInfo * isOptional: bool * possiblyNoMostSpecific: bool + | RequiredSlot of methodInfo: MethInfo * isOptional: bool + | DefaultInterfaceImplementationSlot of methodInfo: MethInfo * isOptional: bool * possiblyNoMostSpecific: bool /// A slot which does not have to be implemented, because an inherited implementation is available. member this.IsOptional = @@ -74,7 +91,12 @@ type RequiredSlot = | RequiredSlot(methInfo, _) | DefaultInterfaceImplementationSlot(methInfo, _, _) -> methInfo -type SlotImplSet = SlotImplSet of RequiredSlot list * NameMultiMap * OverrideInfo list * PropInfo list +type SlotImplSet = + | SlotImplSet of + dispatchSlots: RequiredSlot list * + dispatchSlotsKeyed: NameMultiMap * + availablePriorOverrides: OverrideInfo list * + requiredProperties: PropInfo list exception TypeIsImplicitlyAbstract of range exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option * TcGlobals * Import.ImportMap * range @@ -82,7 +104,7 @@ exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option module DispatchSlotChecking = /// Print the signature of an override to a buffer as part of an error message - let PrintOverrideToBuffer denv os (Override(_, _, id, (methTypars, memberToParentInst), argTys, retTy, _, _)) = + let PrintOverrideToBuffer denv os (Override(_, _, id, methTypars, memberToParentInst, argTys, retTy, _, _)) = let denv = { denv with showTyparBinding = true } let retTy = (retTy |> GetFSharpViewOfReturnType denv.g) let argInfos = @@ -101,10 +123,12 @@ module DispatchSlotChecking = LayoutRender.bufferL os (NicePrint.prettyLayoutOfMemberSig denv (ttpinst, nm, fmethTypars, argInfos, retTy)) /// Format the signature of an override as a string as part of an error message - let FormatOverride denv d = bufs (fun buf -> PrintOverrideToBuffer denv buf d) + let FormatOverride denv d = + buildString (fun buf -> PrintOverrideToBuffer denv buf d) /// Format the signature of a MethInfo as a string as part of an error message - let FormatMethInfoSig g amap m denv d = bufs (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d) + let FormatMethInfoSig g amap m denv d = + buildString (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d) /// Get the override info for an existing (inherited) method being used to implement a dispatch slot. let GetInheritedMemberOverrideInfo g amap m parentType (minfo: MethInfo) = @@ -112,7 +136,7 @@ module DispatchSlotChecking = let (CompiledSig (argTys, retTy, fmethTypars, ttpinst)) = CompiledSigOfMeth g amap m minfo let isFakeEventProperty = minfo.IsFSharpEventPropertyMethod - Override(parentType, minfo.ApparentEnclosingTyconRef, mkSynId m nm, (fmethTypars, ttpinst), argTys, retTy, isFakeEventProperty, false) + Override(parentType, minfo.ApparentEnclosingTyconRef, mkSynId m nm, fmethTypars, ttpinst, argTys, retTy, isFakeEventProperty, false) /// Get the override info for a value being used to implement a dispatch slot. let GetTypeMemberOverrideInfo g reqdTy (overrideBy: ValRef) = @@ -129,6 +153,7 @@ module DispatchSlotChecking = memberMethodTypars, memberToParentInst, argTys, retTy | None -> error(Error(FSComp.SR.typrelMethodIsOverconstrained(), overrideBy.Range)) + let implKind = if ValRefIsExplicitImpl g overrideBy then @@ -150,7 +175,7 @@ module DispatchSlotChecking = //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g) - Override(implKind, overrideBy.MemberApparentEntity, mkSynId overrideBy.Range nm, (memberMethodTypars, memberToParentInst), argTys, retTy, isFakeEventProperty, overrideBy.IsCompilerGenerated) + Override(implKind, overrideBy.MemberApparentEntity, mkSynId overrideBy.Range nm, memberMethodTypars, memberToParentInst, argTys, retTy, isFakeEventProperty, overrideBy.IsCompilerGenerated) /// Get the override information for an object expression method being used to implement dispatch slots let GetObjectExprOverrideInfo g amap (implty, id: Ident, memberFlags, ty, arityInfo, bindingAttribs, rhsExpr) = @@ -173,7 +198,7 @@ module DispatchSlotChecking = CanImplementAnyClassHierarchySlot //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation let isFakeEventProperty = CompileAsEvent g bindingAttribs - let overrideByInfo = Override(implKind, tcrefOfAppTy g implty, id, (tps, []), argTys, retTy, isFakeEventProperty, false) + let overrideByInfo = Override(implKind, tcrefOfAppTy g implty, id, tps, [], argTys, retTy, isFakeEventProperty, false) overrideByInfo, (baseValOpt, thisv, vs, bindingAttribs, rhsExpr) | _ -> error(InternalError("Unexpected shape for object expression override", id.idRange)) @@ -194,13 +219,13 @@ module DispatchSlotChecking = /// Check if the kinds of type parameters match between a dispatch slot and an override. let IsTyparKindMatch compiledSig overrideBy = - let (Override(_, _, _, (methTypars, _), _, _, _, _)) = overrideBy + let (Override(methTypars=methTypars)) = overrideBy let (CompiledSig (_, _, fvmethTypars, _)) = compiledSig List.lengthsEqAndForall2 (fun (tp1: Typar) (tp2: Typar) -> tp1.Kind = tp2.Kind) methTypars fvmethTypars /// Check if an override is a partial match for the requirements for a dispatch slot except for the name. let IsSigPartialMatch g (dispatchSlot: MethInfo) compiledSig overrideBy = - let (Override(_, _, _, (methTypars, _), argTys, _retTy, _, _)) = overrideBy + let (Override(_, _, _, methTypars, _, argTys, _retTy, _, _)) = overrideBy let (CompiledSig (vargTys, _, fvmethTypars, _)) = compiledSig methTypars.Length = fvmethTypars.Length && IsTyparKindMatch compiledSig overrideBy && @@ -222,7 +247,7 @@ module DispatchSlotChecking = /// Check if an override exactly matches the requirements for a dispatch slot except for the name. let IsSigExactMatch g amap m dispatchSlot overrideBy = - let (Override(_, _, _, (methTypars, mtpinst), argTys, retTy, _, _)) = overrideBy + let (Override(_, _, _, methTypars, memberToParentInst, argTys, retTy, _, _)) = overrideBy let compiledSig = CompiledSigOfMeth g amap m dispatchSlot IsSigPartialMatch g dispatchSlot compiledSig overrideBy && let (CompiledSig (vargTys, vrty, fvmethTypars, ttpinst)) = compiledSig @@ -248,20 +273,22 @@ module DispatchSlotChecking = // // we have // ttpinst maps ctps --> ctys[dtps] - // mtpinst maps ttps --> dtps + // memberToParentInst maps ttps --> dtps // // compare fvtmps[ctps] and methTypars[ttps] by // fvtmps[ctps] @ ttpinst -- gives fvtmps[dtps] - // fvtmps[dtps] @ rev(mtpinst) -- gives fvtmps[ttps] + // fvtmps[dtps] @ rev(memberToParentInst) -- gives fvtmps[ttps] // - // Now fvtmps[ttps] and mtpinst[ttps] are comparable, i.e. have constraints w.r.t. the same set of type variables + // Now fvtmps[ttps] and memberToParentInst[ttps] are comparable, i.e. have constraints w.r.t. the same set of type variables // - // i.e. Compose the substitutions ttpinst and rev(mtpinst) + // i.e. Compose the substitutions ttpinst and rev(memberToParentInst) let ttpinst = // check we can reverse - in some error recovery situations we can't - if mtpinst |> List.exists (snd >> isTyparTy g >> not) then ttpinst - else ComposeTyparInsts ttpinst (ReverseTyparRenaming g mtpinst) + if memberToParentInst |> List.exists (snd >> isTyparTy g >> not) then + ttpinst + else + ComposeTyparInsts ttpinst (ReverseTyparRenaming g memberToParentInst) // Compare under the composed substitutions let aenv = TypeEquivEnv.FromTyparInst ttpinst @@ -335,7 +362,7 @@ module DispatchSlotChecking = then // Always try to raise a language version error if we have a DIM that is not explicitly implemented. if reqdSlot.HasDefaultInterfaceImplementation then - checkLanguageFeatureErrorRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m + checkLanguageFeatureAndRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m if reqdSlot.PossiblyNoMostSpecificImplementation then errorR(Error(FSComp.SR.typrelInterfaceMemberNoMostSpecificImplementation(NicePrint.stringOfMethInfo infoReader m denv dispatchSlot), m)) @@ -357,7 +384,7 @@ module DispatchSlotChecking = noimpl() | [ overrideBy ] -> - let (Override(_, _, _, (methTypars, _), argTys, _, _, _)) = overrideBy + let (Override(_, _, _, methTypars, _, argTys, _, _, _)) = overrideBy let moreThanOnePossibleDispatchSlot = dispatchSlots @@ -832,7 +859,7 @@ module DispatchSlotChecking = overrideBy.MemberInfo.Value.ImplementedSlotSigs <- overriden) /// "Type Completion" inference and a few other checks at the end of the inference scope -let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv, sink, isImplementation, denv) (tycon: Tycon) = +let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv, sink, isImplementation, denv, tycon: Tycon) = let g = infoReader.g let amap = infoReader.amap @@ -907,7 +934,7 @@ let GetAbstractMethInfosForSynMethodDecl(infoReader: InfoReader, ad, memberName: /// Get the properties relevant to determining if a uniquely-identified-override exists based on the syntactic information /// at the member signature prior to type inference. This is used to pre-assign type information if it does -let GetAbstractPropInfosForSynPropertyDecl(infoReader: InfoReader, ad, memberName: Ident, bindm, typToSearchForAbstractMembers, _k, _valSynData) = +let GetAbstractPropInfosForSynPropertyDecl(infoReader: InfoReader, ad, memberName: Ident, bindm, typToSearchForAbstractMembers) = let pinfos = match typToSearchForAbstractMembers with | _, Some(SlotImplSet(_, _, _, reqdProps)) -> diff --git a/src/Compiler/Checking/MethodOverrides.fsi b/src/Compiler/Checking/MethodOverrides.fsi index f0e369164b7..e6091626469 100644 --- a/src/Compiler/Checking/MethodOverrides.fsi +++ b/src/Compiler/Checking/MethodOverrides.fsi @@ -24,14 +24,15 @@ type OverrideCanImplement = /// The overall information about a method implementation in a class or object expression type OverrideInfo = | Override of - OverrideCanImplement * - TyconRef * - Ident * - (Typars * TyparInst) * - TType list list * - TType option * - bool * - bool + canImplement: OverrideCanImplement * + boundingTyconRef: TyconRef * + id: Ident * + methTypars: Typars * + memberToParentInstantiation: TyparInstantiation * + argTypes: TType list list * + returnType: TType option * + isFakeEventProperty: bool * + isCompilerGenerated: bool member ArgTypes: TType list list @@ -50,8 +51,8 @@ type OverrideInfo = member ReturnType: TType option type RequiredSlot = - | RequiredSlot of MethInfo * isOptional: bool - | DefaultInterfaceImplementationSlot of MethInfo * isOptional: bool * possiblyNoMostSpecific: bool + | RequiredSlot of methodInfo: MethInfo * isOptional: bool + | DefaultInterfaceImplementationSlot of methodInfo: MethInfo * isOptional: bool * possiblyNoMostSpecific: bool /// Indicates a slot which has a default interface implementation. /// A combination of this flag and the lack of IsOptional means the slot may have been reabstracted. @@ -66,7 +67,12 @@ type RequiredSlot = /// A slot that *might* have ambiguity due to multiple inheritance; happens with default interface implementations. member PossiblyNoMostSpecificImplementation: bool -type SlotImplSet = SlotImplSet of RequiredSlot list * NameMultiMap * OverrideInfo list * PropInfo list +type SlotImplSet = + | SlotImplSet of + dispatchSlots: RequiredSlot list * + dispatchSlotsKeyed: NameMultiMap * + availablePriorOverrides: OverrideInfo list * + requiredProperties: PropInfo list exception TypeIsImplicitlyAbstract of range @@ -133,9 +139,13 @@ module DispatchSlotChecking = /// "Type Completion" inference and a few other checks at the end of the inference scope val FinalTypeDefinitionChecksAtEndOfInferenceScope: - infoReader: InfoReader * nenv: NameResolutionEnv * sink: TcResultsSink * isImplementation: bool * denv: DisplayEnv -> - tycon: Tycon -> - unit + infoReader: InfoReader * + nenv: NameResolutionEnv * + sink: TcResultsSink * + isImplementation: bool * + denv: DisplayEnv * + tycon: Tycon -> + unit /// Get the methods relevant to determining if a uniquely-identified-override exists based on the syntactic information /// at the member signature prior to type inference. This is used to pre-assign type information if it does @@ -155,7 +165,5 @@ val GetAbstractPropInfosForSynPropertyDecl: ad: AccessorDomain * memberName: Ident * bindm: range * - typToSearchForAbstractMembers: (TType * SlotImplSet option) * - _k: 'a * - _valSynData: 'b -> + typToSearchForAbstractMembers: (TType * SlotImplSet option) -> PropInfo list diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 6e927ff49c8..d4825fb9e9a 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -296,16 +296,16 @@ let valRefHash (vref: ValRef) = | ValueNone -> 0 | ValueSome v -> LanguagePrimitives.PhysicalHash v -/// Pairs an Item with a TyparInst showing how generic type variables of the item are instantiated at +/// Pairs an Item with a TyparInstantiation showing how generic type variables of the item are instantiated at /// a particular usage point. [] type ItemWithInst = { Item: Item - TyparInst: TyparInst } + TyparInstantiation: TyparInstantiation } -let ItemWithNoInst item = ({ Item = item; TyparInst = emptyTyparInst } : ItemWithInst) +let ItemWithNoInst item = ({ Item = item; TyparInstantiation = emptyTyparInst } : ItemWithInst) -let (|ItemWithInst|) (x: ItemWithInst) = (x.Item, x.TyparInst) +let (|ItemWithInst|) (x: ItemWithInst) = (x.Item, x.TyparInstantiation) /// Represents a record field resolution and the information if the usage is deprecated. type FieldResolution = FieldResolution of RecdFieldInfo * bool @@ -448,13 +448,13 @@ type NameResolutionEnv = member nenv.TyconsByDemangledNameAndArity fq = match fq with | FullyQualified -> nenv.eFullyQualifiedTyconsByDemangledNameAndArity - | OpenQualified -> nenv.eTyconsByDemangledNameAndArity + | OpenQualified -> nenv.eTyconsByDemangledNameAndArity /// Get the table of types, indexed by name member nenv.TyconsByAccessNames fq = match fq with | FullyQualified -> nenv.eFullyQualifiedTyconsByAccessNames - | OpenQualified -> nenv.eTyconsByAccessNames + | OpenQualified -> nenv.eTyconsByAccessNames /// Get the table of modules and namespaces member nenv.ModulesAndNamespaces fq = @@ -694,7 +694,6 @@ let AllMethInfosOfTypeInScope collectionSettings infoReader nenv optFilter ad fi [] type BulkAdd = Yes | No - /// bulkAddMode: true when adding the values from the 'open' of a namespace /// or module, when we collapse the value table down to a dictionary. let AddValRefsToItems (bulkAddMode: BulkAdd) (eUnqualifiedItems: UnqualifiedItems) (vrefs: ValRef[]) = @@ -718,7 +717,6 @@ let AddValRefToExtensionMembers pri (eIndexedExtensionMembers: TyconRefMultiMap< else eIndexedExtensionMembers - /// This entry point is used to add some extra items to the environment for Visual Studio, e.g. static members let AddFakeNamedValRefToNameEnv nm nenv vref = {nenv with eUnqualifiedItems = nenv.eUnqualifiedItems.Add (nm, Item.Value vref) } @@ -980,6 +978,7 @@ let LookupTypeNameInEntityNoArity _m nm (mtyp: ModuleOrNamespaceType) = /// Lookup a type name in an entity. let LookupTypeNameInEntityMaybeHaveArity (amap, m, ad, nm, staticResInfo: TypeNameResolutionStaticArgsInfo, modref: ModuleOrNamespaceRef) = let mtyp = modref.ModuleOrNamespaceType + let tcrefs = match staticResInfo with | TypeNameResolutionStaticArgsInfo.Indefinite -> @@ -989,14 +988,14 @@ let LookupTypeNameInEntityMaybeHaveArity (amap, m, ad, nm, staticResInfo: TypeNa match LookupTypeNameInEntityHaveArity nm staticResInfo mtyp with | Some tycon -> [modref.NestedTyconRef tycon] | None -> [] + #if !NO_TYPEPROVIDERS let tcrefs = match tcrefs with | [] -> ResolveProvidedTypeNameInEntity (amap, m, nm, modref) | _ -> tcrefs -#else - amap |> ignore #endif + let tcrefs = tcrefs |> List.filter (IsEntityAccessible amap m ad) tcrefs @@ -1010,6 +1009,7 @@ let GetNestedTyconRefsOfType (infoReader: InfoReader) (amap: Import.ImportMap) ( let tycon = tcref.Deref let mty = tycon.ModuleOrNamespaceType // No dotting through type generators to get to a nested type! + #if !NO_TYPEPROVIDERS if checkForGenerated then CheckForDirectReferenceToGeneratedType (tcref, PermitDirectReferenceToGeneratedType.No, m) @@ -1335,7 +1335,6 @@ let AddModuleAbbrevToNameEnv (id: Ident) nenv modrefs = let add old nw = nw @ old NameMap.layerAdditive add (Map.add id.idText modrefs Map.empty) nenv.eModulesAndNamespaces } - //------------------------------------------------------------------------- // Open a structure or an IL namespace //------------------------------------------------------------------------- @@ -1350,6 +1349,7 @@ let MakeNestedModuleRefs (modref: ModuleOrNamespaceRef) = let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: ModuleOrNamespaceRef list) = if isNil modrefs then nenv else let modrefsMap = modrefs |> NameMap.ofKeyedList (fun modref -> modref.DemangledModuleOrNamespaceName) + let addModrefs tab = let add old nw = if IsEntityAccessible amap m ad nw then @@ -1357,20 +1357,23 @@ let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: Module else old NameMap.layerAdditive add modrefsMap tab + let nenv = - {nenv with + { nenv with eModulesAndNamespaces = addModrefs nenv.eModulesAndNamespaces eFullyQualifiedModulesAndNamespaces = if root then addModrefs nenv.eFullyQualifiedModulesAndNamespaces else nenv.eFullyQualifiedModulesAndNamespaces } + let nenv = (nenv, modrefs) ||> List.fold (fun nenv modref -> if modref.IsModule && TryFindFSharpBoolAttribute g g.attrib_AutoOpenAttribute modref.Attribs = Some true then AddModuleOrNamespaceContentsToNameEnv g amap ad m false nenv modref else nenv) + nenv /// Add the contents of a module or namespace to the name resolution environment @@ -1395,10 +1398,12 @@ and AddModuleOrNamespaceContentsToNameEnv (g: TcGlobals) amap (ad: AccessorDomai if IsEntityAccessible amap m ad tcref then Some tcref else None) let nenv = (nenv, tcrefs) ||> AddTyconRefsToNameEnv BulkAdd.Yes false g amap ad m false + let vrefs = mty.AllValsAndMembers.ToList() |> List.choose (fun x -> if IsAccessible ad x.Accessibility then TryMkValRefInModRef modref x else None) |> List.toArray + let nenv = AddValRefsToNameEnvWithPriority g BulkAdd.Yes pri nenv vrefs let nestedModules = MakeNestedModuleRefs modref let nenv = (nenv, nestedModules) ||> AddModuleOrNamespaceRefsToNameEnv g amap m root ad @@ -1428,7 +1433,6 @@ and AddModuleOrNamespaceRefContentsToNameEnv g amap ad m root nenv (modref: Enti let AddModuleOrNamespaceRefToNameEnv g amap m root ad nenv (modref: EntityRef) = AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv [modref] - /// A flag which indicates if it is an error to have two declared type parameters with identical names /// in the name resolution environment. type CheckForDuplicateTyparFlag = @@ -1518,12 +1522,15 @@ let AddResults res1 res2 = | Result x, Result l -> Result (x @ l) | Exception _, Result l -> Result l | Result x, Exception _ -> Result x + // If we have error messages for the same symbol, then we can merge suggestions. | Exception (UndefinedName(n1, f, id1, suggestions1)), Exception (UndefinedName(n2, _, id2, suggestions2)) when n1 = n2 && id1.idText = id2.idText && equals id1.idRange id2.idRange -> Exception(UndefinedName(n1, f, id1, fun addToBuffer -> suggestions1 addToBuffer; suggestions2 addToBuffer)) + // This prefers error messages coming from deeper failing long identifier paths | Exception (UndefinedName(n1, _, _, _) as e1), Exception (UndefinedName(n2, _, _, _) as e2) -> if n1 < n2 then Exception e2 else Exception e1 + // Prefer more concrete errors about things being undefined | Exception (UndefinedName _ as e1), Exception (DiagnosticWithText _) -> Exception e1 | Exception (DiagnosticWithText _), Exception (UndefinedName _ as e2) -> Exception e2 @@ -1626,13 +1633,21 @@ type FormatStringCheckContext = /// An abstract type for reporting the results of name resolution and type checking. type ITypecheckResultsSink = + abstract NotifyEnvWithScope: range * NameResolutionEnv * AccessorDomain -> unit + abstract NotifyExprHasType: TType * NameResolutionEnv * AccessorDomain * range -> unit - abstract NotifyNameResolution: pos * item: Item * TyparInst * ItemOccurence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit - abstract NotifyMethodGroupNameResolution : pos * item: Item * itemMethodGroup: Item * TyparInst * ItemOccurence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit + + abstract NotifyNameResolution: pos * item: Item * TyparInstantiation * ItemOccurence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit + + abstract NotifyMethodGroupNameResolution : pos * item: Item * itemMethodGroup: Item * TyparInstantiation * ItemOccurence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit + abstract NotifyFormatSpecifierLocation: range * int -> unit + abstract NotifyOpenDeclaration: OpenDeclaration -> unit + abstract CurrentSourceText: ISourceText option + abstract FormatStringCheckContext: FormatStringCheckContext option let (|ValRefOfProp|_|) (pi: PropInfo) = pi.ArbitraryValRef @@ -1846,7 +1861,7 @@ type CapturedNameResolution(i: Item, tpinst, io: ItemOccurence, nre: NameResolut member _.Item = i - member _.ItemWithInst = ({ Item = i; TyparInst = tpinst } : ItemWithInst) + member _.ItemWithInst = ({ Item = i; TyparInstantiation = tpinst } : ItemWithInst) member _.ItemOccurence = io @@ -2109,7 +2124,7 @@ let CheckAllTyparsInferrable amap m item = let freeInArgsAndRetType = List.foldBack (accFreeInTypes CollectTyparsNoCaching) (minfo.GetParamTypes(amap, m, fminst)) (accFreeInTypes CollectTyparsNoCaching (minfo.GetObjArgTypes(amap, m, fminst)) - (freeInType CollectTyparsNoCaching (minfo.GetFSharpReturnTy(amap, m, fminst)))) + (freeInType CollectTyparsNoCaching (minfo.GetFSharpReturnType(amap, m, fminst)))) let free = Zset.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars free.IsEmpty) @@ -3634,7 +3649,7 @@ type AfterResolution = | DoNothing /// Notify the tcSink of a precise resolution. The 'Item' contains the candidate overrides. - | RecordResolution of Item option * (TyparInst -> unit) * (MethInfo * PropInfo option * TyparInst -> unit) * (unit -> unit) + | RecordResolution of Item option * (TyparInstantiation -> unit) * (MethInfo * PropInfo option * TyparInstantiation -> unit) * (unit -> unit) /// Resolve a long identifier occurring in an expression position. /// diff --git a/src/Compiler/Checking/NameResolution.fsi b/src/Compiler/Checking/NameResolution.fsi index aad74331295..3683d2846da 100644 --- a/src/Compiler/Checking/NameResolution.fsi +++ b/src/Compiler/Checking/NameResolution.fsi @@ -140,12 +140,14 @@ type Item = /// This includes backticks, parens etc. member DisplayName: string -/// Pairs an Item with a TyparInst showing how generic type variables of the item are instantiated at +/// Pairs an Item with a TyparInstantiation showing how generic type variables of the item are instantiated at /// a particular usage point. [] -type ItemWithInst = { Item: Item; TyparInst: TyparInst } +type ItemWithInst = + { Item: Item + TyparInstantiation: TyparInstantiation } -val (|ItemWithInst|): ItemWithInst -> Item * TyparInst +val (|ItemWithInst|): ItemWithInst -> Item * TyparInstantiation val ItemWithNoInst: Item -> ItemWithInst /// Represents a record field resolution and the information if the usage is deprecated. @@ -458,11 +460,12 @@ type ITypecheckResultsSink = /// Record that a name resolution occurred at a specific location in the source abstract NotifyNameResolution: - pos * Item * TyparInst * ItemOccurence * NameResolutionEnv * AccessorDomain * range * bool -> unit + pos * Item * TyparInstantiation * ItemOccurence * NameResolutionEnv * AccessorDomain * range * bool -> unit /// Record that a method group name resolution occurred at a specific location in the source abstract NotifyMethodGroupNameResolution: - pos * Item * Item * TyparInst * ItemOccurence * NameResolutionEnv * AccessorDomain * range * bool -> unit + pos * Item * Item * TyparInstantiation * ItemOccurence * NameResolutionEnv * AccessorDomain * range * bool -> + unit /// Record that a printf format specifier occurred at a specific location in the source abstract NotifyFormatSpecifierLocation: range * int -> unit @@ -522,15 +525,17 @@ val internal CallEnvSink: TcResultsSink -> range * NameResolutionEnv * AccessorD /// Report a specific name resolution at a source range val internal CallNameResolutionSink: - TcResultsSink -> range * NameResolutionEnv * Item * TyparInst * ItemOccurence * AccessorDomain -> unit + TcResultsSink -> range * NameResolutionEnv * Item * TyparInstantiation * ItemOccurence * AccessorDomain -> unit /// Report a specific method group name resolution at a source range val internal CallMethodGroupNameResolutionSink: - TcResultsSink -> range * NameResolutionEnv * Item * Item * TyparInst * ItemOccurence * AccessorDomain -> unit + TcResultsSink -> + range * NameResolutionEnv * Item * Item * TyparInstantiation * ItemOccurence * AccessorDomain -> + unit /// Report a specific name resolution at a source range, replacing any previous resolutions val internal CallNameResolutionSinkReplacing: - TcResultsSink -> range * NameResolutionEnv * Item * TyparInst * ItemOccurence * AccessorDomain -> unit + TcResultsSink -> range * NameResolutionEnv * Item * TyparInstantiation * ItemOccurence * AccessorDomain -> unit /// Report a specific name resolution at a source range val internal CallExprHasTypeSink: TcResultsSink -> range * NameResolutionEnv * TType * AccessorDomain -> unit @@ -723,8 +728,8 @@ type AfterResolution = /// a specific override. The 'Item option' contains the candidate overrides. | RecordResolution of Item option * - (TyparInst -> unit) * - (MethInfo * PropInfo option * TyparInst -> unit) * + (TyparInstantiation -> unit) * + (MethInfo * PropInfo option * TyparInstantiation -> unit) * (unit -> unit) /// Resolve a long identifier occurring in an expression position. diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index 7a2312dff16..49063183b01 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1112,7 +1112,7 @@ module PrintTypes = let layoutOfValReturnType denv (v: ValRef) = match v.ValReprInfo with | None -> - let _, tau = v.TypeScheme + let tau = v.TauType let _argTysl, retTy = stripFunTy denv.g tau layoutReturnType denv SimplifyTypes.typeSimplificationInfo0 retTy | Some (ValReprInfo(_typars, argInfos, _retInfo)) -> @@ -1303,7 +1303,7 @@ module PrintTastMemberOrVals = let prettyTyparInst, valL = match vref.MemberInfo with | None -> - let tps, tau = vref.TypeScheme + let tps, tau = vref.GeneralizedType // adjust the type in case this is the 'this' pointer stored in a reference cell let tau = StripSelfRefCell(denv.g, vref.BaseOrThisInfo, tau) @@ -1422,7 +1422,7 @@ module InfoMemberPrinting = let layout = layout ^^ paramsL let retL = - let retTy = minfo.GetFSharpReturnTy(amap, m, minst) + let retTy = minfo.GetFSharpReturnType(amap, m, minst) WordL.arrow ^^ PrintTypes.layoutType denv retTy @@ -1434,7 +1434,7 @@ module InfoMemberPrinting = // Container(argName1: argType1, ..., argNameN: argTypeN) : retType // Container.Method(argName1: argType1, ..., argNameN: argTypeN) : retType let layoutMethInfoCSharpStyle amap m denv (minfo: MethInfo) minst = - let retTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst) + let retTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnType(amap, m, minst) let layout = if minfo.IsExtensionMember then LeftL.leftParen ^^ wordL (tagKeyword (FSComp.SR.typeInfoExtension())) ^^ RightL.rightParen @@ -2186,9 +2186,10 @@ module InferredSigPrinting = open PrintTypes /// Layout the inferred signature of a compilation unit - let layoutInferredSigOfModuleExpr showHeader denv infoReader ad m expr = + let layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m expr = let (@@*) = if denv.printVerboseSignatures then (@@----) else (@@--) + let rec isConcreteNamespace x = match x with | TMDefRec(_, _opens, tycons, mbinds, _) -> @@ -2197,13 +2198,8 @@ module InferredSigPrinting = | TMDefDo _ -> true | TMDefOpens _ -> false | TMDefs defs -> defs |> List.exists isConcreteNamespace - | TMWithSig(ModuleOrNamespaceContentsWithSig(_, def, _)) -> isConcreteNamespace def - - let rec imexprLP denv (ModuleOrNamespaceContentsWithSig(_, def, _)) = imdefL denv def - and imexprL denv (ModuleOrNamespaceContentsWithSig(mty, def, m)) = imexprLP denv (ModuleOrNamespaceContentsWithSig(mty, def, m)) - - and imdefsL denv x = aboveListL (x |> List.map (imdefL denv)) + let rec imdefsL denv x = aboveListL (x |> List.map (imdefL denv)) and imdefL denv x = let filterVal (v: Val) = not v.IsCompilerGenerated && Option.isNone v.MemberInfo @@ -2245,8 +2241,6 @@ module InferredSigPrinting = | TMDefDo _ -> emptyL - | TMWithSig mexpr -> imexprLP denv mexpr - and imbindL denv (mspec, def) = let innerPath = (fullCompPathOfModuleOrNamespace mspec).AccessPath let outerPath = mspec.CompilationPath.AccessPath @@ -2306,7 +2300,8 @@ module InferredSigPrinting = else modNameEqualsL @@* basic layoutXmlDoc denv true mspec.XmlDoc basicL - imexprL denv expr + + imdefL denv expr //-------------------------------------------------------------------------- @@ -2391,7 +2386,7 @@ let prettyLayoutOfPropInfoFreeStyle g amap m denv d = InfoMemberPrinting.prettyL /// Convert a MethInfo to a string let stringOfMethInfo infoReader m denv minfo = - bufs (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf minfo) + buildString (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf minfo) /// Convert MethInfos to lines separated by newline including a newline as the first character let multiLineStringOfMethInfos infoReader m denv minfos = @@ -2401,7 +2396,7 @@ let multiLineStringOfMethInfos infoReader m denv minfos = |> String.concat "" /// Convert a ParamData to a string -let stringOfParamData denv paramData = bufs (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData) +let stringOfParamData denv paramData = buildString (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData) let layoutOfParamData denv paramData = InfoMemberPrinting.layoutParamData denv paramData @@ -2444,7 +2439,8 @@ let stringOfFSAttrib denv x = x |> PrintTypes.layoutAttrib denv |> squareAngleL let stringOfILAttrib denv x = x |> PrintTypes.layoutILAttrib denv |> squareAngleL |> showL -let layoutInferredSigOfModuleExpr showHeader denv infoReader ad m expr = InferredSigPrinting.layoutInferredSigOfModuleExpr showHeader denv infoReader ad m expr +let layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents = + InferredSigPrinting.layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents let prettyLayoutOfValOrMember denv infoReader typarInst v = PrintTastMemberOrVals.prettyLayoutOfValOrMember denv infoReader typarInst v @@ -2518,14 +2514,14 @@ let minimalStringsOfTwoTypes denv t1 t2= // Note: Always show imperative annotations when comparing value signatures let minimalStringsOfTwoValues denv infoReader v1 v2= let denvMin = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=false } - let min1 = bufs (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v1) - let min2 = bufs (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v2) + let min1 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v1) + let min2 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v2) if min1 <> min2 then (min1, min2) else let denvMax = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=true } - let max1 = bufs (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v1) - let max2 = bufs (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v2) + let max1 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v1) + let max2 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v2) max1, max2 let minimalStringOfType denv ty = diff --git a/src/Compiler/Checking/NicePrint.fsi b/src/Compiler/Checking/NicePrint.fsi index bfec076c188..c9df76a87a7 100644 --- a/src/Compiler/Checking/NicePrint.fsi +++ b/src/Compiler/Checking/NicePrint.fsi @@ -35,7 +35,7 @@ val prettyLayoutOfMemberSig: denv: DisplayEnv -> (Typar * TType) list * string * Typars * (TType * ArgReprInfo) list list * TType -> Layout val prettyLayoutOfUncurriedSig: - denv: DisplayEnv -> argInfos: TyparInst -> tau: UncurriedArgInfos -> (TType -> TyparInst * Layout) + denv: DisplayEnv -> argInfos: TyparInstantiation -> tau: UncurriedArgInfos -> (TType -> TyparInstantiation * Layout) val prettyLayoutsOfUnresolvedOverloading: denv: DisplayEnv -> @@ -51,7 +51,11 @@ val outputValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os: StringB val stringValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> x: ValRef -> string val layoutQualifiedValOrMember: - denv: DisplayEnv -> infoReader: InfoReader -> typarInst: TyparInst -> v: ValRef -> TyparInst * Layout + denv: DisplayEnv -> + infoReader: InfoReader -> + typarInst: TyparInstantiation -> + v: ValRef -> + TyparInstantiation * Layout val outputQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> v: ValRef -> unit @@ -66,9 +70,9 @@ val prettyLayoutOfMethInfoFreeStyle: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> - typarInst: TyparInst -> + typarInst: TyparInstantiation -> minfo: MethInfo -> - TyparInst * Layout + TyparInstantiation * Layout val prettyLayoutOfPropInfoFreeStyle: g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> d: PropInfo -> Layout @@ -122,17 +126,21 @@ val stringOfFSAttrib: denv: DisplayEnv -> x: Attrib -> string val stringOfILAttrib: denv: DisplayEnv -> ILType * ILAttribElem list -> string -val layoutInferredSigOfModuleExpr: +val layoutImpliedSignatureOfModuleOrNamespace: showHeader: bool -> denv: DisplayEnv -> infoReader: InfoReader -> ad: AccessorDomain -> m: range -> - expr: ModuleOrNamespaceContentsWithSig -> + contents: ModuleOrNamespaceContents -> Layout val prettyLayoutOfValOrMember: - denv: DisplayEnv -> infoReader: InfoReader -> typarInst: TyparInst -> v: ValRef -> TyparInst * Layout + denv: DisplayEnv -> + infoReader: InfoReader -> + typarInst: TyparInstantiation -> + v: ValRef -> + TyparInstantiation * Layout val prettyLayoutOfValOrMemberNoInst: denv: DisplayEnv -> infoReader: InfoReader -> v: ValRef -> Layout @@ -141,7 +149,9 @@ val prettyLayoutOfMemberNoInstShort: denv: DisplayEnv -> v: Val -> Layout val layoutOfValReturnType: denv: DisplayEnv -> v: ValRef -> Layout val prettyLayoutOfInstAndSig: - denv: DisplayEnv -> TyparInst * TTypes * TType -> TyparInst * (TTypes * TType) * (Layout list * Layout) * Layout + denv: DisplayEnv -> + TyparInstantiation * TTypes * TType -> + TyparInstantiation * (TTypes * TType) * (Layout list * Layout) * Layout val minimalStringsOfTwoTypes: denv: DisplayEnv -> t1: TType -> t2: TType -> string * string * string diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index 5c60efab813..521d5ea0e63 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -71,15 +71,15 @@ type Pattern = | TPat_isinst(_, _, _, m) -> m | TPat_error m -> m -and PatternValBinding = PBind of Val * TypeScheme +and PatternValBinding = PatternValBinding of Val * GeneralizedType -and TypedMatchClause = - | TClause of Pattern * Expr option * DecisionTreeTarget * range - member c.GuardExpr = let (TClause(_, whenOpt, _, _)) = c in whenOpt - member c.Pattern = let (TClause(p, _, _, _)) = c in p - member c.Range = let (TClause(_, _, _, m)) = c in m - member c.Target = let (TClause(_, _, tg, _)) = c in tg - member c.BoundVals = let (TClause(_p, _whenOpt, TTarget(vs, _, _), _m)) = c in vs +and MatchClause = + | MatchClause of Pattern * Expr option * DecisionTreeTarget * range + member c.GuardExpr = let (MatchClause(_, whenOpt, _, _)) = c in whenOpt + member c.Pattern = let (MatchClause(p, _, _, _)) = c in p + member c.Range = let (MatchClause(_, _, _, m)) = c in m + member c.Target = let (MatchClause(_, _, tg, _)) = c in tg + member c.BoundVals = let (MatchClause(_p, _whenOpt, TTarget(vs, _, _), _m)) = c in vs let debug = false @@ -104,9 +104,9 @@ let debug = false //--------------------------------------------------------------------------- type SubExprOfInput = - | SubExpr of (TyparInst -> Expr -> Expr) * (Expr * Val) + | SubExpr of (TyparInstantiation -> Expr -> Expr) * (Expr * Val) -let BindSubExprOfInput g amap gtps (PBind(v, tyscheme)) m (SubExpr(accessf, (ve2, v2))) = +let BindSubExprOfInput g amap gtps (PatternValBinding(v, tyscheme)) m (SubExpr(accessf, (ve2, v2))) = let e' = if isNil gtps then accessf [] ve2 @@ -984,19 +984,19 @@ let rec isPatternDisjunctive inpPat = let getDiscrim (EdgeDiscrim(_, discrim, _)) = discrim let CompilePatternBasic - (g: TcGlobals) denv amap tcVal infoReader exprm matchm + (g: TcGlobals) denv amap tcVal infoReader mExpr mMatch warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, _origInputExprOpt: Expr option) - (typedClauses: TypedMatchClause list) + (clauses: MatchClause list) inputTy resultTy = // Add the targets to a match builder. // Note the input expression has already been evaluated and saved into a variable, // hence no need for a new sequence point. - let matchBuilder = MatchBuilder (DebugPointAtBinding.NoneAtInvisible, exprm) - typedClauses |> List.iter (fun c -> matchBuilder.AddTarget c.Target |> ignore) + let matchBuilder = MatchBuilder (DebugPointAtBinding.NoneAtInvisible, mExpr) + clauses |> List.iter (fun clause -> matchBuilder.AddTarget clause.Target |> ignore) // Add the incomplete or rethrow match clause on demand, // printing a warning if necessary (only if it is ever exercised). @@ -1010,13 +1010,13 @@ let CompilePatternBasic match actionOnFailure with | ThrowIncompleteMatchException | IgnoreWithWarning -> let ignoreWithWarning = (actionOnFailure = IgnoreWithWarning) - match ShowCounterExample g denv matchm refuted with + match ShowCounterExample g denv mMatch refuted with | Some(text, failingWhenClause, true) -> - warning (EnumMatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm)) + warning (EnumMatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), mMatch)) | Some(text, failingWhenClause, false) -> - warning (MatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm)) + warning (MatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), mMatch)) | None -> - warning (MatchIncomplete(ignoreWithWarning, None, matchm)) + warning (MatchIncomplete(ignoreWithWarning, None, mMatch)) | _ -> () @@ -1024,22 +1024,22 @@ let CompilePatternBasic match actionOnFailure with | FailFilter -> // Return 0 from the .NET exception filter. - mkInt g matchm 0 + mkInt g mMatch 0 | Rethrow -> // Rethrow unmatched try-with exn. No sequence point at the target since its not real code. - mkReraise matchm resultTy + mkReraise mMatch resultTy | Throw -> let findMethInfo ty isInstance name (sigTys: TType list) = - TryFindIntrinsicMethInfo infoReader matchm AccessorDomain.AccessibleFromEverywhere name ty + TryFindIntrinsicMethInfo infoReader mMatch AccessorDomain.AccessibleFromEverywhere name ty |> List.tryFind (fun methInfo -> methInfo.IsInstance = isInstance && ( - match methInfo.GetParamTypes(amap, matchm, []) with + match methInfo.GetParamTypes(amap, mMatch, []) with | [] -> false | argTysList -> - let argTys = (argTysList |> List.reduce (@)) @ [ methInfo.GetFSharpReturnTy (amap, matchm, []) ] + let argTys = (argTysList |> List.reduce (@)) @ [ methInfo.GetFSharpReturnType (amap, mMatch, []) ] if argTys.Length <> sigTys.Length then false else @@ -1061,27 +1061,27 @@ let CompilePatternBasic match Option.map2 (fun x y -> x,y) ediCaptureMethInfo ediThrowMethInfo with | None -> - mkThrow matchm resultTy (exprForVal matchm origInputVal) + mkThrow mMatch resultTy (exprForVal mMatch origInputVal) | Some (ediCaptureMethInfo, ediThrowMethInfo) -> let edi, _ = - BuildMethodCall tcVal g amap NeverMutates matchm false - ediCaptureMethInfo ValUseFlag.NormalValUse [] [] [ (exprForVal matchm origInputVal) ] + BuildMethodCall tcVal g amap NeverMutates mMatch false + ediCaptureMethInfo ValUseFlag.NormalValUse [] [] [ (exprForVal mMatch origInputVal) ] let e, _ = - BuildMethodCall tcVal g amap NeverMutates matchm false + BuildMethodCall tcVal g amap NeverMutates mMatch false ediThrowMethInfo ValUseFlag.NormalValUse [] [edi] [ ] - mkCompGenSequential matchm e (mkDefault (matchm, resultTy)) + mkCompGenSequential mMatch e (mkDefault (mMatch, resultTy)) | ThrowIncompleteMatchException -> - mkThrow matchm resultTy + mkThrow mMatch resultTy (mkExnExpr(g.MatchFailureException_tcr, - [ mkString g matchm matchm.FileName - mkInt g matchm matchm.StartLine - mkInt g matchm matchm.StartColumn], matchm)) + [ mkString g mMatch mMatch.FileName + mkInt g mMatch mMatch.StartLine + mkInt g mMatch mMatch.StartColumn], mMatch)) | IgnoreWithWarning -> - mkUnit g matchm + mkUnit g mMatch // We don't emit a sequence point at any of the above cases because they don't correspond to user code. // @@ -1090,7 +1090,7 @@ let CompilePatternBasic // That sequence point will have the pattern variables bound, which is exactly what we want. let tg = TTarget([], throwExpr, None) let _ = matchBuilder.AddTarget tg - let clause = TClause(TPat_wild matchm, None, tg, matchm) + let clause = MatchClause(TPat_wild mMatch, None, tg, mMatch) incompleteMatchClauseOnce <- Some clause clause @@ -1098,7 +1098,7 @@ let CompilePatternBasic // Helpers to get the variables bound at a target. // We conceptually add a dummy clause that will always succeed with a "throw". - let clausesA = Array.ofList typedClauses + let clausesA = Array.ofList clauses let nClauses = clausesA.Length let GetClause i refuted = if i < nClauses then @@ -1154,7 +1154,7 @@ let CompilePatternBasic // OK, build the whole tree and whack on the binding if any let finalDecisionTree = let inpExprToSwitch = (match inpExprOpt with Some vExpr -> vExpr | None -> GetSubExprOfInput subexpr) - let tree = BuildSwitch inpExprOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt matchm + let tree = BuildSwitch inpExprOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt mMatch match bindOpt with | None -> tree | Some bind -> TDBind (bind, tree) @@ -1223,7 +1223,7 @@ let CompilePatternBasic if origInputVal.IsMemberOrModuleBinding then AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData let argExpr = GetSubExprOfInput subexpr - let appExpr = mkIsInst tgty argExpr matchm + let appExpr = mkIsInst tgty argExpr mMatch Some vExpr, Some(mkInvisibleBind v appExpr) // Any match on a struct union must take the address of its input. @@ -1236,7 +1236,7 @@ let CompilePatternBasic match argExpr, _origInputExprOpt with | Expr.Val (v1, _, _), Some origInputExpr when valEq origInputVal v1.Deref && IsCopyableInputExpr origInputExpr -> origInputExpr | _ -> argExpr - let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g true false NeverMutates argExpr None matchm + let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g true false NeverMutates argExpr None mMatch match vOpt with | None -> Some addrExp, None | Some (v, e) -> @@ -1259,7 +1259,7 @@ let CompilePatternBasic if origInputVal.IsMemberOrModuleBinding then AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData let argExpr = GetSubExprOfInput subexpr - let appExpr = mkIsInst ucaseTy argExpr matchm + let appExpr = mkIsInst ucaseTy argExpr mMatch Some vExpr, Some (mkInvisibleBind v appExpr) #endif @@ -1273,7 +1273,7 @@ let CompilePatternBasic let argExpr = GetSubExprOfInput subexpr let appExpr = mkApps g ((activePatExpr, tyOfExpr g activePatExpr), [], [argExpr], m) - let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g isStructRetTy false NeverMutates appExpr None matchm + let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g isStructRetTy false NeverMutates appExpr None mMatch match vOpt with | None -> let v, vExpr = mkCompGenLocal m ("activePatternResult" + string (newUnique())) resTy @@ -1364,7 +1364,7 @@ let CompilePatternBasic isMemOfActives path active && let _, patAtActive = lookupActive path active match getDiscrimOfPattern patAtActive with - | Some discrim -> List.exists (isDiscrimSubsumedBy g amap exprm discrim) simulSetOfDiscrims + | Some discrim -> List.exists (isDiscrimSubsumedBy g amap mExpr discrim) simulSetOfDiscrims | None -> false match simulSetOfDiscrims with @@ -1373,7 +1373,7 @@ let CompilePatternBasic | DecisionTreeTest.Const (Const.SByte _) :: _ when simulSetOfCases.Length = 256 -> None | DecisionTreeTest.Const Const.Unit :: _ -> None | DecisionTreeTest.UnionCase (ucref, _) :: _ when simulSetOfCases.Length = ucref.TyconRef.UnionCasesArray.Length -> None - | DecisionTreeTest.ActivePatternCase _ :: _ -> error(InternalError("DecisionTreeTest.ActivePatternCase should have been eliminated", matchm)) + | DecisionTreeTest.ActivePatternCase _ :: _ -> error(InternalError("DecisionTreeTest.ActivePatternCase should have been eliminated", mMatch)) | _ -> let fallthroughPathFrontiers = List.filter (isRefuted >> not) fallthroughPathFrontiers @@ -1421,7 +1421,7 @@ let CompilePatternBasic let ucref = mkChoiceCaseRef g m aparity idx // TODO: In the future we will want active patterns to be able to return struct-unions // In that eventuality, we need to check we are taking the address correctly - mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt, ucref, instTypes tpinst resTys, j, exprm) + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt, ucref, instTypes tpinst resTys, j, mExpr) mkSubFrontiers path subAccess newActives [p] (fun path j -> PathQuery(path, int64 j)) elif hasParam then @@ -1437,9 +1437,9 @@ let CompilePatternBasic let expr = Option.get inpExprOpt if isStructRetTy then // In this case, the inpExprOpt is already an address-of expression - mkUnionCaseFieldGetProvenViaExprAddr (expr, mkValueSomeCase g, instTypes tpinst resTys, 0, exprm) + mkUnionCaseFieldGetProvenViaExprAddr (expr, mkValueSomeCase g, instTypes tpinst resTys, 0, mExpr) else - mkUnionCaseFieldGetUnprovenViaExprAddr (expr, mkSomeCase g, instTypes tpinst resTys, 0, exprm) + mkUnionCaseFieldGetUnprovenViaExprAddr (expr, mkSomeCase g, instTypes tpinst resTys, 0, mExpr) mkSubFrontiers path subAccess newActives [p] (fun path j -> PathQuery(path, int64 j)) else // Successful active patterns don't refute other patterns @@ -1450,13 +1450,13 @@ let CompilePatternBasic | DecisionTreeTest.UnionCase (ucref2, tinst) when g.unionCaseRefEq ucref1 ucref2 -> let subAccess j tpinst exprIn = match resPostBindOpt with - | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e, ucref1, tinst, j, exprm) + | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e, ucref1, tinst, j, mExpr) | None -> let exprIn = match inpExprOpt with | Some addrExp -> addrExp | None -> accessf tpinst exprIn - mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn, ucref1, instTypes tpinst tyargs, j, exprm) + mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn, ucref1, instTypes tpinst tyargs, j, mExpr) mkSubFrontiers path subAccess newActives argpats (fun path j -> PathUnionConstr(path, ucref1, tyargs, j)) | DecisionTreeTest.UnionCase _ -> @@ -1470,7 +1470,7 @@ let CompilePatternBasic match discrim with | DecisionTreeTest.ArrayLength (n, _) -> if List.length argpats = n then - let subAccess j tpinst exprIn = mkCallArrayGet g exprm ty (accessf tpinst exprIn) (mkInt g exprm j) + let subAccess j tpinst exprIn = mkCallArrayGet g mExpr ty (accessf tpinst exprIn) (mkInt g mExpr j) mkSubFrontiers path subAccess newActives argpats (fun path j -> PathArray(path, ty, List.length argpats, j)) else // Successful length tests refute all other lengths @@ -1487,7 +1487,7 @@ let CompilePatternBasic match discrim with | DecisionTreeTest.IsInst (_srcTy, tgtTy2) -> if typeEquiv g tgtTy1 tgtTy2 then - let subAccess j tpinst exprIn = mkExnCaseFieldGet(accessf tpinst exprIn, ecref, j, exprm) + let subAccess j tpinst exprIn = mkExnCaseFieldGet(accessf tpinst exprIn, ecref, j, mExpr) mkSubFrontiers path subAccess newActives argpats (fun path j -> PathExnConstr(path, ecref, j)) else // Successful tests against F# exception definitions refute all other non-equivalent type tests @@ -1519,7 +1519,7 @@ let CompilePatternBasic | Some e -> e | _ -> // Otherwise call the helper - mkCallUnboxFast g exprm (instType tpinst tgtTy1) (accessf tpinst exprIn) + mkCallUnboxFast g mExpr (instType tpinst tgtTy1) (accessf tpinst exprIn) let subActive = Active(path, SubExpr(subAccess, ve), pbind) let subActives = BindProjectionPattern subActive (newActives, valMap) mkFrontiers subActives i @@ -1594,7 +1594,7 @@ let CompilePatternBasic BindProjectionPattern (Active(inpPath, inpExpr, leftPat)) (accActive, accValMap.Add asVal subExpr ) | TPat_tuple(tupInfo, tupFieldPats, tyargs, _m) -> - let subAccess j tpinst subExpr = mkTupleFieldGet g (tupInfo, inpAccess tpinst subExpr, instTypes tpinst tyargs, j, exprm) + let subAccess j tpinst subExpr = mkTupleFieldGet g (tupInfo, inpAccess tpinst subExpr, instTypes tpinst tyargs, j, mExpr) let pathBuilder path j = PathTuple(path, tyargs, j) let newActives = List.mapi (mkSubActive pathBuilder subAccess) tupFieldPats BindProjectionPatterns newActives activeState @@ -1602,7 +1602,7 @@ let CompilePatternBasic | TPat_recd(tcref, tinst, recdFieldPats, _m) -> let newActives = (recdFieldPats, tcref.TrueInstanceFieldsAsRefList) ||> List.mapi2 (fun j recdFieldPat fref -> - let subAccess fref _j tpinst exprIn = mkRecdFieldGet g (inpAccess tpinst exprIn, fref, instTypes tpinst tinst, exprm) + let subAccess fref _j tpinst exprIn = mkRecdFieldGet g (inpAccess tpinst exprIn, fref, instTypes tpinst tinst, mExpr) let pathBuilder path j = PathRecd(path, tcref, tinst, j) mkSubActive pathBuilder (subAccess fref) j recdFieldPat) BindProjectionPatterns newActives activeState @@ -1636,7 +1636,7 @@ let CompilePatternBasic // The setup routine of the match compiler. let frontiers = - ((typedClauses + ((clauses |> List.mapi (fun i c -> let initialSubExpr = SubExpr((fun _ x -> x), (exprForVal origInputVal.Range origInputVal, origInputVal)) let initialActive = Active(PathEmpty inputTy, initialSubExpr, c.Pattern) @@ -1658,7 +1658,7 @@ let CompilePatternBasic if warnOnUnused then let used = HashSet<_>(accTargetsOfDecisionTree dtree [], HashIdentity.Structural) - typedClauses |> List.iteri (fun i c -> + clauses |> List.iteri (fun i c -> if not (used.Contains i) then warning (RuleNeverMatched c.Range)) dtree, targets @@ -1716,7 +1716,7 @@ let CompilePatternBasic // on each path, one switch on C/D // So disjunction alone isn't considered problematic, but in combination with 'when' patterns -let isProblematicClause (clause: TypedMatchClause) = +let isProblematicClause (clause: MatchClause) = let ips = seq { yield! investigationPoints clause.Pattern @@ -1728,15 +1728,15 @@ let isProblematicClause (clause: TypedMatchClause) = // We don't mind about the last logical decision point ips.Length > 0 && Array.exists id ips[0..ips.Length-2] -let rec CompilePattern g denv amap tcVal infoReader exprm matchm warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: TypedMatchClause list) inputTy resultTy = +let rec CompilePattern g denv amap tcVal infoReader mExpr mMatch warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: MatchClause list) inputTy resultTy = match clausesL with | _ when List.exists isProblematicClause clausesL -> // First make sure we generate at least some of the obvious incomplete match warnings. let warnOnUnused = false // we can't turn this on since we're pretending all partials fail in order to control the complexity of this. let warnOnIncomplete = true - let clausesPretendAllPartialFail = clausesL |> List.collect (fun (TClause(p, whenOpt, tg, m)) -> [TClause(erasePartialPatterns p, whenOpt, tg, m)]) - let _ = CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesPretendAllPartialFail inputTy resultTy + let clausesPretendAllPartialFail = clausesL |> List.collect (fun (MatchClause(p, whenOpt, tg, m)) -> [MatchClause(erasePartialPatterns p, whenOpt, tg, m)]) + let _ = CompilePatternBasic g denv amap tcVal infoReader mExpr mMatch warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesPretendAllPartialFail inputTy resultTy let warnOnIncomplete = false // Partial and when clauses cause major code explosion if treated naively @@ -1744,7 +1744,7 @@ let rec CompilePattern g denv amap tcVal infoReader exprm matchm warnOnUnused a let rec atMostOneProblematicClauseAtATime clauses = match List.takeUntil isProblematicClause clauses with | l, [] -> - CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) l inputTy resultTy + CompilePatternBasic g denv amap tcVal infoReader mExpr mMatch warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) l inputTy resultTy | l, h :: t -> // Add the problematic clause. doGroupWithAtMostOneProblematic (l @ [h]) t @@ -1754,15 +1754,15 @@ let rec CompilePattern g denv amap tcVal infoReader exprm matchm warnOnUnused a let decisionTree, targets = atMostOneProblematicClauseAtATime rest // Make the expression that represents the remaining cases of the pattern match. - let expr = mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible exprm matchm resultTy decisionTree targets + let expr = mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy decisionTree targets // Make the clause that represents the remaining cases of the pattern match - let clauseForRestOfMatch = TClause(TPat_wild matchm, None, TTarget(List.empty, expr, None), matchm) + let clauseForRestOfMatch = MatchClause(TPat_wild mMatch, None, TTarget(List.empty, expr, None), mMatch) - CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (group @ [clauseForRestOfMatch]) inputTy resultTy + CompilePatternBasic g denv amap tcVal infoReader mExpr mMatch warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (group @ [clauseForRestOfMatch]) inputTy resultTy atMostOneProblematicClauseAtATime clausesL | _ -> - CompilePatternBasic g denv amap tcVal infoReader exprm matchm warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy + CompilePatternBasic g denv amap tcVal infoReader mExpr mMatch warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy diff --git a/src/Compiler/Checking/PatternMatchCompilation.fsi b/src/Compiler/Checking/PatternMatchCompilation.fsi index d7b613ed1c1..bc52ae83832 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fsi +++ b/src/Compiler/Checking/PatternMatchCompilation.fsi @@ -40,9 +40,9 @@ type Pattern = member Range: range -and PatternValBinding = PBind of Val * TypeScheme +and PatternValBinding = PatternValBinding of Val * GeneralizedType -and TypedMatchClause = TClause of Pattern * Expr option * DecisionTreeTarget * range +and MatchClause = MatchClause of Pattern * Expr option * DecisionTreeTarget * range val ilFieldToTastConst: ILFieldInit -> Const @@ -62,7 +62,7 @@ val internal CompilePattern: ActionOnFailure -> Val * Typars * Expr option -> // input type-checked syntax of pattern matching - TypedMatchClause list -> + MatchClause list -> // input type TType -> // result type diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 5d2179339fc..87eb68c7d80 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2564,14 +2564,7 @@ let CheckEntityDefns cenv env tycons = // check modules //-------------------------------------------------------------------------- -let rec CheckModuleExpr cenv env x = - match x with - | ModuleOrNamespaceContentsWithSig(mty, def, _) -> - let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g def mty - let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } - CheckDefnInModule cenv env def - -and CheckDefnsInModule cenv env mdefs = +let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do CheckDefnInModule cenv env mdef @@ -2596,7 +2589,6 @@ and CheckDefnInModule cenv env mdef = CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e CheckExprNoByrefs cenv env e - | TMWithSig def -> CheckModuleExpr cenv env def | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = @@ -2609,7 +2601,12 @@ and CheckModuleSpec cenv env mbind = let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs -let CheckTopImpl (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, mexpr, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = +let CheckImplFileContents cenv env implFileTy implFileContents = + let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy + let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } + CheckDefnInModule cenv env implFileContents + +let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = let cenv = { g = g reportErrors = reportErrors @@ -2653,7 +2650,7 @@ let CheckTopImpl (g, amap, reportErrors, infoReader, internalsVisibleToPaths, vi isInAppExpr = false resumableCode = Resumable.None } - CheckModuleExpr cenv env mexpr + CheckImplFileContents cenv env implFileTy implFileContents CheckAttribs cenv env extraAttribs if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then diff --git a/src/Compiler/Checking/PostInferenceChecks.fsi b/src/Compiler/Checking/PostInferenceChecks.fsi index 21be554d5dc..6e289af71c8 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fsi +++ b/src/Compiler/Checking/PostInferenceChecks.fsi @@ -11,7 +11,7 @@ open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TcGlobals /// Perform the checks on the TAST for a file after type inference is complete. -val CheckTopImpl: +val CheckImplFile: g: TcGlobals * amap: ImportMap * reportErrors: bool * @@ -20,7 +20,8 @@ val CheckTopImpl: viewCcu: CcuThunk * tcValF: ConstraintSolver.TcValF * denv: DisplayEnv * - mexpr: ModuleOrNamespaceContentsWithSig * + implFileTy: ModuleOrNamespaceType * + implFileContents: ModuleOrNamespaceContents * extraAttribs: Attribs * (bool * bool) * isInternalTestSpanStackReferring: bool -> diff --git a/src/Compiler/Checking/QuotationTranslator.fs b/src/Compiler/Checking/QuotationTranslator.fs index 050c7601157..fe05b73ac0a 100644 --- a/src/Compiler/Checking/QuotationTranslator.fs +++ b/src/Compiler/Checking/QuotationTranslator.fs @@ -585,8 +585,8 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let methArgTypesR = ConvTypes cenv env m argTys let argsR = ConvExprs cenv env args let objR = - QP.mkCtorCall( { ctorParent = parentTyconR - ctorArgTypes = methArgTypesR }, + QP.mkCtorCall( { Parent = parentTyconR + ArgTypes = methArgTypesR }, [], argsR) let exnTypeR = ConvType cenv env m g.exn_ty QP.mkCoerce(exnTypeR, objR) @@ -862,18 +862,18 @@ and ConvObjectModelCallCore cenv env m (isPropGet, isPropSet, isNewObj, parentTy elif isNewObj then assert witnessArgTypesR.IsEmpty let ctorR : QuotationPickler.CtorData = - { ctorParent = parentTyconR - ctorArgTypes = methArgTypesR } + { Parent = parentTyconR + ArgTypes = methArgTypesR } QP.mkCtorCall(ctorR, tyargsR, allArgsR) elif witnessArgTypesR.IsEmpty then let methR : QuotationPickler.MethodData = - { methParent = parentTyconR - methArgTypes = methArgTypesR - methRetType = methRetTypeR - methName = methName - numGenericArgs = numGenericArgs } + { Parent = parentTyconR + ArgTypes = methArgTypesR + RetType = methRetTypeR + Name = methName + NumGenericArgs = numGenericArgs } QP.mkMethodCall(methR, tyargsR, allArgsR) @@ -881,19 +881,19 @@ and ConvObjectModelCallCore cenv env m (isPropGet, isPropSet, isNewObj, parentTy // The old method entry point let methR: QuotationPickler.MethodData = - { methParent = parentTyconR - methArgTypes = methArgTypesR - methRetType = methRetTypeR - methName = methName - numGenericArgs = numGenericArgs } + { Parent = parentTyconR + ArgTypes = methArgTypesR + RetType = methRetTypeR + Name = methName + NumGenericArgs = numGenericArgs } // The witness-passing method entry point let methWR: QuotationPickler.MethodData = - { methParent = parentTyconR - methArgTypes = witnessArgTypesR @ methArgTypesR - methRetType = methRetTypeR - methName = ExtraWitnessMethodName methName - numGenericArgs = numGenericArgs } + { Parent = parentTyconR + ArgTypes = witnessArgTypesR @ methArgTypesR + RetType = methRetTypeR + Name = ExtraWitnessMethodName methName + NumGenericArgs = numGenericArgs } QP.mkMethodCallW(methR, methWR, List.length witnessArgTypesR, tyargsR, allArgsR) @@ -969,9 +969,12 @@ and ConvRecdFieldRef cenv (rfref: RecdFieldRef) m = rfref.FieldName (typR, nm) -and ConvVal cenv env (v: Val) = +and ConvVal cenv env (v: Val) : QuotationPickler.ValData = let tyR = ConvType cenv env v.Range v.Type - QP.freshVar (v.CompiledName cenv.g.CompilerGlobalState, tyR, v.IsMutable) + let name = v.CompiledName cenv.g.CompilerGlobalState + { Name = name + Type = tyR + IsMutable = v.IsMutable } and ConvTyparRef cenv env m (tp: Typar) = match env.tyvs.TryFind tp.Stamp with @@ -1284,15 +1287,15 @@ let ConvMethodBase cenv env (methName, v: Val) = if isNewObj then assert witnessArgTysR.IsEmpty QP.MethodBaseData.Ctor - { ctorParent = parentTyconR - ctorArgTypes = methArgTypesR } + { Parent = parentTyconR + ArgTypes = methArgTypesR } else QP.MethodBaseData.Method - { methParent = parentTyconR - methArgTypes = witnessArgTysR @ methArgTypesR - methRetType = methRetTypeR - methName = methName - numGenericArgs=numGenericArgs } + { Parent = parentTyconR + ArgTypes = witnessArgTysR @ methArgTypesR + RetType = methRetTypeR + Name = methName + NumGenericArgs=numGenericArgs } | _ when v.IsExtensionMember -> @@ -1306,11 +1309,11 @@ let ConvMethodBase cenv env (methName, v: Val) = let numGenericArgs = tps.Length QP.MethodBaseData.Method - { methParent = parentTyconR - methArgTypes = witnessArgTysR @ methArgTypesR - methRetType = methRetTypeR - methName = methName - numGenericArgs=numGenericArgs } + { Parent = parentTyconR + ArgTypes = witnessArgTysR @ methArgTypesR + RetType = methRetTypeR + Name = methName + NumGenericArgs = numGenericArgs } | _ -> let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v @@ -1352,7 +1355,7 @@ let ConvReflectedDefinition cenv methName v e = (fun witnessInfo e -> let ty = GenWitnessTy g witnessInfo let tyR = ConvType cenv env v.DefinitionRange ty - let vR = QuotationPickler.freshVar (witnessInfo.MemberName, tyR, false) + let vR = { Name = witnessInfo.MemberName; Type = tyR; IsMutable = false } QuotationPickler.mkLambda (vR, e)) witnessInfos astExpr diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index 8e31f63b248..f9d9b41b871 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -328,8 +328,8 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = elif implVal.LiteralValue <> sigVal.LiteralValue then (err denv FSComp.SR.ValueNotContainedMutabilityLiteralConstantValuesDiffer) elif implVal.IsTypeFunction <> sigVal.IsTypeFunction then (err denv FSComp.SR.ValueNotContainedMutabilityOneIsTypeFunction) else - let implTypars, atau = implVal.TypeScheme - let sigTypars, ftau = sigVal.TypeScheme + let implTypars, atau = implVal.GeneralizedType + let sigTypars, ftau = sigVal.GeneralizedType if implTypars.Length <> sigTypars.Length then (err {denv with showTyparBinding=true} FSComp.SR.ValueNotContainedMutabilityParameterCountsDiffer) else let aenv = aenv.BindEquivTypars implTypars sigTypars checkTypars m aenv implTypars sigTypars && diff --git a/src/Compiler/Checking/TypeHierarchy.fs b/src/Compiler/Checking/TypeHierarchy.fs index 2eec1c57ec6..12572e87d10 100644 --- a/src/Compiler/Checking/TypeHierarchy.fs +++ b/src/Compiler/Checking/TypeHierarchy.fs @@ -53,7 +53,7 @@ let GetSuperTypeOfType g amap m ty = let tinst = argsOfAppTy g ty match tdef.Extends with | None -> None - | Some ilty -> Some (RescopeAndImportILType scoref amap m tinst ilty) + | Some ilTy -> Some (RescopeAndImportILType scoref amap m tinst ilTy) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> if isFSharpObjModelTy g ty || isFSharpExceptionTy g ty then @@ -327,12 +327,12 @@ let ExistsHeadTypeInEntireHierarchy g amap m typeToSearchFrom tcrefToLookFor = ExistsInEntireHierarchyOfType (HasHeadType g tcrefToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom /// Read an Abstract IL type from metadata and convert to an F# type. -let ImportILTypeFromMetadata amap m scoref tinst minst ilty = - RescopeAndImportILType scoref amap m (tinst@minst) ilty +let ImportILTypeFromMetadata amap m scoref tinst minst ilTy = + RescopeAndImportILType scoref amap m (tinst@minst) ilTy /// Read an Abstract IL type from metadata, including any attributes that may affect the type itself, and convert to an F# type. -let ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst ilty getCattrs = - let ty = RescopeAndImportILType scoref amap m (tinst@minst) ilty +let ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst ilTy getCattrs = + let ty = RescopeAndImportILType scoref amap m (tinst@minst) ilTy // If the type is a byref and one of attributes from a return or parameter has IsReadOnly, then it's a inref. if isByrefTy amap.g ty && TryFindILAttribute amap.g.attrib_IsReadOnlyAttribute (getCattrs ()) then mkInByrefTy amap.g (destByrefTy amap.g ty) @@ -340,13 +340,13 @@ let ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst ilty getCat ty /// Get the parameter type of an IL method. -let ImportParameterTypeFromMetadata amap m ilty getCattrs scoref tinst mist = - ImportILTypeFromMetadataWithAttributes amap m scoref tinst mist ilty getCattrs +let ImportParameterTypeFromMetadata amap m ilTy getCattrs scoref tinst mist = + ImportILTypeFromMetadataWithAttributes amap m scoref tinst mist ilTy getCattrs /// Get the return type of an IL method, taking into account instantiations for type, return attributes and method generic parameters, and /// translating 'void' to 'None'. -let ImportReturnTypeFromMetadata amap m ilty getCattrs scoref tinst minst = - match ilty with +let ImportReturnTypeFromMetadata amap m ilTy getCattrs scoref tinst minst = + match ilTy with | ILType.Void -> None | retTy -> Some(ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst retTy getCattrs) diff --git a/src/Compiler/Checking/TypeHierarchy.fsi b/src/Compiler/Checking/TypeHierarchy.fsi index 4e840f765bb..225e6187477 100644 --- a/src/Compiler/Checking/TypeHierarchy.fsi +++ b/src/Compiler/Checking/TypeHierarchy.fsi @@ -117,7 +117,7 @@ val ExistsHeadTypeInEntireHierarchy: /// Read an Abstract IL type from metadata and convert to an F# type. val ImportILTypeFromMetadata: - amap: ImportMap -> m: range -> scoref: ILScopeRef -> tinst: TType list -> minst: TType list -> ilty: ILType -> TType + amap: ImportMap -> m: range -> scoref: ILScopeRef -> tinst: TType list -> minst: TType list -> ilTy: ILType -> TType /// Read an Abstract IL type from metadata, including any attributes that may affect the type itself, and convert to an F# type. val ImportILTypeFromMetadataWithAttributes: @@ -126,7 +126,7 @@ val ImportILTypeFromMetadataWithAttributes: scoref: ILScopeRef -> tinst: TType list -> minst: TType list -> - ilty: ILType -> + ilTy: ILType -> getCattrs: (unit -> ILAttributes) -> TType @@ -134,7 +134,7 @@ val ImportILTypeFromMetadataWithAttributes: val ImportParameterTypeFromMetadata: amap: ImportMap -> m: range -> - ilty: ILType -> + ilTy: ILType -> getCattrs: (unit -> ILAttributes) -> scoref: ILScopeRef -> tinst: TType list -> @@ -146,7 +146,7 @@ val ImportParameterTypeFromMetadata: val ImportReturnTypeFromMetadata: amap: ImportMap -> m: range -> - ilty: ILType -> + ilTy: ILType -> getCattrs: (unit -> ILAttributes) -> scoref: ILScopeRef -> tinst: TType list -> @@ -161,7 +161,7 @@ val ImportReturnTypeFromMetadata: /// /// Note: this now looks identical to constraint instantiation. -val CopyTyparConstraints: m: range -> tprefInst: TyparInst -> tporig: Typar -> TyparConstraint list +val CopyTyparConstraints: m: range -> tprefInst: TyparInstantiation -> tporig: Typar -> TyparConstraint list /// The constraints for each typar copied from another typar can only be fixed up once /// we have generated all the new constraints, e.g. f List, B :> List> ... @@ -171,4 +171,4 @@ val FixupNewTypars: tinst: TType list -> tpsorig: Typars -> tps: Typars -> - TyparInst * TTypes + TyparInstantiation * TTypes diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index a40ebb591be..fd06a46c2d7 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -456,7 +456,7 @@ let ImportILGenericParameters amap m scoref tinst (gps: ILGenericParameterDefs) let tptys = tps |> List.map mkTyparTy let importInst = tinst@tptys (tps, gps) ||> List.iter2 (fun tp gp -> - let constraints = gp.Constraints |> List.map (fun ilty -> TyparConstraint.CoercesTo(ImportILType amap m importInst (rescopeILType scoref ilty), m) ) + let constraints = gp.Constraints |> List.map (fun ilTy -> TyparConstraint.CoercesTo(ImportILType amap m importInst (rescopeILType scoref ilTy), m) ) let constraints = if gp.HasReferenceTypeConstraint then (TyparConstraint.IsReferenceType(m) :: constraints) else constraints let constraints = if gp.HasNotNullableValueTypeConstraint then (TyparConstraint.IsNonNullableStruct(m) :: constraints) else constraints let constraints = if gp.HasDefaultConstructorConstraint then (TyparConstraint.RequiresDefaultConstructor(m) :: constraints) else constraints @@ -649,9 +649,9 @@ let ImportILAssembly(amap: unit -> ImportMap, m, auxModuleLoader, xmlDocInfoLoad //------------------------------------------------------------------------- /// Import an IL type as an F# type. importInst gives the context for interpreting type variables. -let RescopeAndImportILType scoref amap m importInst ilty = - ilty |> rescopeILType scoref |> ImportILType amap m importInst +let RescopeAndImportILType scoref amap m importInst ilTy = + ilTy |> rescopeILType scoref |> ImportILType amap m importInst -let CanRescopeAndImportILType scoref amap m ilty = - ilty |> rescopeILType scoref |> CanImportILType amap m +let CanRescopeAndImportILType scoref amap m ilTy = + ilTy |> rescopeILType scoref |> CanImportILType amap m diff --git a/src/Compiler/Checking/import.fsi b/src/Compiler/Checking/import.fsi index acc5869615c..0b40eef481d 100644 --- a/src/Compiler/Checking/import.fsi +++ b/src/Compiler/Checking/import.fsi @@ -101,6 +101,6 @@ val internal ImportILAssemblyTypeForwarders: /// Import an IL type as an F# type, first rescoping to view the metadata from the current assembly /// being compiled. importInst gives the context for interpreting type variables. val RescopeAndImportILType: - scoref: ILScopeRef -> amap: ImportMap -> m: range -> importInst: TType list -> ilty: ILType -> TType + scoref: ILScopeRef -> amap: ImportMap -> m: range -> importInst: TType list -> ilTy: ILType -> TType -val CanRescopeAndImportILType: scoref: ILScopeRef -> amap: ImportMap -> m: range -> ilty: ILType -> bool +val CanRescopeAndImportILType: scoref: ILScopeRef -> amap: ImportMap -> m: range -> ilTy: ILType -> bool diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs index de977d0681b..28c4382f918 100644 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -535,12 +535,12 @@ type ILMethInfo = [] /// Get the compiled return type of the method, where 'void' is None. - member x.GetCompiledReturnTy (amap, m, minst) = + member x.GetCompiledReturnType (amap, m, minst) = ImportReturnTypeFromMetadata amap m x.RawMetadata.Return.Type (fun _ -> x.RawMetadata.Return.CustomAttrs) x.MetadataScope x.DeclaringTypeInst minst /// Get the F# view of the return type of the method, where 'void' is 'unit'. - member x.GetFSharpReturnTy (amap, m, minst) = - x.GetCompiledReturnTy(amap, m, minst) + member x.GetFSharpReturnType (amap, m, minst) = + x.GetCompiledReturnType(amap, m, minst) |> GetFSharpViewOfReturnType amap.g @@ -993,10 +993,10 @@ type MethInfo = #endif /// Get the return type of a method info, where 'void' is returned as 'None' - member x.GetCompiledReturnTy (amap, m, minst) = + member x.GetCompiledReturnType (amap, m, minst) = match x with | ILMeth(_g, ilminfo, _) -> - ilminfo.GetCompiledReturnTy(amap, m, minst) + ilminfo.GetCompiledReturnType(amap, m, minst) | FSMeth(g, _, vref, _) -> let ty = x.ApparentEnclosingAppType let inst = GetInstantiationForMemberVal g x.IsCSharpStyleExtensionMember (ty, vref, minst) @@ -1009,8 +1009,8 @@ type MethInfo = #endif /// Get the return type of a method info, where 'void' is returned as 'unit' - member x.GetFSharpReturnTy(amap, m, minst) = - x.GetCompiledReturnTy(amap, m, minst) |> GetFSharpViewOfReturnType amap.g + member x.GetFSharpReturnType(amap, m, minst) = + x.GetCompiledReturnType(amap, m, minst) |> GetFSharpViewOfReturnType amap.g /// Get the parameter types of a method info member x.GetParamTypes(amap, m, minst) = @@ -1224,7 +1224,7 @@ type MethInfo = | ProvidedMeth (_, mi, _, _) -> // GENERIC TYPE PROVIDERS: for generics, formal types should be generated here, not the actual types // For non-generic type providers there is no difference - let formalRetTy = x.GetCompiledReturnTy(amap, m, formalMethTyparTys) + let formalRetTy = x.GetCompiledReturnType(amap, m, formalMethTyparTys) // GENERIC TYPE PROVIDERS: formal types should be generated here, not the actual types // For non-generic type providers there is no difference let formalParams = @@ -2196,7 +2196,7 @@ let stripByrefTy g ty = /// Represents the information about the compiled form of a method signature. Used when analyzing implementation /// relations between members and abstract slots. -type CompiledSig = CompiledSig of argTys: TType list list * returnTy: TType option * formalMethTypars: Typars * formalMethTyparInst: TyparInst +type CompiledSig = CompiledSig of argTys: TType list list * returnTy: TType option * formalMethTypars: Typars * formalMethTyparInst: TyparInstantiation /// Get the information about the compiled form of a method signature. Used when analyzing implementation /// relations between members and abstract slots. @@ -2204,7 +2204,7 @@ let CompiledSigOfMeth g amap m (minfo: MethInfo) = let formalMethTypars = minfo.FormalMethodTypars let fminst = generalizeTypars formalMethTypars let vargTys = minfo.GetParamTypes(amap, m, fminst) - let vrty = minfo.GetCompiledReturnTy(amap, m, fminst) + let vrty = minfo.GetCompiledReturnType(amap, m, fminst) // The formal method typars returned are completely formal - they don't take into account the instantiation // of the enclosing type. For example, they may have constraints involving the _formal_ type parameters diff --git a/src/Compiler/Checking/infos.fsi b/src/Compiler/Checking/infos.fsi index b0af49e2f60..fc5dd98ecc9 100644 --- a/src/Compiler/Checking/infos.fsi +++ b/src/Compiler/Checking/infos.fsi @@ -118,10 +118,10 @@ type ParamNameAndType = static member FromMember: isCSharpExtMem: bool -> g: TcGlobals -> vref: ValRef -> ParamNameAndType list list - static member Instantiate: inst: TyparInst -> p: ParamNameAndType -> ParamNameAndType + static member Instantiate: inst: TyparInstantiation -> p: ParamNameAndType -> ParamNameAndType static member InstantiateCurried: - inst: TyparInst -> paramTypes: ParamNameAndType list list -> ParamNameAndType list list + inst: TyparInstantiation -> paramTypes: ParamNameAndType list list -> ParamNameAndType list list /// Full information about a parameter returned for use by the type checker and language service. [] @@ -143,7 +143,7 @@ type ILTypeInfo = static member FromType: g: TcGlobals -> ty: TType -> ILTypeInfo - member Instantiate: inst: TyparInst -> ILTypeInfo + member Instantiate: inst: TyparInstantiation -> ILTypeInfo member ILScopeRef: ILScopeRef @@ -251,10 +251,10 @@ type ILMethInfo = member TcGlobals: TcGlobals /// Get the compiled return type of the method, where 'void' is None. - member GetCompiledReturnTy: amap: ImportMap * m: range * minst: TType list -> TType option + member GetCompiledReturnType: amap: ImportMap * m: range * minst: TType list -> TType option /// Get the F# view of the return type of the method, where 'void' is 'unit'. - member GetFSharpReturnTy: amap: ImportMap * m: range * minst: TType list -> TType + member GetFSharpReturnType: amap: ImportMap * m: range * minst: TType list -> TType /// Get the (zero or one) 'self'/'this'/'object' arguments associated with an IL method. /// An instance extension method returns one object argument. @@ -352,7 +352,7 @@ type MethInfo = /// Get the formal generic method parameters for the method as a list of variable types. member FormalMethodInst: TypeInst - member FormalMethodTyparInst: TyparInst + member FormalMethodTyparInst: TyparInstantiation /// Get the formal generic method parameters for the method as a list of type variables. /// @@ -477,10 +477,10 @@ type MethInfo = member ComputeHashCode: unit -> int /// Get the return type of a method info, where 'void' is returned as 'None' - member GetCompiledReturnTy: amap: ImportMap * m: range * minst: TType list -> TType option + member GetCompiledReturnType: amap: ImportMap * m: range * minst: TType list -> TType option /// Get the return type of a method info, where 'void' is returned as 'unit' - member GetFSharpReturnTy: amap: ImportMap * m: range * minst: TType list -> TType + member GetFSharpReturnType: amap: ImportMap * m: range * minst: TType list -> TType /// Select all the type parameters of the declaring type of a method. /// @@ -510,7 +510,7 @@ type MethInfo = member HasParamArrayArg: amap: ImportMap * m: range * minst: TType list -> bool /// Apply a type instantiation to a method info, i.e. apply the instantiation to the enclosing type. - member Instantiate: amap: ImportMap * m: range * inst: TyparInst -> MethInfo + member Instantiate: amap: ImportMap * m: range * inst: TyparInstantiation -> MethInfo /// Indicates if this method is an extension member that is read-only. /// An extension member is considered read-only if the first argument is a read-only byref (inref) type. @@ -668,7 +668,7 @@ type UnionCaseInfo = member UnionCaseRef: UnionCaseRef /// Get the instantiation of the type parameters of the declaring type of the union case - member GetTyparInst: m: range -> TyparInst + member GetTyparInst: m: range -> TyparInstantiation /// Describes an F# use of a property backed by Abstract IL metadata [] @@ -987,7 +987,7 @@ type CompiledSig = argTys: TType list list * returnTy: TType option * formalMethTypars: Typars * - formalMethTyparInst: TyparInst + formalMethTyparInst: TyparInstantiation /// Get the information about the compiled form of a method signature. Used when analyzing implementation /// relations between members and abstract slots. diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 16fb91227a0..05049eae208 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -423,7 +423,7 @@ let genWith g : ILCode = g { new ICodeGen with member _.CodeLabel(m) = m member _.GenerateDelayMark() = generateCodeLabel() - member _.GenLocal(ilty) = failwith "not needed" + member _.GenLocal(ilTy) = failwith "not needed" member _.SetMarkToHere(m) = lab2pc[m] <- instrs.Count member _.EmitInstr x = instrs.Add x member cg.EmitInstrs xs = for i in xs do cg.EmitInstr i diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 87a203f6d4c..0bb39d8d750 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -245,6 +245,9 @@ type cenv = /// The ImportMap for reading IL amap: ImportMap + /// Environment for EraseClosures functionality + ilxPubCloEnv: EraseClosures.cenv + /// A callback for TcVal in the typechecker. Used to generalize values when finding witnesses. /// It is unfortunate this is needed but it is until we supply witnesses through the compilation. tcVal: ConstraintSolver.TcValF @@ -255,8 +258,8 @@ type cenv = /// Collection of all debug points available for inlined code namedDebugPointsForInlinedCode: Map - /// The options for ILX code generation - opts: IlxGenOptions + /// The options for ILX code generation. Only available when generating in implementation code. + optionsOpt: IlxGenOptions option /// Cache the generation of the "unit" type mutable ilUnitTy: ILType option @@ -275,20 +278,25 @@ type cenv = } + member cenv.options = + match cenv.optionsOpt with + | None -> failwith "per-module code generation options not available for this operation" + | Some options -> options + override _.ToString() = "" -let mkTypeOfExpr cenv m ilty = +let mkTypeOfExpr cenv m ilTy = let g = cenv.g mkAsmExpr ([ mkNormalCall (mspec_Type_GetTypeFromHandle g) ], [], - [mkAsmExpr ([ I_ldtoken (ILToken.ILType ilty) ], [], [], [g.system_RuntimeTypeHandle_ty], m)], + [mkAsmExpr ([ I_ldtoken (ILToken.ILType ilTy) ], [], [], [g.system_RuntimeTypeHandle_ty], m)], [g.system_Type_ty], m) let mkGetNameExpr cenv (ilt: ILType) m = mkAsmExpr ([I_ldstr ilt.BasicQualifiedName], [], [], [cenv.g.string_ty], m) -let useCallVirt cenv boxity (mspec: ILMethodSpec) isBaseCall = - cenv.opts.alwaysCallVirt && +let useCallVirt (cenv: cenv) boxity (mspec: ILMethodSpec) isBaseCall = + cenv.options.alwaysCallVirt && (boxity = AsObject) && not mspec.CallingConv.IsStatic && not isBaseCall @@ -408,7 +416,7 @@ let ComputeTypeAccess (tref: ILTypeRef) hidden = /// Indicates how type parameters are mapped to IL type variables [] -type TypeReprEnv(reprs: Map, count: int, templateReplacement: (TyconRef * ILTypeRef * Typars * TyparInst) option) = +type TypeReprEnv(reprs: Map, count: int, templateReplacement: (TyconRef * ILTypeRef * Typars * TyparInstantiation) option) = static let empty = TypeReprEnv(count = 0, reprs = Map.empty, templateReplacement = None) @@ -503,53 +511,53 @@ let GenReadOnlyModReqIfNecessary (g: TcGlobals) ty ilTy = else ilTy -let rec GenTypeArgAux amap m tyenv tyarg = - GenTypeAux amap m tyenv VoidNotOK PtrTypesNotOK tyarg +let rec GenTypeArgAux cenv m tyenv tyarg = + GenTypeAux cenv m tyenv VoidNotOK PtrTypesNotOK tyarg -and GenTypeArgsAux amap m tyenv tyargs = - List.map (GenTypeArgAux amap m tyenv) (DropErasedTyargs tyargs) +and GenTypeArgsAux cenv m tyenv tyargs = + List.map (GenTypeArgAux cenv m tyenv) (DropErasedTyargs tyargs) -and GenTyAppAux amap m tyenv repr tinst = +and GenTyAppAux cenv m tyenv repr tinst = match repr with | CompiledTypeRepr.ILAsmOpen ty -> - let ilTypeInst = GenTypeArgsAux amap m tyenv tinst + let ilTypeInst = GenTypeArgsAux cenv m tyenv tinst let ty = instILType ilTypeInst ty ty | CompiledTypeRepr.ILAsmNamed (tref, boxity, ilTypeOpt) -> - GenILTyAppAux amap m tyenv (tref, boxity, ilTypeOpt) tinst + GenILTyAppAux cenv m tyenv (tref, boxity, ilTypeOpt) tinst -and GenILTyAppAux amap m tyenv (tref, boxity, ilTypeOpt) tinst = +and GenILTyAppAux cenv m tyenv (tref, boxity, ilTypeOpt) tinst = match ilTypeOpt with | None -> - let ilTypeInst = GenTypeArgsAux amap m tyenv tinst + let ilTypeInst = GenTypeArgsAux cenv m tyenv tinst mkILTy boxity (mkILTySpec (tref, ilTypeInst)) | Some ilType -> ilType // monomorphic types include a cached ilType to avoid reallocation of an ILType node -and GenNamedTyAppAux (amap: ImportMap) m (tyenv: TypeReprEnv) ptrsOK tcref tinst = - let g = amap.g +and GenNamedTyAppAux (cenv: cenv) m (tyenv: TypeReprEnv) ptrsOK tcref tinst = + let g = cenv.g match tyenv.TemplateReplacement with | Some (tcref2, ilCloTyRef, cloFreeTyvars, _) when tyconRefEq g tcref tcref2 -> let cloInst = List.map mkTyparTy cloFreeTyvars - let ilTypeInst = GenTypeArgsAux amap m tyenv cloInst + let ilTypeInst = GenTypeArgsAux cenv m tyenv cloInst mkILValueTy ilCloTyRef ilTypeInst | _ -> let tinst = DropErasedTyargs tinst // See above note on ptrsOK if ptrsOK = PtrTypesOK && tyconRefEq g tcref g.nativeptr_tcr && (freeInTypes CollectTypars tinst).FreeTypars.IsEmpty then - GenNamedTyAppAux amap m tyenv ptrsOK g.ilsigptr_tcr tinst + GenNamedTyAppAux cenv m tyenv ptrsOK g.ilsigptr_tcr tinst else #if !NO_TYPEPROVIDERS match tcref.TypeReprInfo with // Generate the base type, because that is always the representation of the erased type, unless the assembly is being injected | TProvidedTypeRepr info when info.IsErased -> - GenTypeAux amap m tyenv VoidNotOK ptrsOK (info.BaseTypeForErased (m, g.obj_ty)) + GenTypeAux cenv m tyenv VoidNotOK ptrsOK (info.BaseTypeForErased (m, g.obj_ty)) | _ -> #endif - GenTyAppAux amap m tyenv (GenTyconRef tcref) tinst + GenTyAppAux cenv m tyenv (GenTyconRef tcref) tinst -and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty = - let g = amap.g +and GenTypeAux cenv m (tyenv: TypeReprEnv) voidOK ptrsOK ty = + let g = cenv.g #if DEBUG voidCheck m g voidOK ty #else @@ -557,27 +565,27 @@ and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty = #endif match stripTyEqnsAndMeasureEqns g ty with | TType_app (tcref, tinst, _) -> - GenNamedTyAppAux amap m tyenv ptrsOK tcref tinst + GenNamedTyAppAux cenv m tyenv ptrsOK tcref tinst | TType_tuple (tupInfo, args) -> - GenTypeAux amap m tyenv VoidNotOK ptrsOK (mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) args) + GenTypeAux cenv m tyenv VoidNotOK ptrsOK (mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) args) | TType_fun (dty, returnTy, _) -> - EraseClosures.mkILFuncTy g.ilxPubCloEnv (GenTypeArgAux amap m tyenv dty) (GenTypeArgAux amap m tyenv returnTy) + EraseClosures.mkILFuncTy cenv.ilxPubCloEnv (GenTypeArgAux cenv m tyenv dty) (GenTypeArgAux cenv m tyenv returnTy) | TType_anon (anonInfo, tinst) -> let tref = anonInfo.ILTypeRef let boxity = if evalAnonInfoIsStruct anonInfo then ILBoxity.AsValue else ILBoxity.AsObject - GenILTyAppAux amap m tyenv (tref, boxity, None) tinst + GenILTyAppAux cenv m tyenv (tref, boxity, None) tinst | TType_ucase (ucref, args) -> - let cuspec, idx = GenUnionCaseSpec amap m tyenv ucref args + let cuspec, idx = GenUnionCaseSpec cenv m tyenv ucref args EraseUnions.GetILTypeForAlternative cuspec idx | TType_forall (tps, tau) -> let tps = DropErasedTypars tps - if tps.IsEmpty then GenTypeAux amap m tyenv VoidNotOK ptrsOK tau - else EraseClosures.mkILTyFuncTy g.ilxPubCloEnv + if tps.IsEmpty then GenTypeAux cenv m tyenv VoidNotOK ptrsOK tau + else EraseClosures.mkILTyFuncTy cenv.ilxPubCloEnv | TType_var (tp, _) -> mkILTyvarTy tyenv[tp, m] @@ -589,17 +597,17 @@ and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty = // Generate ILX references to closures, classunions etc. given a tyenv //-------------------------------------------------------------------------- -and GenUnionCaseRef (amap: ImportMap) m tyenv i (fspecs: RecdField[]) = - let g = amap.g +and GenUnionCaseRef (cenv: cenv) m tyenv i (fspecs: RecdField[]) = + let g = cenv.g fspecs |> Array.mapi (fun j fspec -> - let ilFieldDef = mkILInstanceField(fspec.LogicalName, GenType amap m tyenv fspec.FormalType, None, ILMemberAccess.Public) + let ilFieldDef = mkILInstanceField(fspec.LogicalName, GenType cenv m tyenv fspec.FormalType, None, ILMemberAccess.Public) // These properties on the "field" of an alternative end up going on a property generated by cu_erase.fs IlxUnionCaseField (ilFieldDef.With(customAttrs = mkILCustomAttrs [(mkCompilationMappingAttrWithVariantNumAndSeqNum g (int SourceConstructFlags.Field) i j )]))) -and GenUnionRef (amap: ImportMap) m (tcref: TyconRef) = - let g = amap.g +and GenUnionRef (cenv: cenv) m (tcref: TyconRef) = + let g = cenv.g let tycon = tcref.Deref assert(not tycon.IsTypeAbbrev) match tycon.UnionTypeInfo with @@ -614,7 +622,7 @@ and GenUnionRef (amap: ImportMap) m (tcref: TyconRef) = tycon.UnionCasesArray |> Array.mapi (fun i cspec -> { altName=cspec.CompiledName altCustomAttrs=emptyILCustomAttrs - altFields=GenUnionCaseRef amap m tyenvinner i cspec.RecdFieldsArray }) + altFields = GenUnionCaseRef cenv m tyenvinner i cspec.RecdFieldsArray }) let nullPermitted = IsUnionTypeWithNullAsTrueValue g tycon let hasHelpers = ComputeUnionHasHelpers g tcref let boxity = (if tcref.IsStructOrEnumTycon then ILBoxity.AsValue else ILBoxity.AsObject) @@ -634,49 +642,49 @@ and ComputeUnionHasHelpers g (tcref: TyconRef) = | _ -> AllHelpers (* not hiddenRepr *) -and GenUnionSpec amap m tyenv tcref tyargs = - let curef = GenUnionRef amap m tcref - let tinst = GenTypeArgs amap m tyenv tyargs +and GenUnionSpec (cenv: cenv) m tyenv tcref tyargs = + let curef = GenUnionRef cenv m tcref + let tinst = GenTypeArgs cenv m tyenv tyargs IlxUnionSpec(curef, tinst) -and GenUnionCaseSpec amap m tyenv (ucref: UnionCaseRef) tyargs = - let cuspec = GenUnionSpec amap m tyenv ucref.TyconRef tyargs +and GenUnionCaseSpec cenv m tyenv (ucref: UnionCaseRef) tyargs = + let cuspec = GenUnionSpec cenv m tyenv ucref.TyconRef tyargs cuspec, ucref.Index -and GenType amap m tyenv ty = - GenTypeAux amap m tyenv VoidNotOK PtrTypesNotOK ty +and GenType cenv m tyenv ty = + GenTypeAux cenv m tyenv VoidNotOK PtrTypesNotOK ty -and GenTypes amap m tyenv tys = List.map (GenType amap m tyenv) tys +and GenTypes cenv m tyenv tys = List.map (GenType cenv m tyenv) tys -and GenTypePermitVoid amap m tyenv ty = (GenTypeAux amap m tyenv VoidOK PtrTypesNotOK ty) +and GenTypePermitVoid cenv m tyenv ty = (GenTypeAux cenv m tyenv VoidOK PtrTypesNotOK ty) -and GenTypesPermitVoid amap m tyenv tys = List.map (GenTypePermitVoid amap m tyenv) tys +and GenTypesPermitVoid cenv m tyenv tys = List.map (GenTypePermitVoid cenv m tyenv) tys -and GenTyApp amap m tyenv repr tyargs = GenTyAppAux amap m tyenv repr tyargs +and GenTyApp cenv m tyenv repr tyargs = GenTyAppAux cenv m tyenv repr tyargs -and GenNamedTyApp amap m tyenv tcref tinst = GenNamedTyAppAux amap m tyenv PtrTypesNotOK tcref tinst +and GenNamedTyApp cenv m tyenv tcref tinst = GenNamedTyAppAux cenv m tyenv PtrTypesNotOK tcref tinst /// IL void types are only generated for return types -and GenReturnType amap m tyenv returnTyOpt = +and GenReturnType cenv m tyenv returnTyOpt = match returnTyOpt with | None -> ILType.Void | Some returnTy -> - let ilTy = GenTypeAux amap m tyenv VoidNotOK(*1*) PtrTypesOK returnTy (*1: generate void from unit, but not accept void *) - GenReadOnlyModReqIfNecessary amap.g returnTy ilTy + let ilTy = GenTypeAux cenv m tyenv VoidNotOK(*1*) PtrTypesOK returnTy (*1: generate void from unit, but not accept void *) + GenReadOnlyModReqIfNecessary cenv.g returnTy ilTy -and GenParamType amap m tyenv isSlotSig ty = - let ilTy = GenTypeAux amap m tyenv VoidNotOK PtrTypesOK ty +and GenParamType cenv m tyenv isSlotSig ty = + let ilTy = GenTypeAux cenv m tyenv VoidNotOK PtrTypesOK ty if isSlotSig then - GenReadOnlyModReqIfNecessary amap.g ty ilTy + GenReadOnlyModReqIfNecessary cenv.g ty ilTy else ilTy -and GenParamTypes amap m tyenv isSlotSig tys = - tys |> List.map (GenParamType amap m tyenv isSlotSig) +and GenParamTypes cenv m tyenv isSlotSig tys = + tys |> List.map (GenParamType cenv m tyenv isSlotSig) -and GenTypeArgs amap m tyenv tyargs = GenTypeArgsAux amap m tyenv tyargs +and GenTypeArgs cenv m tyenv tyargs = GenTypeArgsAux cenv m tyenv tyargs -and GenTypePermitVoidAux amap m tyenv ty = GenTypeAux amap m tyenv VoidOK PtrTypesNotOK ty +and GenTypePermitVoidAux cenv m tyenv ty = GenTypeAux cenv m tyenv VoidOK PtrTypesNotOK ty // Static fields generally go in a private InitializationCodeAndBackingFields section. This is to ensure all static // fields are initialized only in their class constructors (we generate one primary @@ -719,19 +727,19 @@ let GenRecdFieldRef m cenv (tyenv: TypeReprEnv) (rfref: RecdFieldRef) tyargs = | Some (tcref2, ilCloTyRef, cloFreeTyvars, templateTypeInst) when tyconRefEq cenv.g rfref.TyconRef tcref2 -> let ilCloTy = let cloInst = List.map mkTyparTy cloFreeTyvars - let ilTypeInst = GenTypeArgsAux cenv.amap m tyenv cloInst + let ilTypeInst = GenTypeArgsAux cenv m tyenv cloInst mkILValueTy ilCloTyRef ilTypeInst let tyenvinner = TypeReprEnv.Empty.ForTypars cloFreeTyvars mkILFieldSpecInTy(ilCloTy, ComputeFieldName rfref.Tycon rfref.RecdField, - GenType cenv.amap m tyenvinner (instType templateTypeInst rfref.RecdField.FormalType)) + GenType cenv m tyenvinner (instType templateTypeInst rfref.RecdField.FormalType)) | _ -> let tyenvinner = TypeReprEnv.Empty.ForTycon rfref.Tycon - let ilty = GenTyApp cenv.amap m tyenv rfref.TyconRef.CompiledRepresentation tyargs - mkILFieldSpecInTy(ilty, + let ilTy = GenTyApp cenv m tyenv rfref.TyconRef.CompiledRepresentation tyargs + mkILFieldSpecInTy(ilTy, ComputeFieldName rfref.Tycon rfref.RecdField, - GenType cenv.amap m tyenvinner rfref.RecdField.FormalType) + GenType cenv m tyenvinner rfref.RecdField.FormalType) let GenExnType amap m tyenv (ecref: TyconRef) = GenTyApp amap m tyenv ecref.CompiledRepresentation [] @@ -1130,8 +1138,8 @@ let AddStorageForVal (g: TcGlobals) (v, s) eenv = let AddStorageForLocalVals g vals eenv = List.foldBack (fun (v, s) acc -> AddStorageForVal g (v, notlazy s) acc) vals eenv -let AddTemplateReplacement eenv (tcref, ftyvs, ilty, inst) = - { eenv with tyenv = eenv.tyenv.WithTemplateReplacement (tcref, ftyvs, ilty, inst) } +let AddTemplateReplacement eenv (tcref, ftyvs, ilTy, inst) = + { eenv with tyenv = eenv.tyenv.WithTemplateReplacement (tcref, ftyvs, ilTy, inst) } let AddStorageForLocalWitness eenv (w,s) = { eenv with witnessesInScope = eenv.witnessesInScope.SetItem (w, s) } @@ -1167,7 +1175,8 @@ let IsValRefIsDllImport g (vref: ValRef) = /// Determine how a top level value is represented, when it is being represented /// as a method. -let GetMethodSpecForMemberVal amap g (memberInfo: ValMemberInfo) (vref: ValRef) = +let GetMethodSpecForMemberVal cenv (memberInfo: ValMemberInfo) (vref: ValRef) = + let g = cenv.g let m = vref.Range let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref let tps, witnessInfos, curriedArgInfos, returnTy, retInfo = @@ -1185,10 +1194,10 @@ let GetMethodSpecForMemberVal amap g (memberInfo: ValMemberInfo) (vref: ValRef) let isCompiledAsInstance = ValRefIsCompiledAsInstanceMember g vref let ilActualRetTy = - let ilRetTy = GenReturnType amap m tyenvUnderTypars returnTy + let ilRetTy = GenReturnType cenv m tyenvUnderTypars returnTy if isCtor || cctor then ILType.Void else ilRetTy - let ilTy = GenType amap m tyenvUnderTypars (mkAppTy parentTcref (List.map mkTyparTy ctps)) + let ilTy = GenType cenv m tyenvUnderTypars (mkAppTy parentTcref (List.map mkTyparTy ctps)) let nm = vref.CompiledName g.CompilerGlobalState if isCompiledAsInstance || isCtor then @@ -1218,28 +1227,28 @@ let GetMethodSpecForMemberVal amap g (memberInfo: ValMemberInfo) (vref: ValRef) thisArgTys let methodArgTys, paramInfos = List.unzip flatArgInfos let isSlotSig = memberInfo.MemberFlags.IsDispatchSlot || memberInfo.MemberFlags.IsOverrideOrExplicitImpl - let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars isSlotSig methodArgTys - let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps) + let ilMethodArgTys = GenParamTypes cenv m tyenvUnderTypars isSlotSig methodArgTys + let ilMethodInst = GenTypeArgs cenv m tyenvUnderTypars (List.map mkTyparTy mtps) let mspec = mkILInstanceMethSpecInTy (ilTy, nm, ilMethodArgTys, ilActualRetTy, ilMethodInst) let mspecW = if not g.generateWitnesses || witnessInfos.IsEmpty then mspec else - let ilWitnessArgTys = GenTypes amap m tyenvUnderTypars (GenWitnessTys g witnessInfos) + let ilWitnessArgTys = GenTypes cenv m tyenvUnderTypars (GenWitnessTys g witnessInfos) let nmW = ExtraWitnessMethodName nm mkILInstanceMethSpecInTy (ilTy, nmW, ilWitnessArgTys @ ilMethodArgTys, ilActualRetTy, ilMethodInst) mspec, mspecW, ctps, mtps, curriedArgInfos, paramInfos, retInfo, witnessInfos, methodArgTys, returnTy else let methodArgTys, paramInfos = List.unzip flatArgInfos - let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars false methodArgTys - let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps) + let ilMethodArgTys = GenParamTypes cenv m tyenvUnderTypars false methodArgTys + let ilMethodInst = GenTypeArgs cenv m tyenvUnderTypars (List.map mkTyparTy mtps) let mspec = mkILStaticMethSpecInTy (ilTy, nm, ilMethodArgTys, ilActualRetTy, ilMethodInst) let mspecW = if not g.generateWitnesses || witnessInfos.IsEmpty then mspec else - let ilWitnessArgTys = GenTypes amap m tyenvUnderTypars (GenWitnessTys g witnessInfos) + let ilWitnessArgTys = GenTypes cenv m tyenvUnderTypars (GenWitnessTys g witnessInfos) let nmW = ExtraWitnessMethodName nm mkILStaticMethSpecInTy (ilTy, nmW, ilWitnessArgTys @ ilMethodArgTys, ilActualRetTy, ilMethodInst) @@ -1275,29 +1284,30 @@ let ComputeStorageForFSharpValue amap (g:TcGlobals) cloc optIntraAssemblyInfo op StaticPropertyWithField (ilFieldSpec, vref, hasLiteralAttr, ilTyForProperty, nm, ilTy, ilGetterMethRef, ilSetterMethRef, optShadowLocal) /// Compute the representation information for an F#-declared member -let ComputeStorageForFSharpMember amap g topValInfo memberInfo (vref: ValRef) m = - let mspec, mspecW, ctps, mtps, curriedArgInfos, paramInfos, retInfo, witnessInfos, methodArgTys, _ = GetMethodSpecForMemberVal amap g memberInfo vref +let ComputeStorageForFSharpMember cenv topValInfo memberInfo (vref: ValRef) m = + let mspec, mspecW, ctps, mtps, curriedArgInfos, paramInfos, retInfo, witnessInfos, methodArgTys, _ = GetMethodSpecForMemberVal cenv memberInfo vref Method (topValInfo, vref, mspec, mspecW, m, ctps, mtps, curriedArgInfos, paramInfos, witnessInfos, methodArgTys, retInfo) /// Compute the representation information for an F#-declared function in a module or an F#-declared extension member. /// Note, there is considerable overlap with ComputeStorageForFSharpMember/GetMethodSpecForMemberVal and these could be /// rationalized. -let ComputeStorageForFSharpFunctionOrFSharpExtensionMember amap (g: TcGlobals) cloc topValInfo (vref: ValRef) m = +let ComputeStorageForFSharpFunctionOrFSharpExtensionMember (cenv: cenv) cloc topValInfo (vref: ValRef) m = + let g = cenv.g let nm = vref.CompiledName g.CompilerGlobalState let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref let tps, witnessInfos, curriedArgInfos, returnTy, retInfo = GetTopValTypeInCompiledForm g topValInfo numEnclosingTypars vref.Type m let tyenvUnderTypars = TypeReprEnv.Empty.ForTypars tps let methodArgTys, paramInfos = curriedArgInfos |> List.concat |> List.unzip - let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars false methodArgTys - let ilRetTy = GenReturnType amap m tyenvUnderTypars returnTy + let ilMethodArgTys = GenParamTypes cenv m tyenvUnderTypars false methodArgTys + let ilRetTy = GenReturnType cenv m tyenvUnderTypars returnTy let ilLocTy = mkILTyForCompLoc cloc - let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy tps) + let ilMethodInst = GenTypeArgs cenv m tyenvUnderTypars (List.map mkTyparTy tps) let mspec = mkILStaticMethSpecInTy (ilLocTy, nm, ilMethodArgTys, ilRetTy, ilMethodInst) let mspecW = if not g.generateWitnesses || witnessInfos.IsEmpty then mspec else - let ilWitnessArgTys = GenTypes amap m tyenvUnderTypars (GenWitnessTys g witnessInfos) + let ilWitnessArgTys = GenTypes cenv m tyenvUnderTypars (GenWitnessTys g witnessInfos) mkILStaticMethSpecInTy (ilLocTy, ExtraWitnessMethodName nm, (ilWitnessArgTys @ ilMethodArgTys), ilRetTy, ilMethodInst) Method (topValInfo, vref, mspec, mspecW, m, [], tps, curriedArgInfos, paramInfos, witnessInfos, methodArgTys, retInfo) @@ -1317,7 +1327,7 @@ let IsFSharpValCompiledAsMethod g (v: Val) = /// If it's a function or is polymorphic, then it gets represented as a /// method (possibly and instance method). Otherwise it gets represented as a /// static field and property. -let ComputeStorageForTopVal (amap, g, optIntraAssemblyInfo: IlxGenIntraAssemblyInfo option, isInteractive, optShadowLocal, vref: ValRef, cloc) = +let ComputeStorageForTopVal (cenv, g, optIntraAssemblyInfo: IlxGenIntraAssemblyInfo option, isInteractive, optShadowLocal, vref: ValRef, cloc) = if isUnitTy g vref.Type && not vref.IsMemberOrModuleBinding && not vref.IsMutable then Null @@ -1333,7 +1343,7 @@ let ComputeStorageForTopVal (amap, g, optIntraAssemblyInfo: IlxGenIntraAssemblyI if vref.Deref.IsCompiledAsStaticPropertyWithoutField then let nm = "get_"+nm let tyenvUnderTypars = TypeReprEnv.Empty.ForTypars [] - let ilRetTy = GenType amap m tyenvUnderTypars vref.Type + let ilRetTy = GenType cenv m tyenvUnderTypars vref.Type let ty = mkILTyForCompLoc cloc let mspec = mkILStaticMethSpecInTy (ty, nm, [], ilRetTy, []) @@ -1346,38 +1356,38 @@ let ComputeStorageForTopVal (amap, g, optIntraAssemblyInfo: IlxGenIntraAssemblyI // We should just look at the arity match GetTopValTypeInFSharpForm g topValInfo vref.Type vref.Range with | [], [], returnTy, _ when not vref.IsMember -> - ComputeStorageForFSharpValue amap g cloc optIntraAssemblyInfo optShadowLocal isInteractive returnTy vref m + ComputeStorageForFSharpValue cenv g cloc optIntraAssemblyInfo optShadowLocal isInteractive returnTy vref m | _ -> match vref.MemberInfo with | Some memberInfo when not vref.IsExtensionMember -> - ComputeStorageForFSharpMember amap g topValInfo memberInfo vref m + ComputeStorageForFSharpMember cenv topValInfo memberInfo vref m | _ -> - ComputeStorageForFSharpFunctionOrFSharpExtensionMember amap g cloc topValInfo vref m + ComputeStorageForFSharpFunctionOrFSharpExtensionMember cenv cloc topValInfo vref m /// Determine how an F#-declared value, function or member is represented, if it is in the assembly being compiled. -let ComputeAndAddStorageForLocalTopVal (amap, g, intraAssemblyFieldTable, isInteractive, optShadowLocal) cloc (v: Val) eenv = - let storage = ComputeStorageForTopVal (amap, g, Some intraAssemblyFieldTable, isInteractive, optShadowLocal, mkLocalValRef v, cloc) +let ComputeAndAddStorageForLocalTopVal (cenv, g, intraAssemblyFieldTable, isInteractive, optShadowLocal) cloc (v: Val) eenv = + let storage = ComputeStorageForTopVal (cenv, g, Some intraAssemblyFieldTable, isInteractive, optShadowLocal, mkLocalValRef v, cloc) AddStorageForVal g (v, notlazy storage) eenv /// Determine how an F#-declared value, function or member is represented, if it is an external assembly. -let ComputeStorageForNonLocalTopVal amap g cloc modref (v: Val) = +let ComputeStorageForNonLocalTopVal cenv g cloc modref (v: Val) = match v.ValReprInfo with | None -> error(InternalError("ComputeStorageForNonLocalTopVal, expected an arity for " + v.LogicalName, v.Range)) - | Some _ -> ComputeStorageForTopVal (amap, g, None, false, NoShadowLocal, mkNestedValRef modref v, cloc) + | Some _ -> ComputeStorageForTopVal (cenv, g, None, false, NoShadowLocal, mkNestedValRef modref v, cloc) /// Determine how all the F#-declared top level values, functions and members are represented, for an external module or namespace. -let rec AddStorageForNonLocalModuleOrNamespaceRef amap g cloc acc (modref: ModuleOrNamespaceRef) (modul: ModuleOrNamespace) = +let rec AddStorageForNonLocalModuleOrNamespaceRef cenv g cloc acc (modref: ModuleOrNamespaceRef) (modul: ModuleOrNamespace) = let acc = (acc, modul.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions) ||> List.fold (fun acc smodul -> - AddStorageForNonLocalModuleOrNamespaceRef amap g (CompLocForSubModuleOrNamespace cloc smodul) acc (modref.NestedTyconRef smodul) smodul) + AddStorageForNonLocalModuleOrNamespaceRef cenv g (CompLocForSubModuleOrNamespace cloc smodul) acc (modref.NestedTyconRef smodul) smodul) let acc = (acc, modul.ModuleOrNamespaceType.AllValsAndMembers) ||> Seq.fold (fun acc v -> - AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal amap g cloc modref v)) acc) + AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal cenv g cloc modref v)) acc) acc /// Determine how all the F#-declared top level values, functions and members are represented, for an external assembly. -let AddStorageForExternalCcu amap g eenv (ccu: CcuThunk) = +let AddStorageForExternalCcu cenv g eenv (ccu: CcuThunk) = if not ccu.IsFSharp then eenv else let cloc = CompLocForCcu ccu let eenv = @@ -1385,13 +1395,13 @@ let AddStorageForExternalCcu amap g eenv (ccu: CcuThunk) = (fun smodul acc -> let cloc = CompLocForSubModuleOrNamespace cloc smodul let modref = mkNonLocalCcuRootEntityRef ccu smodul - AddStorageForNonLocalModuleOrNamespaceRef amap g cloc acc modref smodul) + AddStorageForNonLocalModuleOrNamespaceRef cenv g cloc acc modref smodul) ccu.RootModulesAndNamespaces eenv let eenv = let eref = ERefNonLocalPreResolved ccu.Contents (mkNonLocalEntityRef ccu [| |]) (eenv, ccu.Contents.ModuleOrNamespaceType.AllValsAndMembers) ||> Seq.fold (fun acc v -> - AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal amap g cloc eref v)) acc) + AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal cenv g cloc eref v)) acc) eenv /// Record how all the top level F#-declared values, functions and members are represented, for a local module or namespace. @@ -1401,8 +1411,8 @@ let rec AddBindingsForLocalModuleType allocVal cloc eenv (mty: ModuleOrNamespace eenv /// Record how all the top level F#-declared values, functions and members are represented, for a set of referenced assemblies. -let AddExternalCcusToIlxGenEnv amap g eenv ccus = - List.fold (AddStorageForExternalCcu amap g) eenv ccus +let AddExternalCcusToIlxGenEnv cenv g eenv ccus = + List.fold (AddStorageForExternalCcu cenv g) eenv ccus /// Record how all the unrealized abstract slots are represented, for a type definition. let AddBindingsForTycon allocVal (cloc: CompileLocation) (tycon: Tycon) eenv = @@ -1413,10 +1423,7 @@ let AddBindingsForTycon allocVal (cloc: CompileLocation) (tycon: Tycon) eenv = (eenv, unrealizedSlots) ||> List.fold (fun eenv vref -> allocVal cloc vref.Deref eenv) /// Record how constructs are represented, for a sequence of definitions in a module or namespace fragment. -let rec AddBindingsForModuleDefs allocVal (cloc: CompileLocation) eenv mdefs = - List.fold (AddBindingsForModuleDef allocVal cloc) eenv mdefs - -and AddDebugImportsToEnv (cenv: cenv) eenv (openDecls: OpenDeclaration list) = +let AddDebugImportsToEnv (cenv: cenv) eenv (openDecls: OpenDeclaration list) = let ilImports = [| for openDecl in openDecls do @@ -1427,7 +1434,7 @@ and AddDebugImportsToEnv (cenv: cenv) eenv (openDecls: OpenDeclaration list) = ILDebugImport.ImportType (mkILNonGenericBoxedTy modul.CompiledRepresentationForNamedType) for t in openDecl.Types do let m = defaultArg openDecl.Range Range.range0 - ILDebugImport.ImportType (GenType cenv.amap m TypeReprEnv.Empty t) + ILDebugImport.ImportType (GenType cenv m TypeReprEnv.Empty t) |] if ilImports.Length = 0 then @@ -1456,12 +1463,12 @@ and AddDebugImportsToEnv (cenv: cenv) eenv (openDecls: OpenDeclaration list) = { eenv with imports = Some { Parent = None; Imports = imports } } -and AddBindingsForModuleDef allocVal cloc eenv x = +let rec AddBindingsForModuleContents allocVal cloc eenv x = match x with | TMDefRec(_isRec, _opens, tycons, mbinds, _) -> // Virtual don't have 'let' bindings and must be added to the environment let eenv = List.foldBack (AddBindingsForTycon allocVal cloc) tycons eenv - let eenv = List.foldBack (AddBindingsForModule allocVal cloc) mbinds eenv + let eenv = List.foldBack (AddBindingsForModuleBinding allocVal cloc) mbinds eenv eenv | TMDefLet(bind, _) -> allocVal cloc bind.Var eenv @@ -1469,13 +1476,11 @@ and AddBindingsForModuleDef allocVal cloc eenv x = eenv | TMDefOpens _-> eenv - | TMWithSig(ModuleOrNamespaceContentsWithSig(mtyp, _, _)) -> - AddBindingsForLocalModuleType allocVal cloc eenv mtyp | TMDefs mdefs -> - AddBindingsForModuleDefs allocVal cloc eenv mdefs + (eenv, mdefs) ||> List.fold (AddBindingsForModuleContents allocVal cloc) /// Record how constructs are represented, for a module or namespace. -and AddBindingsForModule allocVal cloc x eenv = +and AddBindingsForModuleBinding allocVal cloc x eenv = match x with | ModuleOrNamespaceBinding.Binding bind -> allocVal cloc bind.Var eenv @@ -1484,27 +1489,26 @@ and AddBindingsForModule allocVal cloc x eenv = if mspec.IsNamespace then cloc else CompLocForFixedModule cloc.QualifiedNameOfFile cloc.TopImplQualifiedName mspec - AddBindingsForModuleDef allocVal cloc eenv mdef + AddBindingsForModuleContents allocVal cloc eenv mdef /// Record how constructs are represented, for the values and functions defined in a module or namespace fragment. and AddBindingsForModuleTopVals _g allocVal _cloc eenv vs = List.foldBack allocVal vs eenv - /// Put the partial results for a generated fragment (i.e. a part of a CCU generated by FSI) /// into the stored results for the whole CCU. /// isIncrementalFragment = true --> "typed input" /// isIncrementalFragment = false --> "#load" -let AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap: ImportMap, isIncrementalFragment, g, ccu, fragName, intraAssemblyInfo, eenv, typedImplFiles) = +let AddIncrementalLocalAssemblyFragmentToIlxGenEnv (cenv: cenv, isIncrementalFragment, g, ccu, fragName, intraAssemblyInfo, eenv, implFiles) = let cloc = CompLocForFragment fragName ccu - let allocVal = ComputeAndAddStorageForLocalTopVal (amap, g, intraAssemblyInfo, true, NoShadowLocal) - (eenv, typedImplFiles) ||> List.fold (fun eenv (TImplFile (qualifiedNameOfFile=qname; implExprWithSig=mexpr)) -> + let allocVal = ComputeAndAddStorageForLocalTopVal (cenv, g, intraAssemblyInfo, true, NoShadowLocal) + (eenv, implFiles) ||> List.fold (fun eenv implFile -> + let (CheckedImplFile (qualifiedNameOfFile=qname; signature=signature; contents=contents)) = implFile let cloc = { cloc with TopImplQualifiedName = qname.Text } if isIncrementalFragment then - match mexpr with - | ModuleOrNamespaceContentsWithSig(_, mdef, _) -> AddBindingsForModuleDef allocVal cloc eenv mdef + AddBindingsForModuleContents allocVal cloc eenv contents else - AddBindingsForLocalModuleType allocVal cloc eenv mexpr.Type) + AddBindingsForLocalModuleType allocVal cloc eenv signature) //-------------------------------------------------------------------------- // Generate debugging marks @@ -1520,8 +1524,8 @@ let GenILSourceMarker (g: TcGlobals) (m: range) = endColumn=m.EndColumn+1) /// Optionally generate DebugRange for methods. This gets attached to the whole method. -let GenPossibleILDebugRange cenv m = - if cenv.opts.generateDebugSymbols then +let GenPossibleILDebugRange (cenv: cenv) m = + if cenv.options.generateDebugSymbols then Some (GenILSourceMarker cenv.g m ) else None @@ -1726,7 +1730,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu [ for _, fldName, fldTy in flds -> // Don't hide fields when splitting to multiple assemblies. let access = - if cenv.opts.isInteractive && cenv.opts.fsiMultiAssemblyEmit then ILMemberAccess.Public + if cenv.options.isInteractive && cenv.options.fsiMultiAssemblyEmit then ILMemberAccess.Public else ILMemberAccess.Private let fdef = mkILInstanceField (fldName, fldTy, None, access) fdef.With(customAttrs = mkILCustomAttrs [ g.DebuggerBrowsableNeverAttribute ]) ] @@ -1801,7 +1805,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu let ilTypeDefAttribs = mkILCustomAttrs [ g.CompilerGeneratedAttribute; mkCompilationMappingAttr g (int SourceConstructFlags.RecordType) ] - let ilInterfaceTys = [ for ity, _, _ in tcaug.tcaug_interfaces -> GenType cenv.amap m (TypeReprEnv.Empty.ForTypars tps) ity ] + let ilInterfaceTys = [ for ity, _, _ in tcaug.tcaug_interfaces -> GenType cenv m (TypeReprEnv.Empty.ForTypars tps) ity ] let ilTypeDef = mkILGenericClass (ilTypeRef.Name, ILTypeDefAccess.Public, ilGenericParams, ilBaseTy, ilInterfaceTys, @@ -1935,7 +1939,7 @@ let pop (i: int) : Pops = i let Push tys: Pushes = tys let Push0 = Push [] -let FeeFee (cenv: cenv) = (if cenv.opts.testFlagEmitFeeFeeAs100001 then 100001 else 0x00feefee) +let FeeFee (cenv: cenv) = (if cenv.options.testFlagEmitFeeFeeAs100001 then 100001 else 0x00feefee) let FeeFeeInstr (cenv: cenv) doc = I_seqpoint (ILDebugPoint.Create(document = doc, line = FeeFee cenv, @@ -1972,7 +1976,7 @@ type CodeGenBuffer(m: range, | _ -> codeLabelToPC[lbl] // Add a nop to make way for the first debug point. - do if mgbuf.cenv.opts.generateDebugSymbols then + do if mgbuf.cenv.options.generateDebugSymbols then let doc = g.memoize_file m.FileIndex let i = FeeFeeInstr mgbuf.cenv doc codebuf.Add i // for the FeeFee or a better debug point @@ -2026,7 +2030,7 @@ type CodeGenBuffer(m: range, codebuf.Add(AI_nop) member cgbuf.EmitDebugPoint (m: range) = - if mgbuf.cenv.opts.generateDebugSymbols then + if mgbuf.cenv.options.generateDebugSymbols then let attr = GenILSourceMarker g m let i = I_seqpoint attr @@ -2049,7 +2053,7 @@ type CodeGenBuffer(m: range, // Emit FeeFee breakpoints for hidden code, see https://blogs.msdn.microsoft.com/jmstall/2005/06/19/line-hidden-and-0xfeefee-sequence-points/ member cgbuf.EmitStartOfHiddenCode() = - if mgbuf.cenv.opts.generateDebugSymbols then + if mgbuf.cenv.options.generateDebugSymbols then let doc = g.memoize_file m.FileIndex let i = FeeFeeInstr mgbuf.cenv doc hasDebugPoints <- true @@ -2208,7 +2212,7 @@ let GenConstArray cenv (cgbuf: CodeGenBuffer) eenv ilElementType (data:'a[]) (wr // the bodies of methods in a couple of places //------------------------------------------------------------------------- -let CodeGenThen cenv mgbuf (entryPointInfo, methodName, eenv, alreadyUsedArgs, selfArgOpt: Val option, codeGenFunction, m) = +let CodeGenThen (cenv: cenv) mgbuf (entryPointInfo, methodName, eenv, alreadyUsedArgs, selfArgOpt: Val option, codeGenFunction, m) = let cgbuf = CodeGenBuffer(m, mgbuf, methodName, alreadyUsedArgs) let start = CG.GenerateMark cgbuf "mstart" let finish = CG.GenerateDelayMark cgbuf "mfinish" @@ -2216,17 +2220,20 @@ let CodeGenThen cenv mgbuf (entryPointInfo, methodName, eenv, alreadyUsedArgs, s // When debugging, put the "this" parameter in a local that has the right name match selfArgOpt with - | Some selfArg when selfArg.LogicalName <> "this" && not (selfArg.LogicalName.StartsWith("_")) && not cenv.opts.localOptimizationsEnabled -> - let ilTy = selfArg.Type |> GenType cenv.amap m eenv.tyenv + | Some selfArg when selfArg.LogicalName <> "this" && not (selfArg.LogicalName.StartsWith("_")) && not cenv.options.localOptimizationsEnabled -> + let ilTy = selfArg.Type |> GenType cenv m eenv.tyenv let idx = cgbuf.AllocLocal([(selfArg.LogicalName, (start, finish)) ], ilTy, false) cgbuf.EmitStartOfHiddenCode() CG.EmitInstrs cgbuf (pop 0) Push0 [ mkLdarg0; I_stloc (uint16 idx) ] | _ -> () // Call the given code generator - codeGenFunction cgbuf {eenv with withinSEH=false - liveLocals=IntMap.empty() - innerVals = innerVals} + codeGenFunction cgbuf + { eenv with + withinSEH=false + liveLocals=IntMap.empty() + innerVals = innerVals} + cgbuf.SetMarkToHere finish let locals, maxStack, lab2pc, code, exnSpecs, hasDebugPoints = cgbuf.Close() @@ -2244,7 +2251,7 @@ let CodeGenThen cenv mgbuf (entryPointInfo, methodName, eenv, alreadyUsedArgs, s |> List.map (fun (infos, ty, isFixed) -> let loc = // in interactive environment, attach name and range info to locals to improve debug experience - if cenv.opts.isInteractive && cenv.opts.generateDebugSymbols then + if cenv.options.isInteractive && cenv.options.generateDebugSymbols then match infos with | [(nm, (start, finish))] -> mkILLocal ty (Some(nm, start.CodeLabel, finish.CodeLabel)) // REVIEW: what do these cases represent? @@ -2514,19 +2521,19 @@ and GenExprAux (cenv: cenv) (cgbuf: CodeGenBuffer) eenv expr (sequel: sequel) = | TOp.LValueOp (LAddrOf _, v), [], [] -> GenGetValAddr cenv cgbuf eenv (v, m) sequel | TOp.Array, elems, [elemTy] -> GenNewArray cenv cgbuf eenv (elems, elemTy, m) sequel | TOp.Bytes bytes, [], [] -> - if cenv.opts.emitConstantArraysUsingStaticDataBlobs then + if cenv.options.emitConstantArraysUsingStaticDataBlobs then GenConstArray cenv cgbuf eenv g.ilg.typ_Byte bytes (fun buf b -> buf.EmitByte b) GenSequel cenv eenv.cloc cgbuf sequel else GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkByte g m) bytes), g.byte_ty, m) sequel | TOp.UInt16s arr, [], [] -> - if cenv.opts.emitConstantArraysUsingStaticDataBlobs then + if cenv.options.emitConstantArraysUsingStaticDataBlobs then GenConstArray cenv cgbuf eenv g.ilg.typ_UInt16 arr (fun buf b -> buf.EmitUInt16 b) GenSequel cenv eenv.cloc cgbuf sequel else GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkUInt16 g m) arr), g.uint16_ty, m) sequel | TOp.Goto label, _, _ -> - if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then + if cgbuf.mgbuf.cenv.options.generateDebugSymbols then cgbuf.EmitStartOfHiddenCode() CG.EmitInstr cgbuf (pop 0) Push0 AI_nop CG.EmitInstr cgbuf (pop 0) Push0 (I_br label) @@ -2639,7 +2646,7 @@ and GenSequel cenv cloc cgbuf sequel = // Emit a NOP in debug code in case the branch instruction gets eliminated // because it is a "branch to next instruction". This prevents two unrelated debug points // (the one before the branch and the one after) being coalesced together - if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then + if cgbuf.mgbuf.cenv.options.generateDebugSymbols then cgbuf.EmitStartOfHiddenCode() CG.EmitInstr cgbuf (pop 0) Push0 AI_nop @@ -2669,7 +2676,7 @@ and GenSequel cenv cloc cgbuf sequel = and GenConstant cenv cgbuf eenv (c, m, ty) sequel = let g = cenv.g - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty // Check if we need to generate the value at all match sequelAfterDiscard sequel with | None -> @@ -2714,7 +2721,7 @@ and GenConstant cenv cgbuf eenv (c, m, ty) sequel = and GenUnitTy cenv eenv m = match cenv.ilUnitTy with | None -> - let res = GenType cenv.amap m eenv.tyenv cenv.g.unit_ty + let res = GenType cenv m eenv.tyenv cenv.g.unit_ty cenv.ilUnitTy <- Some res res | Some res -> res @@ -2736,7 +2743,7 @@ and GenAllocTuple cenv cgbuf eenv (tupInfo, args, argTys, m) sequel = let tupInfo = evalTupInfoIsStruct tupInfo let tcref, tys, args, newm = mkCompiledTuple cenv.g tupInfo (argTys, args, m) - let ty = GenNamedTyApp cenv.amap newm eenv.tyenv tcref tys + let ty = GenNamedTyApp cenv newm eenv.tyenv tcref tys let ntyvars = if (tys.Length - 1) < goodTupleFields then (tys.Length - 1) else goodTupleFields let formalTyvars = [ for n in 0 .. ntyvars do yield mkILTyvarTy (uint16 n) ] @@ -2754,14 +2761,14 @@ and GenGetTupleField cenv cgbuf eenv (tupInfo, e, tys, n, m) sequel = if ar <= 0 then failwith "getCompiledTupleItem" elif ar < maxTuple then let tcr' = mkCompiledTupleTyconRef g tupInfo ar - let ty = GenNamedTyApp cenv.amap m eenv.tyenv tcr' tys + let ty = GenNamedTyApp cenv m eenv.tyenv tcr' tys mkGetTupleItemN g m n ty tupInfo e tys[n] else let tysA, tysB = List.splitAfter goodTupleFields tys let tyB = mkCompiledTupleTy g tupInfo tysB let tys' = tysA@[tyB] let tcr' = mkCompiledTupleTyconRef g tupInfo (List.length tys') - let ty' = GenNamedTyApp cenv.amap m eenv.tyenv tcr' tys' + let ty' = GenNamedTyApp cenv m eenv.tyenv tcr' tys' let n' = (min n goodTupleFields) let elast = mkGetTupleItemN g m n' ty' tupInfo e tys'[n'] if n < goodTupleFields then @@ -2772,9 +2779,9 @@ and GenGetTupleField cenv cgbuf eenv (tupInfo, e, tys, n, m) sequel = and GenAllocExn cenv cgbuf eenv (c, args, m) sequel = GenExprs cenv cgbuf eenv args - let ty = GenExnType cenv.amap m eenv.tyenv c + let ty = GenExnType cenv m eenv.tyenv c let flds = recdFieldsOfExnDefRef c - let argTys = flds |> List.map (fun rfld -> GenType cenv.amap m eenv.tyenv rfld.FormalType) + let argTys = flds |> List.map (fun rfld -> GenType cenv m eenv.tyenv rfld.FormalType) let mspec = mkILCtorMethSpecForTy (ty, argTys) CG.EmitInstr cgbuf (pop args.Length) (Push [ty]) @@ -2782,7 +2789,7 @@ and GenAllocExn cenv cgbuf eenv (c, args, m) sequel = GenSequel cenv eenv.cloc cgbuf sequel and GenAllocUnionCaseCore cenv cgbuf eenv (c,tyargs,n,m) = - let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv c tyargs + let cuspec,idx = GenUnionCaseSpec cenv m eenv.tyenv c tyargs CG.EmitInstrs cgbuf (pop n) (Push [cuspec.DeclaringType]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx)) and GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel = @@ -2902,7 +2909,7 @@ and GenLinearExpr cenv cgbuf eenv expr sequel preSteps (contf: FakeUnit -> FakeU contf Fake and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref,argTys,args,m) sequel = - let ty = GenNamedTyApp cenv.amap m eenv.tyenv tcref argTys + let ty = GenNamedTyApp cenv m eenv.tyenv tcref argTys // Filter out fields with default initialization let relevantFields = @@ -2925,14 +2932,14 @@ and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref,argTys,args,m) sequel = let tyenvinner = eenv.tyenv.ForTyconRef tcref CG.EmitInstr cgbuf (pop args.Length) (Push [ty]) (mkNormalNewobj - (mkILCtorMethSpecForTy (ty, relevantFields |> List.map (fun f -> GenType cenv.amap m tyenvinner f.FormalType) ))) + (mkILCtorMethSpecForTy (ty, relevantFields |> List.map (fun f -> GenType cenv m tyenvinner f.FormalType) ))) GenSequel cenv eenv.cloc cgbuf sequel and GenAllocAnonRecd cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, tyargs, args, m) sequel = let anonCtor, _anonMethods, anonType = cgbuf.mgbuf.LookupAnonType ((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) let boxity = anonType.Boxity GenExprs cenv cgbuf eenv args - let ilTypeArgs = GenTypeArgs cenv.amap m eenv.tyenv tyargs + let ilTypeArgs = GenTypeArgs cenv m eenv.tyenv tyargs let anonTypeWithInst = mkILTy boxity (mkILTySpec(anonType.TypeSpec.TypeRef, ilTypeArgs)) CG.EmitInstr cgbuf (pop args.Length) (Push [anonTypeWithInst]) (mkNormalNewobj (mkILMethSpec(anonCtor, boxity, ilTypeArgs, []))) GenSequel cenv eenv.cloc cgbuf sequel @@ -2940,7 +2947,7 @@ and GenAllocAnonRecd cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, tyargs, args, and GenGetAnonRecdField cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, e, tyargs, n, m) sequel = let _anonCtor, anonMethods, anonType = cgbuf.mgbuf.LookupAnonType ((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) let boxity = anonType.Boxity - let ilTypeArgs = GenTypeArgs cenv.amap m eenv.tyenv tyargs + let ilTypeArgs = GenTypeArgs cenv m eenv.tyenv tyargs let anonMethod = anonMethods[n] let anonFieldType = ilTypeArgs[n] GenExpr cenv cgbuf eenv e Continue @@ -2948,7 +2955,7 @@ and GenGetAnonRecdField cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, e, tyargs, GenSequel cenv eenv.cloc cgbuf sequel and GenNewArraySimple cenv cgbuf eenv (elems, elemTy, m) sequel = - let ilElemTy = GenType cenv.amap m eenv.tyenv elemTy + let ilElemTy = GenType cenv m eenv.tyenv elemTy let ilArrTy = mkILArr1DTy ilElemTy if List.isEmpty elems && cenv.g.isArrayEmptyAvailable then @@ -2969,7 +2976,7 @@ and GenNewArray cenv cgbuf eenv (elems: Expr list, elemTy, m) sequel = // InitializeArray is a JIT intrinsic that will result in invalid runtime CodeGen when initializing an array // of enum types. Until bug 872799 is fixed, we'll need to generate arrays the "simple" way for enum types // Also note - C# never uses InitializeArray for enum types, so this change puts us on equal footing with them. - if elems.Length <= 5 || not cenv.opts.emitConstantArraysUsingStaticDataBlobs || (isEnumTy cenv.g elemTy) then + if elems.Length <= 5 || not cenv.options.emitConstantArraysUsingStaticDataBlobs || (isEnumTy cenv.g elemTy) then GenNewArraySimple cenv cgbuf eenv (elems, elemTy, m) sequel else // Try to emit a constant byte-blob array @@ -3009,7 +3016,7 @@ and GenNewArray cenv cgbuf eenv (elems: Expr list, elemTy, m) sequel = | _ -> (function _ -> false), (fun _ _ -> failwith "unreachable") if elemsArray |> Array.forall (function Expr.Const (c, _, _) -> test c | _ -> false) then - let ilElemTy = GenType cenv.amap m eenv.tyenv elemTy + let ilElemTy = GenType cenv m eenv.tyenv elemTy GenConstArray cenv cgbuf eenv ilElemTy elemsArray (fun buf -> function Expr.Const (c, _, _) -> write buf c | _ -> failwith "unreachable") GenSequel cenv eenv.cloc cgbuf sequel @@ -3025,7 +3032,7 @@ and GenCoerce cenv cgbuf eenv (e, tgty, m, srcty) sequel = then if isInterfaceTy g tgty then GenExpr cenv cgbuf eenv e Continue - let ilToTy = GenType cenv.amap m eenv.tyenv tgty + let ilToTy = GenType cenv m eenv.tyenv tgty // Section "III.1.8.1.3 Merging stack states" of ECMA-335 implies that no unboxing // is required, but we still push the coerced type on to the code gen buffer. CG.EmitInstrs cgbuf (pop 1) (Push [ilToTy]) [] @@ -3035,15 +3042,15 @@ and GenCoerce cenv cgbuf eenv (e, tgty, m, srcty) sequel = else GenExpr cenv cgbuf eenv e Continue if not (isObjTy g srcty) then - let ilFromTy = GenType cenv.amap m eenv.tyenv srcty + let ilFromTy = GenType cenv m eenv.tyenv srcty CG.EmitInstr cgbuf (pop 1) (Push [g.ilg.typ_Object]) (I_box ilFromTy) if not (isObjTy g tgty) then - let ilToTy = GenType cenv.amap m eenv.tyenv tgty + let ilToTy = GenType cenv m eenv.tyenv tgty CG.EmitInstr cgbuf (pop 1) (Push [ilToTy]) (I_unbox_any ilToTy) GenSequel cenv eenv.cloc cgbuf sequel and GenReraise cenv cgbuf eenv (rtnty, m) sequel = - let ilReturnTy = GenType cenv.amap m eenv.tyenv rtnty + let ilReturnTy = GenType cenv m eenv.tyenv rtnty CG.EmitInstr cgbuf (pop 0) Push0 I_rethrow // [See comment related to I_throw]. // Rethrow does not return. Required to push dummy value on the stack. @@ -3054,11 +3061,11 @@ and GenReraise cenv cgbuf eenv (rtnty, m) sequel = and GenGetExnField cenv cgbuf eenv (e, ecref, fieldNum, m) sequel = GenExpr cenv cgbuf eenv e Continue let exnc = stripExnEqns ecref - let ty = GenExnType cenv.amap m eenv.tyenv ecref + let ty = GenExnType cenv m eenv.tyenv ecref CG.EmitInstr cgbuf (pop 0) Push0 (I_castclass ty) let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList - let ftyp = GenType cenv.amap m eenv.tyenv fld.FormalType + let ftyp = GenType cenv m eenv.tyenv fld.FormalType let mspec = mkILNonGenericInstanceMethSpecInTy (ty, "get_" + fld.LogicalName, [], ftyp) CG.EmitInstr cgbuf (pop 1) (Push [ftyp]) (mkNormalCall mspec) @@ -3068,10 +3075,10 @@ and GenGetExnField cenv cgbuf eenv (e, ecref, fieldNum, m) sequel = and GenSetExnField cenv cgbuf eenv (e, ecref, fieldNum, e2, m) sequel = GenExpr cenv cgbuf eenv e Continue let exnc = stripExnEqns ecref - let ty = GenExnType cenv.amap m eenv.tyenv ecref + let ty = GenExnType cenv m eenv.tyenv ecref CG.EmitInstr cgbuf (pop 0) Push0 (I_castclass ty) let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList - let ftyp = GenType cenv.amap m eenv.tyenv fld.FormalType + let ftyp = GenType cenv m eenv.tyenv fld.FormalType let ilFieldName = ComputeFieldName exnc fld GenExpr cenv cgbuf eenv e2 Continue CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStfld(mkILFieldSpecInTy (ty, ilFieldName, ftyp))) @@ -3081,7 +3088,7 @@ and UnionCodeGen (cgbuf: CodeGenBuffer) = { new EraseUnions.ICodeGen with member _.CodeLabel m = m.CodeLabel member _.GenerateDelayMark() = CG.GenerateDelayMark cgbuf "unionCodeGenMark" - member _.GenLocal ilty = cgbuf.AllocLocal([], ilty, false) |> uint16 + member _.GenLocal ilTy = cgbuf.AllocLocal([], ilTy, false) |> uint16 member _.SetMarkToHere m = CG.SetMarkToHere cgbuf m member _.MkInvalidCastExnNewobj () = mkInvalidCastExnNewobj cgbuf.mgbuf.cenv.g member _.EmitInstr x = CG.EmitInstr cgbuf (pop 0) (Push []) x @@ -3090,7 +3097,7 @@ and UnionCodeGen (cgbuf: CodeGenBuffer) = and GenUnionCaseProof cenv cgbuf eenv (e, ucref, tyargs, m) sequel = let g = cenv.g GenExpr cenv cgbuf eenv e Continue - let cuspec, idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs + let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = EraseUnions.GetILTypeForAlternative cuspec idx let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, cuspec, idx) @@ -3102,7 +3109,7 @@ and GenGetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr g e)) GenExpr cenv cgbuf eenv e Continue - let cuspec, idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs + let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef CG.EmitInstr cgbuf (pop 1) (Push [fty]) (EraseUnions.mkLdData (avoidHelpers, cuspec, idx, n)) @@ -3113,7 +3120,7 @@ and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr g e)) GenExpr cenv cgbuf eenv e Continue - let cuspec, idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs + let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef CG.EmitInstr cgbuf (pop 1) (Push [ILType.Byref fty]) (EraseUnions.mkLdDataAddr (avoidHelpers, cuspec, idx, n)) @@ -3122,7 +3129,7 @@ and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = let g = cenv.g GenExpr cenv cgbuf eenv e Continue - let cuspec = GenUnionSpec cenv.amap m eenv.tyenv tcref tyargs + let cuspec = GenUnionSpec cenv m eenv.tyenv tcref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore tcref EraseUnions.emitLdDataTag g.ilg (UnionCodeGen cgbuf) (avoidHelpers, cuspec) CG.EmitInstrs cgbuf (pop 1) (Push [g.ilg.typ_Int32]) [ ] // push/pop to match the line above @@ -3131,7 +3138,7 @@ and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = and GenSetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, e2, m) sequel = let g = cenv.g GenExpr cenv cgbuf eenv e Continue - let cuspec, idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs + let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, cuspec, idx) CG.EmitInstrs cgbuf (pop 1) (Push [cuspec.DeclaringType]) [ ] // push/pop to match the line above @@ -3264,7 +3271,7 @@ and GenWitnessArgFromTraitInfo cenv cgbuf eenv m traitInfo = GenExpr cenv cgbuf eenv arg Continue | Some storage -> let ty = GenWitnessTy g traitInfo.TraitKey - GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) storage None + GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv m eenv.tyenv ty) storage None and GenWitnessArgFromWitnessInfo cenv cgbuf eenv m witnessInfo = let g = cenv.g @@ -3275,7 +3282,7 @@ and GenWitnessArgFromWitnessInfo cenv cgbuf eenv m witnessInfo = failwith "unexpected non-generation of witness " | Some storage -> let ty = GenWitnessTy g witnessInfo - GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) storage None + GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv m eenv.tyenv ty) storage None and GenWitnessArgsFromWitnessInfos cenv cgbuf eenv m witnessInfos = let g = cenv.g @@ -3464,7 +3471,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = else mspecW - let ilTyArgs = GenTypeArgs cenv.amap m eenv.tyenv tyargs + let ilTyArgs = GenTypeArgs cenv m eenv.tyenv tyargs // For instance method calls chop off some type arguments, which are already // carried by the class. Also work out if it's a virtual call. @@ -3510,7 +3517,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = let callInstr = match valUseFlags with | PossibleConstrainedCall ty -> - let ilThisTy = GenType cenv.amap m eenv.tyenv ty + let ilThisTy = GenType cenv m eenv.tyenv ty I_callconstraint ( isTailCall, ilThisTy, mspec, None) | _ -> if newobj then I_newobj (mspec, None) @@ -3535,7 +3542,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = (eenv, laterArgs) ||> List.mapFold (fun eenv laterArg -> // Only save arguments that have effects if Optimizer.ExprHasEffect g laterArg then - let ilTy = laterArg |> tyOfExpr g |> GenType cenv.amap m eenv.tyenv + let ilTy = laterArg |> tyOfExpr g |> GenType cenv m eenv.tyenv let locName = // Ensure that we have an g.CompilerGlobalState assert(g.CompilerGlobalState |> Option.isSome) @@ -3548,7 +3555,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = Choice2Of2 laterArg, eenv) let nargs = mspec.FormalArgTypes.Length - let pushes = if mustGenerateUnitAfterCall || isSuperInit || isSelfInit then Push0 else (Push [(GenType cenv.amap m eenv.tyenv actualRetTy)]) + let pushes = if mustGenerateUnitAfterCall || isSuperInit || isSelfInit then Push0 else (Push [(GenType cenv m eenv.tyenv actualRetTy)]) CG.EmitInstr cgbuf (pop (nargs + (if mspec.CallingConv.IsStatic || newobj then 0 else 1))) pushes callInstr // For isSuperInit, load the 'this' pointer as the pretend 'result' of the operation. It will be popped again in most cases @@ -3556,7 +3563,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = // When generating debug code, generate a 'nop' after a 'call' that returns 'void' // This is what C# does, as it allows the call location to be maintained correctly in the stack frame - if cenv.opts.generateDebugSymbols && mustGenerateUnitAfterCall && (isTailCall = Normalcall) then + if cenv.options.generateDebugSymbols && mustGenerateUnitAfterCall && (isTailCall = Normalcall) then CG.EmitInstr cgbuf (pop 0) Push0 AI_nop if isNil laterArgs then @@ -3612,7 +3619,7 @@ and ArgStorageForWitnessInfos (cenv: cenv) (eenv: IlxGenEnv) takenNames pretaken (witnessInfos, List.indexed names) ||> List.map2 (fun w (i, nm) -> let ty = GenWitnessTy cenv.g w - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty let ilParam = mkILParam (Some nm, ilTy) let storage = Arg (i+pretakenArgs) ilParam, (w, storage)) @@ -3624,7 +3631,7 @@ and FreeVarStorageForWitnessInfos (cenv: cenv) (eenv: IlxGenEnv) takenNames ilCl (witnessInfos, names) ||> List.map2 (fun w nm -> let ty = GenWitnessTy cenv.g w - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty let ilFv = mkILFreeVar (nm, true, ilTy) let storage = let ilField = mkILFieldSpecInTy (ilCloTyInner, ilFv.fvName, ilFv.fvType) @@ -3687,7 +3694,7 @@ and AddDirectTyparWitnessParams cenv eenv cloinfo m = and GenNamedLocalTyFuncCall cenv (cgbuf: CodeGenBuffer) eenv ty cloinfo tyargs m = let g = cenv.g - let ilTyArgs = tyargs |> GenTypeArgs cenv.amap m eenv.tyenv + let ilTyArgs = tyargs |> GenTypeArgs cenv m eenv.tyenv let ilCloTy = cloinfo.cloSpec.ILType let ilDirectGenericParams, ilDirectWitnessParams, directWitnessInfos = @@ -3715,7 +3722,7 @@ and GenNamedLocalTyFuncCall cenv (cgbuf: CodeGenBuffer) eenv ty cloinfo tyargs m GenWitnessArgsFromWitnessInfos cenv cgbuf eenv m directWitnessInfos - let ilActualRetTy = GenType cenv.amap m eenv.tyenv actualRetTy + let ilActualRetTy = GenType cenv m eenv.tyenv actualRetTy CountCallFuncInstructions() CG.EmitInstr cgbuf (pop (1+ilDirectWitnessParamsTys.Length)) (Push [ilActualRetTy]) (mkNormalCall ilDirectInvokeMethSpec) actualRetTy @@ -3745,14 +3752,14 @@ and GenIndirectCall cenv cgbuf eenv (functy, tyargs, curriedArgs, m) sequel = let formalRetTy, appBuilder = ((formalFuncTy, id), curriedArgs) ||> List.fold (fun (formalFuncTy, appBuilder) _ -> let dty, rty = destFunTy cenv.g formalFuncTy - (rty, (fun acc -> appBuilder (Apps_app(GenType cenv.amap m feenv dty, acc))))) + (rty, (fun acc -> appBuilder (Apps_app(GenType cenv m feenv dty, acc))))) - let ilxRetApps = Apps_done (GenType cenv.amap m feenv formalRetTy) + let ilxRetApps = Apps_done (GenType cenv m feenv formalRetTy) - List.foldBack (fun tyarg acc -> Apps_tyapp(GenType cenv.amap m eenv.tyenv tyarg, acc)) tyargs (appBuilder ilxRetApps) + List.foldBack (fun tyarg acc -> Apps_tyapp(GenType cenv m eenv.tyenv tyarg, acc)) tyargs (appBuilder ilxRetApps) let actualRetTy = applyTys g functy (tyargs, curriedArgs) - let ilActualRetTy = GenType cenv.amap m eenv.tyenv actualRetTy + let ilActualRetTy = GenType cenv m eenv.tyenv actualRetTy // Check if any byrefs are involved to make sure we don't tailcall let hasByrefArg = @@ -3767,7 +3774,7 @@ and GenIndirectCall cenv cgbuf eenv (functy, tyargs, curriedArgs, m) sequel = CountCallFuncInstructions() // Generate the code code an ILX callfunc operation - let instrs = EraseClosures.mkCallFunc g.ilxPubCloEnv (fun ty -> cgbuf.AllocLocal([], ty, false) |> uint16) eenv.tyenv.Count isTailCall ilxClosureApps + let instrs = EraseClosures.mkCallFunc cenv.ilxPubCloEnv (fun ty -> cgbuf.AllocLocal([], ty, false) |> uint16) eenv.tyenv.Count isTailCall ilxClosureApps CG.EmitInstrs cgbuf (pop (1+curriedArgs.Length)) (Push [ilActualRetTy]) instrs // Done compiling indirect call... @@ -3792,7 +3799,7 @@ and GenTry cenv cgbuf eenv scopeMarks (e1, m, resultTy, spTry) = if isUnitTy g resultTy then None else - Some (GenType cenv.amap m eenvinner.tyenv resultTy) + Some (GenType cenv m eenvinner.tyenv resultTy) let whereToSaveOpt, eenvinner = match ilResultTyOpt with @@ -3865,7 +3872,7 @@ and eligibleForFilter (cenv: cenv) expr = | _ -> false // Filters seem to generate invalid code for the ilreflect.fs backend - (cenv.opts.ilxBackend = IlxGenBackend.IlWriteBackend) && + (cenv.options.ilxBackend = IlxGenBackend.IlWriteBackend) && not isTrivial && check expr @@ -3878,7 +3885,7 @@ and GenTryWith cenv cgbuf eenv (e1, valForFilter: Val, filterExpr, valForHandler let whereToSaveOpt, eenvinner, stack, tryMarks, afterHandler = GenTry cenv cgbuf eenv scopeMarks (e1, m, resty, spTry) let seh = - if cenv.opts.generateFilterBlocks || eligibleForFilter cenv filterExpr then + if cenv.options.generateFilterBlocks || eligibleForFilter cenv filterExpr then let startOfFilter = CG.GenerateMark cgbuf "startOfFilter" let afterFilter = CG.GenerateDelayMark cgbuf "afterFilter" let sequelOnBranches, afterJoin, stackAfterJoin, sequelAfterJoin = GenJoinPoint cenv cgbuf "filter" eenv g.int_ty m EndFilter @@ -4158,8 +4165,8 @@ and GenWhileLoop cenv cgbuf eenv (spWhile, condExpr, bodyExpr, m) sequel = and GenAsmCode cenv cgbuf eenv (il, tyargs, args, returnTys, m) sequel = let g = cenv.g - let ilTyArgs = GenTypesPermitVoid cenv.amap m eenv.tyenv tyargs - let ilReturnTys = GenTypesPermitVoid cenv.amap m eenv.tyenv returnTys + let ilTyArgs = GenTypesPermitVoid cenv m eenv.tyenv tyargs + let ilReturnTys = GenTypesPermitVoid cenv m eenv.tyenv returnTys let ilAfterInst = il |> List.filter (function AI_nop -> false | _ -> true) |> List.map (fun i -> @@ -4337,7 +4344,7 @@ and GenQuotation cenv cgbuf eenv (ast, qdataCell, m, ety) sequel = let someTypeInModuleExpr = mkTypeOfExpr cenv m eenv.someTypeInThisAssembly let rawTy = mkRawQuotedExprTy g - let typeSpliceExprs = List.map (GenType cenv.amap m eenv.tyenv >> (mkTypeOfExpr cenv m)) typeSplices + let typeSpliceExprs = List.map (GenType cenv m eenv.tyenv >> (mkTypeOfExpr cenv m)) typeSplices let bytesExpr = Expr.Op (TOp.Bytes astSerializedBytes, [], [], m) @@ -4379,9 +4386,9 @@ and GenILCall cenv cgbuf eenv (virt, valu, newobj, valUseFlags, isDllImport, ilM let hasStructObjArg = valu && ilMethRef.CallingConv.IsInstance let tail = CanTailcall(hasStructObjArg, ccallInfo, eenv.withinSEH, hasByrefArg, mustGenerateUnitAfterCall, isDllImport, false, makesNoCriticalTailcalls, sequel) - let ilEnclArgTys = GenTypeArgs cenv.amap m eenv.tyenv enclArgTys - let ilMethArgTys = GenTypeArgs cenv.amap m eenv.tyenv methArgTys - let ilReturnTys = GenTypes cenv.amap m eenv.tyenv returnTys + let ilEnclArgTys = GenTypeArgs cenv m eenv.tyenv enclArgTys + let ilMethArgTys = GenTypeArgs cenv m eenv.tyenv methArgTys + let ilReturnTys = GenTypes cenv m eenv.tyenv returnTys let ilMethSpec = mkILMethSpec (ilMethRef, boxity, ilEnclArgTys, ilMethArgTys) let useICallVirt = virt || useCallVirt cenv boxity ilMethSpec isBaseCall @@ -4395,7 +4402,7 @@ and GenILCall cenv cgbuf eenv (virt, valu, newobj, valUseFlags, isDllImport, ilM else match ccallInfo with | Some objArgTy -> - let ilObjArgTy = GenType cenv.amap m eenv.tyenv objArgTy + let ilObjArgTy = GenType cenv m eenv.tyenv objArgTy I_callconstraint (tail, ilObjArgTy, ilMethSpec, None) | None -> if useICallVirt then I_callvirt (tail, ilMethSpec, None) @@ -4417,8 +4424,8 @@ and CommitCallSequel cenv eenv m cloc cgbuf mustGenerateUnitAfterCall sequel = and MakeNotSupportedExnExpr cenv eenv (argExpr, m) = let g = cenv.g let ety = mkAppTy (g.FindSysTyconRef ["System"] "NotSupportedException") [] - let ilty = GenType cenv.amap m eenv.tyenv ety - let mref = mkILCtorMethSpecForTy(ilty, [g.ilg.typ_String]).MethodRef + let ilTy = GenType cenv m eenv.tyenv ety + let mref = mkILCtorMethSpecForTy(ilTy, [g.ilg.typ_String]).MethodRef Expr.Op (TOp.ILCall (false, false, false, true, NormalValUse, false, false, mref, [], [], [ety]), [], [argExpr], m) and GenTraitCall (cenv: cenv) cgbuf eenv (traitInfo: TraitConstraintInfo, argExprs, m) expr sequel = @@ -4435,7 +4442,7 @@ and GenTraitCall (cenv: cenv) cgbuf eenv (traitInfo: TraitConstraintInfo, argExp let ty = GenWitnessTy g traitInfo.TraitKey let argExprs = if argExprs.Length = 0 then [ mkUnit g m ] else argExprs - GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) storage (Some([], argExprs, m, sequel)) + GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv m eenv.tyenv ty) storage (Some([], argExprs, m, sequel)) | None -> @@ -4491,20 +4498,20 @@ and GenGetValAddr cenv cgbuf eenv (v: ValRef, m) sequel = and GenGetByref cenv cgbuf eenv (v: ValRef, m) sequel = GenGetLocalVRef cenv cgbuf eenv m v None - let ilty = GenType cenv.amap m eenv.tyenv (destByrefTy cenv.g v.Type) - CG.EmitInstr cgbuf (pop 1) (Push [ilty]) (mkNormalLdobj ilty) + let ilTy = GenType cenv m eenv.tyenv (destByrefTy cenv.g v.Type) + CG.EmitInstr cgbuf (pop 1) (Push [ilTy]) (mkNormalLdobj ilTy) GenSequel cenv eenv.cloc cgbuf sequel and GenSetByref cenv cgbuf eenv (v: ValRef, e, m) sequel = GenGetLocalVRef cenv cgbuf eenv m v None GenExpr cenv cgbuf eenv e Continue - let ilty = GenType cenv.amap m eenv.tyenv (destByrefTy cenv.g v.Type) - CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStobj ilty) + let ilTy = GenType cenv m eenv.tyenv (destByrefTy cenv.g v.Type) + CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStobj ilTy) GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel and GenDefaultValue cenv cgbuf eenv (ty, m) = let g = cenv.g - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty if isRefTy g ty then CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) AI_ldnull else @@ -4526,7 +4533,7 @@ and GenDefaultValue cenv cgbuf eenv (ty, m) = | ValueSome tcref when (tyconRefEq g g.system_Double_tcref tcref) -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (iLdcDouble 0.0) | _ -> - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty LocalScope "ilzero" cgbuf (fun scopeMarks -> let locIdx, realloc, _ = // Ensure that we have an g.CompilerGlobalState @@ -4558,7 +4565,7 @@ and GenGenericParam cenv eenv (tp: Typar) = let subTypeConstraints = tp.Constraints |> List.choose (function | TyparConstraint.CoercesTo(ty, _) -> Some ty | _ -> None) - |> List.map (GenTypeAux cenv.amap tp.Range eenv.tyenv VoidNotOK PtrTypesNotOK) + |> List.map (GenTypeAux cenv tp.Range eenv.tyenv VoidNotOK PtrTypesNotOK) let refTypeConstraint = tp.Constraints @@ -4606,8 +4613,9 @@ and GenGenericParam cenv eenv (tp: Typar) = //-------------------------------------------------------------------------- /// Generates the data used for parameters at definitions of abstract method slots such as interface methods or override methods. -and GenSlotParam m cenv eenv (TSlotParam(nm, ty, inFlag, outFlag, optionalFlag, attribs)) : ILParameter = - let ilTy = GenParamType cenv.amap m eenv.tyenv true ty +and GenSlotParam m cenv eenv slotParam : ILParameter = + let (TSlotParam(nm, ty, inFlag, outFlag, optionalFlag, attribs)) = slotParam + let ilTy = GenParamType cenv m eenv.tyenv true ty let inFlag2, outFlag2, optionalFlag2, defaultParamValue, paramMarshal2, attribs = GenParamAttribs cenv ty attribs let ilAttribs = GenAttrs cenv eenv attribs @@ -4627,9 +4635,10 @@ and GenSlotParam m cenv eenv (TSlotParam(nm, ty, inFlag, outFlag, optionalFlag, CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs ilAttribs) MetadataIndex = NoMetadataIdx } -and GenFormalSlotsig m cenv eenv (TSlotSig(_, ty, ctps, mtps, paraml, returnTy)) = +and GenFormalSlotsig m cenv eenv slotsig = + let (TSlotSig(_, ty, ctps, mtps, paraml, returnTy)) = slotsig let paraml = List.concat paraml - let ilTy = GenType cenv.amap m eenv.tyenv ty + let ilTy = GenType cenv m eenv.tyenv ty let eenvForSlotSig = EnvForTypars (ctps @ mtps) eenv let ilParams = paraml |> List.map (GenSlotParam m cenv eenvForSlotSig) let ilRet = GenFormalReturnType m cenv eenvForSlotSig returnTy @@ -4643,7 +4652,7 @@ and GenOverridesSpec cenv eenv slotsig m = OverridesSpec(ilOverrideMethRef, ilOverrideTy) and GenFormalReturnType m cenv eenvFormal returnTy : ILReturn = - let ilRetTy = GenReturnType cenv.amap m eenvFormal.tyenv returnTy + let ilRetTy = GenReturnType cenv m eenvFormal.tyenv returnTy let ilRet = mkILReturn ilRetTy match returnTy with | None -> ilRet @@ -4666,7 +4675,7 @@ and GenActualSlotsig m cenv eenv (TSlotSig(_, ty, ctps, mtps, ilSlotParams, ilSl (ilParams, methodParams) ||> List.map2 (fun p pv -> { p with Name = Some (nameOfVal pv) }) else ilParams - let ilRetTy = GenReturnType cenv.amap m eenv.tyenv (Option.map (instType instForSlotSig) ilSlotRetTy) + let ilRetTy = GenReturnType cenv m eenv.tyenv (Option.map (instType instForSlotSig) ilSlotRetTy) let iLRet = mkILReturn ilRetTy ilParams, iLRet @@ -4790,7 +4799,7 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel // The closure implements what ever interfaces the template implements. let interfaceTys = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g cenv.amap m templateStructTy - let ilInterfaceTys = List.map (GenType cenv.amap m eenvinner.tyenv) interfaceTys + let ilInterfaceTys = List.map (GenType cenv m eenvinner.tyenv) interfaceTys let super = g.iltyp_ValueType @@ -4838,9 +4847,9 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel | [meth] when meth.IsInstance -> meth | _ -> error(InternalError(sprintf "expected method %s not found" imethName, m)) let argTys = implementedMeth.GetParamTypes(cenv.amap, m, []) |> List.concat - let retTy = implementedMeth.GetCompiledReturnTy(cenv.amap, m, []) - let ilRetTy = GenReturnType cenv.amap m eenvinner.tyenv retTy - let ilArgTys = argTys |> GenTypes cenv.amap m eenvinner.tyenv + let retTy = implementedMeth.GetCompiledReturnType(cenv.amap, m, []) + let ilRetTy = GenReturnType cenv m eenvinner.tyenv retTy + let ilArgTys = argTys |> GenTypes cenv m eenvinner.tyenv if ilArgTys.Length <> argVals.Length then error(InternalError(sprintf "expected method arg count of %d, got %d for method %s" argVals.Length ilArgTys.Length imethName, m)) let eenvinner = eenvinner |> AddStorageForLocalVals g (thisVals |> List.map (fun v -> (v.Deref, Arg 0))) @@ -4870,7 +4879,7 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel // Suppress the "ResumptionDynamicInfo" from generated state machines if templateFld.LogicalName <> "ResumptionDynamicInfo" then let access = ComputeMemberAccess false - let fty = GenType cenv.amap m eenvinner.tyenv templateFld.FieldType + let fty = GenType cenv m eenvinner.tyenv templateFld.FieldType let fdef = ILFieldDef(name = templateFld.LogicalName, fieldType = fty, attributes = enum 0, data = None, literalValue = None, offset = None, marshal = None, customAttrs = mkILCustomAttrs []) .WithAccess(access) @@ -4989,7 +4998,7 @@ and GenObjectExpr cenv cgbuf eenvouter objExpr (baseType, baseValOpt, basecall, let mimpls = mimpls |> List.choose id // choose the ones that actually have method impls - let interfaceTys = interfaceImpls |> List.map (fst >> GenType cenv.amap m eenvinner.tyenv) + let interfaceTys = interfaceImpls |> List.map (fst >> GenType cenv m eenvinner.tyenv) let super = (if isInterfaceTy g baseType then g.ilg.typ_Object else ilCloRetTy) let interfaceTys = interfaceTys @ (if isInterfaceTy g baseType then [ilCloRetTy] else []) @@ -5003,7 +5012,7 @@ and GenObjectExpr cenv cgbuf eenvouter objExpr (baseType, baseValOpt, basecall, for fv in cloinfo.cloFreeVars do GenGetLocalVal cenv cgbuf eenvouter m fv None - CG.EmitInstr cgbuf (pop ilCloAllFreeVars.Length) (Push [ EraseClosures.mkTyOfLambdas g.ilxPubCloEnv ilCloLambdas]) (I_newobj (cloSpec.Constructor, None)) + CG.EmitInstr cgbuf (pop ilCloAllFreeVars.Length) (Push [ EraseClosures.mkTyOfLambdas cenv.ilxPubCloEnv ilCloLambdas]) (I_newobj (cloSpec.Constructor, None)) GenSequel cenv eenvouter.cloc cgbuf sequel and GenSequenceExpr @@ -5024,13 +5033,13 @@ and GenSequenceExpr let (cloFreeTyvars, cloWitnessInfos, cloFreeVars, ilCloTypeRef: ILTypeRef, ilCloAllFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m [] ILBoxity.AsObject eenvouter [] (mkLambda m nextEnumeratorValRef.Deref (generateNextExpr, g.int32_ty)) - let ilCloSeqElemTy = GenType cenv.amap m eenvinner.tyenv seqElemTy + let ilCloSeqElemTy = GenType cenv m eenvinner.tyenv seqElemTy let cloRetTy = mkSeqTy g seqElemTy - let ilCloRetTyInner = GenType cenv.amap m eenvinner.tyenv cloRetTy - let ilCloRetTyOuter = GenType cenv.amap m eenvouter.tyenv cloRetTy - let ilCloEnumeratorTy = GenType cenv.amap m eenvinner.tyenv (mkIEnumeratorTy g seqElemTy) - let ilCloEnumerableTy = GenType cenv.amap m eenvinner.tyenv (mkSeqTy g seqElemTy) - let ilCloBaseTy = GenType cenv.amap m eenvinner.tyenv (g.mk_GeneratedSequenceBase_ty seqElemTy) + let ilCloRetTyInner = GenType cenv m eenvinner.tyenv cloRetTy + let ilCloRetTyOuter = GenType cenv m eenvouter.tyenv cloRetTy + let ilCloEnumeratorTy = GenType cenv m eenvinner.tyenv (mkIEnumeratorTy g seqElemTy) + let ilCloEnumerableTy = GenType cenv m eenvinner.tyenv (mkSeqTy g seqElemTy) + let ilCloBaseTy = GenType cenv m eenvinner.tyenv (g.mk_GeneratedSequenceBase_ty seqElemTy) let ilCloGenericParams = GenGenericParams cenv eenvinner cloFreeTyvars // Create a new closure class with a single "MoveNext" method that implements the iterator. @@ -5148,7 +5157,7 @@ and GenClosureTypeDefs cenv (tref: ILTypeRef, ilGenParams, attrs, ilCloAllFreeVa .WithEncoding(ILDefaultPInvokeEncoding.Auto) .WithInitSemantics(ILTypeInit.BeforeField) - let tdefs = EraseClosures.convIlxClosureDef g.ilxPubCloEnv tref.Enclosing tdef cloInfo + let tdefs = EraseClosures.convIlxClosureDef cenv.ilxPubCloEnv tref.Enclosing tdef cloInfo tdefs and GenStaticDelegateClosureTypeDefs cenv (tref: ILTypeRef, ilGenParams, attrs, ilCloAllFreeVars, ilCloLambdas, ilCtorBody, mdefs, mimpls, ext, ilIntfTys, staticCloInfo) = @@ -5222,20 +5231,19 @@ and GenLambdaClosure cenv (cgbuf: CodeGenBuffer) eenv isLocalTypeFunc thisVars e | _ -> failwith "GenLambda: not a lambda" and GenClosureAlloc cenv (cgbuf: CodeGenBuffer) eenv (cloinfo, m) = - let g = cenv.g CountClosure() if cloinfo.cloSpec.UseStaticField then let fspec = cloinfo.cloSpec.GetStaticFieldSpec() CG.EmitInstr cgbuf (pop 0) - (Push [EraseClosures.mkTyOfLambdas g.ilxPubCloEnv cloinfo.ilCloLambdas]) + (Push [EraseClosures.mkTyOfLambdas cenv.ilxPubCloEnv cloinfo.ilCloLambdas]) (mkNormalLdsfld fspec) else GenWitnessArgsFromWitnessInfos cenv cgbuf eenv m cloinfo.cloWitnessInfos GenGetLocalVals cenv cgbuf eenv m cloinfo.cloFreeVars CG.EmitInstr cgbuf (pop cloinfo.ilCloAllFreeVars.Length) - (Push [EraseClosures.mkTyOfLambdas g.ilxPubCloEnv cloinfo.ilCloLambdas]) + (Push [EraseClosures.mkTyOfLambdas cenv.ilxPubCloEnv cloinfo.ilCloLambdas]) (I_newobj (cloinfo.cloSpec.Constructor, None)) and GenLambda cenv cgbuf eenv isLocalTypeFunc thisVars expr sequel = @@ -5244,7 +5252,7 @@ and GenLambda cenv cgbuf eenv isLocalTypeFunc thisVars expr sequel = GenSequel cenv eenv.cloc cgbuf sequel and GenTypeOfVal cenv eenv (v: Val) = - GenType cenv.amap v.Range eenv.tyenv v.Type + GenType cenv v.Range eenv.tyenv v.Type and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = let g = cenv.g @@ -5255,7 +5263,7 @@ and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = // Check for things that should never make it into the free variable set. Only do this in debug for performance reasons | StaticPropertyWithField _ | StaticProperty _ | Method _ | Null -> error(InternalError("GenFreevar: compiler error: unexpected unrealized value", fv.Range)) #endif - | _ -> GenType cenv.amap m tyenvinner fv.Type + | _ -> GenType cenv m tyenvinner fv.Type and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) boxity eenvouter takenNames expr = let g = cenv.g @@ -5411,7 +5419,7 @@ and GetIlxClosureInfo cenv m boxity isLocalTypeFunc canUseStaticField thisVars e let lambdas = Lambdas_lambda (mkILParamNamed(nm, GenTypeOfVal cenv eenv v), l) lambdas, eenv | _ -> - let returnTy' = GenType cenv.amap m eenv.tyenv returnTy + let returnTy' = GenType cenv m eenv.tyenv returnTy Lambdas_return returnTy', eenv // start at arg number 1 as "this" pointer holds the current closure @@ -5421,7 +5429,7 @@ and GetIlxClosureInfo cenv m boxity isLocalTypeFunc canUseStaticField thisVars e let narginfo = vs |> List.map (fun _ -> 1) // Generate the ILX view of the lambdas - let ilCloReturnTy = GenType cenv.amap m eenvinner.tyenv returnTy + let ilCloReturnTy = GenType cenv m eenvinner.tyenv returnTy /// Compute the contract if it is a local type function let ilCloGenericFormals = GenGenericParams cenv eenvinner cloFreeTyvars @@ -5451,7 +5459,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod(TSlotSig(_, delega let g = cenv.g // Get the instantiation of the delegate type - let ilCtxtDelTy = GenType cenv.amap m eenvouter.tyenv delegateTy + let ilCtxtDelTy = GenType cenv m eenvouter.tyenv delegateTy let tmvs = List.concat tmvs // Yuck. TLBIMP.EXE generated APIs use UIntPtr for the delegate ctor. @@ -5526,7 +5534,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod(TSlotSig(_, delega GenWitnessArgsFromWitnessInfos cenv cgbuf eenvouter m cloWitnessInfos GenGetLocalVals cenv cgbuf eenvouter m cloFreeVars - CG.EmitInstr cgbuf (pop ilCloAllFreeVars.Length) (Push [EraseClosures.mkTyOfLambdas g.ilxPubCloEnv ilCloLambdas]) (I_newobj (ilxCloSpec.Constructor, None)) + CG.EmitInstr cgbuf (pop ilCloAllFreeVars.Length) (Push [EraseClosures.mkTyOfLambdas cenv.ilxPubCloEnv ilCloLambdas]) (I_newobj (ilxCloSpec.Constructor, None)) // Push the function pointer to the Invoke method of the delegee let ilDelegeeTyOuter = mkILBoxedTy ilDelegeeTypeRef ctxtGenericArgsForDelegee @@ -5604,7 +5612,7 @@ and GenJoinPoint cenv cgbuf pos eenv ty m sequel = // The others (e.g. Continue, LeaveFilter and CmpThenBrOrContinue) can't be done at the end of each branch. We must create a join point. | _ -> - let pushed = GenType cenv.amap m eenv.tyenv ty + let pushed = GenType cenv m eenv.tyenv ty let stackAfterJoin = (pushed :: (cgbuf.GetCurrentStack())) let afterJoin = CG.GenerateDelayMark cgbuf (pos + "_join") // go to the join point @@ -5680,7 +5688,7 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx // We have encountered this target before. See if we should generate it now let targetCount = targetCounts[targetIdx] - let generateTargetNow = isTargetPostponed && cenv.opts.localOptimizationsEnabled && targetCount = 1 && targetNext.Value = targetIdx + let generateTargetNow = isTargetPostponed && cenv.options.localOptimizationsEnabled && targetCount = 1 && targetNext.Value = targetIdx targetCounts[targetIdx] <- targetCount - 1 // If not binding anything we can go directly to the targetMarkBeforeBinds point @@ -5743,7 +5751,7 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx // In debug mode, postpone all decision tree targets to after the switching. // In release mode, if a target is the target of multiple incoming success nodes, postpone it to avoid // making any backward branches - let generateTargetNow = cenv.opts.localOptimizationsEnabled && targetCount = 1 && targetNext.Value = targetIdx + let generateTargetNow = cenv.options.localOptimizationsEnabled && targetCount = 1 && targetNext.Value = targetIdx targetCounts[targetIdx] <- targetCount - 1 let genTargetInfoOpt = @@ -5794,7 +5802,7 @@ and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defau match defaultTargetOpt with | None -> rest.Head.CaseTree | Some tg -> tg - let cuspec = GenUnionSpec cenv.amap m eenv.tyenv c.TyconRef tyargs + let cuspec = GenUnionSpec cenv m eenv.tyenv c.TyconRef tyargs let idx = c.Index let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore c.TyconRef let tester = (Some (pop 1, Push [g.ilg.typ_Bool], Choice1Of2 (avoidHelpers, cuspec, idx))) @@ -5831,7 +5839,7 @@ and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defau GenExpr cenv cgbuf eenv e Continue let srcTy = tyOfExpr g e if isTyparTy g srcTy then - let ilFromTy = GenType cenv.amap m eenv.tyenv srcTy + let ilFromTy = GenType cenv m eenv.tyenv srcTy CG.EmitInstr cgbuf (pop 1) (Push [g.ilg.typ_Object]) (I_box ilFromTy) BI_brfalse | DecisionTreeTest.IsInst (_srcty, tgty) -> @@ -5847,7 +5855,7 @@ and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defau | DecisionTreeTest.UnionCase (hdc, tyargs) -> GenExpr cenv cgbuf eenv e Continue - let cuspec = GenUnionSpec cenv.amap m eenv.tyenv hdc.TyconRef tyargs + let cuspec = GenUnionSpec cenv m eenv.tyenv hdc.TyconRef tyargs let dests = if cases.Length <> caseLabels.Length then failwith "internal error: DecisionTreeTest.UnionCase" (cases, caseLabels) ||> List.map2 (fun case label -> @@ -6241,7 +6249,7 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt = let ilFieldDef = let isClassInitializer = (cgbuf.MethodName = ".cctor") - ilFieldDef.WithInitOnly(not (mut || cenv.opts.isInteractiveItExpr || not isClassInitializer || hasLiteralAttr)) + ilFieldDef.WithInitOnly(not (mut || cenv.options.isInteractiveItExpr || not isClassInitializer || hasLiteralAttr)) let ilAttribs = if not hasLiteralAttr then @@ -6275,7 +6283,7 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt = let ilPropDef = ILPropertyDef(name=ilPropName, attributes = PropertyAttributes.None, - setMethod=(if mut || cenv.opts.isInteractiveItExpr then Some ilSetterMethRef else None), + setMethod=(if mut || cenv.options.isInteractiveItExpr then Some ilSetterMethRef else None), getMethod=Some ilGetterMethRef, callingConv=ILThisConvention.Static, propertyType=fty, @@ -6290,7 +6298,7 @@ and GenBindingAfterDebugPoint cenv cgbuf eenv bind isStateVar startMarkOpt = cgbuf.mgbuf.AddMethodDef(ilTypeRefForProperty, getterMethod) - if mut || cenv.opts.isInteractiveItExpr then + if mut || cenv.options.isInteractiveItExpr then let body = mkMethodBody(true, [], 2, nonBranchingInstrsToCode [ mkLdarg0;mkNormalStsfld fspec], None, eenv.imports) let setterMethod = mkILStaticMethod([], ilSetterMethRef.Name, access, [mkILParamNamed("value", fty)], mkILReturn ILType.Void, body).WithSpecialName @@ -6340,7 +6348,7 @@ and GenMarshal cenv attribs = // For IlReflect backend, we rely on Reflection.Emit API to emit the pseudo-custom attributes // correctly, so we do not filter them out. // For IlWriteBackend, we filter MarshalAs attributes - match cenv.opts.ilxBackend with + match cenv.options.ilxBackend with | IlReflectBackend -> attribs | IlWriteBackend -> attribs |> List.filter (IsMatchingFSharpAttributeOpt g g.attrib_MarshalAsAttribute >> not) @@ -6590,7 +6598,7 @@ and GenPropertyForMethodDef compileAsInstance tref mdef (v: Val) (memberInfo: Va and GenEventForProperty cenv eenvForMeth (mspec: ILMethodSpec) (v: Val) ilAttrsThatGoOnPrimaryItem m returnTy = let evname = v.PropertyName let delegateTy = FindDelegateTypeOfPropertyEvent cenv.g cenv.amap evname m returnTy - let ilDelegateTy = GenType cenv.amap m eenvForMeth.tyenv delegateTy + let ilDelegateTy = GenType cenv m eenvForMeth.tyenv delegateTy let ilThisTy = mspec.DeclaringType let addMethRef = mkILMethRef (ilThisTy.TypeRef, mspec.CallingConv, "add_" + evname, 0, [ilDelegateTy], ILType.Void) let removeMethRef = mkILMethRef (ilThisTy.TypeRef, mspec.CallingConv, "remove_" + evname, 0, [ilDelegateTy], ILType.Void) @@ -6893,9 +6901,9 @@ and GenMethodForBinding // Emit the property, but not if its a private method impl if mdef.Access <> ILMemberAccess.Private then let vtyp = ReturnTypeOfPropertyVal g v - let ilPropTy = GenType cenv.amap m eenvUnderMethTypeTypars.tyenv vtyp + let ilPropTy = GenType cenv m eenvUnderMethTypeTypars.tyenv vtyp let ilPropTy = GenReadOnlyModReqIfNecessary g vtyp ilPropTy - let ilArgTys = v |> ArgInfosOfPropertyVal g |> List.map fst |> GenTypes cenv.amap m eenvUnderMethTypeTypars.tyenv + let ilArgTys = v |> ArgInfosOfPropertyVal g |> List.map fst |> GenTypes cenv m eenvUnderMethTypeTypars.tyenv let ilPropDef = GenPropertyForMethodDef compileAsInstance tref mdef v memberInfo ilArgTys ilPropTy (mkILCustomAttrs ilAttrsThatGoOnPrimaryItem) compiledName mgbuf.AddOrMergePropertyDef(tref, ilPropDef, m) @@ -6998,7 +7006,7 @@ and GenSetVal cenv cgbuf eenv (vref, e, m) sequel = and GenGetValRefAndSequel cenv cgbuf eenv m (v: ValRef) storeSequel = let ty = v.Type - GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv.amap m eenv.tyenv ty) (StorageForValRef cenv.g m v eenv) storeSequel + GenGetStorageAndSequel cenv cgbuf eenv m (ty, GenType cenv m eenv.tyenv ty) (StorageForValRef cenv.g m v eenv) storeSequel and GenGetVal cenv cgbuf eenv (v: ValRef, m) sequel = GenGetValRefAndSequel cenv cgbuf eenv m v None @@ -7147,7 +7155,7 @@ and AllocLocal cenv cgbuf eenv compgen (v, ty, isFixed) (scopeMarks: Mark * Mark let ranges = if compgen then [] else [(v, scopeMarks)] // Get an index for the local let j, realloc = - if cenv.opts.localOptimizationsEnabled then + if cenv.options.localOptimizationsEnabled then cgbuf.ReallocLocal((fun i (_, ty', isFixed') -> not isFixed' && not isFixed && not (IntMap.mem i eenv.liveLocals) && (ty = ty')), ranges, ty, isFixed) else cgbuf.AllocLocal(ranges, ty, isFixed), false @@ -7218,8 +7226,8 @@ and AllocTopValWithinExpr cenv cgbuf endMark cloc v eenv = // decide whether to use a shadow local or not let useShadowLocal = - cenv.opts.generateDebugSymbols && - not cenv.opts.localOptimizationsEnabled && + cenv.options.generateDebugSymbols && + not cenv.options.localOptimizationsEnabled && not v.IsCompilerGenerated && not v.IsMutable && // Don't use shadow locals for things like functions which are not compiled as static values/properties @@ -7233,7 +7241,7 @@ and AllocTopValWithinExpr cenv cgbuf endMark cloc v eenv = else NoShadowLocal, eenv - ComputeAndAddStorageForLocalTopVal (cenv.amap, g, cenv.intraAssemblyInfo, cenv.opts.isInteractive, optShadowLocal) cloc v eenv + ComputeAndAddStorageForLocalTopVal (cenv, g, cenv.intraAssemblyInfo, cenv.options.isInteractive, optShadowLocal) cloc v eenv //-------------------------------------------------------------------------- // Generate stack save/restore and assertions - pulled into letrec by alloc* @@ -7346,25 +7354,25 @@ and GenAttribArg amap g eenv x (ilArgTy: ILType) = error (InternalError ("invalid custom attribute value (not a constant): " + showL (exprL x), x.Range)) -and GenAttr amap g eenv (Attrib(_, k, args, props, _, _, _)) = +and GenAttr cenv g eenv (Attrib(_, k, args, props, _, _, _)) = let props = props |> List.map (fun (AttribNamedArg(s, ty, fld, AttribExpr(_, expr))) -> let m = expr.Range - let ilTy = GenType amap m eenv.tyenv ty - let cval = GenAttribArg amap g eenv expr ilTy + let ilTy = GenType cenv m eenv.tyenv ty + let cval = GenAttribArg cenv g eenv expr ilTy (s, ilTy, fld, cval)) let mspec = match k with | ILAttrib mref -> mkILMethSpec(mref, AsObject, [], []) | FSAttrib vref -> assert vref.IsMember - let mspec, _, _, _, _, _, _, _, _, _ = GetMethodSpecForMemberVal amap g (Option.get vref.MemberInfo) vref + let mspec, _, _, _, _, _, _, _, _, _ = GetMethodSpecForMemberVal cenv (Option.get vref.MemberInfo) vref mspec - let ilArgs = List.map2 (fun (AttribExpr(_, vexpr)) ty -> GenAttribArg amap g eenv vexpr ty) args mspec.FormalArgTypes + let ilArgs = List.map2 (fun (AttribExpr(_, vexpr)) ty -> GenAttribArg cenv g eenv vexpr ty) args mspec.FormalArgTypes mkILCustomAttribMethRef (mspec, ilArgs, props) and GenAttrs cenv eenv attrs = - List.map (GenAttr cenv.amap cenv.g eenv) attrs + List.map (GenAttr cenv cenv.g eenv) attrs and GenCompilationArgumentCountsAttr cenv (v: Val) = let g = cenv.g @@ -7383,7 +7391,7 @@ and CreatePermissionSets cenv eenv (securityAttributes: Attrib list) = let action = match actions with | [AttribInt32Arg act] -> act | _ -> failwith "internal error: unrecognized security action" let secaction = (List.assoc action (Lazy.force ILSecurityActionRevMap)) let tref = tcref.CompiledRepresentationForNamedType - let ilattr = GenAttr cenv.amap g eenv attr + let ilattr = GenAttr cenv g eenv attr let _, ilNamedArgs = match TryDecodeILAttribute tref (mkILCustomAttrs [ilattr]) with | Some(ae, na) -> ae, na @@ -7417,9 +7425,7 @@ and GenTypeDefForCompLoc (cenv, eenv, mgbuf: AssemblyBuilder, cloc, hidden, attr let tdef = tdef.WithSealed(true).WithAbstract(true) mgbuf.AddTypeDef(tref, tdef, eliminateIfEmpty, addAtEnd, None) - -and GenModuleExpr cenv cgbuf qname lazyInitInfo eenv x = - let (ModuleOrNamespaceContentsWithSig(mty, def, _)) = x +and GenImplFileContents cenv cgbuf qname lazyInitInfo eenv mty def = // REVIEW: the scopeMarks are used for any shadow locals we create for the module bindings // We use one scope for all the bindings in the module, which makes them all appear with their "default" values // rather than incrementally as we step through the initializations in the module. This is a little unfortunate @@ -7429,15 +7435,11 @@ and GenModuleExpr cenv cgbuf qname lazyInitInfo eenv x = let eenv = AddSignatureRemapInfo "defs" sigToImplRemapInfo eenv // Allocate all the values, including any shadow locals for static fields - let eenv = AddBindingsForModuleDef (AllocTopValWithinExpr cenv cgbuf endMark) eenv.cloc eenv def - let _eenvEnd = GenModuleDef cenv cgbuf qname lazyInitInfo eenv def + let eenv = AddBindingsForModuleContents (AllocTopValWithinExpr cenv cgbuf endMark) eenv.cloc eenv def + let _eenvEnd = GenModuleOrNamespaceContents cenv cgbuf qname lazyInitInfo eenv def ()) -and GenModuleDefs cenv cgbuf qname lazyInitInfo eenv mdefs = - let _eenvEnd = (eenv, mdefs) ||> List.fold (GenModuleDef cenv cgbuf qname lazyInitInfo) - () - -and GenModuleDef cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo eenv x = +and GenModuleOrNamespaceContents cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo eenv x = match x with | TMDefRec(_isRec, opens, tycons, mbinds, m) -> let eenvinner = AddDebugImportsToEnv cenv eenv opens @@ -7455,7 +7457,7 @@ and GenModuleDef cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo eenv x = let recBinds = bindsRemaining |> List.takeWhile (function ModuleOrNamespaceBinding.Binding _ -> true | _ -> false) - |> List.map (function ModuleOrNamespaceBinding.Binding recBind -> recBind | _ -> failwith "GenModuleDef - unexpected") + |> List.map (function ModuleOrNamespaceBinding.Binding recBind -> recBind | _ -> failwith "GenModuleOrNamespaceContents - unexpected") let otherBinds = bindsRemaining |> List.skipWhile (function ModuleOrNamespaceBinding.Binding _ -> true | _ -> false) @@ -7480,13 +7482,8 @@ and GenModuleDef cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo eenv x = GenExpr cenv cgbuf eenv e discard eenv - | TMWithSig mexpr -> - GenModuleExpr cenv cgbuf qname lazyInitInfo eenv mexpr - eenv - | TMDefs mdefs -> - GenModuleDefs cenv cgbuf qname lazyInitInfo eenv mdefs - eenv + (eenv, mdefs) ||> List.fold (GenModuleOrNamespaceContents cenv cgbuf qname lazyInitInfo) // Generate a module binding and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) lazyInitInfo eenv m x = @@ -7499,7 +7496,7 @@ and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) la let eenvinner = if mspec.IsNamespace then eenv else - { eenv with cloc = CompLocForFixedModule cenv.opts.fragName qname.Text mspec; initLocals = eenv.initLocals && not (HasFSharpAttribute cenv.g cenv.g.attrib_SkipLocalsInitAttribute mspec.Attribs) } + { eenv with cloc = CompLocForFixedModule cenv.options.fragName qname.Text mspec; initLocals = eenv.initLocals && not (HasFSharpAttribute cenv.g cenv.g.attrib_SkipLocalsInitAttribute mspec.Attribs) } // Create the class to hold the contents of this module. No class needed if // we're compiling it as a namespace. @@ -7516,7 +7513,7 @@ and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) la GenTypeDefForCompLoc (cenv, eenvinner, cgbuf.mgbuf, eenvinner.cloc, hidden, mspec.Attribs, staticClassTrigger, false, (* atEnd= *) true) // Generate the declarations in the module and its initialization code - let _envAtEnd = GenModuleDef cenv cgbuf qname lazyInitInfo eenvinner mdef + let _envAtEnd = GenModuleOrNamespaceContents cenv cgbuf qname lazyInitInfo eenvinner mdef // If the module has a .cctor for some mutable fields, we need to ensure that when // those fields are "touched" the InitClass .cctor is forced. The InitClass .cctor will @@ -7526,8 +7523,8 @@ and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) la /// Generate the namespace fragments in a single file -and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedImplFileAfterOptimization) = - let (TImplFile (qname, _, mexpr, hasExplicitEntryPoint, isScript, anonRecdTypes, _)) = implFile.ImplFile +and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: CheckedImplFileAfterOptimization) = + let (CheckedImplFile (qname, _, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, _)) = implFile.ImplFile let optimizeDuringCodeGen = implFile.OptimizeDuringCodeGen let g = cenv.g let m = qname.Range @@ -7548,9 +7545,11 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI let initClassTrigger = (* if isFinalFile then *) ILTypeInit.OnAny (* else ILTypeInit.BeforeField *) - let eenv = {eenv with cloc = initClassCompLoc - isFinalFile = isFinalFile - someTypeInThisAssembly = initClassTy } + let eenv = + { eenv with + cloc = initClassCompLoc + isFinalFile = isFinalFile + someTypeInThisAssembly = initClassTy } // Create the class to hold the initialization code and static fields for this file. // internal static class $ {} @@ -7582,7 +7581,7 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI CodeGenMethod cenv mgbuf ([], methodName, eenv, 0, None, (fun cgbuf eenv -> - GenModuleExpr cenv cgbuf qname lazyInitInfo eenv mexpr + GenImplFileContents cenv cgbuf qname lazyInitInfo eenv signature contents CG.EmitInstr cgbuf (pop 0) Push0 I_ret), m) // The code generation for the initialization is now complete and the IL code is in topCode. @@ -7602,7 +7601,6 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI else [], [] - match mainInfoOpt with // Final file in .EXE | Some mainInfo -> @@ -7626,7 +7624,7 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI // } | None -> let ilAttrs = mkILCustomAttrs (GenAttrs cenv eenv mainInfo) - if not cenv.opts.isInteractive && not doesSomething then + if not cenv.options.isInteractive && not doesSomething then let errorM = m.EndRange warning (Error(FSComp.SR.ilMainModuleEmpty(), errorM)) @@ -7653,8 +7651,8 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI let initFieldName = CompilerGeneratedName "init" let ilFieldDef = mkILStaticField (initFieldName, g.ilg.typ_Int32, None, None, ComputeMemberAccess true) - |> g.AddFieldNeverAttrs - |> g.AddFieldGeneratedAttrs + |> g.AddFieldNeverAttributes + |> g.AddFieldGeneratedAttributes let fspec = mkILFieldSpecInTy (initClassTy, initFieldName, cenv. g.ilg.typ_Int32) CountStaticFieldDef() @@ -7671,8 +7669,8 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: TypedI // uses the constructs exported from this module. // We add the module type all over again. Note no shadow locals for static fields needed here since they are only relevant to the main/.cctor let eenvafter = - let allocVal = ComputeAndAddStorageForLocalTopVal (cenv.amap, g, cenv.intraAssemblyInfo, cenv.opts.isInteractive, NoShadowLocal) - AddBindingsForLocalModuleType allocVal clocCcu eenv mexpr.Type + let allocVal = ComputeAndAddStorageForLocalTopVal (cenv, g, cenv.intraAssemblyInfo, cenv.options.isInteractive, NoShadowLocal) + AddBindingsForLocalModuleType allocVal clocCcu eenv signature eenvafter @@ -7720,7 +7718,7 @@ and GenWitnessParams cenv eenv m (witnessInfos: TraitWitnessInfos) = let nm = if used.Contains nm then nm + string i else nm let ilParam = { Name=Some nm - Type= GenType cenv.amap m eenv.tyenv ty + Type= GenType cenv m eenv.tyenv ty Default=None Marshal=None IsIn=false @@ -7740,7 +7738,7 @@ and GenAbstractBinding cenv eenv tref (vref: ValRef) = let hasPreserveSigImplFlag, hasSynchronizedImplFlag, hasNoInliningFlag, hasAggressiveInliningImplFlag, attribs = ComputeMethodImplAttribs cenv vref.Deref attribs if memberInfo.MemberFlags.IsDispatchSlot && not memberInfo.IsImplemented then let mspec, _mspecW, ctps, mtps, _curriedArgInfos, argInfos, retInfo, witnessInfos, methArgTys, returnTy = - GetMethodSpecForMemberVal cenv.amap cenv.g memberInfo vref + GetMethodSpecForMemberVal cenv memberInfo vref let ilAttrs = [ yield! GenAttrs cenv eenv attribs @@ -7791,9 +7789,9 @@ and GenAbstractBinding cenv eenv tref (vref: ValRef) = [], [], [edef] else let ilPropDef = - let ilPropTy = GenType cenv.amap m eenvForMeth.tyenv vtyp + let ilPropTy = GenType cenv m eenvForMeth.tyenv vtyp let ilPropTy = GenReadOnlyModReqIfNecessary g vtyp ilPropTy - let ilArgTys = v |> ArgInfosOfPropertyVal g |> List.map fst |> GenTypes cenv.amap m eenvForMeth.tyenv + let ilArgTys = v |> ArgInfosOfPropertyVal g |> List.map fst |> GenTypes cenv m eenvForMeth.tyenv GenPropertyForMethodDef compileAsInstance tref mdef v memberInfo ilArgTys ilPropTy (mkILCustomAttrs ilAttrs) None let mdef = mdef.WithSpecialName [mdef], [ilPropDef], [] @@ -7806,12 +7804,13 @@ and GenToStringMethod cenv eenv ilThisTy m = /// Generate a ToString/get_Message method that calls 'sprintf "%A"' and GenPrintingMethod cenv eenv methName ilThisTy m = - let g = cenv.g - [ match (eenv.valsInScope.TryFind g.sprintf_vref.Deref, + let g = cenv.g + [ + match (eenv.valsInScope.TryFind g.sprintf_vref.Deref, eenv.valsInScope.TryFind g.new_format_vref.Deref) with | Some(Lazy(Method(_, _, sprintfMethSpec, _, _, _, _, _, _, _, _, _))), Some(Lazy(Method(_, _, newFormatMethSpec, _, _, _, _, _, _, _, _, _))) -> // The type returned by the 'sprintf' call - let funcTy = EraseClosures.mkILFuncTy g.ilxPubCloEnv ilThisTy g.ilg.typ_String + let funcTy = EraseClosures.mkILFuncTy cenv.ilxPubCloEnv ilThisTy g.ilg.typ_String // Give the instantiation of the printf format object, i.e. a Format`5 object compatible with StringFormat let newFormatMethSpec = @@ -7828,7 +7827,7 @@ and GenPrintingMethod cenv eenv methName ilThisTy m = let sprintfMethSpec = mkILMethSpec(sprintfMethSpec.MethodRef, AsObject, [], [funcTy]) // Here's the body of the method. Call printf, then invoke the function it returns - let callInstrs = EraseClosures.mkCallFunc g.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done g.ilg.typ_String)) + let callInstrs = EraseClosures.mkCallFunc cenv.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done g.ilg.typ_String)) let ilInstrs = [ // load the hardwired format string @@ -7869,10 +7868,10 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let eenvinner = EnvForTycon tycon eenv let thisTy = generalizedTyconRef g tcref - let ilThisTy = GenType cenv.amap m eenvinner.tyenv thisTy + let ilThisTy = GenType cenv m eenvinner.tyenv thisTy let tref = ilThisTy.TypeRef let ilGenParams = GenGenericParams cenv eenvinner tycon.TyparsNoRange - let ilIntfTys = tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv.amap m eenvinner.tyenv) + let ilIntfTys = tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv m eenvinner.tyenv) let ilTypeName = tref.Name let hidden = IsHiddenTycon eenv.sigToImplRemapInfo tycon @@ -7963,7 +7962,10 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = // DebugDisplayAttribute gets copied to the subtypes generated as part of DU compilation let debugDisplayAttrs, normalAttrs = tycon.Attribs |> List.partition (IsMatchingFSharpAttribute g g.attrib_DebuggerDisplayAttribute) let securityAttrs, normalAttrs = normalAttrs |> List.partition (fun a -> IsSecurityAttribute g cenv.amap cenv.casApplied a m) - let generateDebugDisplayAttribute = not g.compilingFSharpCore && tycon.IsUnionTycon && isNil debugDisplayAttrs + let generateDebugDisplayAttribute = + not g.compilingFSharpCore && + tycon.IsUnionTycon && + isNil debugDisplayAttrs let generateDebugProxies = not (tyconRefEq g tcref g.unit_tcr_canon) && @@ -8007,7 +8009,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = // Structs with no instance fields get size 1, pack 0 tycon.AllFieldsArray |> Array.forall (fun f -> f.IsStatic) - isEmptyStruct && cenv.opts.workAroundReflectionEmitBugs && not tycon.TyparsNoRange.IsEmpty + isEmptyStruct && cenv.options.workAroundReflectionEmitBugs && not tycon.TyparsNoRange.IsEmpty // Compute a bunch of useful things for each field let isCLIMutable = (TryFindFSharpBoolAttribute g g.attrib_CLIMutableAttribute tycon.Attribs = Some true) @@ -8027,7 +8029,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = else (fspec.IsCompilerGenerated || hiddenRepr || IsHiddenRecdField eenv.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef fspec)) - let ilType = GenType cenv.amap m eenvinner.tyenv fspec.FormalType + let ilType = GenType cenv m eenvinner.tyenv fspec.FormalType let ilFieldName = ComputeFieldName tycon fspec yield (useGenuineField, ilFieldName, fspec.IsMutable, fspec.IsStatic, fspec.PropertyAttribs, ilType, isPropHidden, fspec) ] @@ -8074,7 +8076,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = isPropHidden || (not useGenuineField && not isFSharpMutable && - not (cenv.opts.isInteractive && cenv.opts.fsiMultiAssemblyEmit)) + not (cenv.options.isInteractive && cenv.options.fsiMultiAssemblyEmit)) let extraAttribs = match tyconRepr with @@ -8158,7 +8160,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = eenv.valsInScope.TryFind g.new_format_vref.Deref) with | Some(Lazy(Method(_, _, sprintfMethSpec, _, _, _, _, _, _, _, _, _))), Some(Lazy(Method(_, _, newFormatMethSpec, _, _, _, _, _, _, _, _, _))) -> // The type returned by the 'sprintf' call - let funcTy = EraseClosures.mkILFuncTy g.ilxPubCloEnv ilThisTy g.ilg.typ_String + let funcTy = EraseClosures.mkILFuncTy cenv.ilxPubCloEnv ilThisTy g.ilg.typ_String // Give the instantiation of the printf format object, i.e. a Format`5 object compatible with StringFormat let newFormatMethSpec = mkILMethSpec(newFormatMethSpec.MethodRef, AsObject, [// 'T -> string' @@ -8172,7 +8174,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let sprintfMethSpec = mkILMethSpec(sprintfMethSpec.MethodRef, AsObject, [], [funcTy]) // Here's the body of the method. Call printf, then invoke the function it returns - let callInstrs = EraseClosures.mkCallFunc g.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done g.ilg.typ_String)) + let callInstrs = EraseClosures.mkCallFunc cenv.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done g.ilg.typ_String)) let ilInstrs = [ // load the hardwired format string @@ -8271,7 +8273,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = | TFSharpRecdRepr _ | TFSharpObjectRepr _ as tyconRepr -> let super = superOfTycon g tycon - let ilBaseTy = GenType cenv.amap m eenvinner.tyenv super + let ilBaseTy = GenType cenv m eenvinner.tyenv super // Build a basic type definition let isObjectType = (match tyconRepr with TFSharpObjectRepr _ -> true | _ -> false) @@ -8350,7 +8352,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = if tycon.AllFieldsArray |> Array.exists (fun f -> not f.IsStatic) || // Reflection emit doesn't let us emit 'pack' and 'size' for generic structs. // In that case we generate a dummy field instead - (cenv.opts.workAroundReflectionEmitBugs && not tycon.TyparsNoRange.IsEmpty) + (cenv.options.workAroundReflectionEmitBugs && not tycon.TyparsNoRange.IsEmpty) then ILTypeDefLayout.Sequential { Size=None; Pack=None }, ILDefaultPInvokeEncoding.Ansi else @@ -8384,7 +8386,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let alternatives = tycon.UnionCasesArray |> Array.mapi (fun i ucspec -> { altName=ucspec.CompiledName - altFields=GenUnionCaseRef cenv.amap m eenvinner.tyenv i ucspec.RecdFieldsArray + altFields=GenUnionCaseRef cenv m eenvinner.tyenv i ucspec.RecdFieldsArray altCustomAttrs= mkILCustomAttrs (GenAttrs cenv eenv ucspec.Attribs @ [mkCompilationMappingAttrWithSeqNum g (int SourceConstructFlags.UnionCase) i]) }) let cuinfo = { UnionCasesAccessibility=reprAccess @@ -8436,7 +8438,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = .WithAccess(access) .WithInitSemantics(ILTypeInit.BeforeField) - let tdef2 = EraseUnions.mkClassUnionDef (g.AddMethodGeneratedAttributes, g.AddPropertyGeneratedAttrs, g.AddPropertyNeverAttrs, g.AddFieldGeneratedAttrs, g.AddFieldNeverAttrs, g.MkDebuggerTypeProxyAttribute) g.ilg tref tdef cuinfo + let tdef2 = EraseUnions.mkClassUnionDef (g.AddMethodGeneratedAttributes, g.AddPropertyGeneratedAttributes, g.AddPropertyNeverAttributes, g.AddFieldGeneratedAttributes, g.AddFieldNeverAttributes, g.MkDebuggerTypeProxyAttribute) g.ilg tref tdef cuinfo // Discard the user-supplied (i.e. prim-type.fs) implementations of the get_Empty, get_IsEmpty, get_Value and get_None and Some methods. // This is because we will replace their implementations by ones that load the unique @@ -8478,7 +8480,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = match exnc.ExceptionInfo with | TExnAbbrevRepr _ | TExnAsmRepr _ | TExnNone -> () | TExnFresh _ -> - let ilThisTy = GenExnType cenv.amap m eenv.tyenv exncref + let ilThisTy = GenExnType cenv m eenv.tyenv exncref let tref = ilThisTy.TypeRef let isHidden = IsHiddenTycon eenv.sigToImplRemapInfo exnc let access = ComputeTypeAccess tref isHidden @@ -8488,7 +8490,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = let ilMethodDefsForProperties, ilFieldDefs, ilPropertyDefs, fieldNamesAndTypes = [ for i, fld in Seq.indexed fspecs do let ilPropName = fld.LogicalName - let ilPropType = GenType cenv.amap m eenv.tyenv fld.FormalType + let ilPropType = GenType cenv m eenv.tyenv fld.FormalType let ilMethName = "get_" + fld.LogicalName let ilFieldName = ComputeFieldName exnc fld let ilMethodDef = mkLdfldMethodDef (ilMethName, reprAccess, false, ilThisTy, ilFieldName, ilPropType) @@ -8550,7 +8552,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = not (exnc.HasMember g "Message" []) then yield! GenPrintingMethod cenv eenv "get_Message" ilThisTy m ] - let interfaces = exnc.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv.amap m eenv.tyenv) + let interfaces = exnc.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv m eenv.tyenv) let tdef = mkILGenericClass @@ -8572,7 +8574,7 @@ let CodegenAssembly cenv eenv mgbuf implFiles = if not (isNil implFiles) then let a, b = List.frontAndBack implFiles let eenv = List.fold (GenImplFile cenv mgbuf None) eenv a - let eenv = GenImplFile cenv mgbuf cenv.opts.mainMethodInfo eenv b + let eenv = GenImplFile cenv mgbuf cenv.options.mainMethodInfo eenv b // Some constructs generate residue types and bindings. Generate these now. They don't result in any // top-level initialization code. @@ -8585,8 +8587,8 @@ let CodegenAssembly cenv eenv mgbuf implFiles = let lazyInitInfo = ResizeArray() let qname = QualifiedNameOfFile(mkSynId range0 "unused") LocalScope "module" cgbuf (fun (_, endMark) -> - let eenv = AddBindingsForModuleDef (AllocTopValWithinExpr cenv cgbuf endMark) eenv.cloc eenv mexpr - let _eenvEnv = GenModuleDef cenv cgbuf qname lazyInitInfo eenv mexpr + let eenv = AddBindingsForModuleContents (AllocTopValWithinExpr cenv cgbuf endMark) eenv.cloc eenv mexpr + let _eenvEnv = GenModuleOrNamespaceContents cenv cgbuf qname lazyInitInfo eenv mexpr ())), range0) //printfn "#_emptyTopInstrs = %d" _emptyTopInstrs.Length () @@ -8627,14 +8629,14 @@ type IlxGenResults = quotationResourceInfo: (ILTypeRef list * byte[]) list } -let GenerateCode (cenv, anonTypeTable, eenv, TypedAssemblyAfterOptimization implFiles, assemAttribs, moduleAttribs) = +let GenerateCode (cenv, anonTypeTable, eenv, CheckedAssemblyAfterOptimization implFiles, assemAttribs, moduleAttribs) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.IlxGen let g = cenv.g // Generate the implementations into the mgbuf let mgbuf = AssemblyBuilder(cenv, anonTypeTable) - let eenv = { eenv with cloc = CompLocForFragment cenv.opts.fragName cenv.viewCcu } + let eenv = { eenv with cloc = CompLocForFragment cenv.options.fragName cenv.viewCcu } // Generate the PrivateImplementationDetails type GenTypeDefForCompLoc (cenv, eenv, mgbuf, CompLocForPrivateImplementationDetails eenv.cloc, useHiddenInitCode, [], ILTypeInit.BeforeField, true, (* atEnd= *) true) @@ -8646,7 +8648,6 @@ let GenerateCode (cenv, anonTypeTable, eenv, TypedAssemblyAfterOptimization impl let tdefs, reflectedDefinitions = mgbuf.Close() - // Generate the quotations let quotationResourceInfo = match reflectedDefinitions with @@ -8717,14 +8718,14 @@ let defaultOf = /// IlxGen knows how v was stored, and then ilreflect knows how this storage was generated. /// IlxGen converts (v: Tast.Val) to AbsIL data structures. /// Ilreflect converts from AbsIL data structures to emitted Type, FieldInfo, MethodInfo etc. -let LookupGeneratedValue (amap: ImportMap) (ctxt: ExecutionContext) eenv (v: Val) = +let LookupGeneratedValue (cenv: cenv) (ctxt: ExecutionContext) eenv (v: Val) = try // Convert the v.Type into a System.Type according to ilxgen and ilreflect. let objTyp() = - let ilTy = GenType amap v.Range TypeReprEnv.Empty v.Type + let ilTy = GenType cenv v.Range TypeReprEnv.Empty v.Type ctxt.LookupType ilTy // Lookup the compiled v value (as an object). - match StorageForVal amap.g v.Range v eenv with + match StorageForVal cenv.g v.Range v eenv with | StaticPropertyWithField (fspec, _, hasLiteralAttr, ilContainerTy, _, _, ilGetterMethRef, _, _) -> let obj = if hasLiteralAttr then @@ -8756,8 +8757,7 @@ let LookupGeneratedValue (amap: ImportMap) (ctxt: ExecutionContext) eenv (v: Val | Method _ -> None | Arg _ -> None | Env _ -> None - with - e -> + with e -> #if DEBUG printf "ilxGen.LookupGeneratedValue for v=%s caught exception:\n%A\n\n" v.LogicalName e #endif @@ -8813,43 +8813,49 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai let intraAssemblyInfo = { StaticFieldInfo = Dictionary<_, _>(HashIdentity.Structural) } let casApplied = Dictionary() + let cenv = + { g = tcGlobals + ilxPubCloEnv = EraseClosures.newIlxPubCloEnv(tcGlobals.ilg, tcGlobals.AddMethodGeneratedAttributes, tcGlobals.AddFieldGeneratedAttributes, tcGlobals.AddFieldNeverAttributes) + tcVal = tcVal + viewCcu = ccu + ilUnitTy = None + namedDebugPointsForInlinedCode = Map.empty + amap = amap + casApplied = casApplied + intraAssemblyInfo = intraAssemblyInfo + optionsOpt = None + optimizeDuringCodeGen = (fun _flag expr -> expr) + stackGuard = StackGuard(IlxGenStackGuardDepth) } + /// Register a set of referenced assemblies with the ILX code generator member _.AddExternalCcus ccus = - ilxGenEnv <- AddExternalCcusToIlxGenEnv amap tcGlobals ilxGenEnv ccus + ilxGenEnv <- AddExternalCcusToIlxGenEnv cenv tcGlobals ilxGenEnv ccus /// Register a fragment of the current assembly with the ILX code generator. If 'isIncrementalFragment' is true then the input /// is assumed to be a fragment 'typed' into FSI.EXE, otherwise the input is assumed to be the result of a '#load' member _.AddIncrementalLocalAssemblyFragment (isIncrementalFragment, fragName, typedImplFiles) = - ilxGenEnv <- AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap, isIncrementalFragment, tcGlobals, ccu, fragName, intraAssemblyInfo, ilxGenEnv, typedImplFiles) + ilxGenEnv <- AddIncrementalLocalAssemblyFragmentToIlxGenEnv (cenv, isIncrementalFragment, tcGlobals, ccu, fragName, intraAssemblyInfo, ilxGenEnv, typedImplFiles) /// Generate ILX code for an assembly fragment - member _.GenerateCode (codeGenOpts, typedAssembly: TypedAssemblyAfterOptimization, assemAttribs, moduleAttribs) = + member _.GenerateCode (codeGenOpts, typedAssembly: CheckedAssemblyAfterOptimization, assemAttribs, moduleAttribs) = let namedDebugPointsForInlinedCode = - let (TypedAssemblyAfterOptimization impls) = typedAssembly + let (CheckedAssemblyAfterOptimization impls) = typedAssembly [| for impl in impls do - let (TImplFile(namedDebugPointsForInlinedCode=dps)) = impl.ImplFile + let (CheckedImplFile(namedDebugPointsForInlinedCode=dps)) = impl.ImplFile for KeyValue(k,v) in dps do yield (k,v) |] - |> Map - let cenv: cenv = - { g=tcGlobals - tcVal = tcVal - viewCcu = ccu - ilUnitTy = None - namedDebugPointsForInlinedCode = namedDebugPointsForInlinedCode - amap = amap - casApplied = casApplied - intraAssemblyInfo = intraAssemblyInfo - opts = codeGenOpts - optimizeDuringCodeGen = (fun _flag expr -> expr) - stackGuard = StackGuard(IlxGenStackGuardDepth) } + + let cenv = { cenv with optionsOpt = Some codeGenOpts; namedDebugPointsForInlinedCode = Map.ofArray namedDebugPointsForInlinedCode } GenerateCode (cenv, anonTypeTable, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs) /// Invert the compilation of the given value and clear the storage of the value - member _.ClearGeneratedValue (ctxt, v) = ClearGeneratedValue ctxt tcGlobals ilxGenEnv v + member _.ClearGeneratedValue (ctxt, v) = + ClearGeneratedValue ctxt tcGlobals ilxGenEnv v /// Invert the compilation of the given value and set the storage of the value, even if it is immutable - member _.ForceSetGeneratedValue (ctxt, v, value: obj) = SetGeneratedValue ctxt tcGlobals ilxGenEnv true v value + member _.ForceSetGeneratedValue (ctxt, v, value: obj) = + SetGeneratedValue ctxt tcGlobals ilxGenEnv true v value /// Invert the compilation of the given value and return its current dynamic value and its compiled System.Type - member _.LookupGeneratedValue (ctxt, v) = LookupGeneratedValue amap ctxt ilxGenEnv v \ No newline at end of file + member _.LookupGeneratedValue (ctxt, v) = + LookupGeneratedValue cenv ctxt ilxGenEnv v \ No newline at end of file diff --git a/src/Compiler/CodeGen/IlxGen.fsi b/src/Compiler/CodeGen/IlxGen.fsi index abeaa477ef9..a746c120be5 100644 --- a/src/Compiler/CodeGen/IlxGen.fsi +++ b/src/Compiler/CodeGen/IlxGen.fsi @@ -92,10 +92,10 @@ type public IlxAssemblyGenerator = /// Register a fragment of the current assembly with the ILX code generator. If 'isIncrementalFragment' is true then the input /// is assumed to be a fragment 'typed' into FSI.EXE, otherwise the input is assumed to be the result of a '#load' member AddIncrementalLocalAssemblyFragment: - isIncrementalFragment: bool * fragName: string * typedImplFiles: TypedImplFile list -> unit + isIncrementalFragment: bool * fragName: string * typedImplFiles: CheckedImplFile list -> unit /// Generate ILX code for an assembly fragment - member GenerateCode: IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults + member GenerateCode: IlxGenOptions * CheckedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults /// Invert the compilation of the given value and clear the storage of the value member ClearGeneratedValue: ExecutionContext * Val -> unit diff --git a/src/Compiler/Driver/BuildGraph.fs b/src/Compiler/Driver/BuildGraph.fs index b8b86e7f7c1..9facb562bcc 100644 --- a/src/Compiler/Driver/BuildGraph.fs +++ b/src/Compiler/Driver/BuildGraph.fs @@ -15,13 +15,13 @@ type NodeCode<'T> = Node of Async<'T> let wrapThreadStaticInfo computation = async { - let errorLogger = CompileThreadStatic.DiagnosticsLogger - let phase = CompileThreadStatic.BuildPhase + let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger + let phase = DiagnosticsThreadStatics.BuildPhase try return! computation finally - CompileThreadStatic.DiagnosticsLogger <- errorLogger - CompileThreadStatic.BuildPhase <- phase + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- phase } type Async<'T> with @@ -72,8 +72,8 @@ type NodeCodeBuilder() = member _.Using(value: CompilationGlobalsScope, binder: CompilationGlobalsScope -> NodeCode<'U>) = Node( async { - CompileThreadStatic.DiagnosticsLogger <- value.DiagnosticsLogger - CompileThreadStatic.BuildPhase <- value.BuildPhase + DiagnosticsThreadStatics.DiagnosticsLogger <- value.DiagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- value.BuildPhase try return! binder value |> Async.AwaitNodeCode finally @@ -90,20 +90,20 @@ type NodeCode private () = Node(wrapThreadStaticInfo Async.CancellationToken) static member RunImmediate (computation: NodeCode<'T>, ct: CancellationToken) = - let errorLogger = CompileThreadStatic.DiagnosticsLogger - let phase = CompileThreadStatic.BuildPhase + let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger + let phase = DiagnosticsThreadStatics.BuildPhase try try let work = async { - CompileThreadStatic.DiagnosticsLogger <- errorLogger - CompileThreadStatic.BuildPhase <- phase + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- phase return! computation |> Async.AwaitNodeCode } Async.StartImmediateAsTask(work, cancellationToken=ct).Result finally - CompileThreadStatic.DiagnosticsLogger <- errorLogger - CompileThreadStatic.BuildPhase <- phase + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- phase with | :? AggregateException as ex when ex.InnerExceptions.Count = 1 -> raise(ex.InnerExceptions[0]) @@ -112,19 +112,19 @@ type NodeCode private () = NodeCode.RunImmediate(computation, CancellationToken.None) static member StartAsTask_ForTesting (computation: NodeCode<'T>, ?ct: CancellationToken) = - let errorLogger = CompileThreadStatic.DiagnosticsLogger - let phase = CompileThreadStatic.BuildPhase + let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger + let phase = DiagnosticsThreadStatics.BuildPhase try let work = async { - CompileThreadStatic.DiagnosticsLogger <- errorLogger - CompileThreadStatic.BuildPhase <- phase + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- phase return! computation |> Async.AwaitNodeCode } Async.StartAsTask(work, cancellationToken=defaultArg ct CancellationToken.None) finally - CompileThreadStatic.DiagnosticsLogger <- errorLogger - CompileThreadStatic.BuildPhase <- phase + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- phase static member CancellationToken = cancellationToken diff --git a/src/Compiler/Driver/CompilerDiagnostics.fs b/src/Compiler/Driver/CompilerDiagnostics.fs index 38cdc428e77..bc3e1b5c9ce 100644 --- a/src/Compiler/Driver/CompilerDiagnostics.fs +++ b/src/Compiler/Driver/CompilerDiagnostics.fs @@ -76,7 +76,7 @@ exception DeprecatedCommandLineOptionNoDescription of string * range /// This exception is an old-style way of reporting a diagnostic exception InternalCommandLineOption of string * range -let GetRangeOfDiagnostic(diag: PhasedDiagnostic) = +let GetRangeOfDiagnostic(diagnostic: PhasedDiagnostic) = let rec RangeFromException exn = match exn with | ErrorFromAddingConstraint(_, exn2, _) -> RangeFromException exn2 @@ -215,9 +215,9 @@ let GetRangeOfDiagnostic(diag: PhasedDiagnostic) = | _ -> None - RangeFromException diag.Exception + RangeFromException diagnostic.Exception -let GetDiagnosticNumber(diag: PhasedDiagnostic) = +let GetDiagnosticNumber(diagnostic: PhasedDiagnostic) = let rec GetFromException(exn: exn) = match exn with // DO NOT CHANGE THESE NUMBERS @@ -349,10 +349,10 @@ let GetDiagnosticNumber(diag: PhasedDiagnostic) = #endif | ErrorsFromAddingSubsumptionConstraint (_, _, _, _, _, ContextInfo.DowncastUsedInsteadOfUpcast _, _) -> fst (FSComp.SR.considerUpcast("", "")) | _ -> 193 - GetFromException diag.Exception + GetFromException diagnostic.Exception -let GetWarningLevel diag = - match diag.Exception with +let GetWarningLevel diagnostic = + match diagnostic.Exception with // Level 5 warnings | RecursiveUseCheckedAtRuntime _ | LetRecEvaluatedOutOfOrder _ @@ -368,7 +368,7 @@ let GetWarningLevel diag = // Level 2 | _ -> 2 -let IsWarningOrInfoEnabled (diag, severity) n level specificWarnOn = +let IsWarningOrInfoEnabled (diagnostic, severity) n level specificWarnOn = List.contains n specificWarnOn || // Some specific warnings/informational are never on by default, i.e. unused variable warnings match n with @@ -383,10 +383,10 @@ let IsWarningOrInfoEnabled (diag, severity) n level specificWarnOn = | 3395 -> false // tcImplicitConversionUsedForMethodArg - off by default | _ -> (severity = FSharpDiagnosticSeverity.Info) || - (severity = FSharpDiagnosticSeverity.Warning && level >= GetWarningLevel diag) + (severity = FSharpDiagnosticSeverity.Warning && level >= GetWarningLevel diagnostic) -let SplitRelatedDiagnostics(diag: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = - let ToPhased exn = {Exception=exn; Phase = diag.Phase} +let SplitRelatedDiagnostics(diagnostic: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = + let ToPhased exn = {Exception=exn; Phase = diagnostic.Phase} let rec SplitRelatedException exn = match exn with | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, exn2, m) -> @@ -409,7 +409,7 @@ let SplitRelatedDiagnostics(diag: PhasedDiagnostic) : PhasedDiagnostic * PhasedD SplitRelatedException exn.InnerException | _ -> ToPhased exn, [] - SplitRelatedException diag.Exception + SplitRelatedException diagnostic.Exception let DeclareMessage = DeclareResourceString @@ -582,11 +582,11 @@ let getErrorString key = SR.GetString key let (|InvalidArgument|_|) (exn: exn) = match exn with :? ArgumentException as e -> Some e.Message | _ -> None -let OutputPhasedErrorR (os: StringBuilder) (diag: PhasedDiagnostic) (canSuggestNames: bool) = +let OutputPhasedErrorR (os: StringBuilder) (diagnostic: PhasedDiagnostic) (canSuggestNames: bool) = let suggestNames suggestionsF idText = if canSuggestNames then - let buffer = ErrorResolutionHints.SuggestionBuffer idText + let buffer = DiagnosticResolutionHints.SuggestionBuffer idText if not buffer.Disabled then suggestionsF buffer.Add if not buffer.IsEmpty then @@ -1708,14 +1708,14 @@ let OutputPhasedErrorR (os: StringBuilder) (diag: PhasedDiagnostic) (canSuggestN Debug.Assert(false, sprintf "Unknown exception seen in compiler: %s" (exn.ToString())) #endif - OutputExceptionR os diag.Exception + OutputExceptionR os diagnostic.Exception // remove any newlines and tabs -let OutputPhasedDiagnostic (os: StringBuilder) (diag: PhasedDiagnostic) (flattenErrors: bool) (suggestNames: bool) = +let OutputPhasedDiagnostic (os: StringBuilder) (diagnostic: PhasedDiagnostic) (flattenErrors: bool) (suggestNames: bool) = let buf = StringBuilder() - OutputPhasedErrorR buf diag suggestNames + OutputPhasedErrorR buf diagnostic suggestNames let text = if flattenErrors then NormalizeErrorString (buf.ToString()) else buf.ToString() os.AppendString text @@ -1764,7 +1764,7 @@ type FormattedDiagnostic = | Long of FSharpDiagnosticSeverity * FormattedDiagnosticDetailedInfo /// returns sequence that contains Diagnostic for the given error + Diagnostic for all related errors -let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity: FSharpDiagnosticSeverity, diag: PhasedDiagnostic, suggestNames: bool) = +let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity: FSharpDiagnosticSeverity, diagnostic: PhasedDiagnostic, suggestNames: bool) = let outputWhere (showFullPaths, diagnosticStyle) m: FormattedDiagnosticLocation = if equals m rangeStartup || equals m rangeCmdArgs then { Range = m; TextRepresentation = ""; IsEmpty = true; File = "" } @@ -1809,7 +1809,7 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError "", m, file { Range = m; TextRepresentation = text; IsEmpty = false; File = file } - match diag.Exception with + match diagnostic.Exception with | ReportedError _ -> assert ("" = "Unexpected ReportedError") // this should never happen [| |] @@ -1818,9 +1818,9 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError [| |] | _ -> let errors = ResizeArray() - let report diag = - let OutputWhere diag = - match GetRangeOfDiagnostic diag with + let report diagnostic = + let OutputWhere diagnostic = + match GetRangeOfDiagnostic diagnostic with | Some m -> Some(outputWhere (showFullPaths, diagnosticStyle) m) | None -> None @@ -1838,9 +1838,9 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError | _ -> sprintf "%s FS%04d: " message errorNumber { ErrorNumber = errorNumber; Subcategory = subcategory; TextRepresentation = text} - let mainError, relatedErrors = SplitRelatedDiagnostics diag + let mainError, relatedErrors = SplitRelatedDiagnostics diagnostic let where = OutputWhere mainError - let canonical = OutputCanonicalInformation(diag.Subcategory(), GetDiagnosticNumber mainError) + let canonical = OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) let message = let os = StringBuilder() OutputPhasedDiagnostic os mainError flattenErrors suggestNames @@ -1850,15 +1850,15 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError errors.Add (FormattedDiagnostic.Long(severity, entry)) - let OutputRelatedError(diag: PhasedDiagnostic) = + let OutputRelatedError(diagnostic: PhasedDiagnostic) = match diagnosticStyle with // Give a canonical string when --vserror. | DiagnosticStyle.VisualStudio -> let relWhere = OutputWhere mainError // mainError? - let relCanonical = OutputCanonicalInformation(diag.Subcategory(), GetDiagnosticNumber mainError) // Use main error for code + let relCanonical = OutputCanonicalInformation(diagnostic.Subcategory(), GetDiagnosticNumber mainError) // Use main error for code let relMessage = let os = StringBuilder() - OutputPhasedDiagnostic os diag flattenErrors suggestNames + OutputPhasedDiagnostic os diagnostic flattenErrors suggestNames os.ToString() let entry: FormattedDiagnosticDetailedInfo = { Location = relWhere; Canonical = relCanonical; Message = relMessage} @@ -1866,16 +1866,16 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError | _ -> let os = StringBuilder() - OutputPhasedDiagnostic os diag flattenErrors suggestNames + OutputPhasedDiagnostic os diagnostic flattenErrors suggestNames errors.Add (FormattedDiagnostic.Short(severity, os.ToString()) ) relatedErrors |> List.iter OutputRelatedError - match diag with + match diagnostic with #if !NO_TYPEPROVIDERS | {Exception = :? TypeProviderError as tpe} -> tpe.Iter (fun exn -> - let newErr = {diag with Exception = exn} + let newErr = {diagnostic with Exception = exn} report newErr ) #endif @@ -1885,10 +1885,10 @@ let CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenError /// used by fsc.exe and fsi.exe, but not by VS /// prints error and related errors to the specified StringBuilder -let rec OutputDiagnostic (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity) os (diag: PhasedDiagnostic) = +let rec OutputDiagnostic (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity) os (diagnostic: PhasedDiagnostic) = // 'true' for "canSuggestNames" is passed last here because we want to report suggestions in fsc.exe and fsi.exe, just not in regular IDE usage. - let errors = CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity, diag, true) + let errors = CollectFormattedDiagnostics (implicitIncludeDir, showFullPaths, flattenErrors, diagnosticStyle, severity, diagnostic, true) for e in errors do Printf.bprintf os "\n" match e with @@ -1901,8 +1901,8 @@ let rec OutputDiagnostic (implicitIncludeDir, showFullPaths, flattenErrors, diag os.AppendString details.Canonical.TextRepresentation os.AppendString details.Message -let OutputDiagnosticContext prefix fileLineFunction os diag = - match GetRangeOfDiagnostic diag with +let OutputDiagnosticContext prefix fileLineFunction os diagnostic = + match GetRangeOfDiagnostic diagnostic with | None -> () | Some m -> let fileName = m.FileName @@ -1916,43 +1916,43 @@ let OutputDiagnosticContext prefix fileLineFunction os diag = Printf.bprintf os "%s%s\n" prefix line Printf.bprintf os "%s%s%s\n" prefix (String.make iA '-') (String.make iLen '^') -let ReportDiagnosticAsInfo options (diag, severity) = +let ReportDiagnosticAsInfo options (diagnostic, severity) = match severity with | FSharpDiagnosticSeverity.Error -> false | FSharpDiagnosticSeverity.Warning -> false | FSharpDiagnosticSeverity.Info -> - let n = GetDiagnosticNumber diag - IsWarningOrInfoEnabled (diag, severity) n options.WarnLevel options.WarnOn && + let n = GetDiagnosticNumber diagnostic + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && not (List.contains n options.WarnOff) | FSharpDiagnosticSeverity.Hidden -> false -let ReportDiagnosticAsWarning options (diag, severity) = +let ReportDiagnosticAsWarning options (diagnostic, severity) = match severity with | FSharpDiagnosticSeverity.Error -> false | FSharpDiagnosticSeverity.Warning -> - let n = GetDiagnosticNumber diag - IsWarningOrInfoEnabled (diag, severity) n options.WarnLevel options.WarnOn && + let n = GetDiagnosticNumber diagnostic + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && not (List.contains n options.WarnOff) // Informational become warning if explicitly on and not explicitly off | FSharpDiagnosticSeverity.Info -> - let n = GetDiagnosticNumber diag + let n = GetDiagnosticNumber diagnostic List.contains n options.WarnOn && not (List.contains n options.WarnOff) | FSharpDiagnosticSeverity.Hidden -> false -let ReportDiagnosticAsError options (diag, severity) = +let ReportDiagnosticAsError options (diagnostic, severity) = match severity with | FSharpDiagnosticSeverity.Error -> true // Warnings become errors in some situations | FSharpDiagnosticSeverity.Warning -> - let n = GetDiagnosticNumber diag - IsWarningOrInfoEnabled (diag, severity) n options.WarnLevel options.WarnOn && + let n = GetDiagnosticNumber diagnostic + IsWarningOrInfoEnabled (diagnostic, severity) n options.WarnLevel options.WarnOn && not (List.contains n options.WarnAsWarn) && ((options.GlobalWarnAsError && not (List.contains n options.WarnOff)) || List.contains n options.WarnAsError) // Informational become errors if explicitly WarnAsError | FSharpDiagnosticSeverity.Info -> - let n = GetDiagnosticNumber diag + let n = GetDiagnosticNumber diagnostic List.contains n options.WarnAsError | FSharpDiagnosticSeverity.Hidden -> false @@ -1968,16 +1968,16 @@ let ReportDiagnosticAsError options (diag, severity) = // 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 DiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagnosticOptions:FSharpDiagnosticOptions, errorLogger: DiagnosticsLogger) = +type DiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagnosticOptions:FSharpDiagnosticOptions, diagnosticsLogger: DiagnosticsLogger) = inherit DiagnosticsLogger("DiagnosticsLoggerFilteringByScopedPragmas") - override x.DiagnosticSink (phasedError, severity) = + override _.DiagnosticSink (diagnostic, severity) = if severity = FSharpDiagnosticSeverity.Error then - errorLogger.DiagnosticSink (phasedError, severity) + diagnosticsLogger.DiagnosticSink (diagnostic, severity) else let report = - let warningNum = GetDiagnosticNumber phasedError - match GetRangeOfDiagnostic phasedError with + let warningNum = GetDiagnosticNumber diagnostic + match GetRangeOfDiagnostic diagnostic with | Some m -> scopedPragmas |> List.exists (fun pragma -> @@ -1989,14 +1989,14 @@ type DiagnosticsLoggerFilteringByScopedPragmas (checkFile, scopedPragmas, diagno | None -> true if report then - if ReportDiagnosticAsError diagnosticOptions (phasedError, severity) then - errorLogger.DiagnosticSink(phasedError, FSharpDiagnosticSeverity.Error) - elif ReportDiagnosticAsWarning diagnosticOptions (phasedError, severity) then - errorLogger.DiagnosticSink(phasedError, FSharpDiagnosticSeverity.Warning) - elif ReportDiagnosticAsInfo diagnosticOptions (phasedError, severity) then - errorLogger.DiagnosticSink(phasedError, severity) + if ReportDiagnosticAsError diagnosticOptions (diagnostic, severity) then + diagnosticsLogger.DiagnosticSink(diagnostic, FSharpDiagnosticSeverity.Error) + elif ReportDiagnosticAsWarning diagnosticOptions (diagnostic, severity) then + diagnosticsLogger.DiagnosticSink(diagnostic, FSharpDiagnosticSeverity.Warning) + elif ReportDiagnosticAsInfo diagnosticOptions (diagnostic, severity) then + diagnosticsLogger.DiagnosticSink(diagnostic, severity) - override _.ErrorCount = errorLogger.ErrorCount + override _.ErrorCount = diagnosticsLogger.ErrorCount -let GetDiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, errorLogger) = - DiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, errorLogger) :> DiagnosticsLogger +let GetDiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, diagnosticsLogger) = + DiagnosticsLoggerFilteringByScopedPragmas(checkFile, scopedPragmas, diagnosticOptions, diagnosticsLogger) :> DiagnosticsLogger diff --git a/src/Compiler/Driver/CompilerDiagnostics.fsi b/src/Compiler/Driver/CompilerDiagnostics.fsi index 46e8644ba24..e31970c55df 100644 --- a/src/Compiler/Driver/CompilerDiagnostics.fsi +++ b/src/Compiler/Driver/CompilerDiagnostics.fsi @@ -48,16 +48,17 @@ exception DeprecatedCommandLineOptionNoDescription of string * range exception InternalCommandLineOption of string * range /// Get the location associated with an error -val GetRangeOfDiagnostic: PhasedDiagnostic -> range option +val GetRangeOfDiagnostic: diagnostic: PhasedDiagnostic -> range option /// Get the number associated with an error -val GetDiagnosticNumber: PhasedDiagnostic -> int +val GetDiagnosticNumber: diagnostic: PhasedDiagnostic -> int /// Split errors into a "main" error and a set of associated errors -val SplitRelatedDiagnostics: PhasedDiagnostic -> PhasedDiagnostic * PhasedDiagnostic list +val SplitRelatedDiagnostics: diagnostic: PhasedDiagnostic -> PhasedDiagnostic * PhasedDiagnostic list /// Output an error to a buffer -val OutputPhasedDiagnostic: StringBuilder -> PhasedDiagnostic -> flattenErrors: bool -> suggestNames: bool -> unit +val OutputPhasedDiagnostic: + os: StringBuilder -> diagnostic: PhasedDiagnostic -> flattenErrors: bool -> suggestNames: bool -> unit /// Output an error or warning to a buffer val OutputDiagnostic: diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index bafd28ed504..7ff48e457e1 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -1327,7 +1327,7 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse runtimeAssemblyAttributes: ILAttribute list, entityToInjectInto, invalidateCcu: Event<_>, m) = - let startingErrorCount = CompileThreadStatic.DiagnosticsLogger.ErrorCount + let startingErrorCount = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorCount // Find assembly level TypeProviderAssemblyAttributes. These will point to the assemblies that // have class which implement ITypeProvider and which have TypeProviderAttribute on them. @@ -1454,7 +1454,7 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse with e -> errorRecovery e m - if startingErrorCount] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let ilGlobals = mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals - let tcGlobals = TcGlobals(tcConfig.compilingFSharpCore, ilGlobals, fslibCcu, - tcConfig.implicitIncludeDir, tcConfig.mlCompatibility, - tcConfig.isInteractive, tryFindSysTypeCcu, tcConfig.emitDebugInfoInQuotations, - tcConfig.noDebugAttributes, tcConfig.pathMap, tcConfig.langVersion) + let tcGlobals = + TcGlobals(tcConfig.compilingFSharpCore, + ilGlobals, + fslibCcu, + tcConfig.implicitIncludeDir, + tcConfig.mlCompatibility, + tcConfig.isInteractive, + tryFindSysTypeCcu, + tcConfig.emitDebugInfoInQuotations, + tcConfig.noDebugAttributes, + tcConfig.pathMap, + tcConfig.langVersion) #if DEBUG // the global_g reference cell is used only for debug printing diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 4df98259688..681d6fa92f1 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -847,6 +847,7 @@ let codeGenerationFlags isFsi (tcConfigB: TcConfigBuilder) = ("crossoptimize", tagNone, OptionSwitch (crossOptimizeSwitch tcConfigB), None, Some (FSComp.SR.optsCrossoptimize())) + ] if isFsi then debug @ codegen else debug @ embed @ codegen diff --git a/src/Compiler/Driver/OptimizeInputs.fs b/src/Compiler/Driver/OptimizeInputs.fs index 97cfd577807..54f800b2a46 100644 --- a/src/Compiler/Driver/OptimizeInputs.fs +++ b/src/Compiler/Driver/OptimizeInputs.fs @@ -140,7 +140,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFiles, implFileOptDatas = List.unzip results let assemblyOptData = Optimizer.UnionOptimizationInfos implFileOptDatas - let tassembly = TypedAssemblyAfterOptimization implFiles + let tassembly = CheckedAssemblyAfterOptimization implFiles PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-end" (implFiles |> List.map (fun implFile -> implFile.ImplFile)) ReportTime tcConfig "Ending Optimizations" tassembly, assemblyOptData, optEnvFirstLoop @@ -155,10 +155,16 @@ let CreateIlxAssemblyGenerator (_tcConfig:TcConfig, tcImports:TcImports, tcGloba ilxGenerator.AddExternalCcus ccus ilxGenerator -let GenerateIlxCode - (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, - tcConfig:TcConfig, topAttrs: TopAttribs, optimizedImpls, - fragName, ilxGenerator: IlxAssemblyGenerator) = +let GenerateIlxCode ( + ilxBackend, + isInteractiveItExpr, + isInteractiveOnMono, + tcConfig:TcConfig, + topAttrs: TopAttribs, + optimizedImpls, + fragName, + ilxGenerator: IlxAssemblyGenerator + ) = let mainMethodInfo = if (tcConfig.target = CompilerTarget.Dll) || (tcConfig.target = CompilerTarget.Module) then @@ -168,8 +174,8 @@ let GenerateIlxCode let ilxGenOpts: IlxGenOptions = { generateFilterBlocks = tcConfig.generateFilterBlocks emitConstantArraysUsingStaticDataBlobs = not isInteractiveOnMono - workAroundReflectionEmitBugs=tcConfig.isInteractive // REVIEW: is this still required? - generateDebugSymbols= tcConfig.debuginfo + workAroundReflectionEmitBugs = tcConfig.isInteractive + generateDebugSymbols = tcConfig.debuginfo fragName = fragName localOptimizationsEnabled= tcConfig.optSettings.LocalOptimizationsEnabled testFlagEmitFeeFeeAs100001 = tcConfig.testFlagEmitFeeFeeAs100001 diff --git a/src/Compiler/Driver/OptimizeInputs.fsi b/src/Compiler/Driver/OptimizeInputs.fsi index b7c3528f7c0..9c5f42f222e 100644 --- a/src/Compiler/Driver/OptimizeInputs.fsi +++ b/src/Compiler/Driver/OptimizeInputs.fsi @@ -29,21 +29,21 @@ val ApplyAllOptimizations: isIncrementalFragment: bool * optEnv: IncrementalOptimizationEnv * ccu: CcuThunk * - implFiles: TypedImplFile list -> - TypedAssemblyAfterOptimization * LazyModuleInfo * IncrementalOptimizationEnv + implFiles: CheckedImplFile list -> + CheckedAssemblyAfterOptimization * LazyModuleInfo * IncrementalOptimizationEnv val CreateIlxAssemblyGenerator: TcConfig * TcImports * TcGlobals * ConstraintSolver.TcValF * CcuThunk -> IlxAssemblyGenerator val GenerateIlxCode: - IlxGenBackend * + ilxBackend: IlxGenBackend * isInteractiveItExpr: bool * isInteractiveOnMono: bool * - TcConfig * - TopAttribs * - TypedAssemblyAfterOptimization * + tcConfig: TcConfig * + topAttrs: TopAttribs * + optimizedImpls: CheckedAssemblyAfterOptimization * fragName: string * - IlxAssemblyGenerator -> + ilxGenerator: IlxAssemblyGenerator -> IlxGenResults // Used during static linking diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 66f55246223..582cbc8be26 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -266,7 +266,7 @@ let DeduplicateParsedInputModuleName (moduleNamesDict: ModuleNamesDict) input = let inputT = ParsedInput.SigFile (ParsedSigFileInput.ParsedSigFileInput (fileName, qualNameOfFileT, scopedPragmas, hashDirectives, modules, trivia)) inputT, moduleNamesDictT -let ParseInput (lexer, diagnosticOptions:FSharpDiagnosticOptions, errorLogger: DiagnosticsLogger, lexbuf: UnicodeLexing.Lexbuf, defaultNamespace, fileName, isLastCompiland) = +let ParseInput (lexer, diagnosticOptions:FSharpDiagnosticOptions, diagnosticsLogger: DiagnosticsLogger, 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 file name // - if you have a #line directive, e.g. @@ -308,7 +308,7 @@ let ParseInput (lexer, diagnosticOptions:FSharpDiagnosticOptions, errorLogger: D input finally // OK, now commit the errors, since the ScopedPragmas will (hopefully) have been scraped - let filteringDiagnosticsLogger = GetDiagnosticsLoggerFilteringByScopedPragmas(false, scopedPragmas, diagnosticOptions, errorLogger) + let filteringDiagnosticsLogger = GetDiagnosticsLoggerFilteringByScopedPragmas(false, scopedPragmas, diagnosticOptions, diagnosticsLogger) delayLogger.CommitDelayedDiagnostics filteringDiagnosticsLogger type Tokenizer = unit -> Parser.token @@ -374,7 +374,7 @@ let EmptyParsedInput(fileName, isLastCompiland) = ) /// Parse an input, drawing tokens from the LexBuffer -let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, errorLogger) = +let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) = use unwindbuildphase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse try @@ -382,10 +382,10 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam let skipWhitespaceTokens = true // Set up the initial status for indentation-aware processing - let lightStatus = IndentationAwareSyntaxStatus (tcConfig.ComputeIndentationAwareSyntaxInitialStatus fileName, true) + let indentationSyntaxStatus = IndentationAwareSyntaxStatus (tcConfig.ComputeIndentationAwareSyntaxInitialStatus fileName, true) // Set up the initial lexer arguments - let lexargs = mkLexargs (tcConfig.conditionalDefines, lightStatus, lexResourceManager, [], errorLogger, tcConfig.pathMap) + let lexargs = mkLexargs (tcConfig.conditionalDefines, indentationSyntaxStatus, lexResourceManager, [], diagnosticsLogger, tcConfig.pathMap) // Set up the initial lexer arguments let shortFilename = SanitizeFileName fileName tcConfig.implicitIncludeDir @@ -399,9 +399,9 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam | TokenizeOption.Unfiltered -> (fun () -> Lexer.token lexargs skipWhitespaceTokens lexbuf), true | TokenizeOption.Only -> - LexFilter.LexFilter(lightStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, true + LexFilter.LexFilter(indentationSyntaxStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, true | _ -> - LexFilter.LexFilter(lightStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, false + LexFilter.LexFilter(indentationSyntaxStatus, tcConfig.compilingFSharpCore, Lexer.token lexargs skipWhitespaceTokens, lexbuf).GetToken, false // If '--tokenize' then show the tokens now and exit if tokenizeOnly then @@ -412,7 +412,7 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam TestInteractionParserAndExit (tokenizer, lexbuf) // Parse the input - let res = ParseInput((fun _ -> tokenizer ()), tcConfig.diagnosticsOptions, errorLogger, lexbuf, None, fileName, isLastCompiland) + let res = ParseInput((fun _ -> tokenizer ()), tcConfig.diagnosticsOptions, diagnosticsLogger, lexbuf, None, fileName, isLastCompiland) // Report the statistics for testing purposes if tcConfig.reportNumDecls then @@ -435,23 +435,23 @@ let checkInputFile (tcConfig: TcConfig) fileName = else error(Error(FSComp.SR.buildInvalidSourceFileExtension(SanitizeFileName fileName tcConfig.implicitIncludeDir), rangeStartup)) -let parseInputStreamAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked, stream: Stream) = +let parseInputStreamAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream: Stream) = use reader = stream.GetReader(tcConfig.inputCodePage, retryLocked) // Set up the LexBuffer for the file let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) // Parse the file drawing tokens from the lexbuf - ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, errorLogger) + ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) -let parseInputSourceTextAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, sourceText: ISourceText) = +let parseInputSourceTextAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText: ISourceText) = // Set up the LexBuffer for the file let lexbuf = UnicodeLexing.SourceTextAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, sourceText) // Parse the file drawing tokens from the lexbuf - ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, errorLogger) + ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) -let parseInputFileAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked) = +let parseInputFileAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) = // Get a stream reader for the file use fileStream = FileSystem.OpenFileForReadShim(fileName) use reader = fileStream.GetReader(tcConfig.inputCodePage, retryLocked) @@ -460,35 +460,35 @@ let parseInputFileAux (tcConfig: TcConfig, lexResourceManager, fileName, isLastC let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(not tcConfig.compilingFSharpCore, tcConfig.langVersion, reader) // Parse the file drawing tokens from the lexbuf - ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, errorLogger) + ParseOneInputLexbuf(tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) /// Parse an input from stream -let ParseOneInputStream (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked, stream: Stream) = +let ParseOneInputStream (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream: Stream) = try - parseInputStreamAux(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked, stream) + parseInputStreamAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) /// Parse an input from source text -let ParseOneInputSourceText (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, sourceText: ISourceText) = +let ParseOneInputSourceText (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText: ISourceText) = try - parseInputSourceTextAux(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, sourceText) + parseInputSourceTextAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) /// Parse an input from disk -let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked) = +let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) = try checkInputFile tcConfig fileName - parseInputFileAux(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, retryLocked) + parseInputFileAux(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) with exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) /// Parse multiple input files from disk -let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, errorLogger: DiagnosticsLogger, exiter: Exiter, createDiagnosticsLogger: Exiter -> CapturingDiagnosticsLogger, retryLocked) = +let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagnosticsLogger: DiagnosticsLogger, exiter: Exiter, createDiagnosticsLogger: Exiter -> CapturingDiagnosticsLogger, retryLocked) = try let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint let sourceFiles = isLastCompiland |> List.zip sourceFiles |> Array.ofList @@ -521,7 +521,7 @@ let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, errorL finally delayedDiagnosticsLoggers |> Array.iter (fun delayedDiagnosticsLogger -> - delayedDiagnosticsLogger.CommitDelayedDiagnostics errorLogger + delayedDiagnosticsLogger.CommitDelayedDiagnostics diagnosticsLogger ) with | StopProcessing -> @@ -533,7 +533,7 @@ let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, sourceFiles, errorL sourceFiles |> Array.map (fun (fileName, isLastCompiland) -> let directoryName = Path.GetDirectoryName fileName - let input = ParseOneInputFile(tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), errorLogger, retryLocked) + let input = ParseOneInputFile(tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), diagnosticsLogger, retryLocked) (input, directoryName)) |> List.ofArray @@ -830,9 +830,8 @@ let GetInitialTcState(m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcIm } /// Dummy typed impl file that contains no definitions and is not used for emitting any kind of assembly. -let CreateEmptyDummyTypedImplFile qualNameOfFile sigTy = - let dummyExpr = ModuleOrNamespaceContentsWithSig.ModuleOrNamespaceContentsWithSig(sigTy, ModuleOrNamespaceContents.TMDefs [], range.Zero) - TypedImplFile.TImplFile(qualNameOfFile, [], dummyExpr, false, false, StampMap [], Map.empty) +let CreateEmptyDummyImplFile qualNameOfFile sigTy = + CheckedImplFile.CheckedImplFile(qualNameOfFile, [], sigTy, ModuleOrNamespaceContents.TMDefs [], false, false, StampMap [], Map.empty) /// Typecheck a single file (or interactive entry into F# Interactive) let CheckOneInput @@ -913,14 +912,14 @@ let CheckOneInput // Typecheck the implementation file let typeCheckOne = if skipImplIfSigExists && hadSig then - (EmptyTopAttrs, CreateEmptyDummyTypedImplFile qualNameOfFile rootSigOpt.Value, Unchecked.defaultof<_>, tcImplEnv, false) + (EmptyTopAttrs, CreateEmptyDummyImplFile qualNameOfFile rootSigOpt.Value, Unchecked.defaultof<_>, tcImplEnv, false) |> Cancellable.ret else CheckOneImplFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, tcState.tcsImplicitOpenDeclarations, checkForErrors, conditionalDefines, tcSink, tcConfig.internalTestSpanStackReferring, tcImplEnv, rootSigOpt, file) let! topAttrs, implFile, _implFileHiddenType, tcEnvAtEnd, createsGeneratedProvidedTypes = typeCheckOne - let implFileSigType = SigTypeOfImplFile implFile + let implFileSigType = implFile.Signature let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls @@ -993,7 +992,7 @@ let CheckOneInputAndFinish(checkForErrors, tcConfig: TcConfig, tcImports, tcGlob return result } -let CheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = +let CheckClosedInputSetFinish (declaredImpls: CheckedImplFile list, tcState) = // Latest contents to the CCU let ccuContents = Construct.NewCcuContents ILScopeRef.Local range0 tcState.tcsCcu.AssemblyName tcState.tcsCcuSig diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fsi b/src/Compiler/Driver/ParseAndCheckInputs.fsi index 95406e74a72..738d2886552 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fsi +++ b/src/Compiler/Driver/ParseAndCheckInputs.fsi @@ -35,7 +35,7 @@ val DeduplicateParsedInputModuleName: ModuleNamesDict -> ParsedInput -> ParsedIn val ParseInput: lexer: (Lexbuf -> Parser.token) * diagnosticOptions: FSharpDiagnosticOptions * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * lexbuf: Lexbuf * defaultNamespace: string option * fileName: string * @@ -62,7 +62,7 @@ val ParseOneInputStream: lexResourceManager: Lexhelp.LexResourceManager * fileName: string * isLastCompiland: (bool * bool) * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * retryLocked: bool * stream: Stream -> ParsedInput @@ -73,7 +73,7 @@ val ParseOneInputSourceText: lexResourceManager: Lexhelp.LexResourceManager * fileName: string * isLastCompiland: (bool * bool) * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * sourceText: ISourceText -> ParsedInput @@ -83,7 +83,7 @@ val ParseOneInputFile: lexResourceManager: Lexhelp.LexResourceManager * fileName: string * isLastCompiland: (bool * bool) * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * retryLocked: bool -> ParsedInput @@ -93,7 +93,7 @@ val ParseOneInputLexbuf: lexbuf: Lexbuf * fileName: string * isLastCompiland: (bool * bool) * - errorLogger: DiagnosticsLogger -> + diagnosticsLogger: DiagnosticsLogger -> ParsedInput val EmptyParsedInput: fileName: string * isLastCompiland: (bool * bool) -> ParsedInput @@ -103,7 +103,7 @@ val ParseInputFiles: tcConfig: TcConfig * lexResourceManager: Lexhelp.LexResourceManager * sourceFiles: string list * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * exiter: Exiter * createDiagnosticsLogger: (Exiter -> CapturingDiagnosticsLogger) * retryLocked: bool -> @@ -150,14 +150,14 @@ val CheckOneInput: TcState * ParsedInput * skipImplIfSigExists: bool -> - Cancellable<(TcEnv * TopAttribs * TypedImplFile option * ModuleOrNamespaceType) * TcState> + Cancellable<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState> /// Finish the checking of multiple inputs val CheckMultipleInputsFinish: (TcEnv * TopAttribs * 'T option * 'U) list * TcState -> (TcEnv * TopAttribs * 'T list * 'U list) * TcState /// Finish the checking of a closed set of inputs -val CheckClosedInputSetFinish: TypedImplFile list * TcState -> TcState * TypedImplFile list * ModuleOrNamespace +val CheckClosedInputSetFinish: CheckedImplFile list * TcState -> TcState * CheckedImplFile list * ModuleOrNamespace /// Check a closed set of inputs val CheckClosedInputSet: @@ -169,7 +169,7 @@ val CheckClosedInputSet: LongIdent option * TcState * ParsedInput list -> - TcState * TopAttribs * TypedImplFile list * TcEnv + TcState * TopAttribs * CheckedImplFile list * TcEnv /// Check a single input and finish the checking val CheckOneInputAndFinish: @@ -181,4 +181,4 @@ val CheckOneInputAndFinish: NameResolution.TcResultsSink * TcState * ParsedInput -> - Cancellable<(TcEnv * TopAttribs * TypedImplFile list * ModuleOrNamespaceType list) * TcState> + Cancellable<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState> diff --git a/src/Compiler/Driver/ScriptClosure.fs b/src/Compiler/Driver/ScriptClosure.fs index 03e1910ecef..7351edde58f 100644 --- a/src/Compiler/Driver/ScriptClosure.fs +++ b/src/Compiler/Driver/ScriptClosure.fs @@ -117,7 +117,7 @@ module ScriptPreprocessClosure = tcConfig: TcConfig, codeContext, lexResourceManager: Lexhelp.LexResourceManager, - errorLogger: DiagnosticsLogger + diagnosticsLogger: DiagnosticsLogger ) = // fsc.exe -- COMPILED\!INTERACTIVE @@ -139,7 +139,7 @@ module ScriptPreprocessClosure = // The root compiland is last in the list of compilands. let isLastCompiland = (IsScript fileName, tcConfig.target.IsExe) - ParseOneInputLexbuf (tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, errorLogger) + ParseOneInputLexbuf (tcConfig, lexResourceManager, lexbuf, fileName, isLastCompiland, diagnosticsLogger) /// Create a TcConfig for load closure starting from a single .fsx file let CreateScriptTextTcConfig @@ -185,8 +185,8 @@ module ScriptPreprocessClosure = match basicReferences with | None -> - let errorLogger = CapturingDiagnosticsLogger("ScriptDefaultReferences") - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let diagnosticsLogger = CapturingDiagnosticsLogger("ScriptDefaultReferences") + use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) let references, useDotNetFramework = tcConfigB.FxResolver.GetDefaultReferences useFsiAuxLib // If the user requested .NET Core scripting but something went wrong and we reverted to @@ -198,7 +198,7 @@ module ScriptPreprocessClosure = for reference in references do tcConfigB.AddReferencedAssemblyByPath(range0, reference) - errorLogger.Diagnostics + diagnosticsLogger.Diagnostics | Some (rs, diagnostics) -> for m, reference in rs do @@ -357,13 +357,13 @@ module ScriptPreprocessClosure = //printfn "visiting %s" fileName if IsScript fileName || parseRequired then let parseResult, parseDiagnostics = - let errorLogger = CapturingDiagnosticsLogger("FindClosureParse") - use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) - let result = ParseScriptClosureInput (fileName, sourceText, tcConfig, codeContext, lexResourceManager, errorLogger) - result, errorLogger.Diagnostics + let diagnosticsLogger = CapturingDiagnosticsLogger("FindClosureParse") + use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) + let result = ParseScriptClosureInput (fileName, sourceText, tcConfig, codeContext, lexResourceManager, diagnosticsLogger) + result, diagnosticsLogger.Diagnostics - let errorLogger = CapturingDiagnosticsLogger("FindClosureMetaCommands") - use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let diagnosticsLogger = CapturingDiagnosticsLogger("FindClosureMetaCommands") + use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) let pathOfMetaCommandSource = Path.GetDirectoryName fileName let preSources = tcConfig.GetAvailableLoadedSources() @@ -382,7 +382,7 @@ module ScriptPreprocessClosure = yield! loop subSource else yield ClosureFile(subFile, m, None, [], [], []) - yield ClosureFile(fileName, m, Some parseResult, parseDiagnostics, errorLogger.Diagnostics, noWarns) + yield ClosureFile(fileName, m, Some parseResult, parseDiagnostics, diagnosticsLogger.Diagnostics, noWarns) else // Don't traverse into .fs leafs. @@ -429,12 +429,12 @@ module ScriptPreprocessClosure = // Resolve all references. let references, unresolvedReferences, resolutionDiagnostics = - let errorLogger = CapturingDiagnosticsLogger("GetLoadClosure") + let diagnosticsLogger = CapturingDiagnosticsLogger("GetLoadClosure") - use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) let references, unresolvedReferences = TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) let references = references |> List.map (fun ar -> ar.resolvedPath, ar) - references, unresolvedReferences, errorLogger.Diagnostics + references, unresolvedReferences, diagnosticsLogger.Diagnostics // Root errors and warnings - look at the last item in the closureFiles list let loadClosureRootDiagnostics, allRootDiagnostics = diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index c18802e084a..773b9ae7d5a 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -68,34 +68,34 @@ type DiagnosticsLoggerUpToMaxErrors(tcConfigB: TcConfigBuilder, exiter: Exiter, let mutable errors = 0 /// Called when an error or warning occurs - abstract HandleIssue: tcConfigB: TcConfigBuilder * error: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + abstract HandleIssue: tcConfigB: TcConfigBuilder * diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit /// Called when 'too many errors' has occurred abstract HandleTooManyErrors: text: string -> unit override _.ErrorCount = errors - override x.DiagnosticSink(phasedError, severity) = - if ReportDiagnosticAsError tcConfigB.diagnosticsOptions (phasedError, severity) then + override x.DiagnosticSink(diagnostic, severity) = + if ReportDiagnosticAsError tcConfigB.diagnosticsOptions (diagnostic, severity) then if errors >= tcConfigB.maxErrors then x.HandleTooManyErrors(FSComp.SR.fscTooManyErrors()) exiter.Exit 1 - x.HandleIssue(tcConfigB, phasedError, FSharpDiagnosticSeverity.Error) + x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Error) errors <- errors + 1 - match phasedError.Exception, tcConfigB.simulateException with + match diagnostic.Exception, tcConfigB.simulateException with | InternalError (msg, _), None - | Failure msg, None -> Debug.Assert(false, sprintf "Bug in compiler: %s\n%s" msg (phasedError.Exception.ToString())) - | :? KeyNotFoundException, None -> Debug.Assert(false, sprintf "Lookup exception in compiler: %s" (phasedError.Exception.ToString())) + | Failure msg, None -> Debug.Assert(false, sprintf "Bug in compiler: %s\n%s" msg (diagnostic.Exception.ToString())) + | :? KeyNotFoundException, None -> Debug.Assert(false, sprintf "Lookup exception in compiler: %s" (diagnostic.Exception.ToString())) | _ -> () - elif ReportDiagnosticAsWarning tcConfigB.diagnosticsOptions (phasedError, severity) then - x.HandleIssue(tcConfigB, phasedError, FSharpDiagnosticSeverity.Warning) + elif ReportDiagnosticAsWarning tcConfigB.diagnosticsOptions (diagnostic, severity) then + x.HandleIssue(tcConfigB, diagnostic, FSharpDiagnosticSeverity.Warning) - elif ReportDiagnosticAsInfo tcConfigB.diagnosticsOptions (phasedError, severity) then - x.HandleIssue(tcConfigB, phasedError, severity) + elif ReportDiagnosticAsInfo tcConfigB.diagnosticsOptions (diagnostic, severity) then + x.HandleIssue(tcConfigB, diagnostic, severity) /// Create an error logger that counts and prints errors @@ -107,27 +107,26 @@ let ConsoleDiagnosticsLoggerUpToMaxErrors (tcConfigB: TcConfigBuilder, exiter : member _.HandleIssue(tcConfigB, err, severity) = DoWithDiagnosticColor severity (fun () -> - let diag = OutputDiagnostic (tcConfigB.implicitIncludeDir, tcConfigB.showFullPaths, tcConfigB.flatErrors, tcConfigB.diagnosticStyle, severity) - writeViaBuffer stderr diag err + let diagnostic = OutputDiagnostic (tcConfigB.implicitIncludeDir, tcConfigB.showFullPaths, tcConfigB.flatErrors, tcConfigB.diagnosticStyle, severity) + writeViaBuffer stderr diagnostic err stderr.WriteLine()) } :> DiagnosticsLogger /// This error logger delays the messages it receives. At the end, call ForwardDelayedDiagnostics /// to send the held messages. -type DelayAndForwardDiagnosticsLogger(exiter: Exiter, errorLoggerProvider: DiagnosticsLoggerProvider) = +type DelayAndForwardDiagnosticsLogger(exiter: Exiter, diagnosticsLoggerProvider: DiagnosticsLoggerProvider) = inherit CapturingDiagnosticsLogger("DelayAndForwardDiagnosticsLogger") member x.ForwardDelayedDiagnostics(tcConfigB: TcConfigBuilder) = - let errorLogger = errorLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) - x.CommitDelayedDiagnostics errorLogger + let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + x.CommitDelayedDiagnostics diagnosticsLogger and [] DiagnosticsLoggerProvider() = member this.CreateDelayAndForwardLogger exiter = DelayAndForwardDiagnosticsLogger(exiter, this) - abstract CreateDiagnosticsLoggerUpToMaxErrors : tcConfigBuilder : TcConfigBuilder * exiter : Exiter -> DiagnosticsLogger - + abstract CreateDiagnosticsLoggerUpToMaxErrors: tcConfigBuilder: TcConfigBuilder * exiter: Exiter -> DiagnosticsLogger /// The default DiagnosticsLogger implementation, reporting messages to the Console up to the maxerrors maximum type ConsoleLoggerProvider() = @@ -138,18 +137,18 @@ type ConsoleLoggerProvider() = ConsoleDiagnosticsLoggerUpToMaxErrors(tcConfigBuilder, exiter) /// Notify the exiter if any error has occurred -let AbortOnError (errorLogger: DiagnosticsLogger, exiter : Exiter) = - if errorLogger.ErrorCount > 0 then +let AbortOnError (diagnosticsLogger: DiagnosticsLogger, exiter : Exiter) = + if diagnosticsLogger.ErrorCount > 0 then exiter.Exit 1 -let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, errorLogger: DiagnosticsLogger, assemblyName, niceNameGen, tcEnv0, openDecls0, inputs, exiter: Exiter) = +let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: DiagnosticsLogger, assemblyName, niceNameGen, tcEnv0, openDecls0, inputs, exiter: Exiter) = try if isNil inputs then error(Error(FSComp.SR.fscNoImplementationFiles(), rangeStartup)) let ccuName = assemblyName let tcInitialState = GetInitialTcState (rangeStartup, ccuName, tcConfig, tcGlobals, tcImports, niceNameGen, tcEnv0, openDecls0) - CheckClosedInputSet (ctok, (fun () -> errorLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, tcInitialState, inputs) - with e -> - errorRecovery e rangeStartup + CheckClosedInputSet (ctok, (fun () -> diagnosticsLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, tcInitialState, inputs) + with exn -> + errorRecovery exn rangeStartup exiter.Exit 1 /// Check for .fsx and, if present, compute the load closure for of #loaded files. @@ -274,16 +273,16 @@ let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, lcidFromCodePage, argv) /// Write a .fsi file for the --sig option module InterfaceFileWriter = - let WriteInterfaceFile (tcGlobals, tcConfig: TcConfig, infoReader, declaredImpls: TypedImplFile list) = + let WriteInterfaceFile (tcGlobals, tcConfig: TcConfig, infoReader, declaredImpls: CheckedImplFile list) = // there are two modes here: // * write one unified sig file to a given path, or // * write individual sig files to paths matching their impl files let denv = DisplayEnv.InitialForSigFileGeneration tcGlobals let denv = { denv with shrinkOverloads = false; printVerboseSignatures = true } - let writeToFile os (TImplFile (implExprWithSig=mexpr)) = + let writeToFile os (CheckedImplFile (contents=mexpr)) = writeViaBuffer os (fun os s -> Printf.bprintf os "%s\n\n" s) - (NicePrint.layoutInferredSigOfModuleExpr true denv infoReader AccessibleFromSomewhere range0 mexpr |> Display.squashTo 80 |> LayoutRender.showL) + (NicePrint.layoutImpliedSignatureOfModuleOrNamespace true denv infoReader AccessibleFromSomewhere range0 mexpr |> Display.squashTo 80 |> LayoutRender.showL) let writeHeader filePath os = if filePath <> "" && not (List.exists (FileSystemUtils.checkSuffix filePath) FSharpIndentationAwareSyntaxFileSuffixes) then @@ -311,8 +310,8 @@ module InterfaceFileWriter = else ".fsi" - let writeToSeparateFiles (declaredImpls: TypedImplFile list) = - for TImplFile (qualifiedNameOfFile=name) as impl in declaredImpls do + let writeToSeparateFiles (declaredImpls: CheckedImplFile list) = + for CheckedImplFile (qualifiedNameOfFile=name) as impl in declaredImpls do let fileName = Path.ChangeExtension(name.Range.FileName, extensionForFile name.Range.FileName) printfn "writing impl file to %s" fileName use os = FileSystem.OpenFileForWriteShim(fileName, FileMode.Create).GetWriter() @@ -382,7 +381,7 @@ type Args<'T> = Args of 'T /// - Check the inputs let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage: ReduceMemoryFlag, defaultCopyFSharpCore: CopyFSharpCoreFlag, - exiter: Exiter, errorLoggerProvider: DiagnosticsLoggerProvider, disposables: DisposablesTracker) = + exiter: Exiter, diagnosticsLoggerProvider: DiagnosticsLoggerProvider, disposables: DisposablesTracker) = // See Bug 735819 let lcidFromCodePage = @@ -418,7 +417,7 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, SetTailcallSwitch tcConfigB OptionSwitch.On // Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors) - let delayForFlagsLogger = errorLoggerProvider.CreateDelayAndForwardLogger exiter + let delayForFlagsLogger = diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter let _unwindEL_1 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger) @@ -469,16 +468,16 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, delayForFlagsLogger.ForwardDelayedDiagnostics tcConfigB exiter.Exit 1 - let errorLogger = errorLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) // Install the global error logger and never remove it. This logger does have all command-line flags considered. - let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) // Forward all errors from flags - delayForFlagsLogger.CommitDelayedDiagnostics errorLogger + delayForFlagsLogger.CommitDelayedDiagnostics diagnosticsLogger if not tcConfigB.continueAfterParseFailure then - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Resolve assemblies ReportTime tcConfig "Import mscorlib and FSharp.Core.dll" @@ -498,9 +497,9 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, ReportTime tcConfig "Parse inputs" use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - let createDiagnosticsLogger = (fun exiter -> errorLoggerProvider.CreateDelayAndForwardLogger(exiter) :> CapturingDiagnosticsLogger) + let createDiagnosticsLogger = (fun exiter -> diagnosticsLoggerProvider.CreateDelayAndForwardLogger(exiter) :> CapturingDiagnosticsLogger) - let inputs = ParseInputFiles(tcConfig, lexResourceManager, sourceFiles, errorLogger, exiter, createDiagnosticsLogger, (*retryLocked*)false) + let inputs = ParseInputFiles(tcConfig, lexResourceManager, sourceFiles, diagnosticsLogger, exiter, createDiagnosticsLogger, (*retryLocked*)false) let inputs, _ = (Map.empty, inputs) ||> List.mapFold (fun state (input, x) -> @@ -517,7 +516,7 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, if tcConfig.parseOnly then exiter.Exit 0 if not tcConfig.continueAfterParseFailure then - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Apply any nowarn flags let tcConfig = @@ -537,7 +536,7 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, disposables.Register tcImports if not tcConfig.continueAfterParseFailure then - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) if tcConfig.importAllReferencesOnly then exiter.Exit 0 @@ -552,12 +551,12 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, let inputs = inputs |> List.map fst let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = - TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) + TypeCheck(ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, diagnosticsLogger, exiter) /// Alternative first phase of compilation. This is for the compile-from-AST feature of FCS. /// - Import assemblies @@ -566,7 +565,7 @@ let main1OfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, outfile, pdbFile, dllReferences, noframework, exiter: Exiter, - errorLoggerProvider: DiagnosticsLoggerProvider, + diagnosticsLoggerProvider: DiagnosticsLoggerProvider, disposables: DisposablesTracker, inputs: ParsedInput list) = @@ -611,7 +610,7 @@ let main1OfAst SetTailcallSwitch tcConfigB OptionSwitch.On // Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors) - let delayForFlagsLogger = errorLoggerProvider.CreateDelayAndForwardLogger exiter + let delayForFlagsLogger = diagnosticsLoggerProvider.CreateDelayAndForwardLogger exiter let _unwindEL_1 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger) tcConfigB.conditionalDefines <- "COMPILED" :: tcConfigB.conditionalDefines @@ -628,13 +627,13 @@ let main1OfAst exiter.Exit 1 let dependencyProvider = new DependencyProvider() - let errorLogger = errorLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) + let diagnosticsLogger = diagnosticsLoggerProvider.CreateDiagnosticsLoggerUpToMaxErrors(tcConfigB, exiter) // Install the global error logger and never remove it. This logger does have all command-line flags considered. - let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let _unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) // Forward all errors from flags - delayForFlagsLogger.CommitDelayedDiagnostics errorLogger + delayForFlagsLogger.CommitDelayedDiagnostics diagnosticsLogger // Resolve assemblies ReportTime tcConfig "Import mscorlib and FSharp.Core.dll" @@ -672,16 +671,16 @@ let main1OfAst // Type check the inputs let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = - TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) + TypeCheck(ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, assemblyName, NiceNameGenerator(), tcEnv0, openDecls0, inputs, exiter) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbFile, assemblyName, errorLogger, exiter) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbFile, assemblyName, diagnosticsLogger, exiter) /// Second phase of compilation. /// - Write the signature file, check some attributes -let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu: CcuThunk, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = +let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu: CcuThunk, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, diagnosticsLogger, exiter: Exiter)) = if tcConfig.typeCheckOnly then exiter.Exit 0 @@ -690,16 +689,16 @@ let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener use unwindPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.CodeGen let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) - // Build an updated errorLogger that filters according to the scopedPragmas. Then install + // Build an updated diagnosticsLogger that filters according to the scopedPragmas. Then install // it as the updated global error logger and never remove it - let oldLogger = errorLogger - let errorLogger = - let scopedPragmas = [ for TImplFile (pragmas=pragmas) in typedImplFiles do yield! pragmas ] + let oldLogger = diagnosticsLogger + let diagnosticsLogger = + let scopedPragmas = [ for CheckedImplFile (pragmas=pragmas) in typedImplFiles do yield! pragmas ] GetDiagnosticsLoggerFilteringByScopedPragmas(true, scopedPragmas, tcConfig.diagnosticsOptions, oldLogger) - let _unwindEL_3 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> errorLogger) + let _unwindEL_3 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) // Try to find an AssemblyVersion attribute let assemVerFromAttrib = @@ -728,7 +727,7 @@ let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener XmlDocWriter.WriteXmlDocFile (tcGlobals, assemblyName, generatedCcu, xmlFile)) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, diagnosticsLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) /// Third phase of compilation. @@ -736,7 +735,7 @@ let main2(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener /// - optimize /// - encode optimization data let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, - errorLogger: DiagnosticsLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, + diagnosticsLogger: DiagnosticsLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = // Encode the signature data @@ -771,7 +770,7 @@ let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlob (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Encode the optimization data ReportTime tcConfig ("Encoding OptData") @@ -779,7 +778,7 @@ let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlob optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, + Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, sigDataAttributes, sigDataResources, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) @@ -788,7 +787,7 @@ let main3(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlob /// - IL code generation let main4 (tcImportsCapture,dynamicAssemblyCreator) - (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, + (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, diagnosticsLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, sigDataAttributes, sigDataResources, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = @@ -828,14 +827,14 @@ let main4 sigDataAttributes, sigDataResources, optDataResources, codegenResults, assemVerFromAttrib, metadataVersion, secDecls) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter) /// Fifth phase of compilation. /// - static linking -let main5(Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger: DiagnosticsLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter: Exiter)) = +let main5(Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger: DiagnosticsLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter: Exiter)) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output @@ -846,15 +845,15 @@ let main5(Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger: DiagnosticsLo errorRecoveryNoRange e exiter.Exit 1 - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, ilxMainModule, outfile, pdbfile, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, tcGlobals, diagnosticsLogger, ilxMainModule, outfile, pdbfile, signingInfo, exiter) /// Sixth phase of compilation. /// - write the binaries let main6 dynamicAssemblyCreator (Args (ctok, tcConfig, tcImports: TcImports, tcGlobals: TcGlobals, - errorLogger: DiagnosticsLogger, ilxMainModule, outfile, pdbfile, + diagnosticsLogger: DiagnosticsLogger, ilxMainModule, outfile, pdbfile, signingInfo, exiter: Exiter)) = ReportTime tcConfig "Write .NET Binary" @@ -947,7 +946,7 @@ let main6 dynamicAssemblyCreator (Args (ctok, tcConfig, tcImports: TcImports, t exiter.Exit 1 | Some da -> da (tcConfig, tcGlobals, outfile, ilxMainModule) - AbortOnError(errorLogger, exiter) + AbortOnError(diagnosticsLogger, exiter) // Don't copy referenced FSharp.core.dll if we are building FSharp.Core.dll if (tcConfig.copyFSharpCore = CopyFSharpCoreFlag.Yes) && not tcConfig.compilingFSharpCore && not tcConfig.standalone then diff --git a/src/Compiler/Driver/fsc.fsi b/src/Compiler/Driver/fsc.fsi index 8a8ba8e91bc..7ab933dc80e 100644 --- a/src/Compiler/Driver/fsc.fsi +++ b/src/Compiler/Driver/fsc.fsi @@ -32,16 +32,16 @@ type DiagnosticsLoggerUpToMaxErrors = inherit DiagnosticsLogger new: tcConfigB: TcConfigBuilder * exiter: Exiter * nameForDebugging: string -> DiagnosticsLoggerUpToMaxErrors - /// Called when an error or warning occurs + /// Called when a diagnostic occurs abstract HandleIssue: - tcConfigB: TcConfigBuilder * error: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + tcConfigB: TcConfigBuilder * diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit /// Called when 'too many errors' has occurred abstract HandleTooManyErrors: text: string -> unit override ErrorCount: int - override DiagnosticSink: phasedError: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + override DiagnosticSink: diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit /// The main (non-incremental) compilation entry point used by fsc.exe val CompileFromCommandLineArguments: diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 4dd5c16632c..a7a9b3d0ecb 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -231,11 +231,11 @@ Facilities\LanguageFeatures.fs - - Facilities\Diagnostics.fsi + + Facilities\DiagnosticOptions.fsi - - Facilities\Diagnostics.fs + + Facilities\DiagnosticOptions.fs Facilities\TextLayoutRender.fsi @@ -249,11 +249,11 @@ Facilities\DiagnosticsLogger.fs - - Facilities\ErrorResolutionHints.fsi + + Facilities\DiagnosticResolutionHints.fsi - - Facilities\ErrorResolutionHints.fs + + Facilities\DiagnosticResolutionHints.fs Facilities\prim-lexing.fsi @@ -384,16 +384,10 @@ AbstractIL\ilreflect.fs - PrettyNaming\PrettyNaming.fsi + SyntaxTree\PrettyNaming.fsi - PrettyNaming\PrettyNaming.fs - - - ILXErase\EraseClosures.fsi - - - ILXErase\EraseClosures.fs + SyntaxTree\PrettyNaming.fs --unicode --lexlib Internal.Utilities.Text.Lexing @@ -466,10 +460,10 @@ SyntaxTree\FsYaccOutput\pars.fs - SyntaxTree\lexhelp.fsi + SyntaxTree\LexHelpers.fsi - SyntaxTree\lexhelp.fs + SyntaxTree\LexHelpers.fs SyntaxTree\FsLexOutput\pplex.fs @@ -711,6 +705,12 @@ Optimize\LowerLocalMutables.fs + + CodeGen\EraseClosures.fsi + + + CodeGen\EraseClosures.fs + CodeGen\EraseUnions.fsi diff --git a/src/Compiler/Facilities/Diagnostics.fs b/src/Compiler/Facilities/DiagnosticOptions.fs similarity index 100% rename from src/Compiler/Facilities/Diagnostics.fs rename to src/Compiler/Facilities/DiagnosticOptions.fs diff --git a/src/Compiler/Facilities/Diagnostics.fsi b/src/Compiler/Facilities/DiagnosticOptions.fsi similarity index 100% rename from src/Compiler/Facilities/Diagnostics.fsi rename to src/Compiler/Facilities/DiagnosticOptions.fsi diff --git a/src/Compiler/Facilities/ErrorResolutionHints.fs b/src/Compiler/Facilities/DiagnosticResolutionHints.fs similarity index 96% rename from src/Compiler/Facilities/ErrorResolutionHints.fs rename to src/Compiler/Facilities/DiagnosticResolutionHints.fs index bd62b6bbf4b..c9c35c04cd7 100644 --- a/src/Compiler/Facilities/ErrorResolutionHints.fs +++ b/src/Compiler/Facilities/DiagnosticResolutionHints.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// Functions to format error message details -module internal FSharp.Compiler.ErrorResolutionHints +module internal FSharp.Compiler.DiagnosticResolutionHints open Internal.Utilities open Internal.Utilities.Library @@ -19,7 +19,7 @@ let minStringLengthForSuggestion = 3 /// We report a candidate if its edit distance is <= the threshold. /// The threshold is set to about a quarter of the number of characters. let IsInEditDistanceProximity idText suggestion = - let editDistance = EditDistance.CalcEditDistance(idText, suggestion) + let editDistance = EditDistance.CalculateEditDistance(idText, suggestion) let threshold = match idText.Length with | x when x < 5 -> 1 diff --git a/src/Compiler/Facilities/ErrorResolutionHints.fsi b/src/Compiler/Facilities/DiagnosticResolutionHints.fsi similarity index 92% rename from src/Compiler/Facilities/ErrorResolutionHints.fsi rename to src/Compiler/Facilities/DiagnosticResolutionHints.fsi index 5d1ee7b27d8..21418532984 100644 --- a/src/Compiler/Facilities/ErrorResolutionHints.fsi +++ b/src/Compiler/Facilities/DiagnosticResolutionHints.fsi @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// Functions to format error message details -module internal FSharp.Compiler.ErrorResolutionHints +module internal FSharp.Compiler.DiagnosticResolutionHints open System.Collections open System.Collections.Generic diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 6dd5ee7aef7..a786fa314f0 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -223,9 +223,8 @@ type PhasedDiagnostic = /// Construct a phased error static member Create(exn:exn, phase:BuildPhase) : PhasedDiagnostic = - // FUTURE: reenable this assert, which has historically triggered in some compiler service scenarios - // System.Diagnostics.Debug.Assert(phase<>BuildPhase.DefaultPhase, sprintf "Compile error seen with no phase to attribute it to.%A %s %s" phase exn.Message exn.StackTrace ) - {Exception = exn; Phase=phase} + { Exception = exn + Phase=phase} member this.DebugDisplay() = sprintf "%s: %s" (this.Subcategory()) this.Exception.Message @@ -277,18 +276,9 @@ type PhasedDiagnostic = /// Return true if this phase is one that's known to be part of the 'compile'. This is the initial phase of the entire compilation that /// the language service knows about. member pe.IsPhaseInCompile() = - let isPhaseInCompile = - match pe.Phase with - | BuildPhase.Compile | BuildPhase.Parameter | BuildPhase.Parse | BuildPhase.TypeCheck -> true - | _ -> false - // Sanity check ensures that Phase matches Subcategory -#if DEBUG - if isPhaseInCompile then - Debug.Assert(PhasedDiagnostic.IsSubcategoryOfCompile(pe.Subcategory()), "Subcategory did not match isPhaseInCompile=true") - else - Debug.Assert(not(PhasedDiagnostic.IsSubcategoryOfCompile(pe.Subcategory())), "Subcategory did not match isPhaseInCompile=false") -#endif - isPhaseInCompile + match pe.Phase with + | BuildPhase.Compile | BuildPhase.Parameter | BuildPhase.Parse | BuildPhase.TypeCheck -> true + | _ -> false [] [] @@ -297,20 +287,20 @@ type DiagnosticsLogger(nameForDebugging:string) = // The 'Impl' factoring enables a developer to place a breakpoint at the non-Impl // code just below and get a breakpoint for all error logger implementations. - abstract DiagnosticSink: phasedError: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + abstract DiagnosticSink: diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit member _.DebugDisplay() = sprintf "DiagnosticsLogger(%s)" nameForDebugging -let DiscardErrorsLogger = +let DiscardErrorsLogger = { new DiagnosticsLogger("DiscardErrorsLogger") with - member _.DiagnosticSink(phasedError, severity) = () + member _.DiagnosticSink(diagnostic, severity) = () member _.ErrorCount = 0 } let AssertFalseDiagnosticsLogger = { new DiagnosticsLogger("AssertFalseDiagnosticsLogger") with // TODO: reenable these asserts in the compiler service - member _.DiagnosticSink(phasedError, severity) = (* assert false; *) () + member _.DiagnosticSink(diagnostic, severity) = (* assert false; *) () member _.ErrorCount = (* assert false; *) 0 } @@ -319,42 +309,42 @@ type CapturingDiagnosticsLogger(nm) = let mutable errorCount = 0 let diagnostics = ResizeArray() - override _.DiagnosticSink(phasedError, severity) = + override _.DiagnosticSink(diagnostic, severity) = if severity = FSharpDiagnosticSeverity.Error then errorCount <- errorCount + 1 - diagnostics.Add (phasedError, severity) + diagnostics.Add (diagnostic, severity) override _.ErrorCount = errorCount member _.Diagnostics = diagnostics |> Seq.toList - member _.CommitDelayedDiagnostics(errorLogger:DiagnosticsLogger) = + member _.CommitDelayedDiagnostics(diagnosticsLogger:DiagnosticsLogger) = // Eagerly grab all the errors and warnings from the mutable collection let errors = diagnostics.ToArray() - errors |> Array.iter errorLogger.DiagnosticSink + errors |> Array.iter diagnosticsLogger.DiagnosticSink /// Type holds thread-static globals for use by the compile. -type internal CompileThreadStatic = +type internal DiagnosticsThreadStatics = [] static val mutable private buildPhase: BuildPhase [] - static val mutable private errorLogger: DiagnosticsLogger + static val mutable private diagnosticsLogger: DiagnosticsLogger - static member BuildPhaseUnchecked = CompileThreadStatic.buildPhase + static member BuildPhaseUnchecked = DiagnosticsThreadStatics.buildPhase static member BuildPhase with get() = - match box CompileThreadStatic.buildPhase with + match box DiagnosticsThreadStatics.buildPhase with | Null -> BuildPhase.DefaultPhase - | _ -> CompileThreadStatic.buildPhase - and set v = CompileThreadStatic.buildPhase <- v + | _ -> DiagnosticsThreadStatics.buildPhase + and set v = DiagnosticsThreadStatics.buildPhase <- v static member DiagnosticsLogger with get() = - match box CompileThreadStatic.errorLogger with + match box DiagnosticsThreadStatics.diagnosticsLogger with | Null -> AssertFalseDiagnosticsLogger - | _ -> CompileThreadStatic.errorLogger - and set v = CompileThreadStatic.errorLogger <- v + | _ -> DiagnosticsThreadStatics.diagnosticsLogger + and set v = DiagnosticsThreadStatics.diagnosticsLogger <- v [] @@ -407,7 +397,7 @@ module DiagnosticsLoggerExtensions = | ReportedError _ -> PreserveStackTrace exn raise exn - | _ -> x.DiagnosticSink(PhasedDiagnostic.Create(exn, CompileThreadStatic.BuildPhase), severity) + | _ -> x.DiagnosticSink(PhasedDiagnostic.Create(exn, DiagnosticsThreadStatics.BuildPhase), severity) member x.ErrorR exn = x.EmitDiagnostic (exn, FSharpDiagnosticSeverity.Error) @@ -418,19 +408,19 @@ module DiagnosticsLoggerExtensions = member x.InformationalWarning exn = x.EmitDiagnostic (exn, FSharpDiagnosticSeverity.Info) - member x.Error exn = + member x.Error exn = x.ErrorR exn raise (ReportedError (Some exn)) - member x.SimulateError (ph: PhasedDiagnostic) = - x.DiagnosticSink (ph, FSharpDiagnosticSeverity.Error) - raise (ReportedError (Some ph.Exception)) + member x.SimulateError diagnostic = + x.DiagnosticSink (diagnostic, FSharpDiagnosticSeverity.Error) + raise (ReportedError (Some diagnostic.Exception)) member x.ErrorRecovery (exn: exn) (m: range) = // Never throws ReportedError. // Throws StopProcessing and exceptions raised by the DiagnosticSink(exn) handler. match exn with - (* Don't send ThreadAbortException down the error channel *) + // Don't send ThreadAbortException down the error channel | :? System.Threading.ThreadAbortException | WrappedError(:? System.Threading.ThreadAbortException, _) -> () | ReportedError _ | WrappedError(ReportedError _, _) -> () | StopProcessing | WrappedError(StopProcessing, _) -> @@ -462,31 +452,31 @@ module DiagnosticsLoggerExtensions = /// NOTE: The change will be undone when the returned "unwind" object disposes let PushThreadBuildPhaseUntilUnwind (phase:BuildPhase) = - let oldBuildPhase = CompileThreadStatic.BuildPhaseUnchecked - CompileThreadStatic.BuildPhase <- phase + let oldBuildPhase = DiagnosticsThreadStatics.BuildPhaseUnchecked + DiagnosticsThreadStatics.BuildPhase <- phase { new IDisposable with - member x.Dispose() = CompileThreadStatic.BuildPhase <- oldBuildPhase } + member x.Dispose() = DiagnosticsThreadStatics.BuildPhase <- oldBuildPhase } /// NOTE: The change will be undone when the returned "unwind" object disposes -let PushDiagnosticsLoggerPhaseUntilUnwind(errorLoggerTransformer: DiagnosticsLogger -> #DiagnosticsLogger) = - let oldDiagnosticsLogger = CompileThreadStatic.DiagnosticsLogger - CompileThreadStatic.DiagnosticsLogger <- errorLoggerTransformer oldDiagnosticsLogger +let PushDiagnosticsLoggerPhaseUntilUnwind(diagnosticsLoggerTransformer: DiagnosticsLogger -> #DiagnosticsLogger) = + let oldDiagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLoggerTransformer oldDiagnosticsLogger { new IDisposable with member _.Dispose() = - CompileThreadStatic.DiagnosticsLogger <- oldDiagnosticsLogger } + DiagnosticsThreadStatics.DiagnosticsLogger <- oldDiagnosticsLogger } -let SetThreadBuildPhaseNoUnwind(phase:BuildPhase) = CompileThreadStatic.BuildPhase <- phase +let SetThreadBuildPhaseNoUnwind(phase:BuildPhase) = DiagnosticsThreadStatics.BuildPhase <- phase -let SetThreadDiagnosticsLoggerNoUnwind errorLogger = CompileThreadStatic.DiagnosticsLogger <- errorLogger +let SetThreadDiagnosticsLoggerNoUnwind diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger /// This represents the thread-local state established as each task function runs as part of the build. /// /// Use to reset error and warning handlers. -type CompilationGlobalsScope(errorLogger: DiagnosticsLogger, buildPhase: BuildPhase) = - let unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> errorLogger) +type CompilationGlobalsScope(diagnosticsLogger: DiagnosticsLogger, buildPhase: BuildPhase) = + let unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) let unwindBP = PushThreadBuildPhaseUntilUnwind buildPhase - member _.DiagnosticsLogger = errorLogger + member _.DiagnosticsLogger = diagnosticsLogger member _.BuildPhase = buildPhase // Return the disposable object that cleans up @@ -498,31 +488,32 @@ type CompilationGlobalsScope(errorLogger: DiagnosticsLogger, buildPhase: BuildPh // Global functions are still used by parser and TAST ops. /// Raises an exception with error recovery and returns unit. -let errorR exn = CompileThreadStatic.DiagnosticsLogger.ErrorR exn +let errorR exn = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorR exn /// Raises a warning with error recovery and returns unit. -let warning exn = CompileThreadStatic.DiagnosticsLogger.Warning exn +let warning exn = DiagnosticsThreadStatics.DiagnosticsLogger.Warning exn /// Raises a warning with error recovery and returns unit. -let informationalWarning exn = CompileThreadStatic.DiagnosticsLogger.InformationalWarning exn +let informationalWarning exn = DiagnosticsThreadStatics.DiagnosticsLogger.InformationalWarning exn /// Raises a special exception and returns 'T - can be caught later at an errorRecovery point. -let error exn = CompileThreadStatic.DiagnosticsLogger.Error exn +let error exn = DiagnosticsThreadStatics.DiagnosticsLogger.Error exn /// Simulates an error. For test purposes only. -let simulateError (p : PhasedDiagnostic) = CompileThreadStatic.DiagnosticsLogger.SimulateError p +let simulateError (diagnostic : PhasedDiagnostic) = + DiagnosticsThreadStatics.DiagnosticsLogger.SimulateError diagnostic -let diagnosticSink (phasedError, severity) = CompileThreadStatic.DiagnosticsLogger.DiagnosticSink (phasedError, severity) +let diagnosticSink (diagnostic, severity) = DiagnosticsThreadStatics.DiagnosticsLogger.DiagnosticSink (diagnostic, severity) -let errorSink pe = diagnosticSink (pe, FSharpDiagnosticSeverity.Error) +let errorSink diagnostic = diagnosticSink (diagnostic, FSharpDiagnosticSeverity.Error) -let warnSink pe = diagnosticSink (pe, FSharpDiagnosticSeverity.Warning) +let warnSink diagnostic = diagnosticSink (diagnostic, FSharpDiagnosticSeverity.Warning) -let errorRecovery exn m = CompileThreadStatic.DiagnosticsLogger.ErrorRecovery exn m +let errorRecovery exn m = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorRecovery exn m -let stopProcessingRecovery exn m = CompileThreadStatic.DiagnosticsLogger.StopProcessingRecovery exn m +let stopProcessingRecovery exn m = DiagnosticsThreadStatics.DiagnosticsLogger.StopProcessingRecovery exn m -let errorRecoveryNoRange exn = CompileThreadStatic.DiagnosticsLogger.ErrorRecoveryNoRange exn +let errorRecoveryNoRange exn = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorRecoveryNoRange exn let report f = f() @@ -540,16 +531,16 @@ let mlCompatWarning s m = warning(UserCompilerMessage(FSComp.SR.mlCompatMessage let mlCompatError s m = errorR(UserCompilerMessage(FSComp.SR.mlCompatError s, 62, m)) let suppressErrorReporting f = - let errorLogger = CompileThreadStatic.DiagnosticsLogger + let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger try - let errorLogger = + let diagnosticsLogger = { new DiagnosticsLogger("suppressErrorReporting") with member _.DiagnosticSink(_phasedError, _isError) = () member _.ErrorCount = 0 } - SetThreadDiagnosticsLoggerNoUnwind errorLogger + SetThreadDiagnosticsLoggerNoUnwind diagnosticsLogger f() finally - SetThreadDiagnosticsLoggerNoUnwind errorLogger + SetThreadDiagnosticsLoggerNoUnwind diagnosticsLogger let conditionallySuppressErrorReporting cond f = if cond then suppressErrorReporting f else f() @@ -559,8 +550,8 @@ let conditionallySuppressErrorReporting cond f = if cond then suppressErrorRepor /// The result type of a computational modality to colelct warnings and possibly fail [] type OperationResult<'T> = - | OkResult of warnings: exn list * 'T - | ErrorResult of warnings: exn list * exn + | OkResult of warnings: exn list * result: 'T + | ErrorResult of warnings: exn list * error: exn type ImperativeOperationResult = OperationResult @@ -720,7 +711,7 @@ let internal checkLanguageFeatureError langVersion langFeature m = | Some e -> error e | None -> () -let internal checkLanguageFeatureErrorRecover langVersion langFeature m = +let internal checkLanguageFeatureAndRecover langVersion langFeature m = match tryLanguageFeatureErrorAux langVersion langFeature m with | Some e -> errorR e | None -> () @@ -742,12 +733,12 @@ type StackGuard(maxDepth: int) = depth <- depth + 1 try if depth % maxDepth = 0 then - let errorLogger = CompileThreadStatic.DiagnosticsLogger - let buildPhase = CompileThreadStatic.BuildPhase + let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger + let buildPhase = DiagnosticsThreadStatics.BuildPhase async { do! Async.SwitchToNewThread() Thread.CurrentThread.Name <- "F# Extra Compilation Thread" - use _scope = new CompilationGlobalsScope(errorLogger, buildPhase) + use _scope = new CompilationGlobalsScope(diagnosticsLogger, buildPhase) return f() } |> Async.RunImmediate else diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index b003fac96dd..170c04baa06 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -77,11 +77,11 @@ exception DiagnosticWithSuggestions of /// Creates a DiagnosticWithSuggestions whose text comes via SR.* val ErrorWithSuggestions: (int * string) * range * string * Suggestions -> exn -val inline protectAssemblyExploration: dflt: 'a -> f: (unit -> 'a) -> 'a +val inline protectAssemblyExploration: dflt: 'T -> f: (unit -> 'T) -> 'T -val inline protectAssemblyExplorationF: dflt: (string * string -> 'a) -> f: (unit -> 'a) -> 'a +val inline protectAssemblyExplorationF: dflt: (string * string -> 'T) -> f: (unit -> 'T) -> 'T -val inline protectAssemblyExplorationNoReraise: dflt1: 'a -> dflt2: 'a -> f: (unit -> 'a) -> 'a +val inline protectAssemblyExplorationNoReraise: dflt1: 'T -> dflt2: 'T -> f: (unit -> 'T) -> 'T val AttachRange: m: range -> exn: exn -> exn @@ -173,7 +173,7 @@ type DiagnosticsLogger = member DebugDisplay: unit -> string - abstract member DiagnosticSink: phasedError: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + abstract member DiagnosticSink: diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit abstract member ErrorCount: int @@ -186,16 +186,16 @@ type CapturingDiagnosticsLogger = new: nm: string -> CapturingDiagnosticsLogger - member CommitDelayedDiagnostics: errorLogger: DiagnosticsLogger -> unit + member CommitDelayedDiagnostics: diagnosticsLogger: DiagnosticsLogger -> unit - override DiagnosticSink: phasedError: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit + override DiagnosticSink: diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit member Diagnostics: (PhasedDiagnostic * FSharpDiagnosticSeverity) list override ErrorCount: int [] -type CompileThreadStatic = +type DiagnosticsThreadStatics = static member BuildPhase: BuildPhase with get, set @@ -209,7 +209,7 @@ module DiagnosticsLoggerExtensions = val tryAndDetectDev15: bool /// Instruct the exception not to reset itself when thrown again. - val PreserveStackTrace: exn: 'a -> unit + val PreserveStackTrace: exn: 'T -> unit /// Reraise an exception if it is one we want to report to Watson. val ReraiseIfWatsonable: exn: exn -> unit @@ -220,9 +220,9 @@ module DiagnosticsLoggerExtensions = member Warning: exn: exn -> unit - member Error: exn: exn -> 'b + member Error: exn: exn -> 'T - member SimulateError: ph: PhasedDiagnostic -> 'a + member SimulateError: diagnostic: PhasedDiagnostic -> 'T member ErrorRecovery: exn: exn -> m: range -> unit @@ -235,11 +235,11 @@ val PushThreadBuildPhaseUntilUnwind: phase: BuildPhase -> IDisposable /// NOTE: The change will be undone when the returned "unwind" object disposes val PushDiagnosticsLoggerPhaseUntilUnwind: - errorLoggerTransformer: (DiagnosticsLogger -> #DiagnosticsLogger) -> IDisposable + diagnosticsLoggerTransformer: (DiagnosticsLogger -> #DiagnosticsLogger) -> IDisposable val SetThreadBuildPhaseNoUnwind: phase: BuildPhase -> unit -val SetThreadDiagnosticsLoggerNoUnwind: errorLogger: DiagnosticsLogger -> unit +val SetThreadDiagnosticsLoggerNoUnwind: diagnosticsLogger: DiagnosticsLogger -> unit /// Reports an error diagnostic and continues val errorR: exn: exn -> unit @@ -248,18 +248,18 @@ val errorR: exn: exn -> unit val warning: exn: exn -> unit /// Reports an error and raises a ReportedError exception -val error: exn: exn -> 'a +val error: exn: exn -> 'T /// Reports an informational diagnostic val informationalWarning: exn: exn -> unit -val simulateError: p: PhasedDiagnostic -> 'a +val simulateError: diagnostic: PhasedDiagnostic -> 'T -val diagnosticSink: phasedError: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit +val diagnosticSink: diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity -> unit -val errorSink: pe: PhasedDiagnostic -> unit +val errorSink: diagnostic: PhasedDiagnostic -> unit -val warnSink: pe: PhasedDiagnostic -> unit +val warnSink: diagnostic: PhasedDiagnostic -> unit val errorRecovery: exn: exn -> m: range -> unit @@ -267,7 +267,7 @@ val stopProcessingRecovery: exn: exn -> m: range -> unit val errorRecoveryNoRange: exn: exn -> unit -val report: f: (unit -> 'a) -> 'a +val report: f: (unit -> 'T) -> 'T val deprecatedWithError: s: string -> m: range -> unit @@ -281,42 +281,42 @@ val mlCompatWarning: s: string -> m: range -> unit val mlCompatError: s: string -> m: range -> unit -val suppressErrorReporting: f: (unit -> 'a) -> 'a +val suppressErrorReporting: f: (unit -> 'T) -> 'T -val conditionallySuppressErrorReporting: cond: bool -> f: (unit -> 'a) -> 'a +val conditionallySuppressErrorReporting: cond: bool -> f: (unit -> 'T) -> 'T -/// The result type of a computational modality to colelct warnings and possibly fail +/// The result type of a computational modality to collect warnings and possibly fail [] type OperationResult<'T> = - | OkResult of warnings: exn list * 'T - | ErrorResult of warnings: exn list * exn + | OkResult of warnings: exn list * result: 'T + | ErrorResult of warnings: exn list * error: exn type ImperativeOperationResult = OperationResult val ReportWarnings: warns: #exn list -> unit -val CommitOperationResult: res: OperationResult<'a> -> 'a +val CommitOperationResult: res: OperationResult<'T> -> 'T val RaiseOperationResult: res: OperationResult -> unit -val ErrorD: err: exn -> OperationResult<'a> +val ErrorD: err: exn -> OperationResult<'T> val WarnD: err: exn -> OperationResult val CompleteD: OperationResult -val ResultD: x: 'a -> OperationResult<'a> +val ResultD: x: 'T -> OperationResult<'T> -val CheckNoErrorsAndGetWarnings: res: OperationResult<'a> -> (exn list * 'a) option +val CheckNoErrorsAndGetWarnings: res: OperationResult<'T> -> (exn list * 'T) option -val (++): res: OperationResult<'a> -> f: ('a -> OperationResult<'b>) -> OperationResult<'b> +val (++): res: OperationResult<'T> -> f: ('T -> OperationResult<'b>) -> OperationResult<'b> /// Stop on first error. Accumulate warnings and continue. -val IterateD: f: ('a -> OperationResult) -> xs: 'a list -> OperationResult +val IterateD: f: ('T -> OperationResult) -> xs: 'T list -> OperationResult val WhileD: gd: (unit -> bool) -> body: (unit -> OperationResult) -> OperationResult -val MapD: f: ('a -> OperationResult<'b>) -> xs: 'a list -> OperationResult<'b list> +val MapD: f: ('T -> OperationResult<'b>) -> xs: 'T list -> OperationResult<'b list> type TrackErrorsBuilder = @@ -334,7 +334,7 @@ type TrackErrorsBuilder = member ReturnFrom: res: 'f -> 'f - member Run: fn: (unit -> 'a) -> 'a + member Run: fn: (unit -> 'T) -> 'T member While: gd: (unit -> bool) * k: (unit -> OperationResult) -> OperationResult @@ -342,34 +342,34 @@ type TrackErrorsBuilder = val trackErrors: TrackErrorsBuilder -val OptionD: f: ('a -> OperationResult) -> xs: 'a option -> OperationResult +val OptionD: f: ('T -> OperationResult) -> xs: 'T option -> OperationResult -val IterateIdxD: f: (int -> 'a -> OperationResult) -> xs: 'a list -> OperationResult +val IterateIdxD: f: (int -> 'T -> OperationResult) -> xs: 'T list -> OperationResult /// Stop on first error. Accumulate warnings and continue. -val Iterate2D: f: ('a -> 'b -> OperationResult) -> xs: 'a list -> ys: 'b list -> OperationResult +val Iterate2D: f: ('T -> 'b -> OperationResult) -> xs: 'T list -> ys: 'b list -> OperationResult -val TryD: f: (unit -> OperationResult<'a>) -> g: (exn -> OperationResult<'a>) -> OperationResult<'a> +val TryD: f: (unit -> OperationResult<'T>) -> g: (exn -> OperationResult<'T>) -> OperationResult<'T> val RepeatWhileD: nDeep: int -> body: (int -> OperationResult) -> OperationResult -val inline AtLeastOneD: f: ('a -> OperationResult) -> l: 'a list -> OperationResult +val inline AtLeastOneD: f: ('T -> OperationResult) -> l: 'T list -> OperationResult -val inline AtLeastOne2D: f: ('a -> 'b -> OperationResult) -> xs: 'a list -> ys: 'b list -> OperationResult +val inline AtLeastOne2D: f: ('T -> 'b -> OperationResult) -> xs: 'T list -> ys: 'b list -> OperationResult val inline MapReduceD: - mapper: ('a -> OperationResult<'b>) -> zero: 'b -> reducer: ('b -> 'b -> 'b) -> l: 'a list -> OperationResult<'b> + mapper: ('T -> OperationResult<'b>) -> zero: 'b -> reducer: ('b -> 'b -> 'b) -> l: 'T list -> OperationResult<'b> val inline MapReduce2D: - mapper: ('a -> 'b -> OperationResult<'c>) -> + mapper: ('T -> 'T2 -> OperationResult<'c>) -> zero: 'c -> reducer: ('c -> 'c -> 'c) -> - xs: 'a list -> - ys: 'b list -> + xs: 'T list -> + ys: 'T2 list -> OperationResult<'c> module OperationResult = - val inline ignore: res: OperationResult<'a> -> OperationResult + val inline ignore: res: OperationResult<'T> -> OperationResult // For --flaterrors flag that is only used by the IDE val stringThatIsAProxyForANewlineInFlatErrors: String @@ -383,13 +383,13 @@ val NormalizeErrorString: text: string -> string val checkLanguageFeatureError: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> unit -val checkLanguageFeatureErrorRecover: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> unit +val checkLanguageFeatureAndRecover: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> unit val tryLanguageFeatureErrorOption: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> exn option val languageFeatureNotSupportedInLibraryError: - langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> 'a + langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> 'T type StackGuard = new: maxDepth: int -> StackGuard @@ -403,7 +403,7 @@ type StackGuard = /// /// Use to reset error and warning handlers. type CompilationGlobalsScope = - new: errorLogger: DiagnosticsLogger * buildPhase: BuildPhase -> CompilationGlobalsScope + new: diagnosticsLogger: DiagnosticsLogger * buildPhase: BuildPhase -> CompilationGlobalsScope interface IDisposable diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index 287868b11eb..e95e6f10804 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -58,10 +58,10 @@ type LanguageVersion = member SupportsFeature: LanguageFeature -> bool /// Get the list of valid versions - member ValidVersions: string array + member ValidVersions: string [] /// Get the list of valid options - member ValidOptions: string array + member ValidOptions: string [] /// Get the specified LanguageVersion member SpecifiedVersion: decimal diff --git a/src/Compiler/Facilities/prim-lexing.fs b/src/Compiler/Facilities/prim-lexing.fs index be5740f14d2..b78054ddc92 100644 --- a/src/Compiler/Facilities/prim-lexing.fs +++ b/src/Compiler/Facilities/prim-lexing.fs @@ -255,7 +255,7 @@ namespace Internal.Utilities.Text.Lexing member _.SupportsFeature featureId = langVersion.SupportsFeature featureId member _.CheckLanguageFeatureErrorRecover featureId range = - FSharp.Compiler.DiagnosticsLogger.checkLanguageFeatureErrorRecover langVersion featureId range + FSharp.Compiler.DiagnosticsLogger.checkLanguageFeatureAndRecover langVersion featureId range static member FromFunction (reportLibraryOnlyFeatures, langVersion, f : 'Char[] * int * int -> int) : LexBuffer<'Char> = let extension= Array.zeroCreate 4096 diff --git a/src/Compiler/Facilities/prim-parsing.fs b/src/Compiler/Facilities/prim-parsing.fs index 22609926079..59243a98a3f 100644 --- a/src/Compiler/Facilities/prim-parsing.fs +++ b/src/Compiler/Facilities/prim-parsing.fs @@ -14,55 +14,61 @@ exception Accept of obj [] type internal IParseState(ruleStartPoss:Position[], ruleEndPoss:Position[], lhsPos:Position[], ruleValues:obj[], lexbuf:LexBuffer) = - member p.LexBuffer = lexbuf + member _.LexBuffer = lexbuf - member p.InputRange index = ruleStartPoss[index-1], ruleEndPoss[index-1] + member _.InputRange index = ruleStartPoss[index-1], ruleEndPoss[index-1] - member p.InputStartPosition index = ruleStartPoss[index-1] + member _.InputStartPosition index = ruleStartPoss[index-1] - member p.InputEndPosition index = ruleEndPoss[index-1] + member _.InputEndPosition index = ruleEndPoss[index-1] - member p.ResultStartPosition = lhsPos[0] + member _.ResultStartPosition = lhsPos[0] - member p.ResultEndPosition = lhsPos[1] + member _.ResultEndPosition = lhsPos[1] - member p.GetInput index = ruleValues[index-1] + member _.GetInput index = ruleValues[index-1] - member p.ResultRange = (lhsPos[0], lhsPos[1]) + member _.ResultRange = (lhsPos[0], lhsPos[1]) // Side note: this definition coincidentally tests the fairly complex logic associated with an object expression implementing a generic abstract method. - member p.RaiseError() = raise RecoverableParseError - + member _.RaiseError() = raise RecoverableParseError /// This context is passed to the error reporter when a syntax error occurs [] -type internal ParseErrorContext<'tok> +type internal ParseErrorContext<'Token> (//lexbuf: LexBuffer<_>, stateStack:int list, - parseState: IParseState, - reduceTokens: int list, - currentToken: 'tok option, + parseState: IParseState, + reduceTokens: int list, + currentToken: 'Token option, reducibleProductions: int list list, - shiftableTokens: int list , + shiftableTokens: int list, message : string) = - //member x.LexBuffer = lexbuf - member x.StateStack = stateStack - member x.ReduceTokens = reduceTokens - member x.CurrentToken = currentToken - member x.ParseState = parseState - member x.ReducibleProductions = reducibleProductions - member x.ShiftTokens = shiftableTokens - member x.Message = message + //member _.LexBuffer = lexbuf + + member _.StateStack = stateStack + + member _.ReduceTokens = reduceTokens + + member _.CurrentToken = currentToken + + member _.ParseState = parseState + + member _.ReducibleProductions = reducibleProductions + + member _.ShiftTokens = shiftableTokens + + member _.Message = message //------------------------------------------------------------------------- // This is the data structure emitted as code by FSYACC. -type internal Tables<'tok> = +type internal Tables<'Token> = { reductions: (IParseState -> obj)[] endOfInputTag: int - tagOfToken: 'tok -> int - dataOfToken: 'tok -> obj + tagOfToken: 'Token -> int + dataOfToken: 'Token -> obj actionTableElements: uint16[] actionTableRowOffsets: uint16[] reductionSymbolCounts: uint16[] @@ -72,10 +78,11 @@ type internal Tables<'tok> = stateToProdIdxsTableElements: uint16[] stateToProdIdxsTableRowOffsets: uint16[] productionToNonTerminalTable: uint16[] - /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function - /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened + + /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function + /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened /// at the top of the generated parser file) - parseError: ParseErrorContext<'tok> -> unit + parseError: ParseErrorContext<'Token> -> unit numTerminals: int tagOfErrorTerminal: int } @@ -85,7 +92,7 @@ type internal Tables<'tok> = // This type is in System.dll so for the moment we can't use it in FSharp.Core.dll // type Stack<'a> = System.Collections.Generic.Stack<'a> -type Stack<'a>(n) = +type Stack<'a>(n) = let mutable contents = Array.zeroCreate<'a>(n) let mutable count = 0 @@ -173,7 +180,7 @@ module internal Implementation = // Read all entries in the association table // Used during error recovery to find all valid entries in the table - member x.ReadAll(n) = + member _.ReadAll(n) = let headOfTable = int offsetTab[n] let firstElemNumber = headOfTable + 1 let numberOfElementsInAssoc = int32 elemTab[headOfTable*2] @@ -184,7 +191,7 @@ module internal Implementation = type IdxToIdxListTable(elemTab:uint16[], offsetTab:uint16[]) = // Read all entries in a row of the table - member x.ReadAll(n) = + member _.ReadAll(n) = let headOfTable = int offsetTab[n] let firstElemNumber = headOfTable + 1 let numberOfElements = int32 elemTab[headOfTable] @@ -201,7 +208,7 @@ module internal Implementation = val endPos: Position new(value,startPos,endPos) = { value=value; startPos=startPos;endPos=endPos } - let interpret (tables: Tables<'tok>) lexer (lexbuf : LexBuffer<_>) initialState = + let interpret (tables: Tables<'Token>) lexer (lexbuf : LexBuffer<_>) initialState = #if DEBUG if Flags.debug then Console.WriteLine("\nParser: interpret tables") #endif @@ -209,7 +216,7 @@ module internal Implementation = stateStack.Push(initialState) let valueStack = Stack(100) let mutable haveLookahead = false - let mutable lookaheadToken = Unchecked.defaultof<'tok> + let mutable lookaheadToken = Unchecked.defaultof<'Token> let mutable lookaheadEndPos = Unchecked.defaultof let mutable lookaheadStartPos = Unchecked.defaultof let mutable finished = false @@ -227,9 +234,9 @@ module internal Implementation = let mutable eofCountDown = 20 // Number of EOFs to supply at the end for error recovery // The 100 here means a maximum of 100 elements for each rule let ruleStartPoss = (Array.zeroCreate 100 : Position[]) - let ruleEndPoss = (Array.zeroCreate 100 : Position[]) - let ruleValues = (Array.zeroCreate 100 : obj[]) - let lhsPos = (Array.zeroCreate 2 : Position[]) + let ruleEndPoss = (Array.zeroCreate 100 : Position[]) + let ruleValues = (Array.zeroCreate 100 : obj[]) + let lhsPos = (Array.zeroCreate 2 : Position[]) let reductions = tables.reductions let cacheSize = 7919 // the 1000'th prime // Use a simpler hash table with faster lookup, but only one @@ -479,7 +486,7 @@ module internal Implementation = if not (explicit.Contains(tag)) then yield tag ] in //let activeRules = stateStack |> List.iter (fun state -> - let errorContext = new ParseErrorContext<'tok>(stateStack, parseState, reduceTokens, currentToken, reducibleProductions, shiftableTokens, "syntax error") + let errorContext = new ParseErrorContext<'Token>(stateStack, parseState, reduceTokens, currentToken, reducibleProductions, shiftableTokens, "syntax error") tables.parseError(errorContext) popStackUntilErrorShifted(None) errorSuppressionCountDown <- 3 @@ -497,7 +504,7 @@ module internal Implementation = // OK, we're done - read off the overall generated value valueStack.Peep().value -type internal Tables<'tok> with +type internal Tables<'Token> with member tables.Interpret (lexer, lexbuf, initialState) = Implementation.interpret tables lexer lexbuf initialState diff --git a/src/Compiler/Facilities/prim-parsing.fsi b/src/Compiler/Facilities/prim-parsing.fsi index e34181709e8..50ebcc95029 100644 --- a/src/Compiler/Facilities/prim-parsing.fsi +++ b/src/Compiler/Facilities/prim-parsing.fsi @@ -39,7 +39,7 @@ type internal IParseState = /// The context provided when a parse error occurs. [] -type internal ParseErrorContext<'tok> = +type internal ParseErrorContext<'Token> = /// The stack of state indexes active at the parse error . member StateStack : int list @@ -53,7 +53,7 @@ type internal ParseErrorContext<'tok> = member ReducibleProductions : int list list /// The token that caused the parse error. - member CurrentToken : 'tok option + member CurrentToken : 'Token option /// The token that would cause a shift at the parse error. member ShiftTokens : int list @@ -63,7 +63,7 @@ type internal ParseErrorContext<'tok> = /// Tables generated by fsyacc /// The type of the tables contained in a file produced by the fsyacc.exe parser generator. -type internal Tables<'tok> = +type internal Tables<'Token> = { /// The reduction table. reductions: (IParseState -> obj)[] @@ -72,10 +72,10 @@ type internal Tables<'tok> = endOfInputTag: int /// A function to compute the tag of a token. - tagOfToken: 'tok -> int + tagOfToken: 'Token -> int /// A function to compute the data carried by a token. - dataOfToken: 'tok -> obj + dataOfToken: 'Token -> obj /// The sparse action table elements. actionTableElements: uint16[] @@ -105,7 +105,7 @@ type internal Tables<'tok> = productionToNonTerminalTable: uint16[] /// This function is used to hold the user specified "parse_error" or "parse_error_rich" functions. - parseError: ParseErrorContext<'tok> -> unit + parseError: ParseErrorContext<'Token> -> unit /// The total number of terminals. numTerminals: int @@ -115,7 +115,7 @@ type internal Tables<'tok> = /// Interpret the parser table taking input from the given lexer, using the given lex buffer, and the given start state. /// Returns an object indicating the final synthesized value for the parse. - member Interpret : lexer:(LexBuffer -> 'tok) * lexbuf:LexBuffer * initialState:int -> obj + member Interpret : lexer:(LexBuffer -> 'Token) * lexbuf:LexBuffer * initialState:int -> obj /// Indicates an accept action has occurred. exception internal Accept of obj @@ -132,7 +132,7 @@ module internal Flags = module internal ParseHelpers = /// The default implementation of the parse_error_rich function. - val parse_error_rich: (ParseErrorContext<'tok> -> unit) option + val parse_error_rich: (ParseErrorContext<'Token> -> unit) option /// The default implementation of the parse_error function. val parse_error: string -> unit diff --git a/src/Compiler/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index 52bdb119f83..70e56990e98 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -1089,9 +1089,9 @@ let internal SetCurrentUICultureForThread (lcid : int option) = // Reporting - warnings, errors //---------------------------------------------------------------------------- -let internal InstallErrorLoggingOnThisThread errorLogger = +let internal InstallErrorLoggingOnThisThread diagnosticsLogger = if progress then dprintfn "Installing logger on id=%d name=%s" Thread.CurrentThread.ManagedThreadId Thread.CurrentThread.Name - SetThreadDiagnosticsLoggerNoUnwind(errorLogger) + SetThreadDiagnosticsLoggerNoUnwind(diagnosticsLogger) SetThreadBuildPhaseNoUnwind(BuildPhase.Interactive) /// Set the input/output encoding. The use of a thread is due to a known bug on @@ -1303,20 +1303,21 @@ let internal mkBoundValueTypedImpl tcGlobals m moduleName name ty = let vis = Accessibility.TAccess([]) let compPath = (CompilationPath.CompPath(ILScopeRef.Local, [])) let mutable mty = Unchecked.defaultof<_> - let moduleOrNamespace = Construct.NewModuleOrNamespace (Some compPath) vis (Ident(moduleName, m)) XmlDoc.Empty [] (MaybeLazy.Lazy(lazy mty)) + let entity = Construct.NewModuleOrNamespace (Some compPath) vis (Ident(moduleName, m)) XmlDoc.Empty [] (MaybeLazy.Lazy(lazy mty)) let v = Construct.NewVal (name, m, None, ty, ValMutability.Immutable, false, Some(ValReprInfo([], [], { Attribs = []; Name = None })), vis, ValNotInRecScope, None, NormalVal, [], ValInline.Optional, XmlDoc.Empty, true, false, false, false, - false, false, None, Parent(TypedTreeBasics.ERefLocal moduleOrNamespace)) + false, false, None, Parent(TypedTreeBasics.ERefLocal entity)) mty <- ModuleOrNamespaceType(ModuleOrNamespaceKind.ModuleOrType, QueueList.one v, QueueList.empty) let bindExpr = mkCallDefaultOf tcGlobals range0 ty let binding = Binding.TBind(v, bindExpr, DebugPointAtBinding.NoneAtLet) - let mbinding = ModuleOrNamespaceBinding.Module(moduleOrNamespace, TMDefs([TMDefLet(binding, m)])) - let mexpr = ModuleOrNamespaceContentsWithSig(mty, TMDefs([TMDefs[TMDefRec(false, [], [], [mbinding], m)]]), range0) - moduleOrNamespace, v, TypedImplFile.TImplFile(QualifiedNameOfFile.QualifiedNameOfFile(Ident(moduleName, m)), [], mexpr, false, false, StampMap.Empty, Map.empty) + let mbinding = ModuleOrNamespaceBinding.Module(entity, TMDefs([TMDefLet(binding, m)])) + let contents = TMDefs([TMDefs[TMDefRec(false, [], [], [mbinding], m)]]) + let qname = QualifiedNameOfFile.QualifiedNameOfFile(Ident(moduleName, m)) + entity, v, CheckedImplFile.CheckedImplFile(qname, [], mty, contents, false, false, StampMap.Empty, Map.empty) /// Encapsulates the coordination of the typechecking, optimization and code generation /// components of the F# compiler for interactively executed fragments of code. @@ -1496,7 +1497,7 @@ type internal FsiDynamicCompiler( execs // Emit the codegen results using the assembly writer - let ProcessCodegenResults (ctok, errorLogger: DiagnosticsLogger, istate, optEnv, tcState: TcState, tcConfig, prefixPath, showTypes: bool, isIncrementalFragment, fragName, declaredImpls, ilxGenerator: IlxAssemblyGenerator, codegenResults, m) = + let ProcessCodegenResults (ctok, diagnosticsLogger: DiagnosticsLogger, istate, optEnv, tcState: TcState, tcConfig, prefixPath, showTypes: bool, isIncrementalFragment, fragName, declaredImpls, ilxGenerator: IlxAssemblyGenerator, codegenResults, m) = let emEnv = istate.emEnv // Each input is like a small separately compiled extension to a single source file. @@ -1506,16 +1507,16 @@ type internal FsiDynamicCompiler( ilxGenerator.AddIncrementalLocalAssemblyFragment (isIncrementalFragment, fragName, declaredImpls) ReportTime tcConfig "TAST -> ILX" - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) ReportTime tcConfig "Linking" let ilxMainModule = CreateModuleFragment (tcConfigB, dynamicCcuName, codegenResults) - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) ReportTime tcConfig "Assembly refs Normalised" let ilxMainModule = Morphs.morphILScopeRefsInILModuleMemoized (NormalizeAssemblyRefs (ctok, ilGlobals, tcImports)) ilxMainModule - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) #if DEBUG if fsiOptions.ShowILCode then @@ -1544,7 +1545,7 @@ type internal FsiDynamicCompiler( MultipleInMemoryAssemblies emEnv, execs - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) // Explicitly register the resources with the QuotationPickler module match emEnv with @@ -1575,17 +1576,17 @@ type internal FsiDynamicCompiler( execs |> List.iter (fun exec -> match exec() with | Some err -> - match errorLogger with - | :? DiagnosticsLoggerThatStopsOnFirstError as errorLogger -> + match diagnosticsLogger with + | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> fprintfn fsiConsoleOutput.Error "%s" (err.ToString()) - errorLogger.SetError() - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.SetError() + diagnosticsLogger.AbortOnError(fsiConsoleOutput) | _ -> raise (StopProcessingExn (Some err)) | None -> ())) - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) // Echo the decls (reach inside wrapping) // This code occurs AFTER the execution of the declarations. @@ -1604,8 +1605,8 @@ type internal FsiDynamicCompiler( // 'Open' the path for the fragment we just compiled for any future printing. let denv = denv.AddOpenPath (pathOfLid prefixPath) - for TImplFile (implExprWithSig=mexpr) in declaredImpls do - let responseL = NicePrint.layoutInferredSigOfModuleExpr false denv infoReader AccessibleFromSomewhere m mexpr + for CheckedImplFile (contents=mexpr) in declaredImpls do + let responseL = NicePrint.layoutImpliedSignatureOfModuleOrNamespace false denv infoReader AccessibleFromSomewhere m mexpr if not (isEmptyL responseL) then let opts = valuePrinter.GetFsiPrintOptions() colorPrintL outWriter opts responseL @@ -1621,7 +1622,7 @@ type internal FsiDynamicCompiler( // Return the new state and the environment at the end of the last input, ready for further inputs. (istate,declaredImpls) - let ProcessTypedImpl (errorLogger: DiagnosticsLogger, optEnv, tcState: TcState, tcConfig: TcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator: IlxAssemblyGenerator) = + let ProcessTypedImpl (diagnosticsLogger: DiagnosticsLogger, optEnv, tcState: TcState, tcConfig: TcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator: IlxAssemblyGenerator) = #if DEBUG // Logging/debugging if tcConfig.printAst then @@ -1630,20 +1631,20 @@ type internal FsiDynamicCompiler( fprintfn fsiConsoleOutput.Out "%+A" input #endif - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) let importMap = tcImports.GetImportMap() // optimize: note we collect the incremental optimization environment let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, LightweightTcValForUsingInBuildMethodCall tcGlobals, outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls) - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) let fragName = textOfLid prefixPath let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) codegenResults, optEnv, fragName - let ProcessInputs (ctok, errorLogger: DiagnosticsLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent, m) = + let ProcessInputs (ctok, diagnosticsLogger: DiagnosticsLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent, m) = let optEnv = istate.optEnv let tcState = istate.tcState let ilxGenerator = istate.ilxGenerator @@ -1652,11 +1653,11 @@ type internal FsiDynamicCompiler( // Typecheck. The lock stops the type checker running at the same time as the // server intellisense implementation (which is currently incomplete and #if disabled) let tcState, topCustomAttrs, declaredImpls, tcEnvAtEndOfLastInput = - lock tcLockObject (fun _ -> CheckClosedInputSet(ctok, errorLogger.CheckForErrors, tcConfig, tcImports, tcGlobals, Some prefixPath, tcState, inputs)) + lock tcLockObject (fun _ -> CheckClosedInputSet(ctok, diagnosticsLogger.CheckForErrors, tcConfig, tcImports, tcGlobals, Some prefixPath, tcState, inputs)) - let codegenResults, optEnv, fragName = ProcessTypedImpl(errorLogger, optEnv, tcState, tcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator) + let codegenResults, optEnv, fragName = ProcessTypedImpl(diagnosticsLogger, optEnv, tcState, tcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator) - let newState, declaredImpls = ProcessCodegenResults(ctok, errorLogger, istate, optEnv, tcState, tcConfig, prefixPath, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) + let newState, declaredImpls = ProcessCodegenResults(ctok, diagnosticsLogger, istate, optEnv, tcState, tcConfig, prefixPath, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) (newState, tcEnvAtEndOfLastInput, declaredImpls) @@ -1791,17 +1792,17 @@ type internal FsiDynamicCompiler( member _.FindDynamicAssembly(simpleAssemName) = dynamicAssemblies |> ResizeArray.tryFind (fun asm -> asm.GetName().Name = simpleAssemName) - member _.EvalParsedSourceFiles (ctok, errorLogger, istate, inputs, m) = + member _.EvalParsedSourceFiles (ctok, diagnosticsLogger, istate, inputs, m) = let i = nextFragmentId() let prefix = mkFragmentPath m i // Ensure the path includes the qualifying name let inputs = inputs |> List.map (PrependPathToInput prefix) let isIncrementalFragment = false - let istate,_,_ = ProcessInputs (ctok, errorLogger, istate, inputs, true, isIncrementalFragment, false, prefix, m) + let istate,_,_ = ProcessInputs (ctok, diagnosticsLogger, istate, inputs, true, isIncrementalFragment, false, prefix, m) istate /// Evaluate the given definitions and produce a new interactive state. - member _.EvalParsedDefinitions (ctok, errorLogger: DiagnosticsLogger, istate, showTypes, isInteractiveItExpr, defs: SynModuleDecl list) = + member _.EvalParsedDefinitions (ctok, diagnosticsLogger: DiagnosticsLogger, istate, showTypes, isInteractiveItExpr, defs: SynModuleDecl list) = let fileName = stdinMockFileName let i = nextFragmentId() let m = match defs with [] -> rangeStdin0 | _ -> List.reduce unionRanges [for d in defs -> d.Range] @@ -1812,13 +1813,13 @@ type internal FsiDynamicCompiler( let isExe = false let input = ParsedInput.ImplFile (ParsedImplFileInput (fileName,true, ComputeQualifiedNameOfFileFromUniquePath (m,prefixPath),[],[],[impl],(isLastCompiland, isExe), { ConditionalDirectives = []; CodeComments = [] })) let isIncrementalFragment = true - let istate,tcEnvAtEndOfLastInput,declaredImpls = ProcessInputs (ctok, errorLogger, istate, [input], showTypes, isIncrementalFragment, isInteractiveItExpr, prefix, m) + let istate,tcEnvAtEndOfLastInput,declaredImpls = ProcessInputs (ctok, diagnosticsLogger, istate, [input], showTypes, isIncrementalFragment, isInteractiveItExpr, prefix, m) let tcState = istate.tcState let newState = { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) } processContents newState declaredImpls /// Evaluate the given expression and produce a new interactive state. - member fsiDynamicCompiler.EvalParsedExpression (ctok, errorLogger: DiagnosticsLogger, istate, expr: SynExpr) = + member fsiDynamicCompiler.EvalParsedExpression (ctok, diagnosticsLogger: DiagnosticsLogger, istate, expr: SynExpr) = let tcConfig = TcConfig.Create (tcConfigB, validate=false) let itName = "it" @@ -1826,7 +1827,7 @@ type internal FsiDynamicCompiler( let defs = fsiDynamicCompiler.BuildItBinding expr // Evaluate the overall definitions. - let istate = fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, false, true, defs) |> fst + let istate = fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, false, true, defs) |> fst // Snarf the type for 'it' via the binding match istate.tcState.TcEnvFromImpls.NameEnv.FindUnqualifiedItem itName with | Item.Value vref -> @@ -1890,7 +1891,7 @@ type internal FsiDynamicCompiler( tcConfigB.packageManagerLines <- PackageManagerLine.AddLineWithKey packageManager.Key lt path m tcConfigB.packageManagerLines needsPackageResolution <- true - member fsiDynamicCompiler.CommitDependencyManagerText (ctok, istate: FsiDynamicCompilerState, lexResourceManager, errorLogger) = + member fsiDynamicCompiler.CommitDependencyManagerText (ctok, istate: FsiDynamicCompilerState, lexResourceManager, diagnosticsLogger) = if not needsPackageResolution then istate else needsPackageResolution <- false @@ -1935,7 +1936,7 @@ type internal FsiDynamicCompiler( let scripts = result.SourceFiles |> Seq.toList if not (isNil scripts) then - fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, scripts, lexResourceManager, errorLogger) + fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, scripts, lexResourceManager, diagnosticsLogger) else istate else // Send outputs via diagnostics @@ -1986,7 +1987,7 @@ type internal FsiDynamicCompiler( (fun _ _ -> ())) (tcConfigB, inp, Path.GetDirectoryName sourceFile, istate)) - member fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, sourceFiles, lexResourceManager, errorLogger: DiagnosticsLogger) = + member fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, sourceFiles, lexResourceManager, diagnosticsLogger: DiagnosticsLogger) = let tcConfig = TcConfig.Create(tcConfigB,validate=false) match sourceFiles with | [] -> istate @@ -2026,14 +2027,14 @@ type internal FsiDynamicCompiler( input.MetaCommandDiagnostics |> List.iter diagnosticSink let parsedInput = match input.SyntaxTree with - | None -> ParseOneInputFile(tcConfig, lexResourceManager, input.FileName, (true, false), errorLogger, (*retryLocked*)false) + | None -> ParseOneInputFile(tcConfig, lexResourceManager, input.FileName, (true, false), diagnosticsLogger, (*retryLocked*)false) | Some parseTree -> parseTree input.FileName, parsedInput) |> List.unzip - errorLogger.AbortOnError(fsiConsoleOutput); + diagnosticsLogger.AbortOnError(fsiConsoleOutput); let istate = (istate, sourceFiles, inputs) |||> List.fold2 (fun istate sourceFile input -> fsiDynamicCompiler.ProcessMetaCommandsFromInputAsInteractiveCommands(ctok, istate, sourceFile, input)) - fsiDynamicCompiler.EvalParsedSourceFiles (ctok, errorLogger, istate, inputs, m) + fsiDynamicCompiler.EvalParsedSourceFiles (ctok, diagnosticsLogger, istate, inputs, m) member _.GetBoundValues istate = let cenv = SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) @@ -2058,7 +2059,7 @@ type internal FsiDynamicCompiler( | _ -> None - member _.AddBoundValue (ctok, errorLogger: DiagnosticsLogger, istate, name: string, value: obj) = + member _.AddBoundValue (ctok, diagnosticsLogger: DiagnosticsLogger, istate, name: string, value: obj) = try match value with | null -> nullArg "value" @@ -2091,9 +2092,9 @@ type internal FsiDynamicCompiler( let tcConfig = TcConfig.Create(tcConfigB,validate=false) // Build a simple module with a single 'let' decl with a default value. - let moduleOrNamespace, v, impl = mkBoundValueTypedImpl istate.tcGlobals range0 qualifiedName.Text name ty + let moduleEntity, v, impl = mkBoundValueTypedImpl istate.tcGlobals range0 qualifiedName.Text name ty let tcEnvAtEndOfLastInput = - AddLocalSubModule tcGlobals amap range0 istate.tcState.TcEnvFromImpls moduleOrNamespace + AddLocalSubModule tcGlobals amap range0 istate.tcState.TcEnvFromImpls moduleEntity |> AddLocalVal tcGlobals TcResultsSink.NoSink range0 v // Generate IL for the given typled impl and create new interactive state. @@ -2101,8 +2102,8 @@ type internal FsiDynamicCompiler( let isIncrementalFragment = true let showTypes = false let declaredImpls = [impl] - let codegenResults, optEnv, fragName = ProcessTypedImpl(errorLogger, istate.optEnv, istate.tcState, tcConfig, false, EmptyTopAttrs, prefix, isIncrementalFragment, declaredImpls, ilxGenerator) - let istate, declaredImpls = ProcessCodegenResults(ctok, errorLogger, istate, optEnv, istate.tcState, tcConfig, prefix, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) + let codegenResults, optEnv, fragName = ProcessTypedImpl(diagnosticsLogger, istate.optEnv, istate.tcState, tcConfig, false, EmptyTopAttrs, prefix, isIncrementalFragment, declaredImpls, ilxGenerator) + let istate, declaredImpls = ProcessCodegenResults(ctok, diagnosticsLogger, istate, optEnv, istate.tcState, tcConfig, prefix, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) let newState = { istate with tcState = istate.tcState.NextStateAfterIncrementalFragment tcEnvAtEndOfLastInput } // Force set the val with the given value obj. @@ -2439,9 +2440,9 @@ type FsiStdinLexerProvider ) = // #light is the default for FSI - let lightStatus = + let indentationSyntaxStatus = let initialIndentationAwareSyntaxStatus = (tcConfigB.indentationAwareSyntax <> Some false) - IndentationAwareSyntaxStatus (initialIndentationAwareSyntaxStatus, false (* no warnings *)) + IndentationAwareSyntaxStatus (initialIndentationAwareSyntaxStatus, warn=false) let LexbufFromLineReader (fsiStdinSyphon: FsiStdinSyphon) readF = UnicodeLexing.FunctionAsLexbuf @@ -2450,40 +2451,44 @@ type FsiStdinLexerProvider let inputOption = try Some(readF()) with :? EndOfStreamException -> None inputOption |> Option.iter (fun t -> fsiStdinSyphon.Add (t + "\n")) match inputOption with - | Some(null) | None -> + | Some null | None -> if progress then fprintfn fsiConsoleOutput.Out "End of file from TextReader.ReadLine" 0 - | Some (input:string) -> + | Some (input: string) -> let input = input + "\n" - let ninput = input.Length - if ninput > len then fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiLineTooLong()) - let ntrimmed = min len ninput - for i = 0 to ntrimmed-1 do + + if input.Length > len then + fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiLineTooLong()) + + let numTrimmed = min len input.Length + + for i = 0 to numTrimmed-1 do buf[i+start] <- input[i] - ntrimmed + + numTrimmed )) //---------------------------------------------------------------------------- // Reading stdin as a lex stream //---------------------------------------------------------------------------- - let removeZeroCharsFromString (str:string) = (* bug:/4466 *) - if str<>null && str.Contains("\000") then + let removeZeroCharsFromString (str:string) = + if str <> null && str.Contains("\000") then String(str |> Seq.filter (fun c -> c<>'\000') |> Seq.toArray) else str - let CreateLexerForLexBuffer (sourceFileName, lexbuf, errorLogger) = + let CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) = resetLexbufPos sourceFileName lexbuf let skip = true // don't report whitespace from lexer let defines = tcConfigB.conditionalDefines - let lexargs = mkLexargs (defines, lightStatus, lexResourceManager, [], errorLogger, PathMap.empty) - let tokenizer = LexFilter.LexFilter(lightStatus, tcConfigB.compilingFSharpCore, Lexer.token lexargs skip, lexbuf) + let lexargs = mkLexargs (defines, indentationSyntaxStatus, lexResourceManager, [], diagnosticsLogger, PathMap.empty) + let tokenizer = LexFilter.LexFilter(indentationSyntaxStatus, tcConfigB.compilingFSharpCore, Lexer.token lexargs skip, lexbuf) tokenizer // Create a new lexer to read stdin - member _.CreateStdinLexer errorLogger = + member _.CreateStdinLexer diagnosticsLogger = let lexbuf = match fsiConsoleInput.TryGetConsole() with | Some console when fsiOptions.EnableConsoleKeyProcessing && not fsiOptions.UseServerPrompt -> @@ -2495,21 +2500,22 @@ type FsiStdinLexerProvider LexbufFromLineReader fsiStdinSyphon (fun () -> fsiConsoleInput.In.ReadLine() |> removeZeroCharsFromString) fsiStdinSyphon.Reset() - CreateLexerForLexBuffer (stdinMockFileName, lexbuf, errorLogger) + CreateLexerForLexBuffer (stdinMockFileName, lexbuf, diagnosticsLogger) // Create a new lexer to read an "included" script file - member _.CreateIncludedScriptLexer (sourceFileName, reader, errorLogger) = + member _.CreateIncludedScriptLexer (sourceFileName, reader, diagnosticsLogger) = let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(true, tcConfigB.langVersion, reader) - CreateLexerForLexBuffer (sourceFileName, lexbuf, errorLogger) + CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) // Create a new lexer to read a string - member _.CreateStringLexer (sourceFileName, source, errorLogger) = + member _.CreateStringLexer (sourceFileName, source, diagnosticsLogger) = let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, source) - CreateLexerForLexBuffer (sourceFileName, lexbuf, errorLogger) + CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) member _.ConsoleInput = fsiConsoleInput - member _.CreateBufferLexer (sourceFileName, lexbuf, errorLogger) = CreateLexerForLexBuffer (sourceFileName, lexbuf, errorLogger) + member _.CreateBufferLexer (sourceFileName, lexbuf, diagnosticsLogger) = + CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) //---------------------------------------------------------------------------- @@ -2537,7 +2543,7 @@ type FsiInteractionProcessor let event = Control.Event() let setCurrState s = currState <- s; event.Trigger() - let runCodeOnEventLoop errorLogger f istate = + let runCodeOnEventLoop diagnosticsLogger f istate = try fsi.EventLoopInvoke (fun () -> @@ -2546,17 +2552,17 @@ type FsiInteractionProcessor let ctok = AssumeCompilationThreadWithoutEvidence() // FSI error logging on switched to thread - InstallErrorLoggingOnThisThread errorLogger + InstallErrorLoggingOnThisThread diagnosticsLogger use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID f ctok istate) with _ -> (istate,Completed None) - let InteractiveCatch (errorLogger: DiagnosticsLogger) (f:_ -> _ * FsiInteractionStepStatus) istate = + let InteractiveCatch (diagnosticsLogger: DiagnosticsLogger) (f:_ -> _ * FsiInteractionStepStatus) istate = try // reset error count - match errorLogger with - | :? DiagnosticsLoggerThatStopsOnFirstError as errorLogger -> errorLogger.ResetErrorCount() + match diagnosticsLogger with + | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> diagnosticsLogger.ResetErrorCount() | _ -> () f istate @@ -2603,7 +2609,7 @@ type FsiInteractionProcessor None /// Execute a single parsed interaction. Called on the GUI/execute/main thread. - let ExecInteraction (ctok, tcConfig:TcConfig, istate, action:ParsedScriptInteraction, errorLogger: DiagnosticsLogger) = + let ExecInteraction (ctok, tcConfig:TcConfig, istate, action:ParsedScriptInteraction, diagnosticsLogger: DiagnosticsLogger) = let packageManagerDirective directive path m = let dm = fsiOptions.DependencyProvider.TryFindDependencyManagerInPath(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m, path) match dm with @@ -2646,23 +2652,23 @@ type FsiInteractionProcessor fsiConsoleOutput.uprintnfnn "%s" format) istate,Completed None - istate |> InteractiveCatch errorLogger (fun istate -> + istate |> InteractiveCatch diagnosticsLogger (fun istate -> match action with | ParsedScriptInteraction.Definitions ([], _) -> - let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, errorLogger) + let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) istate,Completed None | ParsedScriptInteraction.Definitions ([SynModuleDecl.Expr(expr, _)], _) -> - let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, errorLogger) - fsiDynamicCompiler.EvalParsedExpression(ctok, errorLogger, istate, expr) + let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger, istate, expr) | ParsedScriptInteraction.Definitions (defs,_) -> - let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, errorLogger) - fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, true, false, defs) + let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, true, false, defs) | ParsedScriptInteraction.HashDirective (ParsedHashDirective("load", ParsedHashDirectiveArguments sourceFiles, m), _) -> - let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, errorLogger) - fsiDynamicCompiler.EvalSourceFiles (ctok, istate, m, sourceFiles, lexResourceManager, errorLogger),Completed None + let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + fsiDynamicCompiler.EvalSourceFiles (ctok, istate, m, sourceFiles, lexResourceManager, diagnosticsLogger),Completed None | ParsedScriptInteraction.HashDirective (ParsedHashDirective(("reference" | "r"), ParsedHashDirectiveArguments [path], m), _) -> packageManagerDirective Directive.Resolution path m @@ -2743,7 +2749,7 @@ type FsiInteractionProcessor /// /// #directive comes through with other definitions as a SynModuleDecl.HashDirective. /// We split these out for individual processing. - let rec execParsedInteractions (ctok, tcConfig, istate, action, errorLogger: DiagnosticsLogger, lastResult: FsiInteractionStepStatus option, cancellationToken: CancellationToken) = + let rec execParsedInteractions (ctok, tcConfig, istate, action, diagnosticsLogger: DiagnosticsLogger, lastResult: FsiInteractionStepStatus option, cancellationToken: CancellationToken) = cancellationToken.ThrowIfCancellationRequested() let action,nextAction,istate = match action with @@ -2796,9 +2802,9 @@ type FsiInteractionProcessor | None, Some prev -> assert nextAction.IsNone; istate, prev | None,_ -> assert nextAction.IsNone; istate, Completed None | Some action, _ -> - let istate,cont = ExecInteraction (ctok, tcConfig, istate, action, errorLogger) + let istate,cont = ExecInteraction (ctok, tcConfig, istate, action, diagnosticsLogger) match cont with - | Completed _ -> execParsedInteractions (ctok, tcConfig, istate, nextAction, errorLogger, Some cont, cancellationToken) + | Completed _ -> execParsedInteractions (ctok, tcConfig, istate, nextAction, diagnosticsLogger, Some cont, cancellationToken) | CompletedWithReportedError e -> istate,CompletedWithReportedError e (* drop nextAction on error *) | CompletedWithAlreadyReportedError -> istate,CompletedWithAlreadyReportedError (* drop nextAction on error *) | EndOfFile -> istate,defaultArg lastResult (Completed None) (* drop nextAction on EOF *) @@ -2806,11 +2812,11 @@ type FsiInteractionProcessor /// Execute a single parsed interaction which may contain multiple items to be executed /// independently - let executeParsedInteractions (ctok, tcConfig, istate, action, errorLogger: DiagnosticsLogger, lastResult: FsiInteractionStepStatus option, cancellationToken: CancellationToken) = - let istate, completed = execParsedInteractions (ctok, tcConfig, istate, action, errorLogger, lastResult, cancellationToken) + let executeParsedInteractions (ctok, tcConfig, istate, action, diagnosticsLogger: DiagnosticsLogger, lastResult: FsiInteractionStepStatus option, cancellationToken: CancellationToken) = + let istate, completed = execParsedInteractions (ctok, tcConfig, istate, action, diagnosticsLogger, lastResult, cancellationToken) match completed with | Completed _ -> - let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, errorLogger) + let istate = fsiDynamicCompiler.CommitDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) istate, completed | _ -> istate, completed @@ -2836,18 +2842,18 @@ type FsiInteractionProcessor stopProcessingRecovery e range0; istate, CompletedWithReportedError e - let mainThreadProcessParsedInteractions ctok errorLogger (action, istate) cancellationToken = + let mainThreadProcessParsedInteractions ctok diagnosticsLogger (action, istate) cancellationToken = istate |> mainThreadProcessAction ctok (fun ctok tcConfig istate -> - executeParsedInteractions (ctok, tcConfig, istate, action, errorLogger, None, cancellationToken)) + executeParsedInteractions (ctok, tcConfig, istate, action, diagnosticsLogger, None, cancellationToken)) let parseExpression (tokenizer:LexFilter.LexFilter) = reusingLexbufForParsing tokenizer.LexBuffer (fun () -> Parser.typedSequentialExprEOF (fun _ -> tokenizer.GetToken()) tokenizer.LexBuffer) - let mainThreadProcessParsedExpression ctok errorLogger (expr, istate) = - istate |> InteractiveCatch errorLogger (fun istate -> + let mainThreadProcessParsedExpression ctok diagnosticsLogger (expr, istate) = + istate |> InteractiveCatch diagnosticsLogger (fun istate -> istate |> mainThreadProcessAction ctok (fun ctok _tcConfig istate -> - fsiDynamicCompiler.EvalParsedExpression(ctok, errorLogger, istate, expr) )) + fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger, istate, expr) )) let commitResult (istate, result) = match result with @@ -2872,7 +2878,7 @@ type FsiInteractionProcessor /// During processing of startup scripts, this runs on the main thread. /// /// This is blocking: it reads until one chunk of input have been received, unless IsPastEndOfStream is true - member _.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnMainThread, istate:FsiDynamicCompilerState, tokenizer:LexFilter.LexFilter, errorLogger, ?cancellationToken: CancellationToken) = + member _.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnMainThread, istate:FsiDynamicCompilerState, tokenizer:LexFilter.LexFilter, diagnosticsLogger, ?cancellationToken: CancellationToken) = let cancellationToken = defaultArg cancellationToken CancellationToken.None if tokenizer.LexBuffer.IsPastEndOfStream then let stepStatus = @@ -2886,7 +2892,7 @@ type FsiInteractionProcessor else fsiConsolePrompt.Print(); - istate |> InteractiveCatch errorLogger (fun istate -> + istate |> InteractiveCatch diagnosticsLogger (fun istate -> if progress then fprintfn fsiConsoleOutput.Out "entering ParseInteraction..."; // Parse the interaction. When FSI.EXE is waiting for input from the console the @@ -2897,7 +2903,7 @@ type FsiInteractionProcessor // After we've unblocked and got something to run we switch // over to the run-thread (e.g. the GUI thread) - let res = istate |> runCodeOnMainThread (fun ctok istate -> mainThreadProcessParsedInteractions ctok errorLogger (action, istate) cancellationToken) + let res = istate |> runCodeOnMainThread (fun ctok istate -> mainThreadProcessParsedInteractions ctok diagnosticsLogger (action, istate) cancellationToken) if progress then fprintfn fsiConsoleOutput.Out "Just called runCodeOnMainThread, res = %O..." res; res) @@ -2905,7 +2911,7 @@ type FsiInteractionProcessor member _.CurrentState = currState /// Perform an "include" on a script file (i.e. a script file specified on the command line) - member processor.EvalIncludedScript (ctok, istate, sourceFile, m, errorLogger) = + member processor.EvalIncludedScript (ctok, istate, sourceFile, m, diagnosticsLogger) = let tcConfig = TcConfig.Create(tcConfigB, validate=false) // Resolve the file name to an absolute file name let sourceFile = tcConfig.ResolveSourceFile(m, sourceFile, tcConfig.implicitIncludeDir) @@ -2918,9 +2924,9 @@ type FsiInteractionProcessor use fileStream = FileSystem.OpenFileForReadShim(sourceFile) use reader = fileStream.GetReader(tcConfigB.inputCodePage, false) - let tokenizer = fsiStdinLexerProvider.CreateIncludedScriptLexer (sourceFile, reader, errorLogger) + let tokenizer = fsiStdinLexerProvider.CreateIncludedScriptLexer (sourceFile, reader, diagnosticsLogger) let rec run istate = - let istate,cont = processor.ParseAndExecOneSetOfInteractionsFromLexbuf ((fun f istate -> f ctok istate), istate, tokenizer, errorLogger) + let istate,cont = processor.ParseAndExecOneSetOfInteractionsFromLexbuf ((fun f istate -> f ctok istate), istate, tokenizer, diagnosticsLogger) match cont with Completed _ -> run istate | _ -> istate,cont let istate,cont = run istate @@ -2935,21 +2941,21 @@ type FsiInteractionProcessor /// Load the source files, one by one. Called on the main thread. - member processor.EvalIncludedScripts (ctok, istate, sourceFiles, errorLogger) = + member processor.EvalIncludedScripts (ctok, istate, sourceFiles, diagnosticsLogger) = match sourceFiles with | [] -> istate | sourceFile :: moreSourceFiles -> // Catch errors on a per-file basis, so results/bindings from pre-error files can be kept. - let istate,cont = InteractiveCatch errorLogger (fun istate -> processor.EvalIncludedScript (ctok, istate, sourceFile, rangeStdin0, errorLogger)) istate + let istate,cont = InteractiveCatch diagnosticsLogger (fun istate -> processor.EvalIncludedScript (ctok, istate, sourceFile, rangeStdin0, diagnosticsLogger)) istate match cont with - | Completed _ -> processor.EvalIncludedScripts (ctok, istate, moreSourceFiles, errorLogger) + | Completed _ -> processor.EvalIncludedScripts (ctok, istate, moreSourceFiles, diagnosticsLogger) | CompletedWithAlreadyReportedError -> istate // do not process any more files | CompletedWithReportedError _ -> istate // do not process any more files | CtrlC -> istate // do not process any more files | EndOfFile -> assert false; istate // This is unexpected. EndOfFile is replaced by Completed in the called function - member processor.LoadInitialFiles (ctok, errorLogger) = + member processor.LoadInitialFiles (ctok, diagnosticsLogger) = /// Consume initial source files in chunks of scripts or non-scripts let rec consume istate sourceFiles = match sourceFiles with @@ -2959,9 +2965,9 @@ type FsiInteractionProcessor let sourceFiles = List.map fst sourceFiles let istate = if isScript1 then - processor.EvalIncludedScripts (ctok, istate, sourceFiles, errorLogger) + processor.EvalIncludedScripts (ctok, istate, sourceFiles, diagnosticsLogger) else - istate |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalSourceFiles(ctok, istate, rangeStdin0, sourceFiles, lexResourceManager, errorLogger), Completed None) |> fst + istate |> InteractiveCatch diagnosticsLogger (fun istate -> fsiDynamicCompiler.EvalSourceFiles(ctok, istate, rangeStdin0, sourceFiles, lexResourceManager, diagnosticsLogger), Completed None) |> fst consume istate rest setCurrState (consume currState fsiOptions.SourceFiles) @@ -2971,46 +2977,46 @@ type FsiInteractionProcessor /// Send a dummy interaction through F# Interactive, to ensure all the most common code generation paths are /// JIT'ed and ready for use. - member _.LoadDummyInteraction(ctok, errorLogger) = - setCurrState (currState |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, true, false, []) |> fst, Completed None) |> fst) + member _.LoadDummyInteraction(ctok, diagnosticsLogger) = + setCurrState (currState |> InteractiveCatch diagnosticsLogger (fun istate -> fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, true, false, []) |> fst, Completed None) |> fst) - member _.EvalInteraction(ctok, sourceText, scriptFileName, errorLogger, ?cancellationToken) = + member _.EvalInteraction(ctok, sourceText, scriptFileName, diagnosticsLogger, ?cancellationToken) = let cancellationToken = defaultArg cancellationToken CancellationToken.None use _unwind1 = PushThreadBuildPhaseUntilUnwind(BuildPhase.Interactive) - use _unwind2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> errorLogger) + use _unwind2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, sourceText) - let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, errorLogger) + let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) currState - |> InteractiveCatch errorLogger (fun istate -> + |> InteractiveCatch diagnosticsLogger (fun istate -> let expr = ParseInteraction tokenizer - mainThreadProcessParsedInteractions ctok errorLogger (expr, istate) cancellationToken) + mainThreadProcessParsedInteractions ctok diagnosticsLogger (expr, istate) cancellationToken) |> commitResult - member this.EvalScript (ctok, scriptPath, errorLogger) = + member this.EvalScript (ctok, scriptPath, diagnosticsLogger) = // Todo: this runs the script as expected but errors are displayed one line to far in debugger let sourceText = sprintf "#load @\"%s\" " scriptPath - this.EvalInteraction (ctok, sourceText, scriptPath, errorLogger) + this.EvalInteraction (ctok, sourceText, scriptPath, diagnosticsLogger) - member _.EvalExpression (ctok, sourceText, scriptFileName, errorLogger) = + member _.EvalExpression (ctok, sourceText, scriptFileName, diagnosticsLogger) = use _unwind1 = PushThreadBuildPhaseUntilUnwind(BuildPhase.Interactive) - use _unwind2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> errorLogger) + use _unwind2 = PushDiagnosticsLoggerPhaseUntilUnwind(fun _ -> diagnosticsLogger) use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, sourceText) - let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, errorLogger) + let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) currState - |> InteractiveCatch errorLogger (fun istate -> + |> InteractiveCatch diagnosticsLogger (fun istate -> let expr = parseExpression tokenizer let m = expr.Range // Make this into "(); expr" to suppress generalization and compilation-as-function let exprWithSeq = SynExpr.Sequential (DebugPointAtSequential.SuppressExpr, true, SynExpr.Const (SynConst.Unit,m.StartRange), expr, m) - mainThreadProcessParsedExpression ctok errorLogger (exprWithSeq, istate)) + mainThreadProcessParsedExpression ctok diagnosticsLogger (exprWithSeq, istate)) |> commitResult - member _.AddBoundValue(ctok, errorLogger, name, value: obj) = + member _.AddBoundValue(ctok, diagnosticsLogger, name, value: obj) = currState - |> InteractiveCatch errorLogger (fun istate -> - fsiDynamicCompiler.AddBoundValue(ctok, errorLogger, istate, name, value)) + |> InteractiveCatch diagnosticsLogger (fun istate -> + fsiDynamicCompiler.AddBoundValue(ctok, diagnosticsLogger, istate, name, value)) |> commitResult member _.PartialAssemblySignatureUpdated = event.Publish @@ -3023,17 +3029,17 @@ type FsiInteractionProcessor // mainForm.Invoke to pipe a message back through the form's main event loop. (The message // is a delegate to execute on the main Thread) // - member processor.StartStdinReadAndProcessThread errorLogger = + member processor.StartStdinReadAndProcessThread diagnosticsLogger = if progress then fprintfn fsiConsoleOutput.Out "creating stdinReaderThread"; let stdinReaderThread = Thread(ThreadStart(fun () -> - InstallErrorLoggingOnThisThread errorLogger // FSI error logging on stdinReaderThread, e.g. parse errors. + InstallErrorLoggingOnThisThread diagnosticsLogger // FSI error logging on stdinReaderThread, e.g. parse errors. use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID try try - let initialTokenizer = fsiStdinLexerProvider.CreateStdinLexer(errorLogger) + let initialTokenizer = fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger) if progress then fprintfn fsiConsoleOutput.Out "READER: stdin thread started..."; // Delay until we've peeked the input or read the entire first line @@ -3041,19 +3047,19 @@ type FsiInteractionProcessor if progress then fprintfn fsiConsoleOutput.Out "READER: stdin thread got first line..."; - let runCodeOnMainThread = runCodeOnEventLoop errorLogger + let runCodeOnMainThread = runCodeOnEventLoop diagnosticsLogger // Keep going until EndOfFile on the inReader or console let rec loop currTokenizer = let istateNew,contNew = - processor.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnMainThread, currState, currTokenizer, errorLogger) + processor.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnMainThread, currState, currTokenizer, diagnosticsLogger) setCurrState istateNew match contNew with | EndOfFile -> () - | CtrlC -> loop (fsiStdinLexerProvider.CreateStdinLexer(errorLogger)) // After each interrupt, restart to a brand new tokenizer + | CtrlC -> loop (fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger)) // After each interrupt, restart to a brand new tokenizer | CompletedWithAlreadyReportedError | CompletedWithReportedError _ | Completed _ -> loop currTokenizer @@ -3253,9 +3259,9 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let fsiStdinSyphon = FsiStdinSyphon(errorWriter) let fsiConsoleOutput = FsiConsoleOutput(tcConfigB, outWriter, errorWriter) - let errorLogger = DiagnosticsLoggerThatStopsOnFirstError(tcConfigB, fsiStdinSyphon, fsiConsoleOutput) + let diagnosticsLogger = DiagnosticsLoggerThatStopsOnFirstError(tcConfigB, fsiStdinSyphon, fsiConsoleOutput) - do InstallErrorLoggingOnThisThread errorLogger // FSI error logging on main thread. + do InstallErrorLoggingOnThisThread diagnosticsLogger // FSI error logging on main thread. let updateBannerText() = tcConfigB.productNameForBannerText <- FSIstrings.SR.fsiProductName(FSharpBannerVersion) @@ -3368,8 +3374,8 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i | Choice2Of2 None -> raise (FsiCompilationException(FSIstrings.SR.fsiOperationFailed(), None)) | Choice2Of2 (Some userExn) -> raise (makeNestedException userExn) - let commitResultNonThrowing errorOptions scriptFile (errorLogger: CompilationDiagnosticLogger) res = - let errs = errorLogger.GetDiagnostics() + let commitResultNonThrowing errorOptions scriptFile (diagnosticsLogger: CompilationDiagnosticLogger) res = + let errs = diagnosticsLogger.GetDiagnostics() let errorInfos = DiagnosticHelpers.CreateDiagnostics (errorOptions, true, scriptFile, errs, true) let userRes = match res with @@ -3424,9 +3430,9 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i fsi.EventLoopInvoke ( fun () -> fprintfn fsiConsoleOutput.Error "%s" (exn.ToString()) - errorLogger.SetError() + diagnosticsLogger.SetError() try - errorLogger.AbortOnError(fsiConsoleOutput) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) with StopProcessing -> // BUG 664864 some window that use System.Windows.Forms.DataVisualization types (possible FSCharts) was created in FSI. // at some moment one chart has raised InvalidArgumentException from OnPaint, this exception was intercepted by the code in higher layer and @@ -3495,7 +3501,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() - fsiInteractionProcessor.EvalExpression(ctok, code, dummyScriptFileName, errorLogger) + fsiInteractionProcessor.EvalExpression(ctok, code, dummyScriptFileName, diagnosticsLogger) |> commitResult member _.EvalExpressionNonThrowing(code) = @@ -3505,9 +3511,9 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let ctok = AssumeCompilationThreadWithoutEvidence() let errorOptions = TcConfig.Create(tcConfigB,validate = false).diagnosticsOptions - let errorLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) - fsiInteractionProcessor.EvalExpression(ctok, code, dummyScriptFileName, errorLogger) - |> commitResultNonThrowing errorOptions dummyScriptFileName errorLogger + let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) + fsiInteractionProcessor.EvalExpression(ctok, code, dummyScriptFileName, diagnosticsLogger) + |> commitResultNonThrowing errorOptions dummyScriptFileName diagnosticsLogger member _.EvalInteraction(code, ?cancellationToken) : unit = // Explanation: When the user of the FsiInteractiveSession object calls this method, the @@ -3515,7 +3521,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() let cancellationToken = defaultArg cancellationToken CancellationToken.None - fsiInteractionProcessor.EvalInteraction(ctok, code, dummyScriptFileName, errorLogger, cancellationToken) + fsiInteractionProcessor.EvalInteraction(ctok, code, dummyScriptFileName, diagnosticsLogger, cancellationToken) |> commitResult |> ignore @@ -3527,9 +3533,9 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let cancellationToken = defaultArg cancellationToken CancellationToken.None let errorOptions = TcConfig.Create(tcConfigB,validate = false).diagnosticsOptions - let errorLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) - fsiInteractionProcessor.EvalInteraction(ctok, code, dummyScriptFileName, errorLogger, cancellationToken) - |> commitResultNonThrowing errorOptions "input.fsx" errorLogger + let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) + fsiInteractionProcessor.EvalInteraction(ctok, code, dummyScriptFileName, diagnosticsLogger, cancellationToken) + |> commitResultNonThrowing errorOptions "input.fsx" diagnosticsLogger member _.EvalScript(filePath) : unit = // Explanation: When the user of the FsiInteractiveSession object calls this method, the @@ -3537,7 +3543,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() - fsiInteractionProcessor.EvalScript(ctok, filePath, errorLogger) + fsiInteractionProcessor.EvalScript(ctok, filePath, diagnosticsLogger) |> commitResult |> ignore @@ -3548,9 +3554,9 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let ctok = AssumeCompilationThreadWithoutEvidence() let errorOptions = TcConfig.Create(tcConfigB, validate = false).diagnosticsOptions - let errorLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) - fsiInteractionProcessor.EvalScript(ctok, filePath, errorLogger) - |> commitResultNonThrowing errorOptions filePath errorLogger + let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions) + fsiInteractionProcessor.EvalScript(ctok, filePath, diagnosticsLogger) + |> commitResultNonThrowing errorOptions filePath diagnosticsLogger |> function Choice1Of2 _, errs -> Choice1Of2 (), errs | Choice2Of2 exn, errs -> Choice2Of2 exn, errs /// Event fires when a root-level value is bound to an identifier, e.g., via `let x = ...`. @@ -3568,7 +3574,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() - fsiInteractionProcessor.AddBoundValue(ctok, errorLogger, name, value) + fsiInteractionProcessor.AddBoundValue(ctok, diagnosticsLogger, name, value) |> commitResult |> ignore @@ -3604,7 +3610,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i if fsiOptions.Interact then // page in the type check env - fsiInteractionProcessor.LoadDummyInteraction(ctokStartup, errorLogger) + fsiInteractionProcessor.LoadDummyInteraction(ctokStartup, diagnosticsLogger) if progress then fprintfn fsiConsoleOutput.Out "MAIN: InstallKillThread!"; // Compute how long to pause before a ThreadAbort is actually executed. @@ -3623,18 +3629,18 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i | _ -> ()) #endif - fsiInteractionProcessor.LoadInitialFiles(ctokRun, errorLogger) + fsiInteractionProcessor.LoadInitialFiles(ctokRun, diagnosticsLogger) - fsiInteractionProcessor.StartStdinReadAndProcessThread(errorLogger) + fsiInteractionProcessor.StartStdinReadAndProcessThread(diagnosticsLogger) DriveFsiEventLoop (fsi, fsiConsoleOutput ) else // not interact if progress then fprintfn fsiConsoleOutput.Out "Run: not interact, loading initial files..." - fsiInteractionProcessor.LoadInitialFiles(ctokRun, errorLogger) + fsiInteractionProcessor.LoadInitialFiles(ctokRun, diagnosticsLogger) if progress then fprintfn fsiConsoleOutput.Out "Run: done..." - exit (min errorLogger.ErrorCount 1) + exit (min diagnosticsLogger.ErrorCount 1) // The Ctrl-C exception handler that we've passed to native code has // to be explicitly kept alive. diff --git a/src/Compiler/Interactive/fsi.fsi b/src/Compiler/Interactive/fsi.fsi index 3c24cd60d8d..16b337c0d01 100644 --- a/src/Compiler/Interactive/fsi.fsi +++ b/src/Compiler/Interactive/fsi.fsi @@ -316,7 +316,7 @@ module Settings = /// Schedule a restart for the event loop. abstract ScheduleRestart: unit -> unit - /// Operations supported by the currently executing F# Interactive session. + /// Operations supported by the currently executing F# Interactive session. [] type InteractiveSettings = /// Get or set the floating point format used in the output of the interactive session. diff --git a/src/Compiler/Optimize/DetupleArgs.fsi b/src/Compiler/Optimize/DetupleArgs.fsi index 3f3564b82d9..cf59935ea6d 100644 --- a/src/Compiler/Optimize/DetupleArgs.fsi +++ b/src/Compiler/Optimize/DetupleArgs.fsi @@ -6,7 +6,7 @@ open Internal.Utilities.Collections open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree -val DetupleImplFile: CcuThunk -> TcGlobals -> TypedImplFile -> TypedImplFile +val DetupleImplFile: CcuThunk -> TcGlobals -> CheckedImplFile -> CheckedImplFile module GlobalUsageAnalysis = val GetValsBoundInExpr: Expr -> Zset @@ -32,4 +32,4 @@ module GlobalUsageAnalysis = /// top of expr toplevel? (true) IterationIsAtTopLevel: bool } - val GetUsageInfoOfImplFile: TcGlobals -> TypedImplFile -> Results + val GetUsageInfoOfImplFile: TcGlobals -> CheckedImplFile -> Results diff --git a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs index 4a6a32e8172..6739dcc3d83 100644 --- a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs +++ b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs @@ -839,7 +839,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = let envp = Zmap.force fc envPackM ("CreateNewValuesForTLR - envp", string) let name = f.LogicalName (* + "_TLR_" + string wf *) let m = f.Range - let tps, tau = f.TypeScheme + let tps, tau = f.GeneralizedType let argTys, retTy = stripFunTy g tau let newTps = envp.ep_etps @ tps @@ -1166,13 +1166,13 @@ module Pass4_RewriteAssembly = // Lifting TLR out over constructs (disabled) // Lift minimally to ensure the defn is not lifted up and over defns on which it depends (disabled) - | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> + | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> let targets = Array.toList targets let dtree, z = TransDecisionTree penv z dtree let targets, z = List.mapFold (TransDecisionTreeTarget penv) z targets // TransDecisionTreeTarget wraps EnterInner/exitInnter, so need to collect any top decs let pds,z = ExtractPreDecs z - MakePreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets), z + MakePreDecs m pds (mkAndSimplifyMatch spBind mExpr m ty dtree targets), z // all others - below - rewrite structurally - so boiler plate code after this point... | Expr.Const _ -> @@ -1256,12 +1256,12 @@ module Pass4_RewriteAssembly = let e = mkLetsFromBindings m rebinds e MakePreDecs m pds (mkLetsFromBindings m binds e), z)) - | LinearMatchExpr (spBind, exprm, dtree, tg1, e2, m2, ty) -> + | LinearMatchExpr (spBind, mExpr, dtree, tg1, e2, m2, ty) -> let dtree, z = TransDecisionTree penv z dtree let tg1, z = TransDecisionTreeTarget penv z tg1 // tailcall TransLinearExpr penv z e2 (contf << (fun (e2, z) -> - rebuildLinearMatchExpr (spBind, exprm, dtree, tg1, e2, m2, ty), z)) + rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1, e2, m2, ty), z)) | LinearOpExpr (op, tyargs, argsHead, argLast, m) -> let argsHead,z = List.mapFold (TransExpr penv) z argsHead @@ -1315,15 +1315,7 @@ module Pass4_RewriteAssembly = and TransValBindings penv z binds = List.mapFold (TransValBinding penv) z binds - and TransModuleExpr penv z x = - match x with - | ModuleOrNamespaceContentsWithSig(mty, def, m) -> - let def, z = TransModuleDef penv z def - ModuleOrNamespaceContentsWithSig(mty, def, m), z - - and TransModuleDefs penv z x = List.mapFold (TransModuleDef penv) z x - - and TransModuleDef penv (z: RewriteState) x: ModuleOrNamespaceContents * RewriteState = + and TransModuleContents penv (z: RewriteState) x: ModuleOrNamespaceContents * RewriteState = match x with | TMDefRec(isRec, opens, tycons, mbinds, m) -> let mbinds, z = TransModuleBindings penv z mbinds @@ -1335,13 +1327,10 @@ module Pass4_RewriteAssembly = let _bind, z = TransExpr penv z e TMDefDo(e, m), z | TMDefs defs -> - let defs, z = TransModuleDefs penv z defs + let defs, z = List.mapFold (TransModuleContents penv) z defs TMDefs defs, z | TMDefOpens _ -> x, z - | TMWithSig mexpr -> - let mexpr, z = TransModuleExpr penv z mexpr - TMWithSig mexpr, z and TransModuleBindings penv z binds = List.mapFold (TransModuleBinding penv) z binds @@ -1351,12 +1340,12 @@ module Pass4_RewriteAssembly = let bind, z = TransValBinding penv z bind ModuleOrNamespaceBinding.Binding bind, z | ModuleOrNamespaceBinding.Module(nm, rhs) -> - let rhs, z = TransModuleDef penv z rhs + let rhs, z = TransModuleContents penv z rhs ModuleOrNamespaceBinding.Module(nm, rhs), z - let TransImplFile penv z (TImplFile (fragName, pragmas, moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = - let moduleExpr, z = TransModuleExpr penv z moduleExpr - (TImplFile (fragName, pragmas, moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)), z + let TransImplFile penv z (CheckedImplFile (fragName, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = + let contentsR, z = TransModuleContents penv z contents + (CheckedImplFile (fragName, pragmas, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)), z //------------------------------------------------------------------------- // pass5: copyExpr diff --git a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fsi b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fsi index 473bffb8c7f..5a745306764 100644 --- a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fsi +++ b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fsi @@ -5,4 +5,4 @@ module internal FSharp.Compiler.InnerLambdasToTopLevelFuncs open FSharp.Compiler.TypedTree open FSharp.Compiler.TcGlobals -val MakeTopLevelRepresentationDecisions: CcuThunk -> TcGlobals -> TypedImplFile -> TypedImplFile +val MakeTopLevelRepresentationDecisions: CcuThunk -> TcGlobals -> CheckedImplFile -> CheckedImplFile diff --git a/src/Compiler/Optimize/LowerCalls.fsi b/src/Compiler/Optimize/LowerCalls.fsi index aecb0ff3f9e..94cbf32d218 100644 --- a/src/Compiler/Optimize/LowerCalls.fsi +++ b/src/Compiler/Optimize/LowerCalls.fsi @@ -7,4 +7,4 @@ open FSharp.Compiler.TypedTree /// Expands under-applied values of known arity to lambda expressions, and then reduce to bind /// any known arguments. The results are later optimized by Optimizer.fs -val LowerImplFile: g: TcGlobals -> assembly: TypedImplFile -> TypedImplFile +val LowerImplFile: g: TcGlobals -> assembly: CheckedImplFile -> CheckedImplFile diff --git a/src/Compiler/Optimize/LowerComputedCollections.fs b/src/Compiler/Optimize/LowerComputedCollections.fs index 054a6d9f559..e3091ec71fe 100644 --- a/src/Compiler/Optimize/LowerComputedCollections.fs +++ b/src/Compiler/Optimize/LowerComputedCollections.fs @@ -35,8 +35,8 @@ let BuildDisposableCleanup tcVal (g: TcGlobals) infoReader m (v: Val) = else let disposeObjVar, disposeObjExpr = mkCompGenLocal m "objectToDispose" g.system_IDisposable_ty let disposeExpr, _ = BuildMethodCall tcVal g infoReader.amap PossiblyMutates m false disposeMethod NormalValUse [] [disposeObjExpr] [] - let inpe = mkCoerceExpr(exprForVal v.Range v, g.obj_ty, m, v.Type) - mkIsInstConditional g m g.system_IDisposable_ty inpe disposeObjVar disposeExpr (mkUnit g m) + let inputExpr = mkCoerceExpr(exprForVal v.Range v, g.obj_ty, m, v.Type) + mkIsInstConditional g m g.system_IDisposable_ty inputExpr disposeObjVar disposeExpr (mkUnit g m) let mkCallCollectorMethod tcVal (g: TcGlobals) infoReader m name collExpr args = let listCollectorTy = tyOfExpr g collExpr @@ -167,7 +167,7 @@ let LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr = Result.Ok(closed, exprR) | Result.Error msg -> Result.Error msg - | Expr.Match (spBind, exprm, pt, targets, m, ty) -> + | Expr.Match (spBind, mExpr, pt, targets, m, ty) -> // lower all the targets. abandon if any fail to lower let resTargets = targets |> Array.map (fun (TTarget(vs, targetExpr, flags)) -> @@ -179,7 +179,7 @@ let LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr = if resTargets |> Array.forall (function Result.Ok _ -> true | _ -> false) then let tglArray = Array.map (function Result.Ok v -> v | _ -> failwith "unreachable") resTargets - let exprR = primMkMatch (spBind, exprm, pt, tglArray, m, ty) + let exprR = primMkMatch (spBind, mExpr, pt, tglArray, m, ty) Result.Ok(false, exprR) else resTargets |> Array.pick (function Result.Error msg -> Some (Result.Error msg) | _ -> None) diff --git a/src/Compiler/Optimize/LowerLocalMutables.fsi b/src/Compiler/Optimize/LowerLocalMutables.fsi index 614bdda7164..ea14dad14f6 100644 --- a/src/Compiler/Optimize/LowerLocalMutables.fsi +++ b/src/Compiler/Optimize/LowerLocalMutables.fsi @@ -7,4 +7,4 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree /// Rewrite mutable locals to reference cells across an entire implementation file -val TransformImplFile: g: TcGlobals -> amap: ImportMap -> implFile: TypedImplFile -> TypedImplFile +val TransformImplFile: g: TcGlobals -> amap: ImportMap -> implFile: CheckedImplFile -> CheckedImplFile diff --git a/src/Compiler/Optimize/LowerSequences.fs b/src/Compiler/Optimize/LowerSequences.fs index b82947b11ff..294635559c9 100644 --- a/src/Compiler/Optimize/LowerSequences.fs +++ b/src/Compiler/Optimize/LowerSequences.fs @@ -417,7 +417,7 @@ let ConvertSequenceExprToObject g amap overallExpr = // transferred to the r.h.s. are not yet compiled. // // TODO: remove this limitation - | Expr.Match (spBind, exprm, pt, targets, m, ty) -> + | Expr.Match (spBind, mExpr, pt, targets, m, ty) -> // lower all the targets. abandon if any fail to lower let tglArray = targets @@ -449,7 +449,7 @@ let ConvertSequenceExprToObject g amap overallExpr = let gtg = TTarget(vs, generate, Some flags) gtg, dispose, checkDispose) |> List.unzip3 - let generate = primMkMatch (spBind, exprm, pt, Array.ofList gtgs, m, ty) + let generate = primMkMatch (spBind, mExpr, pt, Array.ofList gtgs, m, ty) let dispose = if isNil disposals then mkUnit g m else List.reduce (mkSequential m) disposals let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkSequential m) checkDisposes generate, dispose, checkDispose) diff --git a/src/Compiler/Optimize/LowerStateMachines.fs b/src/Compiler/Optimize/LowerStateMachines.fs index c0530768877..abb8210b2af 100644 --- a/src/Compiler/Optimize/LowerStateMachines.fs +++ b/src/Compiler/Optimize/LowerStateMachines.fs @@ -258,7 +258,7 @@ type LowerStateMachine(g: TcGlobals) = | Expr.Const (Const.Zero, m, ty) -> Some (Expr.Const (Const.Zero, m, ty)) - | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> + | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> let mutable newTyOpt = None let targets2 = targets |> Array.choose (fun (TTarget(vs, targetExpr, flags)) -> @@ -289,7 +289,7 @@ type LowerStateMachine(g: TcGlobals) = | Some targetExpr2 -> Some (TTarget(vs, targetExpr2, flags)) | None -> None) if targets2.Length = targets.Length then - Some (Expr.Match (spBind, exprm, dtree, targets2, m, ty)) + Some (Expr.Match (spBind, mExpr, dtree, targets2, m, ty)) else None @@ -489,8 +489,8 @@ type LowerStateMachine(g: TcGlobals) = ConvertResumableTryWith env pcValInfo (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) // control-flow match - | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> - ConvertResumableMatch env pcValInfo (spBind, exprm, dtree, targets, m, ty) + | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> + ConvertResumableMatch env pcValInfo (spBind, mExpr, dtree, targets, m, ty) // Non-control-flow let binding can appear as part of state machine. The body is considered state-machine code, // the expression being bound is not. @@ -756,7 +756,7 @@ type LowerStateMachine(g: TcGlobals) = |> Result.Ok | Result.Error err, _, _ | _, Result.Error err, _ | _, _, Result.Error err -> Result.Error err - and ConvertResumableMatch env pcValInfo (spBind, exprm, dtree, targets, m, ty) = + and ConvertResumableMatch env pcValInfo (spBind, mExpr, dtree, targets, m, ty) = if sm_verbose then printfn "MatchExpr" // lower all the targets. let dtreeR = ConvertStateMachineLeafDecisionTree env dtree @@ -783,14 +783,14 @@ type LowerStateMachine(g: TcGlobals) = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, _)) res -> let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) TTarget(vs, res.phase1, Some flags)) - primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) + primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) phase2 = (fun ctxt -> let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, _)) res -> let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) TTarget(vs, res.phase2 ctxt, Some flags)) - let generate = primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) + let generate = primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) generate) entryPoints = entryPoints diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index b4ebb0838c8..788d82dfe8e 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -1317,21 +1317,10 @@ let RemapOptimizationInfo g tmenv = remapLazyModulInfo /// Hide information when a value is no longer visible -let AbstractAndRemapModulInfo msg g m (repackage, hidden) info = +let AbstractAndRemapModulInfo g (repackage, hidden) info = let mrpi = mkRepackageRemapping repackage -#if DEBUG - if verboseOptimizationInfo then dprintf "%s - %a - Optimization data prior to trim: \n%s\n" msg outputRange m (showL (Display.squashTo 192 (moduleInfoL g info))) -#else - ignore (msg, m) -#endif let info = info |> AbstractLazyModulInfoByHiding false hidden -#if DEBUG - if verboseOptimizationInfo then dprintf "%s - %a - Optimization data after trim:\n%s\n" msg outputRange m (showL (Display.squashTo 192 (moduleInfoL g info))) -#endif let info = info |> RemapOptimizationInfo g mrpi -#if DEBUG - if verboseOptimizationInfo then dprintf "%s - %a - Optimization data after remap:\n%s\n" msg outputRange m (showL (Display.squashTo 192 (moduleInfoL g info))) -#endif info //------------------------------------------------------------------------- @@ -1986,7 +1975,7 @@ let rec tryRewriteToSeqCombinators g (e: Expr) = | None -> None // match --> match - | Expr.Match (spBind, exprm, pt, targets, m, _ty) -> + | Expr.Match (spBind, mExpr, pt, targets, m, _ty) -> let targets = targets |> Array.map (fun (TTarget(vs, e, flags)) -> match tryRewriteToSeqCombinators g e with @@ -1996,7 +1985,7 @@ let rec tryRewriteToSeqCombinators g (e: Expr) = if targets |> Array.forall Option.isSome then let targets = targets |> Array.map Option.get let ty = targets |> Array.pick (fun (TTarget(_, e, _)) -> Some(tyOfExpr g e)) - Some (Expr.Match (spBind, exprm, pt, targets, m, ty)) + Some (Expr.Match (spBind, mExpr, pt, targets, m, ty)) else None @@ -2203,8 +2192,8 @@ let rec OptimizeExpr cenv (env: IncrementalOptimizationEnv) expr = | Expr.TyChoose _ -> OptimizeExpr cenv env (ChooseTyparSolutionsForFreeChoiceTypars g cenv.amap expr) - | Expr.Match (spMatch, exprm, dtree, targets, m, ty) -> - OptimizeMatch cenv env (spMatch, exprm, dtree, targets, m, ty) + | Expr.Match (spMatch, mExpr, dtree, targets, m, ty) -> + OptimizeMatch cenv env (spMatch, mExpr, dtree, targets, m, ty) | Expr.LetRec (binds, bodyExpr, m, _) -> OptimizeLetRec cenv env (binds, bodyExpr, m) @@ -2707,7 +2696,7 @@ and OptimizeLinearExpr cenv env expr contf = MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall // discard tailcall info from binding - not in tailcall position Info = evalueR } )) - | LinearMatchExpr (spMatch, exprm, dtree, tg1, e2, m, ty) -> + | LinearMatchExpr (spMatch, mExpr, dtree, tg1, e2, m, ty) -> let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree let tg1, tg1info = OptimizeDecisionTreeTarget cenv env m tg1 // tailcall @@ -2716,7 +2705,7 @@ and OptimizeLinearExpr cenv env expr contf = let e2, e2info = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (e2, e2info) let tinfos = [tg1info; e2info] let targetsR = [tg1; TTarget([], e2, None)] - OptimizeMatchPart2 cenv (spMatch, exprm, dtreeR, targetsR, dinfo, tinfos, m, ty))) + OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty))) | LinearOpExpr (op, tyargs, argsHead, argLast, m) -> let argsHeadR, argsHeadInfosR = OptimizeList (OptimizeExprThenConsiderSplit cenv env) argsHead @@ -3288,7 +3277,7 @@ and StripPreComputationsFromComputedFunction g f0 args mkApp = fs, (remake >> (fun bodyExpr2 -> Expr.Sequential (x1, bodyExpr2, NormalSeq, m))) // Matches which compute a different function on each branch are awkward, see above. - | Expr.Match (spMatch, exprm, dtree, targets, dflt, _ty) when targets.Length <= 2 -> + | Expr.Match (spMatch, mExpr, dtree, targets, dflt, _ty) when targets.Length <= 2 -> let fsl, targetRemakes = targets |> Array.map (fun (TTarget(vs, bodyExpr, flags)) -> @@ -3306,7 +3295,7 @@ and StripPreComputationsFromComputedFunction g f0 args mkApp = chunk, (acc, i+chunkSize)) let targetsR = (newExprsInChunks, targetRemakes) ||> Array.map2 (fun newExprsChunk targetRemake -> targetRemake newExprsChunk) let tyR = tyOfExpr g targetsR[0].TargetExpression - Expr.Match (spMatch, exprm, dtree, targetsR, dflt, tyR) + Expr.Match (spMatch, mExpr, dtree, targetsR, dflt, tyR) fs, remake | Expr.DebugPoint (dp, innerExpr) -> @@ -3722,14 +3711,14 @@ and ConsiderSplitToMethod flag threshold cenv env (e, einfo) = e, einfo /// Optimize/analyze a pattern matching expression -and OptimizeMatch cenv env (spMatch, exprm, dtree, targets, m, ty) = +and OptimizeMatch cenv env (spMatch, mExpr, dtree, targets, m, ty) = // REVIEW: consider collecting, merging and using information flowing through each line of the decision tree to each target let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree let targetsR, tinfos = OptimizeDecisionTreeTargets cenv env m targets - OptimizeMatchPart2 cenv (spMatch, exprm, dtreeR, targetsR, dinfo, tinfos, m, ty) + OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty) -and OptimizeMatchPart2 cenv (spMatch, exprm, dtreeR, targetsR, dinfo, tinfos, m, ty) = - let newExpr, newInfo = RebuildOptimizedMatch (spMatch, exprm, m, ty, dtreeR, targetsR, dinfo, tinfos) +and OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty) = + let newExpr, newInfo = RebuildOptimizedMatch (spMatch, mExpr, m, ty, dtreeR, targetsR, dinfo, tinfos) let newExpr2 = if not cenv.settings.LocalOptimizationsEnabled then newExpr else CombineBoolLogic newExpr newExpr2, newInfo @@ -3740,9 +3729,9 @@ and CombineMatchInfos dinfo tinfo = MightMakeCriticalTailcall=tinfo.MightMakeCriticalTailcall // discard tailcall info from decision tree since it's not in tailcall position Info= UnknownValue } -and RebuildOptimizedMatch (spMatch, exprm, m, ty, dtree, tgs, dinfo, tinfos) = +and RebuildOptimizedMatch (spMatch, mExpr, m, ty, dtree, tgs, dinfo, tinfos) = let tinfo = CombineValueInfosUnknown tinfos - let expr = mkAndSimplifyMatch spMatch exprm m ty dtree tgs + let expr = mkAndSimplifyMatch spMatch mExpr m ty dtree tgs let einfo = CombineMatchInfos dinfo tinfo expr, einfo @@ -3957,12 +3946,10 @@ and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = and OptimizeBindings cenv isRec env xs = List.mapFold (OptimizeBinding cenv isRec) env xs -and OptimizeModuleExprWithSig cenv env mexpr = - let g = cenv.g - match mexpr with - | ModuleOrNamespaceContentsWithSig(mty, def, m) -> +and OptimizeModuleExprWithSig cenv env mty def = + let g = cenv.g // Optimize the module implementation - let (def, info), (_env, bindInfosColl) = OptimizeModuleDef cenv (env, []) def + let (def, info), (_env, bindInfosColl) = OptimizeModuleContents cenv (env, []) def let bindInfosColl = List.concat bindInfosColl // Compute the elements truly hidden by the module signature. @@ -4009,7 +3996,7 @@ and OptimizeModuleExprWithSig cenv env mexpr = and elimModSpec (mspec: ModuleOrNamespace) = let mtyp = elimModTy mspec.ModuleOrNamespaceType - mspec.entity_modul_contents <- MaybeLazy.Strict mtyp + mspec.entity_modul_type <- MaybeLazy.Strict mtyp let rec elimModuleDefn x = match x with @@ -4021,7 +4008,6 @@ and OptimizeModuleExprWithSig cenv env mexpr = | TMDefOpens _ -> x | TMDefDo _ -> x | TMDefs defs -> TMDefs(List.map elimModuleDefn defs) - | TMWithSig _ -> x and elimModuleBinding modBind = match modBind with @@ -4035,14 +4021,14 @@ and OptimizeModuleExprWithSig cenv env mexpr = elimModuleDefn def - let info = AbstractAndRemapModulInfo "defs" g m rpi info + let info = AbstractAndRemapModulInfo g rpi info - ModuleOrNamespaceContentsWithSig(mty, def, m), info + def, info and mkValBind (bind: Binding) info = (mkLocalValRef bind.Var, info) -and OptimizeModuleDef cenv (env, bindInfosColl) input = +and OptimizeModuleContents cenv (env, bindInfosColl) input = match input with | TMDefRec(isRec, opens, tycons, mbinds, m) -> let env = if isRec then BindInternalValsToUnknown cenv (allValsOfModDef input) env else env @@ -4057,11 +4043,6 @@ and OptimizeModuleDef cenv (env, bindInfosColl) input = ModuleOrNamespaceInfos = NameMap.ofList minfos}), (env, bindInfosColl) - | TMWithSig mexpr -> - let mexpr, info = OptimizeModuleExprWithSig cenv env mexpr - let env = BindValsInModuleOrNamespace cenv info env - (TMWithSig mexpr, info), (env, bindInfosColl) - | TMDefOpens _openDecls -> (input, EmptyModuleInfo), (env, bindInfosColl) @@ -4091,29 +4072,28 @@ and OptimizeModuleBinding cenv (env, bindInfosColl) x = (ModuleOrNamespaceBinding.Binding bindR, Choice1Of2 (bindR, binfo)), (env, [ bindInfo ] :: bindInfosColl) | ModuleOrNamespaceBinding.Module(mspec, def) -> let id = mspec.Id - let (def, info), (_, bindInfosColl) = OptimizeModuleDef cenv (env, bindInfosColl) def + let (def, info), (_, bindInfosColl) = OptimizeModuleContents cenv (env, bindInfosColl) def let env = BindValsInModuleOrNamespace cenv info env (ModuleOrNamespaceBinding.Module(mspec, def), Choice2Of2 (id.idText, info)), (env, bindInfosColl) and OptimizeModuleDefs cenv (env, bindInfosColl) defs = - let defs, (env, bindInfosColl) = List.mapFold (OptimizeModuleDef cenv) (env, bindInfosColl) defs + let defs, (env, bindInfosColl) = List.mapFold (OptimizeModuleContents cenv) (env, bindInfosColl) defs let defs, minfos = List.unzip defs (defs, UnionOptimizationInfos minfos), (env, bindInfosColl) and OptimizeImplFileInternal cenv env isIncrementalFragment fsiMultiAssemblyEmit hidden implFile = let g = cenv.g - let (TImplFile (qname, pragmas, mexpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile - let env, mexprR, minfo, hidden = - match mexpr with + let (CheckedImplFile (qname, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile + let env, contentsR, minfo, hidden = // FSI compiles interactive fragments as if you're typing incrementally into one module. // // This means the fragment is not constrained by its signature and later fragments will be typechecked // against the implementation of the module rather than the externals. // - | ModuleOrNamespaceContentsWithSig(mty, def, m) when isIncrementalFragment -> + if isIncrementalFragment then // This optimizes and builds minfo ignoring the signature - let (defR, minfo), (_env, _bindInfosColl) = OptimizeModuleDef cenv (env, []) def + let (defR, minfo), (_env, _bindInfosColl) = OptimizeModuleContents cenv (env, []) contents let hidden = ComputeImplementationHidingInfoAtAssemblyBoundary defR hidden let minfo = // In F# interactive multi-assembly mode, no internals are accessible across interactive fragments. @@ -4123,11 +4103,11 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment fsiMultiAssemblyEmit else AbstractLazyModulInfoByHiding false hidden minfo let env = BindValsInModuleOrNamespace cenv minfo env - env, ModuleOrNamespaceContentsWithSig(mty, defR, m), minfo, hidden - | _ -> + env, defR, minfo, hidden + else // This optimizes and builds minfo w.r.t. the signature - let mexprR, minfo = OptimizeModuleExprWithSig cenv env mexpr - let hidden = ComputeSignatureHidingInfoAtAssemblyBoundary mexpr.Type hidden + let mexprR, minfo = OptimizeModuleExprWithSig cenv env signature contents + let hidden = ComputeSignatureHidingInfoAtAssemblyBoundary signature hidden let minfoExternal = AbstractLazyModulInfoByHiding true hidden minfo let env = // In F# interactive multi-assembly mode, internals are not accessible in the 'env' used intra-assembly @@ -4138,7 +4118,7 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment fsiMultiAssemblyEmit BindValsInModuleOrNamespace cenv minfo env env, mexprR, minfoExternal, hidden - let implFileR = TImplFile (qname, pragmas, mexprR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + let implFileR = CheckedImplFile (qname, pragmas, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) env, implFileR, minfo, hidden diff --git a/src/Compiler/Optimize/Optimizer.fsi b/src/Compiler/Optimize/Optimizer.fsi index 8da9fad1650..1fceb0d2b68 100644 --- a/src/Compiler/Optimize/Optimizer.fsi +++ b/src/Compiler/Optimize/Optimizer.fsi @@ -76,8 +76,8 @@ val internal OptimizeImplFile: fsiMultiAssemblyEmit: bool * emitTailcalls: bool * SignatureHidingInfo * - TypedImplFile -> - (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * + CheckedImplFile -> + (IncrementalOptimizationEnv * CheckedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (bool -> Expr -> Expr) #if DEBUG diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index 7398e1d00ea..2213ebbe331 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -207,7 +207,7 @@ module internal FSharpCheckerResultsSettings = let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(Some(Path.GetDirectoryName(typeof.Assembly.Location))).Value [] -type FSharpSymbolUse(denv: DisplayEnv, symbol:FSharpSymbol, inst: TyparInst, itemOcc, range: range) = +type FSharpSymbolUse(denv: DisplayEnv, symbol:FSharpSymbol, inst: TyparInstantiation, itemOcc, range: range) = member _.Symbol = symbol @@ -314,7 +314,7 @@ type internal TypeCheckInfo // This is a name resolution environment to use if no better match can be found. sFallback: NameResolutionEnv, loadClosure : LoadClosure option, - implFileOpt: TypedImplFile option, + implFileOpt: CheckedImplFile option, openDeclarations: OpenDeclaration[]) = // These strings are potentially large and the editor may choose to hold them for a while. @@ -522,7 +522,7 @@ type internal TypeCheckInfo let props = methods |> List.collect (fun meth -> - let retTy = meth.GetFSharpReturnTy(amap, m, meth.FormalMethodInst) + let retTy = meth.GetFSharpReturnType(amap, m, meth.FormalMethodInst) ResolveCompletionsInType ncenv nenv ResolveCompletionTargets.SettablePropertiesAndFields m ad false retTy ) let parameters = CollectParameters methods amap m @@ -1231,7 +1231,7 @@ type internal TypeCheckInfo | items -> items |> List.map (fun item -> let symbol = FSharpSymbol.Create(cenv, item.Item) - FSharpSymbolUse(denv, symbol, item.ItemWithInst.TyparInst, ItemOccurence.Use, m))) + FSharpSymbolUse(denv, symbol, item.ItemWithInst.TyparInstantiation, ItemOccurence.Use, m))) //end filtering items) @@ -1294,7 +1294,7 @@ type internal TypeCheckInfo let item = symbol.Item let inst = inst |> List.map (fun (typar, t) -> typar.TypeParameter, t.Type) - let itemWithInst = { ItemWithInst.Item = item; ItemWithInst.TyparInst = inst } + let itemWithInst = { ItemWithInst.Item = item; ItemWithInst.TyparInstantiation = inst } let toolTipElement = FormatStructuredDescriptionOfItem displayFullName infoReader accessorDomain m denv itemWithInst ToolTipText [toolTipElement] @@ -1581,11 +1581,11 @@ type internal TypeCheckInfo type FSharpParsingOptions = { SourceFiles: string [] ConditionalDefines: string list - ErrorSeverityOptions: FSharpDiagnosticOptions + DiagnosticOptions: FSharpDiagnosticOptions LangVersionText: string IsInteractive: bool IndentationAwareSyntax: bool option - CompilingFsLib: bool + CompilingFSharpCore: bool IsExe: bool } member x.LastFileName = @@ -1595,32 +1595,32 @@ type FSharpParsingOptions = static member Default = { SourceFiles = Array.empty ConditionalDefines = [] - ErrorSeverityOptions = FSharpDiagnosticOptions.Default + DiagnosticOptions = FSharpDiagnosticOptions.Default LangVersionText = LanguageVersion.Default.VersionText IsInteractive = false IndentationAwareSyntax = None - CompilingFsLib = false + CompilingFSharpCore = false IsExe = false } static member FromTcConfig(tcConfig: TcConfig, sourceFiles, isInteractive: bool) = { SourceFiles = sourceFiles ConditionalDefines = tcConfig.conditionalDefines - ErrorSeverityOptions = tcConfig.diagnosticsOptions + DiagnosticOptions = tcConfig.diagnosticsOptions LangVersionText = tcConfig.langVersion.VersionText IsInteractive = isInteractive IndentationAwareSyntax = tcConfig.indentationAwareSyntax - CompilingFsLib = tcConfig.compilingFSharpCore + CompilingFSharpCore = tcConfig.compilingFSharpCore IsExe = tcConfig.target.IsExe } static member FromTcConfigBuilder(tcConfigB: TcConfigBuilder, sourceFiles, isInteractive: bool) = { SourceFiles = sourceFiles ConditionalDefines = tcConfigB.conditionalDefines - ErrorSeverityOptions = tcConfigB.diagnosticsOptions + DiagnosticOptions = tcConfigB.diagnosticsOptions LangVersionText = tcConfigB.langVersion.VersionText IsInteractive = isInteractive IndentationAwareSyntax = tcConfigB.indentationAwareSyntax - CompilingFsLib = tcConfigB.compilingFSharpCore + CompilingFSharpCore = tcConfigB.compilingFSharpCore IsExe = tcConfigB.target.IsExe } @@ -1629,58 +1629,60 @@ module internal ParseAndCheckFile = /// Error handler for parsing & type checking while processing a single file type ErrorHandler(reportErrors, mainInputFileName, diagnosticsOptions: FSharpDiagnosticOptions, sourceText: ISourceText, suggestNamesForErrors: bool) = let mutable options = diagnosticsOptions - let errorsAndWarningsCollector = ResizeArray<_>() + let diagnosticsCollector = ResizeArray<_>() let mutable errorCount = 0 // We'll need number of lines for adjusting error messages at EOF let fileInfo = sourceText.GetLastCharacterPosition() + let collectOne severity diagnostic = + for diagnostic in DiagnosticHelpers.ReportDiagnostic (options, false, mainInputFileName, fileInfo, diagnostic, severity, suggestNamesForErrors) do + diagnosticsCollector.Add diagnostic + if severity = FSharpDiagnosticSeverity.Error then + errorCount <- errorCount + 1 + // This function gets called whenever an error happens during parsing or checking - let diagnosticSink sev (exn: PhasedDiagnostic) = + let diagnosticSink severity (diagnostic: PhasedDiagnostic) = // 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 + let diagnostic = + if not(diagnostic.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. - Trace.TraceInformation(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 DiagnosticHelpers.ReportDiagnostic (options, false, mainInputFileName, fileInfo, (exn, sev), suggestNamesForErrors) do - errorsAndWarningsCollector.Add ei - if sev = FSharpDiagnosticSeverity.Error then - errorCount <- errorCount + 1 + Trace.TraceInformation(sprintf "The subcategory '%s' seen in an error should not be seen by the language service" (diagnostic.Subcategory())) + { diagnostic with Phase = BuildPhase.TypeCheck } + else diagnostic - match exn with + if reportErrors then + match diagnostic with #if !NO_TYPEPROVIDERS - | { Exception = :? TypeProviderError as tpe } -> tpe.Iter(fun e -> report { exn with Exception = e }) + | { Exception = :? TypeProviderError as tpe } -> + tpe.Iter(fun exn -> collectOne severity { diagnostic with Exception = exn }) #endif - | e -> report e + | _ -> collectOne severity diagnostic - let errorLogger = + let diagnosticsLogger = { new DiagnosticsLogger("ErrorHandler") with - member x.DiagnosticSink (exn, severity) = diagnosticSink severity exn - member x.ErrorCount = errorCount } + member _.DiagnosticSink (exn, severity) = diagnosticSink severity exn + member _.ErrorCount = errorCount } // Public members - member _.DiagnosticsLogger = errorLogger + member _.DiagnosticsLogger = diagnosticsLogger - member _.CollectedDiagnostics = errorsAndWarningsCollector.ToArray() + member _.CollectedDiagnostics = diagnosticsCollector.ToArray() member _.ErrorCount = errorCount - member _.ErrorSeverityOptions with set opts = options <- opts + member _.DiagnosticOptions with set opts = options <- opts member _.AnyErrors = errorCount > 0 let getLightSyntaxStatus fileName options = let indentationAwareSyntaxOnByDefault = List.exists (FileSystemUtils.checkSuffix fileName) FSharpIndentationAwareSyntaxFileSuffixes - let lightStatus = if indentationAwareSyntaxOnByDefault then (options.IndentationAwareSyntax <> Some false) else (options.IndentationAwareSyntax = Some true) - IndentationAwareSyntaxStatus(lightStatus, true) + let indentationSyntaxStatus = if indentationAwareSyntaxOnByDefault then (options.IndentationAwareSyntax <> Some false) else (options.IndentationAwareSyntax = Some true) + IndentationAwareSyntaxStatus(indentationSyntaxStatus, true) let createLexerFunction fileName options lexbuf (errHandler: ErrorHandler) = - let lightStatus = getLightSyntaxStatus fileName options + let indentationSyntaxStatus = getLightSyntaxStatus fileName options // If we're editing a script then we define INTERACTIVE otherwise COMPILED. // Since this parsing for intellisense we always define EDITING. @@ -1693,10 +1695,10 @@ module internal ParseAndCheckFile = // When analyzing files using ParseOneFile, i.e. for the use of editing clients, we do not apply line directives. // TODO(pathmap): expose PathMap on the service API, and thread it through here - let lexargs = mkLexargs(conditionalDefines, lightStatus, lexResourceManager, [], errHandler.DiagnosticsLogger, PathMap.empty) + let lexargs = mkLexargs(conditionalDefines, indentationSyntaxStatus, lexResourceManager, [], errHandler.DiagnosticsLogger, PathMap.empty) let lexargs = { lexargs with applyLineDirectives = false } - let tokenizer = LexFilter.LexFilter(lightStatus, options.CompilingFsLib, Lexer.token lexargs true, lexbuf) + let tokenizer = LexFilter.LexFilter(indentationSyntaxStatus, options.CompilingFSharpCore, Lexer.token lexargs true, lexbuf) (fun _ -> tokenizer.GetToken()) let createLexbuf langVersion sourceText = @@ -1716,7 +1718,7 @@ module internal ParseAndCheckFile = let matchingBraces = ResizeArray<_>() usingLexbufForParsing(createLexbuf options.LangVersionText sourceText, fileName) (fun lexbuf -> - let errHandler = ErrorHandler(false, fileName, options.ErrorSeverityOptions, sourceText, suggestNamesForErrors) + let errHandler = ErrorHandler(false, fileName, options.DiagnosticOptions, sourceText, suggestNamesForErrors) let lexfun = createLexerFunction fileName options lexbuf errHandler let parenTokensBalance t1 t2 = match t1, t2 with @@ -1787,7 +1789,7 @@ module internal ParseAndCheckFile = let parseFile(sourceText: ISourceText, fileName, options: FSharpParsingOptions, userOpName: string, suggestNamesForErrors: bool) = Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "parseFile", fileName) - let errHandler = ErrorHandler(true, fileName, options.ErrorSeverityOptions, sourceText, suggestNamesForErrors) + let errHandler = ErrorHandler(true, fileName, options.DiagnosticOptions, sourceText, suggestNamesForErrors) use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.DiagnosticsLogger) use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse @@ -1801,7 +1803,7 @@ module internal ParseAndCheckFile = let isExe = options.IsExe try - ParseInput(lexfun, options.ErrorSeverityOptions, errHandler.DiagnosticsLogger, lexbuf, None, fileName, (isLastCompiland, isExe)) + ParseInput(lexfun, options.DiagnosticOptions, errHandler.DiagnosticsLogger, lexbuf, None, fileName, (isLastCompiland, isExe)) with e -> errHandler.DiagnosticsLogger.StopProcessingRecovery e range0 // don't re-raise any exceptions, we must return None. EmptyParsedInput(fileName, (isLastCompiland, isExe))) @@ -1856,9 +1858,9 @@ module internal ParseAndCheckFile = if sameFile file fileOfHashLoad then for rangeOfHashLoad in rangesOfHashLoad do // Handle the case of two #loads of the same file let diagnostics = errorGroupedByFileName |> Array.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 diagnostics do if sev = FSharpDiagnosticSeverity.Error then yield err ] - let warnings = [ for err, sev in diagnostics do if sev = FSharpDiagnosticSeverity.Warning then yield err ] - let infos = [ for err, sev in diagnostics do if sev = FSharpDiagnosticSeverity.Info then yield err ] + let errors = [ for err, severity in diagnostics do if severity = FSharpDiagnosticSeverity.Error then yield err ] + let warnings = [ for err, severity in diagnostics do if severity = FSharpDiagnosticSeverity.Warning then yield err ] + let infos = [ for err, severity in diagnostics do if severity = FSharpDiagnosticSeverity.Info then yield err ] let message = HashLoadedSourceHasIssues(infos, warnings, errors, rangeOfHashLoad) if isNil errors && isNil warnings then @@ -1869,11 +1871,11 @@ module internal ParseAndCheckFile = errorR message // Replay other background errors. - for phasedError, sev in otherBackgroundDiagnostics do - match sev with - | FSharpDiagnosticSeverity.Info -> informationalWarning phasedError.Exception - | FSharpDiagnosticSeverity.Warning -> warning phasedError.Exception - | FSharpDiagnosticSeverity.Error -> errorR phasedError.Exception + for diagnostic, severity in otherBackgroundDiagnostics do + match severity with + | FSharpDiagnosticSeverity.Info -> informationalWarning diagnostic.Exception + | FSharpDiagnosticSeverity.Warning -> warning diagnostic.Exception + | FSharpDiagnosticSeverity.Error -> errorR diagnostic.Exception | FSharpDiagnosticSeverity.Hidden -> () | None -> @@ -1908,11 +1910,11 @@ module internal ParseAndCheckFile = use _unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.DiagnosticsLogger) use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck - // Apply nowarns to tcConfig (may generate errors, so ensure errorLogger is installed) + // Apply nowarns to tcConfig (may generate errors, so ensure diagnosticsLogger is installed) let tcConfig = ApplyNoWarnsToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) // update the error handler with the modified tcConfig - errHandler.ErrorSeverityOptions <- tcConfig.diagnosticsOptions + errHandler.DiagnosticOptions <- tcConfig.diagnosticsOptions // Play background errors and warnings for this file. do for err, severity in backgroundDiagnostics do @@ -2057,13 +2059,13 @@ type FSharpCheckFileResults member _.GetSymbolUseAtLocation (line, colAtEndOfNames, lineText, names) = threadSafeOp (fun () -> None) (fun scope -> scope.GetSymbolUseAtLocation (line, lineText, colAtEndOfNames, names) - |> Option.map (fun (sym, itemWithInst, denv,m) -> FSharpSymbolUse(denv,sym,itemWithInst.TyparInst,ItemOccurence.Use,m))) + |> Option.map (fun (sym, itemWithInst, denv,m) -> FSharpSymbolUse(denv,sym,itemWithInst.TyparInstantiation,ItemOccurence.Use,m))) member _.GetMethodsAsSymbols (line, colAtEndOfNames, lineText, names) = threadSafeOp (fun () -> None) (fun scope -> scope.GetMethodsAsSymbols (line, lineText, colAtEndOfNames, names) |> Option.map (fun (symbols,denv,m) -> - symbols |> List.map (fun (sym, itemWithInst) -> FSharpSymbolUse(denv,sym,itemWithInst.TyparInst,ItemOccurence.Use,m)))) + symbols |> List.map (fun (sym, itemWithInst) -> FSharpSymbolUse(denv,sym,itemWithInst.TyparInstantiation,ItemOccurence.Use,m)))) member _.GetSymbolAtLocation (line, colAtEndOfNames, lineStr, names) = threadSafeOp (fun () -> None) (fun scope -> @@ -2110,7 +2112,7 @@ type FSharpCheckFileResults cancellationToken |> Option.iter (fun ct -> ct.ThrowIfCancellationRequested()) if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then let symbol = FSharpSymbol.Create(cenv, symbolUse.ItemWithInst.Item) - FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInst, symbolUse.ItemOccurence, symbolUse.Range) + FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInstantiation, symbolUse.ItemOccurence, symbolUse.Range) }) member _.GetUsesOfSymbolInFile(symbol:FSharpSymbol, ?cancellationToken: CancellationToken) = @@ -2120,7 +2122,7 @@ type FSharpCheckFileResults [| for symbolUse in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) do cancellationToken |> Option.iter (fun ct -> ct.ThrowIfCancellationRequested()) if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then - yield FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInst, symbolUse.ItemOccurence, symbolUse.Range) |]) + yield FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInstantiation, symbolUse.ItemOccurence, symbolUse.Range) |]) member _.GetVisibleNamespacesAndModulesAtPoint(pos: pos) = threadSafeOp @@ -2146,12 +2148,12 @@ type FSharpCheckFileResults |> Option.map (fun implFile -> let denv = DisplayEnv.InitialForSigFileGeneration scope.TcGlobals let infoReader = InfoReader(scope.TcGlobals, scope.TcImports.GetImportMap()) - let (TImplFile (implExprWithSig=mexpr)) = implFile + let (CheckedImplFile (contents=mexpr)) = implFile let ad = match scopeOptX with | Some scope -> scope.AccessRights | _ -> AccessibleFromSomewhere - let layout = NicePrint.layoutInferredSigOfModuleExpr true denv infoReader ad range0 mexpr + let layout = NicePrint.layoutImpliedSignatureOfModuleOrNamespace true denv infoReader ad range0 mexpr layout |> LayoutRender.showL |> SourceText.ofString ) ) @@ -2260,7 +2262,7 @@ type FSharpCheckProjectResults diagnostics: FSharpDiagnostic[], details:(TcGlobals * TcImports * CcuThunk * ModuleOrNamespaceType * Choice * TopAttribs option * (unit -> IRawFSharpAssemblyData option) * ILAssemblyRef * - AccessorDomain * TypedImplFile list option * string[] * FSharpProjectOptions) option) = + AccessorDomain * CheckedImplFile list option * string[] * FSharpProjectOptions) option) = let getDetails() = match details with @@ -2313,7 +2315,7 @@ type FSharpCheckProjectResults let optimizedImpls, _optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, LightweightTcValForUsingInBuildMethodCall tcGlobals, outfile, importMap, isIncrementalFragment, optEnv0, thisCcu, mimpls) let mimpls = match optimizedImpls with - | TypedAssemblyAfterOptimization files -> + | CheckedAssemblyAfterOptimization files -> files |> List.map (fun implFile -> implFile.ImplFile) FSharpAssemblyContents(tcGlobals, thisCcu, Some ccuSig, tcImports, mimpls) @@ -2346,7 +2348,7 @@ type FSharpCheckProjectResults |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) |> Seq.map (fun symbolUse -> cancellationToken |> Option.iter (fun ct -> ct.ThrowIfCancellationRequested()) - FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInst, symbolUse.ItemOccurence, symbolUse.Range)) + FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInstantiation, symbolUse.ItemOccurence, symbolUse.Range)) |> Seq.toArray // Not, this does not have to be a SyncOp, it can be called from any thread @@ -2379,7 +2381,7 @@ type FSharpCheckProjectResults cancellationToken |> Option.iter (fun ct -> ct.ThrowIfCancellationRequested()) if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then let symbol = FSharpSymbol.Create(cenv, symbolUse.ItemWithInst.Item) - yield FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInst, symbolUse.ItemOccurence, symbolUse.Range) |] + yield FSharpSymbolUse(symbolUse.DisplayEnv, symbol, symbolUse.ItemWithInst.TyparInstantiation, symbolUse.ItemOccurence, symbolUse.Range) |] member _.ProjectContext = let tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr, _dependencyFiles, projectOptions = getDetails() diff --git a/src/Compiler/Service/FSharpCheckerResults.fsi b/src/Compiler/Service/FSharpCheckerResults.fsi index c7fea4e9b61..b1e754f38e0 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fsi +++ b/src/Compiler/Service/FSharpCheckerResults.fsi @@ -181,7 +181,7 @@ type public FSharpSymbolUse = // For internal use only internal new: - denv: DisplayEnv * symbol: FSharpSymbol * inst: TyparInst * itemOcc: ItemOccurence * range: range -> + denv: DisplayEnv * symbol: FSharpSymbol * inst: TyparInstantiation * itemOcc: ItemOccurence * range: range -> FSharpSymbolUse /// Represents the checking context implied by the ProjectOptions @@ -201,11 +201,11 @@ type public FSharpProjectContext = type public FSharpParsingOptions = { SourceFiles: string [] ConditionalDefines: string list - ErrorSeverityOptions: FSharpDiagnosticOptions + DiagnosticOptions: FSharpDiagnosticOptions LangVersionText: string IsInteractive: bool IndentationAwareSyntax: bool option - CompilingFsLib: bool + CompilingFSharpCore: bool IsExe: bool } static member Default: FSharpParsingOptions @@ -421,7 +421,7 @@ type public FSharpCheckFileResults = sSymbolUses: TcSymbolUses * sFallback: NameResolutionEnv * loadClosure: LoadClosure option * - implFileOpt: TypedImplFile option * + implFileOpt: CheckedImplFile option * openDeclarations: OpenDeclaration [] -> FSharpCheckFileResults @@ -495,7 +495,7 @@ type public FSharpCheckProjectResults = tcConfigOption: TcConfig option * keepAssemblyContents: bool * diagnostics: FSharpDiagnostic [] * - details: (TcGlobals * TcImports * CcuThunk * ModuleOrNamespaceType * Choice * TopAttribs option * (unit -> IRawFSharpAssemblyData option) * ILAssemblyRef * AccessorDomain * TypedImplFile list option * string [] * FSharpProjectOptions) option -> + details: (TcGlobals * TcImports * CcuThunk * ModuleOrNamespaceType * Choice * TopAttribs option * (unit -> IRawFSharpAssemblyData option) * ILAssemblyRef * AccessorDomain * CheckedImplFile list option * string [] * FSharpProjectOptions) option -> FSharpCheckProjectResults module internal ParseAndCheckFile = diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index 43d39de71ed..c9f7e51675e 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -114,9 +114,9 @@ module IncrementalBuildSyntaxTree = let mutable weakCache: WeakReference<_> option = None let parse(sigNameOpt: QualifiedNameOfFile option) = - let errorLogger = CompilationDiagnosticLogger("Parse", tcConfig.diagnosticsOptions) + let diagnosticsLogger = CompilationDiagnosticLogger("Parse", tcConfig.diagnosticsOptions) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parse) + use _holder = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.Parse) try IncrementalBuilderEventTesting.MRU.Add(IncrementalBuilderEventTesting.IBEParsed fileName) @@ -139,15 +139,15 @@ module IncrementalBuildSyntaxTree = use text = source.GetTextContainer() match text with | TextContainer.Stream(stream) -> - ParseOneInputStream(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, (*retryLocked*)false, stream) + ParseOneInputStream(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, (*retryLocked*)false, stream) | TextContainer.SourceText(sourceText) -> - ParseOneInputSourceText(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, sourceText) + ParseOneInputSourceText(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) | TextContainer.OnDisk -> - ParseOneInputFile(tcConfig, lexResourceManager, fileName, isLastCompiland, errorLogger, (*retryLocked*)true) + ParseOneInputFile(tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, (*retryLocked*)true) fileParsed.Trigger fileName - let res = input, sourceRange, fileName, errorLogger.GetDiagnostics() + let res = input, sourceRange, fileName, diagnosticsLogger.GetDiagnostics() // If we do not skip parsing the file, then we can cache the real result. if not canSkip then weakCache <- Some(WeakReference<_>(res)) @@ -205,7 +205,7 @@ type TcInfoExtras = tcOpenDeclarations: OpenDeclaration[] /// Result of checking most recent file, if any - latestImplFile: TypedImplFile option + latestImplFile: CheckedImplFile option /// If enabled, stores a linear list of ranges and strings that identify an Item(symbol) in a file. Used for background find all references. itemKeyStore: ItemKeyStore option @@ -473,8 +473,8 @@ type BoundModel private (tcConfig: TcConfig, IncrementalBuilderEventTesting.MRU.Add(IncrementalBuilderEventTesting.IBETypechecked fileName) let capturingDiagnosticsLogger = CapturingDiagnosticsLogger("TypeCheck") - let errorLogger = GetDiagnosticsLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput input, tcConfig.diagnosticsOptions, capturingDiagnosticsLogger) - use _ = new CompilationGlobalsScope(errorLogger, BuildPhase.TypeCheck) + let diagnosticsLogger = GetDiagnosticsLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput input, tcConfig.diagnosticsOptions, capturingDiagnosticsLogger) + use _ = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.TypeCheck) beforeFileChecked.Trigger fileName let prevModuleNamesDict = prevTcInfo.moduleNamesDict @@ -491,7 +491,7 @@ type BoundModel private (tcConfig: TcConfig, let! (tcEnvAtEndOfFile, topAttribs, implFile, ccuSigForFile), tcState = CheckOneInput - ((fun () -> hadParseErrors || errorLogger.ErrorCount > 0), + ((fun () -> hadParseErrors || diagnosticsLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, @@ -754,8 +754,8 @@ module IncrementalBuilderHelpers = importsInvalidatedByTypeProvider: Event) : NodeCode = node { - let errorLogger = CompilationDiagnosticLogger("CombineImportedAssembliesTask", tcConfig.diagnosticsOptions) - use _ = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) + let diagnosticsLogger = CompilationDiagnosticLogger("CombineImportedAssembliesTask", tcConfig.diagnosticsOptions) + use _ = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.Parameter) let! tcImports = node { @@ -786,7 +786,7 @@ module IncrementalBuilderHelpers = return tcImports with exn -> Debug.Assert(false, sprintf "Could not BuildAllReferencedDllTcImports %A" exn) - errorLogger.Warning exn + diagnosticsLogger.Warning exn return frameworkTcImports } @@ -799,7 +799,7 @@ module IncrementalBuilderHelpers = for inp in loadClosure.Inputs do yield! inp.MetaCommandDiagnostics ] - let initialErrors = Array.append (Array.ofList loadClosureErrors) (errorLogger.GetDiagnostics()) + let initialErrors = Array.append (Array.ofList loadClosureErrors) (diagnosticsLogger.GetDiagnostics()) let tcInfo = { tcState=tcState @@ -847,8 +847,8 @@ module IncrementalBuilderHelpers = /// Finish up the typechecking to produce outputs for the rest of the compilation process let FinalizeTypeCheckTask (tcConfig: TcConfig) tcGlobals enablePartialTypeChecking assemblyName outfile (boundModels: ImmutableArray) = node { - let errorLogger = CompilationDiagnosticLogger("FinalizeTypeCheckTask", tcConfig.diagnosticsOptions) - use _ = new CompilationGlobalsScope(errorLogger, BuildPhase.TypeCheck) + let diagnosticsLogger = CompilationDiagnosticLogger("FinalizeTypeCheckTask", tcConfig.diagnosticsOptions) + use _ = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.TypeCheck) let! results = boundModels @@ -928,7 +928,7 @@ module IncrementalBuilderHelpers = errorRecoveryNoRange exn mkSimpleAssemblyRef assemblyName, ProjectAssemblyDataResult.Unavailable true, None - let diagnostics = errorLogger.GetDiagnostics() :: finalInfo.tcDiagnosticsRev + let diagnostics = diagnosticsLogger.GetDiagnostics() :: finalInfo.tcDiagnosticsRev let! finalBoundModelWithErrors = finalBoundModel.Finish(diagnostics, Some topAttrs) return ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt, finalBoundModelWithErrors } @@ -1015,7 +1015,7 @@ type IncrementalBuilderState = stampedReferencedAssemblies: ImmutableArray initialBoundModel: GraphNode boundModels: ImmutableArray> - finalizedBoundModel: GraphNode<(ILAssemblyRef * ProjectAssemblyDataResult * TypedImplFile list option * BoundModel) * DateTime> + finalizedBoundModel: GraphNode<(ILAssemblyRef * ProjectAssemblyDataResult * CheckedImplFile list option * BoundModel) * DateTime> } [] @@ -1546,21 +1546,21 @@ type IncrementalBuilder(initialState: IncrementalBuilderInitialState, state: Inc // included in these references. let! tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolvedReferences = frameworkTcImportsCache.Get(tcConfig) - // Note we are not calling errorLogger.GetDiagnostics() anywhere for this task. + // Note we are not calling diagnosticsLogger.GetDiagnostics() anywhere for this task. // This is ok because not much can actually go wrong here. - let errorLogger = CompilationDiagnosticLogger("nonFrameworkAssemblyInputs", tcConfig.diagnosticsOptions) - use _ = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) + let diagnosticsLogger = CompilationDiagnosticLogger("nonFrameworkAssemblyInputs", tcConfig.diagnosticsOptions) + use _ = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.Parameter) // Get the names and time stamps of all the non-framework referenced assemblies, which will act // as inputs to one of the nodes in the build. // // This operation is done when constructing the builder itself, rather than as an incremental task. let nonFrameworkAssemblyInputs = - // Note we are not calling errorLogger.GetDiagnostics() anywhere for this task. + // Note we are not calling diagnosticsLogger.GetDiagnostics() anywhere for this task. // This is ok because not much can actually go wrong here. - let errorLogger = CompilationDiagnosticLogger("nonFrameworkAssemblyInputs", tcConfig.diagnosticsOptions) + let diagnosticsLogger = CompilationDiagnosticLogger("nonFrameworkAssemblyInputs", tcConfig.diagnosticsOptions) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) + use _holder = new CompilationGlobalsScope(diagnosticsLogger, BuildPhase.Parameter) [ for r in nonFrameworkResolutions do let fileName = r.resolvedPath @@ -1670,13 +1670,13 @@ type IncrementalBuilder(initialState: IncrementalBuilderInitialState, state: Inc match builderOpt with | Some builder -> let diagnosticsOptions = builder.TcConfig.diagnosticsOptions - let errorLogger = CompilationDiagnosticLogger("IncrementalBuilderCreation", diagnosticsOptions) - delayedLogger.CommitDelayedDiagnostics errorLogger - errorLogger.GetDiagnostics() + let diagnosticsLogger = CompilationDiagnosticLogger("IncrementalBuilderCreation", diagnosticsOptions) + delayedLogger.CommitDelayedDiagnostics diagnosticsLogger + diagnosticsLogger.GetDiagnostics() | _ -> Array.ofList delayedLogger.Diagnostics - |> Array.map (fun (diag, severity) -> - FSharpDiagnostic.CreateFromException(diag, severity, range.Zero, suggestNamesForErrors)) + |> Array.map (fun (diagnostic, severity) -> + FSharpDiagnostic.CreateFromException(diagnostic, severity, range.Zero, suggestNamesForErrors)) return builderOpt, diagnostics } \ No newline at end of file diff --git a/src/Compiler/Service/IncrementalBuild.fsi b/src/Compiler/Service/IncrementalBuild.fsi index a431dca2e27..dd678cc3bb3 100755 --- a/src/Compiler/Service/IncrementalBuild.fsi +++ b/src/Compiler/Service/IncrementalBuild.fsi @@ -74,7 +74,7 @@ type internal TcInfoExtras = tcOpenDeclarations: OpenDeclaration [] /// Result of checking most recent file, if any - latestImplFile: TypedImplFile option + latestImplFile: CheckedImplFile option /// If enabled, stores a linear list of ranges and strings that identify an Item(symbol) in a file. Used for background find all references. itemKeyStore: ItemKeyStore option @@ -214,16 +214,18 @@ type internal IncrementalBuilder = /// This may be a long-running operation. member GetCheckResultsAfterLastFileInProject: unit -> NodeCode - /// Get the final typecheck result. If 'generateTypedImplFiles' was set on Create then the TypedAssemblyAfterOptimization will contain implementations. + /// Get the final typecheck result. If 'generateTypedImplFiles' was set on Create then the CheckedAssemblyAfterOptimization will contain implementations. /// This may be a long-running operation. member GetCheckResultsAndImplementationsForProject: - unit -> NodeCode + unit -> + NodeCode - /// Get the final typecheck result. If 'generateTypedImplFiles' was set on Create then the TypedAssemblyAfterOptimization will contain implementations. + /// Get the final typecheck result. If 'generateTypedImplFiles' was set on Create then the CheckedAssemblyAfterOptimization will contain implementations. /// This may be a long-running operation. /// This will get full type-check info for the project, meaning no partial type-checking. member GetFullCheckResultsAndImplementationsForProject: - unit -> NodeCode + unit -> + NodeCode /// Get the logical time stamp that is associated with the output of the project if it were gully built immediately member GetLogicalTimeStampForProject: TimeStampCache -> DateTime diff --git a/src/Compiler/Service/ItemKey.fs b/src/Compiler/Service/ItemKey.fs index bbfe0fcc77d..15b56d8287b 100644 --- a/src/Compiler/Service/ItemKey.fs +++ b/src/Compiler/Service/ItemKey.fs @@ -180,8 +180,8 @@ and [] ItemKeyStoreBuilder() = eref.CompilationPath.MangledPath |> List.iter (fun str -> writeString str) - let rec writeILType (ilty: ILType) = - match ilty with + let rec writeILType (ilTy: ILType) = + match ilTy with | ILType.TypeVar n -> writeString "!" writeUInt16 n diff --git a/src/Compiler/Service/ServiceCompilerDiagnostics.fs b/src/Compiler/Service/ServiceCompilerDiagnostics.fs index f61b8ad9b6f..dcfed426252 100644 --- a/src/Compiler/Service/ServiceCompilerDiagnostics.fs +++ b/src/Compiler/Service/ServiceCompilerDiagnostics.fs @@ -2,7 +2,7 @@ namespace FSharp.Compiler.Diagnostics -open FSharp.Compiler.ErrorResolutionHints +open FSharp.Compiler.DiagnosticResolutionHints [] type FSharpDiagnosticKind = diff --git a/src/Compiler/Service/ServiceDeclarationLists.fs b/src/Compiler/Service/ServiceDeclarationLists.fs index cae7ebfe708..82fc0afae36 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fs +++ b/src/Compiler/Service/ServiceDeclarationLists.fs @@ -100,7 +100,7 @@ module DeclarationListHelpers = let layouts = [ for minfo in minfos -> - let prettyTyparInst, layout = NicePrint.prettyLayoutOfMethInfoFreeStyle infoReader m denv item.TyparInst minfo + let prettyTyparInst, layout = NicePrint.prettyLayoutOfMethInfoFreeStyle infoReader m denv item.TyparInstantiation minfo let xml = GetXmlCommentForMethInfoItem infoReader m item.Item minfo let tpsL = FormatTyparMapping denv prettyTyparInst let layout = toArray layout @@ -158,7 +158,7 @@ module DeclarationListHelpers = FormatItemDescriptionToToolTipElement displayFullName infoReader ad m denv { item with Item = Item.Value vref } | Item.Value vref | Item.CustomBuilder (_, vref) -> - let prettyTyparInst, resL = NicePrint.layoutQualifiedValOrMember denv infoReader item.TyparInst vref + let prettyTyparInst, resL = NicePrint.layoutQualifiedValOrMember denv infoReader item.TyparInstantiation vref let remarks = OutputFullName displayFullName pubpathOfValRef fullDisplayTextOfValRefAsLayout vref let tpsL = FormatTyparMapping denv prettyTyparInst let tpsL = List.map toArray tpsL @@ -199,7 +199,7 @@ module DeclarationListHelpers = // Format the type parameters to get e.g. ('a -> 'a) rather than ('?1234 -> '?1234) let tau = v.TauType // REVIEW: use _cxs here - let (prettyTyparInst, ptau), _cxs = PrettyTypes.PrettifyInstAndType denv.g (item.TyparInst, tau) + let (prettyTyparInst, ptau), _cxs = PrettyTypes.PrettifyInstAndType denv.g (item.TyparInstantiation, tau) let remarks = OutputFullName displayFullName pubpathOfValRef fullDisplayTextOfValRefAsLayout v let layout = wordL (tagText (FSComp.SR.typeInfoActiveRecognizer())) ^^ @@ -640,12 +640,12 @@ module internal DescriptionListsImpl = match tryDestFunTy denv.g tau with | ValueSome(arg, rtau) -> let args = tryDestRefTupleTy denv.g arg - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args rtau + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInstantiation args rtau // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group prettyParams, prettyRetTyL | _ -> - let _prettyTyparInst, prettyTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] tau + let _prettyTyparInst, prettyTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] tau [], prettyTyL match vref.ValReprInfo with @@ -678,7 +678,7 @@ module internal DescriptionListsImpl = | ValueSome(_, rtau) -> rtau | _ -> lastRetTy - let _prettyTyparInst, prettyFirstCurriedParams, prettyCurriedRetTyL, prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst firstCurriedParamDatas curriedRetTy + let _prettyTyparInst, prettyFirstCurriedParams, prettyCurriedRetTyL, prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInstantiation firstCurriedParamDatas curriedRetTy let prettyCurriedRetTyL = prettyCurriedRetTyL ^^ SepL.space ^^ prettyConstraintsL @@ -703,37 +703,37 @@ module internal DescriptionListsImpl = let caseTy = if aparity <= 1 then resTy else (argsOfAppTy g resTy)[apref.CaseIndex] - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args caseTy + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInstantiation args caseTy // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group prettyParams, prettyRetTyL | Item.ExnCase ecref -> let prettyParams = ecref |> recdFieldsOfExnDefRef |> List.mapi (PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedExceptionField) - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] g.exn_ty + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] g.exn_ty prettyParams, prettyRetTyL | Item.RecdField rfinfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] rfinfo.FieldType + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] rfinfo.FieldType [], prettyRetTyL | Item.AnonRecdField(_anonInfo, tys, i, _) -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] tys[i] + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] tys[i] [], prettyRetTyL | Item.ILField finfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (finfo.FieldType(amap, m)) + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] (finfo.FieldType(amap, m)) [], prettyRetTyL | Item.Event einfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo) + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo) [], prettyRetTyL | Item.Property(_, pinfo :: _) -> let paramDatas = pinfo.GetParamDatas(amap, m) let propTy = pinfo.GetPropertyType(amap, m) - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas propTy + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInstantiation paramDatas propTy // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group prettyParams, prettyRetTyL @@ -741,8 +741,8 @@ module internal DescriptionListsImpl = | Item.CtorGroup(_, minfo :: _) | Item.MethodGroup(_, minfo :: _, _) -> let paramDatas = minfo.GetParamDatas(amap, m, minfo.FormalMethodInst) |> List.head - let retTy = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas retTy + let retTy = minfo.GetFSharpReturnType(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInstantiation paramDatas retTy // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group prettyParams, prettyRetTyL @@ -759,27 +759,27 @@ module internal DescriptionListsImpl = let argNamesAndTys = ParamNameAndTypesOfUnaryCustomOperation g minfo let argTys, _ = PrettyTypes.PrettifyTypes g (argNamesAndTys |> List.map (fun (ParamNameAndType(_, ty)) -> ty)) let paramDatas = (argNamesAndTys, argTys) ||> List.map2 (fun (ParamNameAndType(nmOpt, _)) argTy -> ParamData(false, false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, argTy)) - let retTy = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas retTy + let retTy = minfo.GetFSharpReturnType(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInstantiation paramDatas retTy // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group prettyParams, prettyRetTyL | Some _ -> - let retTy = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] retTy + let retTy = minfo.GetFSharpReturnType(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] retTy [], prettyRetTyL // no parameter data available for binary operators like 'zip', 'join' and 'groupJoin' since they use bespoke syntax | Item.FakeInterfaceCtor ty -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] ty + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInstantiation [] ty [], prettyRetTyL | Item.DelegateCtor delty -> let (SigOfFunctionForDelegate(_, _, _, delFuncTy)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere // No need to pass more generic type information in here since the instanitations have already been applied - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst [ParamData(false, false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, delFuncTy)] delty + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInstantiation [ParamData(false, false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, delFuncTy)] delty // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned // for display as part of the method group diff --git a/src/Compiler/Service/ServiceLexing.fs b/src/Compiler/Service/ServiceLexing.fs index a823215c5f3..e3e5aa58280 100644 --- a/src/Compiler/Service/ServiceLexing.fs +++ b/src/Compiler/Service/ServiceLexing.fs @@ -532,38 +532,38 @@ module internal LexerStateEncoding = (colorState, ncomments, pos, ifDefs, hardwhite, stringKind, stringNest) - let encodeLexInt lightStatus (lexcont: LexerContinuation) = + let encodeLexInt indentationSyntaxStatus (lexcont: LexerContinuation) = match lexcont with | LexCont.Token (ifdefs, stringNest) -> - encodeLexCont (FSharpTokenizerColorState.Token, 0L, pos0, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.Token, 0L, pos0, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.IfDefSkip (ifdefs, stringNest, n, m) -> - encodeLexCont (FSharpTokenizerColorState.IfDefSkip, int64 n, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.IfDefSkip, int64 n, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.EndLine(ifdefs, stringNest, econt) -> match econt with | LexerEndlineContinuation.Skip(n, m) -> - encodeLexCont (FSharpTokenizerColorState.EndLineThenSkip, int64 n, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.EndLineThenSkip, int64 n, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexerEndlineContinuation.Token -> - encodeLexCont (FSharpTokenizerColorState.EndLineThenToken, 0L, pos0, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.EndLineThenToken, 0L, pos0, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.String (ifdefs, stringNest, style, kind, m) -> let state = match style with | LexerStringStyle.SingleQuote -> FSharpTokenizerColorState.String | LexerStringStyle.Verbatim -> FSharpTokenizerColorState.VerbatimString | LexerStringStyle.TripleQuote -> FSharpTokenizerColorState.TripleQuoteString - encodeLexCont (state, 0L, m.Start, ifdefs, lightStatus, kind, stringNest) + encodeLexCont (state, 0L, m.Start, ifdefs, indentationSyntaxStatus, kind, stringNest) | LexCont.Comment (ifdefs, stringNest, n, m) -> - encodeLexCont (FSharpTokenizerColorState.Comment, int64 n, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.Comment, int64 n, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.SingleLineComment (ifdefs, stringNest, n, m) -> - encodeLexCont (FSharpTokenizerColorState.SingleLineComment, int64 n, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.SingleLineComment, int64 n, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.StringInComment (ifdefs, stringNest, style, n, m) -> let state = match style with | LexerStringStyle.SingleQuote -> FSharpTokenizerColorState.StringInComment | LexerStringStyle.Verbatim -> FSharpTokenizerColorState.VerbatimStringInComment | LexerStringStyle.TripleQuote -> FSharpTokenizerColorState.TripleQuoteStringInComment - encodeLexCont (state, int64 n, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (state, int64 n, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) | LexCont.MLOnly (ifdefs, stringNest, m) -> - encodeLexCont (FSharpTokenizerColorState.CamlOnly, 0L, m.Start, ifdefs, lightStatus, LexerStringKind.String, stringNest) + encodeLexCont (FSharpTokenizerColorState.CamlOnly, 0L, m.Start, ifdefs, indentationSyntaxStatus, LexerStringKind.String, stringNest) let decodeLexInt (state: FSharpTokenizerLexState) = let tag, n1, p1, ifdefs, lightSyntaxStatusInitial, stringKind, stringNest = decodeLexCont state @@ -692,10 +692,10 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, // Call the given continuation, reusing the same 'lexargs' each time but adjust // its mutable entries to set up the right state - let callLexCont lexcont lightStatus skip = + let callLexCont lexcont indentationSyntaxStatus skip = // Set up the arguments to lexing - lexargs.lightStatus <- lightStatus + lexargs.indentationSyntaxStatus <- indentationSyntaxStatus match lexcont with | LexCont.EndLine (ifdefs, stringNest, cont) -> @@ -758,7 +758,7 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, let rightc = rightc - 1 struct (leftc, rightc) - let getTokenWithPosition lexcont lightStatus = + let getTokenWithPosition lexcont indentationSyntaxStatus = // Column of token // Get the token & position - either from a stack or from the lexer try @@ -766,7 +766,7 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, true, tokenStack.Pop() else // Choose which lexer entry point to call and call it - let token = callLexCont lexcont lightStatus skip + let token = callLexCont lexcont indentationSyntaxStatus skip let struct (leftc, rightc) = columnsOfCurrentToken() // Splits tokens like ">." into multiple tokens - this duplicates behavior from the 'lexfilter' @@ -834,11 +834,11 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse use unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> DiscardErrorsLogger) - let lightStatus, lexcont = LexerStateEncoding.decodeLexInt lexState - let lightStatus = IndentationAwareSyntaxStatus(lightStatus, false) + let indentationSyntaxStatus, lexcont = LexerStateEncoding.decodeLexInt lexState + let indentationSyntaxStatus = IndentationAwareSyntaxStatus(indentationSyntaxStatus, false) // Grab a token - let isCached, (token, leftc, rightc) = getTokenWithPosition lexcont lightStatus + let isCached, (token, leftc, rightc) = getTokenWithPosition lexcont indentationSyntaxStatus // Check for end-of-string and failure let tokenDataOption, lexcontFinal, tokenTag = @@ -876,13 +876,13 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, // Check for patterns like #-IDENT and see if they look like meta commands for .fsx files. If they do then merge them into a single token. let tokenDataOption, lexintFinal = - let lexintFinal = LexerStateEncoding.encodeLexInt lightStatus.Status lexcontFinal + let lexintFinal = LexerStateEncoding.encodeLexInt indentationSyntaxStatus.Status lexcontFinal match tokenDataOption, singleLineTokenState, tokenTagToTokenId tokenTag with | Some tokenData, SingleLineTokenState.BeforeHash, TOKEN_HASH -> // Don't allow further matches. singleLineTokenState <- SingleLineTokenState.NoFurtherMatchPossible // Peek at the next token - let isCached, (nextToken, _, rightc) = getTokenWithPosition lexcont lightStatus + let isCached, (nextToken, _, rightc) = getTokenWithPosition lexcont indentationSyntaxStatus match nextToken with | IDENT possibleMetaCommand -> match fsx, possibleMetaCommand with @@ -909,7 +909,7 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, // Merge both tokens into one. let lexcontFinal = if isCached then lexcont else LexerStateEncoding.computeNextLexState token lexcont let tokenData = {tokenData with RightColumn=rightc;ColorClass=FSharpTokenColorKind.PreprocessorKeyword;CharClass=FSharpTokenCharKind.Keyword;FSharpTokenTriggerClass=FSharpTokenTriggerClass.None} - let lexintFinal = LexerStateEncoding.encodeLexInt lightStatus.Status lexcontFinal + let lexintFinal = LexerStateEncoding.encodeLexInt indentationSyntaxStatus.Status lexcontFinal Some tokenData, lexintFinal | _ -> tokenDataOption, lexintFinal | _ -> tokenDataOption, lexintFinal @@ -1521,7 +1521,7 @@ type FSharpToken = [] module FSharpLexerImpl = - let lexWithDiagnosticsLogger (text: ISourceText) conditionalDefines (flags: FSharpLexerFlags) reportLibraryOnlyFeatures langVersion errorLogger onToken pathMap (ct: CancellationToken) = + let lexWithDiagnosticsLogger (text: ISourceText) conditionalDefines (flags: FSharpLexerFlags) reportLibraryOnlyFeatures langVersion diagnosticsLogger onToken pathMap (ct: CancellationToken) = let canSkipTrivia = (flags &&& FSharpLexerFlags.SkipTrivia) = FSharpLexerFlags.SkipTrivia let isLightSyntaxOn = (flags &&& FSharpLexerFlags.LightSyntaxOn) = FSharpLexerFlags.LightSyntaxOn let isCompiling = (flags &&& FSharpLexerFlags.Compiling) = FSharpLexerFlags.Compiling @@ -1529,15 +1529,15 @@ module FSharpLexerImpl = let canUseLexFilter = (flags &&& FSharpLexerFlags.UseLexFilter) = FSharpLexerFlags.UseLexFilter let lexbuf = UnicodeLexing.SourceTextAsLexbuf(reportLibraryOnlyFeatures, langVersion, text) - let lightStatus = IndentationAwareSyntaxStatus(isLightSyntaxOn, true) - let lexargs = mkLexargs (conditionalDefines, lightStatus, LexResourceManager(0), [], errorLogger, pathMap) + let indentationSyntaxStatus = IndentationAwareSyntaxStatus(isLightSyntaxOn, true) + let lexargs = mkLexargs (conditionalDefines, indentationSyntaxStatus, LexResourceManager(0), [], diagnosticsLogger, pathMap) let lexargs = { lexargs with applyLineDirectives = isCompiling } let getNextToken = let lexer = Lexer.token lexargs canSkipTrivia if canUseLexFilter then - let lexFilter = LexFilter.LexFilter(lexargs.lightStatus, isCompilingFSharpCore, lexer, lexbuf) + let lexFilter = LexFilter.LexFilter(lexargs.indentationSyntaxStatus, isCompilingFSharpCore, lexer, lexbuf) (fun _ -> lexFilter.GetToken()) else lexer @@ -1551,8 +1551,8 @@ module FSharpLexerImpl = onToken (getNextToken lexbuf) lexbuf.LexemeRange let lex text conditionalDefines flags reportLibraryOnlyFeatures langVersion lexCallback pathMap ct = - let errorLogger = CompilationDiagnosticLogger("Lexer", FSharpDiagnosticOptions.Default) - lexWithDiagnosticsLogger text conditionalDefines flags reportLibraryOnlyFeatures langVersion errorLogger lexCallback pathMap ct + let diagnosticsLogger = CompilationDiagnosticLogger("Lexer", FSharpDiagnosticOptions.Default) + lexWithDiagnosticsLogger text conditionalDefines flags reportLibraryOnlyFeatures langVersion diagnosticsLogger lexCallback pathMap ct [] type FSharpLexer = diff --git a/src/Compiler/Service/service.fs b/src/Compiler/Service/service.fs index 3cbbb6cd3c9..47fb5591178 100644 --- a/src/Compiler/Service/service.fs +++ b/src/Compiler/Service/service.fs @@ -94,24 +94,24 @@ module CompileHelpers = oneDiagnostic main List.iter oneDiagnostic related - let errorLogger = + let diagnosticsLogger = { new DiagnosticsLogger("CompileAPI") with member _.DiagnosticSink(exn, isError) = diagnosticSink isError exn member _.ErrorCount = diagnostics - |> Seq.filter (fun diag -> diag.Severity = FSharpDiagnosticSeverity.Error) + |> Seq.filter (fun diagnostic -> diagnostic.Severity = FSharpDiagnosticSeverity.Error) |> Seq.length } let loggerProvider = { new DiagnosticsLoggerProvider() with - member _.CreateDiagnosticsLoggerUpToMaxErrors(_tcConfigBuilder, _exiter) = errorLogger } - diagnostics, errorLogger, loggerProvider + member _.CreateDiagnosticsLoggerUpToMaxErrors(_tcConfigBuilder, _exiter) = diagnosticsLogger } + diagnostics, diagnosticsLogger, loggerProvider - let tryCompile errorLogger f = + let tryCompile diagnosticsLogger f = use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - use unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> errorLogger) + use unwindEL_2 = PushDiagnosticsLoggerPhaseUntilUnwind (fun _ -> diagnosticsLogger) let exiter = { new Exiter with member x.Exit n = raise StopProcessing } try f exiter @@ -123,22 +123,22 @@ module CompileHelpers = /// Compile using the given flags. Source files names are resolved via the FileSystem API. The output file must be given by a -o flag. let compileFromArgs (ctok, argv: string[], legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) = - let diagnostics, errorLogger, loggerProvider = mkCompilationDiagnosticsHandlers() + let diagnostics, diagnosticsLogger, loggerProvider = mkCompilationDiagnosticsHandlers() let result = - tryCompile errorLogger (fun exiter -> + tryCompile diagnosticsLogger (fun exiter -> CompileFromCommandLineArguments (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)true, ReduceMemoryFlag.Yes, CopyFSharpCoreFlag.No, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) diagnostics.ToArray(), result let compileFromAsts (ctok, legacyReferenceResolver, asts, assemblyName, outFile, dependencies, noframework, pdbFile, executable, tcImportsCapture, dynamicAssemblyCreator) = - let diagnostics, errorLogger, loggerProvider = mkCompilationDiagnosticsHandlers() + let diagnostics, diagnosticsLogger, loggerProvider = mkCompilationDiagnosticsHandlers() let executable = defaultArg executable true let target = if executable then CompilerTarget.ConsoleExe else CompilerTarget.Dll let result = - tryCompile errorLogger (fun exiter -> + tryCompile diagnosticsLogger (fun exiter -> CompileFromSyntaxTrees (ctok, legacyReferenceResolver, ReduceMemoryFlag.Yes, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) diagnostics.ToArray(), result @@ -832,8 +832,8 @@ type BackgroundCompiler( let tcDiagnostics = tcInfo.TcDiagnostics let tcDependencyFiles = tcInfo.tcDependencyFiles let diagnostics = - [| yield! creationDiags; - yield! DiagnosticHelpers.CreateDiagnostics (diagnosticsOptions, true, fileName, tcDiagnostics, suggestNamesForErrors) |] + [| yield! creationDiags + yield! DiagnosticHelpers.CreateDiagnostics (diagnosticsOptions, true, fileName, tcDiagnostics, suggestNamesForErrors) |] let getAssemblyData() = match tcAssemblyDataOpt with diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index e9ccc85ddc8..e2416af351e 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1338,7 +1338,7 @@ module FSharpExprConvert = FSharpExpr(cenv, Some(fun () -> ConvExpr cenv env expr), E.Unused, expr.Range, tyOfExpr cenv.g expr) /// The contents of the F# assembly as provided through the compiler API -type FSharpAssemblyContents(cenv: SymbolEnv, mimpls: TypedImplFile list) = +type FSharpAssemblyContents(cenv: SymbolEnv, mimpls: CheckedImplFile list) = new (tcGlobals, thisCcu, thisCcuType, tcImports, mimpls) = FSharpAssemblyContents(SymbolEnv(tcGlobals, thisCcu, thisCcuType, tcImports), mimpls) @@ -1352,7 +1352,7 @@ and FSharpImplementationFileDeclaration = and FSharpImplementationFileContents(cenv, mimpl) = let g = cenv.g - let (TImplFile (qname, _pragmas, ModuleOrNamespaceContentsWithSig(_, mdef, _), hasExplicitEntryPoint, isScript, _anonRecdTypes, _)) = mimpl + let (CheckedImplFile (qname, _pragmas, _, contents, hasExplicitEntryPoint, isScript, _anonRecdTypes, _)) = mimpl let rec getBind (bind: Binding) = let v = bind.Var assert v.IsCompiledAsTopLevel @@ -1366,7 +1366,7 @@ and FSharpImplementationFileContents(cenv, mimpl) = let e = FSharpExprConvert.ConvExprOnDemand cenv env body FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vslR, e) - and getDecls mdef = + and getDeclarations mdef = match mdef with | TMDefRec(_isRec, _opens, tycons, mbinds, _m) -> [ for tycon in tycons do @@ -1376,11 +1376,9 @@ and FSharpImplementationFileContents(cenv, mimpl) = match mbind with | ModuleOrNamespaceBinding.Module(mspec, def) -> let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) - yield FSharpImplementationFileDeclaration.Entity (entity, getDecls def) + yield FSharpImplementationFileDeclaration.Entity (entity, getDeclarations def) | ModuleOrNamespaceBinding.Binding bind -> yield getBind bind ] - | TMWithSig mexpr -> - getDecls mexpr.Contents | TMDefLet(bind, _m) -> [ yield getBind bind ] | TMDefOpens _ -> @@ -1389,13 +1387,13 @@ and FSharpImplementationFileContents(cenv, mimpl) = [ let expr = FSharpExprConvert.ConvExprOnDemand cenv (ExprTranslationEnv.Empty(g)) expr yield FSharpImplementationFileDeclaration.InitAction expr ] | TMDefs mdefs -> - [ for mdef in mdefs do yield! getDecls mdef ] + [ for mdef in mdefs do yield! getDeclarations mdef ] member _.QualifiedName = qname.Text member _.FileName = qname.Range.FileName - member _.Declarations = getDecls mdef + member _.Declarations = getDeclarations contents member _.HasExplicitEntryPoint = hasExplicitEntryPoint diff --git a/src/Compiler/Symbols/Exprs.fsi b/src/Compiler/Symbols/Exprs.fsi index 0cfd58f16f9..e05c7b31560 100644 --- a/src/Compiler/Symbols/Exprs.fsi +++ b/src/Compiler/Symbols/Exprs.fsi @@ -16,7 +16,7 @@ type public FSharpAssemblyContents = thisCcu: CcuThunk * thisCcuType: ModuleOrNamespaceType option * tcImports: TcImports * - mimpls: TypedImplFile list -> + mimpls: CheckedImplFile list -> FSharpAssemblyContents /// The contents of the implementation files in the assembly @@ -24,7 +24,7 @@ type public FSharpAssemblyContents = /// Represents the definitional contents of a single file or fragment in an assembly, as seen by the F# language type public FSharpImplementationFileContents = - internal new: cenv: SymbolEnv * mimpl: TypedImplFile -> FSharpImplementationFileContents + internal new: cenv: SymbolEnv * mimpl: CheckedImplFile -> FSharpImplementationFileContents /// The qualified name acts to fully-qualify module specifications and implementations member QualifiedName: string diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index 09e118a3ea4..a99f02dbc44 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -71,30 +71,31 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, message: str sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName s.Line (s.Column + 1) e.Line (e.Column + 1) subcategory severity message /// Decompose a warning or error into parts: position, severity, message, error number - static member CreateFromException(diag, severity, fallbackRange: range, suggestNames: bool) = - let m = match GetRangeOfDiagnostic diag with Some m -> m | None -> fallbackRange - let msg = bufs (fun buf -> OutputPhasedDiagnostic buf diag false suggestNames) - let errorNum = GetDiagnosticNumber diag - FSharpDiagnostic(m, severity, msg, diag.Subcategory(), errorNum, "FS") + static member CreateFromException(diagnostic, severity, fallbackRange: range, suggestNames: bool) = + let m = match GetRangeOfDiagnostic diagnostic with Some m -> m | None -> fallbackRange + let msg = buildString (fun buf -> OutputPhasedDiagnostic buf diagnostic false suggestNames) + let errorNum = GetDiagnosticNumber diagnostic + FSharpDiagnostic(m, severity, msg, diagnostic.Subcategory(), errorNum, "FS") /// Decompose a warning or error into parts: position, severity, message, error number - static member CreateFromExceptionAndAdjustEof(diag, severity, fallbackRange: range, (linesCount: int, lastLength: int), suggestNames: bool) = - let diag = FSharpDiagnostic.CreateFromException(diag, severity, fallbackRange, suggestNames) + static member CreateFromExceptionAndAdjustEof(diagnostic, severity, fallbackRange: range, (linesCount: int, lastLength: int), suggestNames: bool) = + let diagnostic = FSharpDiagnostic.CreateFromException(diagnostic, severity, fallbackRange, suggestNames) - // Adjust to make sure that errors reported at Eof are shown at the linesCount - let startline, schange = min (Line.toZ diag.Range.StartLine, false) (linesCount, true) - let endline, echange = min (Line.toZ diag.Range.EndLine, false) (linesCount, true) + // Adjust to make sure that diagnostics reported at Eof are shown at the linesCount + let startLine, startChanged = min (Line.toZ diagnostic.Range.StartLine, false) (linesCount, true) + let endLine, endChanged = min (Line.toZ diagnostic.Range.EndLine, false) (linesCount, true) - if not (schange || echange) then diag + if not (startChanged || endChanged) then + diagnostic else - let r = if schange then diag.WithStart(mkPos startline lastLength) else diag - if echange then r.WithEnd(mkPos endline (1 + lastLength)) else r + let r = if startChanged then diagnostic.WithStart(mkPos startLine lastLength) else diagnostic + if endChanged then r.WithEnd(mkPos endLine (1 + lastLength)) else r static member NewlineifyErrorString(message) = NewlineifyErrorString(message) static member NormalizeErrorString(text) = NormalizeErrorString(text) - static member Create(severity: FSharpDiagnosticSeverity, message: string, number: int, range: range, ?numberPrefix: string, ?subcategory: string) = + static member Create(severity, message, number, range, ?numberPrefix, ?subcategory) = let subcategory = defaultArg subcategory BuildPhaseSubcategory.TypeCheck let numberPrefix = defaultArg numberPrefix "FS" FSharpDiagnostic(range, severity, message, subcategory, number, numberPrefix) @@ -103,17 +104,16 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, message: str [] type DiagnosticsScope() = let mutable diags = [] - let mutable firstError = None let unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck let unwindEL = PushDiagnosticsLoggerPhaseUntilUnwind (fun _oldLogger -> { new DiagnosticsLogger("DiagnosticsScope") with - member x.DiagnosticSink(exn, severity) = - let err = FSharpDiagnostic.CreateFromException(exn, severity, range.Zero, false) - diags <- err :: diags - if severity = FSharpDiagnosticSeverity.Error && firstError.IsNone then - firstError <- Some err.Message - member x.ErrorCount = diags.Length }) + + member _.DiagnosticSink(diagnostic, severity) = + let diagnostic = FSharpDiagnostic.CreateFromException(diagnostic, severity, range.Zero, false) + diags <- diagnostic :: diags + + member _.ErrorCount = diags.Length }) member _.Errors = diags |> List.filter (fun error -> error.Severity = FSharpDiagnosticSeverity.Error) @@ -129,8 +129,6 @@ type DiagnosticsScope() = unwindEL.Dispose() (* unwind pushes when DiagnosticsScope disposes *) unwindBP.Dispose() - member _.FirstError with get() = firstError and set v = firstError <- v - /// Used at entry points to FSharp.Compiler.Service (service.fsi) which manipulate symbols and /// perform other operations which might expose us to either bona-fide F# error messages such /// "missing assembly" (for incomplete assembly reference sets), or, if there is a compiler bug, @@ -141,7 +139,7 @@ type DiagnosticsScope() = /// autocomplete, then the error message is shown in replacement of the text (rather than crashing Visual /// Studio, or swallowing the exception completely) static member Protect<'a> (m: range) (f: unit->'a) (err: string->'a): 'a = - use errorScope = new DiagnosticsScope() + use diagnosticsScope = new DiagnosticsScope() let res = try Some (f()) @@ -150,58 +148,65 @@ type DiagnosticsScope() = try errorRecovery e m with _ -> - // If error recovery fails, then we have an internal compiler error. In this case, we show the whole stack - // in the extra message, should the extra message be used. - errorScope.FirstError <- Some (e.ToString()) + () None match res with | Some res -> res | None -> - match errorScope.TryGetFirstErrorText() with + match diagnosticsScope.TryGetFirstErrorText() with | Some text -> err text | None -> err "" -/// An error logger that capture errors, filtering them according to warning levels etc. +/// A diagnostics logger that capture diagnostics, filtering them according to warning levels etc. type internal CompilationDiagnosticLogger (debugName: string, options: FSharpDiagnosticOptions) = inherit DiagnosticsLogger("CompilationDiagnosticLogger("+debugName+")") let mutable errorCount = 0 let diagnostics = ResizeArray<_>() - override _.DiagnosticSink(err, severity) = - if ReportDiagnosticAsError options (err, severity) then - diagnostics.Add(err, FSharpDiagnosticSeverity.Error) + override _.DiagnosticSink(diagnostic, severity) = + if ReportDiagnosticAsError options (diagnostic, severity) then + diagnostics.Add(diagnostic, FSharpDiagnosticSeverity.Error) errorCount <- errorCount + 1 - elif ReportDiagnosticAsWarning options (err, severity) then - diagnostics.Add(err, FSharpDiagnosticSeverity.Warning) - elif ReportDiagnosticAsInfo options (err, severity) then - diagnostics.Add(err, severity) - override x.ErrorCount = errorCount + elif ReportDiagnosticAsWarning options (diagnostic, severity) then + diagnostics.Add(diagnostic, FSharpDiagnosticSeverity.Warning) + elif ReportDiagnosticAsInfo options (diagnostic, severity) then + diagnostics.Add(diagnostic, severity) + + override _.ErrorCount = errorCount - member x.GetDiagnostics() = diagnostics.ToArray() + member _.GetDiagnostics() = diagnostics.ToArray() module DiagnosticHelpers = - let ReportDiagnostic (options: FSharpDiagnosticOptions, allErrors, mainInputFileName, fileInfo, (exn, severity), suggestNames) = + let ReportDiagnostic (options: FSharpDiagnosticOptions, allErrors, mainInputFileName, fileInfo, diagnostic, severity, suggestNames) = [ let severity = - if ReportDiagnosticAsError options (exn, severity) then FSharpDiagnosticSeverity.Error - else severity - if (severity = FSharpDiagnosticSeverity.Error || ReportDiagnosticAsWarning options (exn, severity) || ReportDiagnosticAsInfo options (exn, severity)) then - let oneError exn = + if ReportDiagnosticAsError options (diagnostic, severity) then + FSharpDiagnosticSeverity.Error + else + severity + + if severity = FSharpDiagnosticSeverity.Error || + ReportDiagnosticAsWarning options (diagnostic, severity) || + ReportDiagnosticAsInfo options (diagnostic, severity) then + + let oneDiagnostic diagnostic = [ // 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 = FSharpDiagnostic.CreateFromExceptionAndAdjustEof (exn, severity, fallbackRange, fileInfo, suggestNames) - let fileName = ei.Range.FileName + let diagnostic = FSharpDiagnostic.CreateFromExceptionAndAdjustEof (diagnostic, severity, fallbackRange, fileInfo, suggestNames) + let fileName = diagnostic.Range.FileName if allErrors || fileName = mainInputFileName || fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation then - yield ei ] + yield diagnostic ] + + let mainDiagnostic, relatedDiagnostics = SplitRelatedDiagnostics diagnostic + + yield! oneDiagnostic mainDiagnostic - let mainError, relatedErrors = SplitRelatedDiagnostics exn - yield! oneError mainError - for e in relatedErrors do - yield! oneError e ] + for e in relatedDiagnostics do + yield! oneDiagnostic e ] - let CreateDiagnostics (options, allErrors, mainInputFileName, errors, suggestNames) = + let CreateDiagnostics (options, allErrors, mainInputFileName, diagnostics, suggestNames) = let fileInfo = (Int32.MaxValue, Int32.MaxValue) - [| for exn, severity in errors do - yield! ReportDiagnostic (options, allErrors, mainInputFileName, fileInfo, (exn, severity), suggestNames) |] + [| for diagnostic, severity in diagnostics do + yield! ReportDiagnostic (options, allErrors, mainInputFileName, fileInfo, diagnostic, severity, suggestNames) |] diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fsi b/src/Compiler/Symbols/FSharpDiagnostic.fsi index 2e5ea40dcf2..1e50fd22d0f 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fsi +++ b/src/Compiler/Symbols/FSharpDiagnostic.fsi @@ -67,7 +67,7 @@ type public FSharpDiagnostic = FSharpDiagnostic static member internal CreateFromExceptionAndAdjustEof: - diag: PhasedDiagnostic * + diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity * range * lastPosInFile: (int * int) * @@ -75,7 +75,8 @@ type public FSharpDiagnostic = FSharpDiagnostic static member internal CreateFromException: - diag: PhasedDiagnostic * severity: FSharpDiagnosticSeverity * range * suggestNames: bool -> FSharpDiagnostic + diagnostic: PhasedDiagnostic * severity: FSharpDiagnosticSeverity * range * suggestNames: bool -> + FSharpDiagnostic /// Newlines are recognized and replaced with (ASCII 29, the 'group separator'), /// which is decoded by the IDE with 'NewlineifyErrorString' back into newlines, so that multi-line errors can be displayed in QuickInfo @@ -117,7 +118,8 @@ module internal DiagnosticHelpers = allErrors: bool * mainInputFileName: string * fileInfo: (int * int) * - (PhasedDiagnostic * FSharpDiagnosticSeverity) * + diagnostic: PhasedDiagnostic * + severity: FSharpDiagnosticSeverity * suggestNames: bool -> FSharpDiagnostic list diff --git a/src/Compiler/Symbols/SymbolHelpers.fs b/src/Compiler/Symbols/SymbolHelpers.fs index 5def8ebe7be..f65cd4541cc 100644 --- a/src/Compiler/Symbols/SymbolHelpers.fs +++ b/src/Compiler/Symbols/SymbolHelpers.fs @@ -315,7 +315,7 @@ module internal SymbolHelpers = else mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) - let FormatTyparMapping denv (prettyTyparInst: TyparInst) = + let FormatTyparMapping denv (prettyTyparInst: TyparInstantiation) = [ for tp, ty in prettyTyparInst -> wordL (tagTypeParameter ("'" + tp.DisplayName)) ^^ wordL (tagText (FSComp.SR.descriptionWordIs())) ^^ NicePrint.layoutType denv ty ] @@ -500,19 +500,19 @@ module internal SymbolHelpers = | Item.AnonRecdField(anon, _argTys, i, _) -> anon.SortedNames[i] | Item.RecdField rfinfo -> fullDisplayTextOfRecdFieldRef rfinfo.RecdFieldRef | Item.NewDef id -> id.idText - | Item.ILField finfo -> bufs (fun os -> NicePrint.outputType denv os finfo.ApparentEnclosingType; bprintf os ".%s" finfo.FieldName) - | Item.Event einfo -> bufs (fun os -> NicePrint.outputTyconRef denv os einfo.DeclaringTyconRef; bprintf os ".%s" einfo.EventName) - | Item.Property(_, pinfo :: _) -> bufs (fun os -> NicePrint.outputTyconRef denv os pinfo.DeclaringTyconRef; bprintf os ".%s" pinfo.PropertyName) + | Item.ILField finfo -> buildString (fun os -> NicePrint.outputType denv os finfo.ApparentEnclosingType; bprintf os ".%s" finfo.FieldName) + | Item.Event einfo -> buildString (fun os -> NicePrint.outputTyconRef denv os einfo.DeclaringTyconRef; bprintf os ".%s" einfo.EventName) + | Item.Property(_, pinfo :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os pinfo.DeclaringTyconRef; bprintf os ".%s" pinfo.PropertyName) | Item.CustomOperation (customOpName, _, _) -> customOpName - | Item.CtorGroup(_, minfo :: _) -> bufs (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef) - | Item.MethodGroup(_, _, Some minfo) -> bufs (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) - | Item.MethodGroup(_, minfo :: _, _) -> bufs (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) - | Item.UnqualifiedType (tcref :: _) -> bufs (fun os -> NicePrint.outputTyconRef denv os tcref) + | Item.CtorGroup(_, minfo :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef) + | Item.MethodGroup(_, _, Some minfo) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) + | Item.MethodGroup(_, minfo :: _, _) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) + | Item.UnqualifiedType (tcref :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os tcref) | Item.FakeInterfaceCtor ty | Item.DelegateCtor ty | Item.Types(_, ty :: _) -> match tryTcrefOfAppTy g ty with - | ValueSome tcref -> bufs (fun os -> NicePrint.outputTyconRef denv os tcref) + | ValueSome tcref -> buildString (fun os -> NicePrint.outputTyconRef denv os tcref) | _ -> "" | Item.ModuleOrNamespaces(modref :: _ as modrefs) -> let definiteNamespace = modrefs |> List.forall (fun modref -> modref.IsNamespace) @@ -839,9 +839,9 @@ module internal SymbolHelpers = ignore m match item.Item with | Item.MethodGroup(nm, minfos, orig) -> - minfos |> List.map (fun minfo -> { Item = Item.MethodGroup(nm, [minfo], orig); TyparInst = item.TyparInst }) + minfos |> List.map (fun minfo -> { Item = Item.MethodGroup(nm, [minfo], orig); TyparInstantiation = item.TyparInstantiation }) | Item.CtorGroup(nm, cinfos) -> - cinfos |> List.map (fun minfo -> { Item = Item.CtorGroup(nm, [minfo]); TyparInst = item.TyparInst }) + cinfos |> List.map (fun minfo -> { Item = Item.CtorGroup(nm, [minfo]); TyparInstantiation = item.TyparInstantiation }) | Item.FakeInterfaceCtor _ | Item.DelegateCtor _ -> [item] | Item.NewDef _ diff --git a/src/Compiler/Symbols/SymbolHelpers.fsi b/src/Compiler/Symbols/SymbolHelpers.fsi index d0057c47496..b5ee20fa8b3 100755 --- a/src/Compiler/Symbols/SymbolHelpers.fsi +++ b/src/Compiler/Symbols/SymbolHelpers.fsi @@ -75,4 +75,4 @@ module internal SymbolHelpers = val GetXmlCommentForMethInfoItem: infoReader: InfoReader -> m: range -> d: Item -> minfo: MethInfo -> FSharpXmlDoc - val FormatTyparMapping: denv: DisplayEnv -> prettyTyparInst: TyparInst -> Layout list + val FormatTyparMapping: denv: DisplayEnv -> prettyTyparInst: TyparInstantiation -> Layout list diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index 292457e6e67..58172c2b23f 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -1681,7 +1681,7 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | E e -> e.GetDelegateType(cenv.amap, range0) | P p -> p.GetPropertyType(cenv.amap, range0) | M m | C m -> - let retTy = m.GetFSharpReturnTy(cenv.amap, range0, m.FormalMethodInst) + let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) mkIteratedFunTy cenv.g (List.map (mkRefTupledTy cenv.g) argTysl) retTy | V v -> v.TauType @@ -2041,7 +2041,7 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | V v -> match v.ValReprInfo with | None -> - let _, tau = v.TypeScheme + let _, tau = v.GeneralizedType if isFunTy cenv.g tau then let argTysl, _typ = stripFunTy cenv.g tau [ for ty in argTysl do @@ -2088,12 +2088,12 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, x.DeclarationLocationOpt) | M m | C m -> // INCOMPLETENESS: Attribs is empty here, so we can't look at return attributes for .NET or F# methods - let retTy = m.GetFSharpReturnTy(cenv.amap, range0, m.FormalMethodInst) + let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, x.DeclarationLocationOpt) | V v -> match v.ValReprInfo with | None -> - let _, tau = v.TypeScheme + let _, tau = v.GeneralizedType let _argTysl, retTy = stripFunTy cenv.g tau FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, x.DeclarationLocationOpt) | Some (ValReprInfo(_typars, argInfos, retInfo)) -> @@ -2242,7 +2242,7 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | E e -> e.GetDelegateType(cenv.amap, range0) | P p -> p.GetPropertyType(cenv.amap, range0) | M m | C m -> - let retTy = m.GetFSharpReturnTy(cenv.amap, range0, m.FormalMethodInst) + let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) mkIteratedFunTy cenv.g (List.map (mkRefTupledTy cenv.g) argTysl) retTy | V v -> v.TauType @@ -2260,7 +2260,7 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | P _ | C _ -> None | M m -> - let retTy = m.GetFSharpReturnTy(cenv.amap, range0, m.FormalMethodInst) + let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) NicePrint.layoutType (displayContext.Contents cenv.g) retTy |> LayoutRender.toArray |> Some diff --git a/src/Compiler/SyntaxTree/LexFilter.fs b/src/Compiler/SyntaxTree/LexFilter.fs index 5396ffdaabd..31f515eead2 100644 --- a/src/Compiler/SyntaxTree/LexFilter.fs +++ b/src/Compiler/SyntaxTree/LexFilter.fs @@ -14,6 +14,7 @@ open FSharp.Compiler.Features open FSharp.Compiler.Lexhelp open FSharp.Compiler.ParseHelpers open FSharp.Compiler.Parser +open FSharp.Compiler.UnicodeLexing let debug = false @@ -575,7 +576,12 @@ type PositionWithColumn = //---------------------------------------------------------------------------- // build a LexFilter //--------------------------------------------------------------------------*) -type LexFilterImpl (lightStatus: IndentationAwareSyntaxStatus, compilingFsLib, lexer, lexbuf: UnicodeLexing.Lexbuf) = +type LexFilterImpl ( + indentationSyntaxStatus: IndentationAwareSyntaxStatus, + compilingFSharpCore, + lexer: (Lexbuf -> token), + lexbuf: Lexbuf +) = //---------------------------------------------------------------------------- // Part I. Building a new lex stream from an old @@ -1381,7 +1387,7 @@ type LexFilterImpl (lightStatus: IndentationAwareSyntaxStatus, compilingFsLib, l // (# "unbox.any !0" type ('T) x : 'T #) // where the type keyword is used inside an expression, so we must exempt FSharp.Core from some extra failed-parse-diagnostics-recovery-processing of the 'type' keyword let mutable effectsToDo = [] - if not compilingFsLib then + if not compilingFSharpCore then // ... <<< code with unmatched ( or [ or { or [| >>> ... "type" ... // We want a TYPE or MODULE keyword to close any currently-open "expression" contexts, as though there were close delimiters in the file, so: let rec nextOuterMostInterestingContextIsNamespaceOrModule offsideStack = @@ -2532,15 +2538,15 @@ type LexFilterImpl (lightStatus: IndentationAwareSyntaxStatus, compilingFsLib, l let _firstTokenTup = peekInitial() () - if lightStatus.Status + if indentationSyntaxStatus.Status then hwTokenFetch true else swTokenFetch() // LexFilterImpl does the majority of the work for offsides rules and other magic. // LexFilter just wraps it with light post-processing that introduces a few more 'coming soon' symbols, to // make it easier for the parser to 'look ahead' and safely shift tokens in a number of recovery scenarios. -type LexFilter (lightStatus: IndentationAwareSyntaxStatus, compilingFsLib, lexer, lexbuf: UnicodeLexing.Lexbuf) = - let inner = LexFilterImpl(lightStatus, compilingFsLib, lexer, lexbuf) +type LexFilter (indentationSyntaxStatus: IndentationAwareSyntaxStatus, compilingFSharpCore, lexer, lexbuf: UnicodeLexing.Lexbuf) = + let inner = LexFilterImpl(indentationSyntaxStatus, compilingFSharpCore, lexer, lexbuf) // 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. diff --git a/src/Compiler/SyntaxTree/LexFilter.fsi b/src/Compiler/SyntaxTree/LexFilter.fsi index 58baa8f7991..3fc6843eb1b 100644 --- a/src/Compiler/SyntaxTree/LexFilter.fsi +++ b/src/Compiler/SyntaxTree/LexFilter.fsi @@ -18,8 +18,8 @@ type LexFilter = /// Create a lex filter new: - lightStatus: IndentationAwareSyntaxStatus * - compilingFsLib: bool * + indentationSyntaxStatus: IndentationAwareSyntaxStatus * + compilingFSharpCore: bool * lexer: (LexBuffer -> token) * lexbuf: LexBuffer -> LexFilter diff --git a/src/Compiler/SyntaxTree/LexHelpers.fs b/src/Compiler/SyntaxTree/LexHelpers.fs index 698ada21335..ad46269bf64 100644 --- a/src/Compiler/SyntaxTree/LexHelpers.fs +++ b/src/Compiler/SyntaxTree/LexHelpers.fs @@ -52,11 +52,11 @@ type LexArgs = { conditionalDefines: string list resourceManager: LexResourceManager - errorLogger: DiagnosticsLogger + diagnosticsLogger: DiagnosticsLogger applyLineDirectives: bool pathMap: PathMap mutable ifdefStack: LexerIfdefStack - mutable lightStatus : IndentationAwareSyntaxStatus + mutable indentationSyntaxStatus : IndentationAwareSyntaxStatus mutable stringNest: LexerInterpolatedStringNesting } @@ -67,13 +67,13 @@ type LongUnicodeLexResult = | SingleChar of uint16 | Invalid -let mkLexargs (conditionalDefines, lightStatus, resourceManager, ifdefStack, errorLogger, pathMap: PathMap) = +let mkLexargs (conditionalDefines, indentationSyntaxStatus, resourceManager, ifdefStack, diagnosticsLogger, pathMap: PathMap) = { conditionalDefines = conditionalDefines ifdefStack = ifdefStack - lightStatus = lightStatus + indentationSyntaxStatus = indentationSyntaxStatus resourceManager = resourceManager - errorLogger = errorLogger + diagnosticsLogger = diagnosticsLogger applyLineDirectives = true stringNest = [] pathMap = pathMap diff --git a/src/Compiler/SyntaxTree/LexHelpers.fsi b/src/Compiler/SyntaxTree/LexHelpers.fsi index 246da511506..33f6bcf951d 100644 --- a/src/Compiler/SyntaxTree/LexHelpers.fsi +++ b/src/Compiler/SyntaxTree/LexHelpers.fsi @@ -32,11 +32,11 @@ type LexResourceManager = type LexArgs = { conditionalDefines: string list resourceManager: LexResourceManager - errorLogger: DiagnosticsLogger + diagnosticsLogger: DiagnosticsLogger applyLineDirectives: bool pathMap: PathMap mutable ifdefStack: LexerIfdefStack - mutable lightStatus: IndentationAwareSyntaxStatus + mutable indentationSyntaxStatus: IndentationAwareSyntaxStatus mutable stringNest: LexerInterpolatedStringNesting } type LongUnicodeLexResult = @@ -48,10 +48,10 @@ val resetLexbufPos: string -> Lexbuf -> unit val mkLexargs: conditionalDefines: string list * - lightStatus: IndentationAwareSyntaxStatus * + indentationSyntaxStatus: IndentationAwareSyntaxStatus * resourceManager: LexResourceManager * ifdefStack: LexerIfdefStack * - errorLogger: DiagnosticsLogger * + diagnosticsLogger: DiagnosticsLogger * pathMap: PathMap -> LexArgs diff --git a/src/Compiler/SyntaxTree/SyntaxTree.fs b/src/Compiler/SyntaxTree/SyntaxTree.fs index 23c0582ee16..a51e83cd813 100644 --- a/src/Compiler/SyntaxTree/SyntaxTree.fs +++ b/src/Compiler/SyntaxTree/SyntaxTree.fs @@ -1570,7 +1570,7 @@ type SynValSig = | SynValSig of attributes: SynAttributes * ident: SynIdent * - explicitValDecls: SynValTyparDecls * + explicitTypeParams: SynValTyparDecls * synType: SynType * arity: SynValInfo * isInline: bool * diff --git a/src/Compiler/SyntaxTree/SyntaxTree.fsi b/src/Compiler/SyntaxTree/SyntaxTree.fsi index a66d4a05225..73e2fafbaed 100644 --- a/src/Compiler/SyntaxTree/SyntaxTree.fsi +++ b/src/Compiler/SyntaxTree/SyntaxTree.fsi @@ -1428,7 +1428,7 @@ type SynValSig = | SynValSig of attributes: SynAttributes * ident: SynIdent * - explicitValDecls: SynValTyparDecls * + explicitTypeParams: SynValTyparDecls * synType: SynType * arity: SynValInfo * isInline: bool * diff --git a/src/Compiler/TypedTree/QuotationPickler.fs b/src/Compiler/TypedTree/QuotationPickler.fs index 7d855dae3eb..4c613f007d2 100644 --- a/src/Compiler/TypedTree/QuotationPickler.fs +++ b/src/Compiler/TypedTree/QuotationPickler.fs @@ -17,7 +17,7 @@ type NamedTypeData = | Named of tcName: string * tcAssembly: string type TypeCombOp = - | ArrayTyOp of int (* rank *) + | ArrayTyOp of rank: int | FunTyOp | NamedTyOp of NamedTypeData @@ -34,20 +34,20 @@ let mkArrayTy (n, x) = AppType(ArrayTyOp n, [x]) let mkILNamedTy (r, l) = AppType(NamedTyOp r, l) type CtorData = - { ctorParent: NamedTypeData - ctorArgTypes: TypeData list; } + { Parent: NamedTypeData + ArgTypes: TypeData list } type MethodData = - { methParent: NamedTypeData - methName: string - methArgTypes: TypeData list - methRetType: TypeData - numGenericArgs: int } + { Parent: NamedTypeData + Name: string + ArgTypes: TypeData list + RetType: TypeData + NumGenericArgs: int } -type VarData = - { vText: string - vType: TypeData - vMutable: bool } +type ValData = + { Name: string + Type: TypeData + IsMutable: bool } type PropInfoData = NamedTypeData * string * TypeData * TypeData list @@ -109,7 +109,7 @@ type ExprData = | CombExpr of CombOp * TypeData list * ExprData list | VarExpr of int | QuoteExpr of ExprData - | LambdaExpr of VarData * ExprData + | LambdaExpr of ValData * ExprData | HoleExpr of TypeData * int | ThisVarExpr of TypeData | QuoteRawExpr of ExprData @@ -243,8 +243,6 @@ let isAttributedExpression e = match e with AttrExpr _ -> true | _ -> false let SerializedReflectedDefinitionsResourceNameBase = "ReflectedDefinitions" -let freshVar (n, ty, mut) = { vText=n; vType=ty; vMutable=mut } - /// Arbitrary value [] let PickleBufferCapacity = 100000 @@ -415,17 +413,17 @@ let rec p_type x st = and p_types x st = p_list p_type x st -let p_varDecl v st = p_tup3 p_string p_type p_bool (v.vText, v.vType, v.vMutable) st +let p_varDecl (v: ValData) st = p_tup3 p_string p_type p_bool (v.Name, v.Type, v.IsMutable) st let p_recdFieldSpec v st = p_tup2 p_NamedType p_string v st let p_ucaseSpec v st = p_tup2 p_NamedType p_string v st -let p_MethodData a st = - p_tup5 p_NamedType p_types p_type p_string p_int (a.methParent, a.methArgTypes, a.methRetType, a.methName, a.numGenericArgs) st +let p_MethodData (a: MethodData) st = + p_tup5 p_NamedType p_types p_type p_string p_int (a.Parent, a.ArgTypes, a.RetType, a.Name, a.NumGenericArgs) st -let p_CtorData a st = - p_tup2 p_NamedType p_types (a.ctorParent, a.ctorArgTypes) st +let p_CtorData (a: CtorData) st = + p_tup2 p_NamedType p_types (a.Parent, a.ArgTypes) st let p_PropInfoData a st = p_tup4 p_NamedType p_string p_type p_types a st diff --git a/src/Compiler/TypedTree/QuotationPickler.fsi b/src/Compiler/TypedTree/QuotationPickler.fsi index 40c012b923d..b4c99699d26 100644 --- a/src/Compiler/TypedTree/QuotationPickler.fsi +++ b/src/Compiler/TypedTree/QuotationPickler.fsi @@ -25,18 +25,21 @@ val mkILNamedTy: NamedTypeData * TypeData list -> TypeData type ExprData -type VarData +type ValData = + { Name: string + Type: TypeData + IsMutable: bool } type CtorData = - { ctorParent: NamedTypeData - ctorArgTypes: TypeData list } + { Parent: NamedTypeData + ArgTypes: TypeData list } type MethodData = - { methParent: NamedTypeData - methName: string - methArgTypes: TypeData list - methRetType: TypeData - numGenericArgs: int } + { Parent: NamedTypeData + Name: string + ArgTypes: TypeData list + RetType: TypeData + NumGenericArgs: int } type ModuleDefnData = { Module: NamedTypeData @@ -58,7 +61,7 @@ val mkHole: TypeData * int -> ExprData val mkApp: ExprData * ExprData -> ExprData -val mkLambda: VarData * ExprData -> ExprData +val mkLambda: ValData * ExprData -> ExprData val mkQuote: ExprData -> ExprData @@ -70,9 +73,9 @@ val mkModuleValueApp: NamedTypeData * string * bool * TypeData list * ExprData l val mkModuleValueWApp: NamedTypeData * string * bool * string * int * TypeData list * ExprData list -> ExprData -val mkLetRec: (VarData * ExprData) list * ExprData -> ExprData +val mkLetRec: (ValData * ExprData) list * ExprData -> ExprData -val mkLet: (VarData * ExprData) * ExprData -> ExprData +val mkLet: (ValData * ExprData) * ExprData -> ExprData val mkRecdMk: NamedTypeData * TypeData list * ExprData list -> ExprData @@ -142,7 +145,7 @@ val mkWhileLoop: ExprData * ExprData -> ExprData val mkTryFinally: ExprData * ExprData -> ExprData -val mkTryWith: ExprData * VarData * ExprData * VarData * ExprData -> ExprData +val mkTryWith: ExprData * ValData * ExprData * ValData * ExprData -> ExprData val mkDelegate: TypeData * ExprData -> ExprData @@ -169,5 +172,3 @@ val isAttributedExpression: ExprData -> bool val PickleDefns: ((MethodBaseData * ExprData) list -> byte []) val SerializedReflectedDefinitionsResourceNameBase: string - -val freshVar: string * TypeData * bool -> VarData diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 09e05f9d3c0..51060755e80 100755 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -184,12 +184,19 @@ let tname_IsByRefLikeAttribute = "System.Runtime.CompilerServices.IsByRefLikeAtt // Table of all these "globals" //------------------------------------------------------------------------- -type public TcGlobals(compilingFSharpCore: bool, ilg:ILGlobals, fslibCcu: CcuThunk, directoryToResolveRelativePaths, - mlCompatibility: bool, isInteractive:bool, - // The helper to find system types amongst referenced DLLs - tryFindSysTypeCcu, - emitDebugInfoInQuotations: bool, noDebugAttributes: bool, - pathMap: PathMap, langVersion: LanguageVersion) = +type TcGlobals( + compilingFSharpCore: bool, + ilg: ILGlobals, + fslibCcu: CcuThunk, + directoryToResolveRelativePaths, + mlCompatibility: bool, + isInteractive: bool, + // The helper to find system types amongst referenced DLLs + tryFindSysTypeCcu, + emitDebugInfoInQuotations: bool, + noDebugAttributes: bool, + pathMap: PathMap, + langVersion: LanguageVersion) = let vara = Construct.NewRigidTypar "a" envRange let varb = Construct.NewRigidTypar "b" envRange @@ -978,7 +985,7 @@ type public TcGlobals(compilingFSharpCore: bool, ilg:ILGlobals, fslibCcu: CcuThu tryFindSysAttrib "System.Runtime.InteropServices.UnmanagedCallersOnlyAttribute" ] |> List.choose (Option.map (fun x -> x.TyconRef)) - override x.ToString() = "" + override _.ToString() = "" member _.ilg = ilg @@ -991,78 +998,151 @@ type public TcGlobals(compilingFSharpCore: bool, ilg:ILGlobals, fslibCcu: CcuThu // A table of known modules in FSharp.Core. Not all modules are necessarily listed, but the more we list the // better the job we do of mapping from provided expressions back to FSharp.Core F# functions and values. member _.knownFSharpCoreModules = v_knownFSharpCoreModules + member _.compilingFSharpCore = compilingFSharpCore + member _.mlCompatibility = mlCompatibility + member _.emitDebugInfoInQuotations = emitDebugInfoInQuotations + member _.directoryToResolveRelativePaths = directoryToResolveRelativePaths + member _.pathMap = pathMap + member _.langVersion = langVersion + member _.unionCaseRefEq x y = primUnionCaseRefEq compilingFSharpCore fslibCcu x y + member _.valRefEq x y = primValRefEq compilingFSharpCore fslibCcu x y + member _.fslibCcu = fslibCcu + member val refcell_tcr_canon = v_refcell_tcr_canon + member val option_tcr_canon = mk_MFCore_tcref fslibCcu "Option`1" + member val valueoption_tcr_canon = mk_MFCore_tcref fslibCcu "ValueOption`1" + member _.list_tcr_canon = v_list_tcr_canon + member val set_tcr_canon = mk_MFCollections_tcref fslibCcu "Set`1" + member val map_tcr_canon = mk_MFCollections_tcref fslibCcu "Map`2" + member _.lazy_tcr_canon = lazy_tcr + member val refcell_tcr_nice = v_refcell_tcr_nice + member val array_tcr_nice = v_il_arr_tcr_map[0] + member _.option_tcr_nice = v_option_tcr_nice + member _.valueoption_tcr_nice = v_valueoption_tcr_nice + member _.list_tcr_nice = v_list_tcr_nice + member _.lazy_tcr_nice = v_lazy_tcr_nice + member _.format_tcr = v_format_tcr + member _.expr_tcr = v_expr_tcr + member _.raw_expr_tcr = v_raw_expr_tcr + member _.nativeint_tcr = v_nativeint_tcr + member _.unativeint_tcr = v_unativeint_tcr + member _.int_tcr = v_int_tcr + member _.int32_tcr = v_int32_tcr + member _.int16_tcr = v_int16_tcr + member _.int64_tcr = v_int64_tcr + member _.uint16_tcr = v_uint16_tcr + member _.uint32_tcr = v_uint32_tcr + member _.uint64_tcr = v_uint64_tcr + member _.sbyte_tcr = v_sbyte_tcr + member _.decimal_tcr = v_decimal_tcr + member _.date_tcr = v_date_tcr + member _.pdecimal_tcr = v_pdecimal_tcr + member _.byte_tcr = v_byte_tcr + member _.bool_tcr = v_bool_tcr + member _.unit_tcr_canon = v_unit_tcr_canon + member _.unit_tcr_nice = v_unit_tcr_nice + member _.exn_tcr = v_exn_tcr + member _.char_tcr = v_char_tcr + member _.float_tcr = v_float_tcr + member _.float32_tcr = v_float32_tcr + member _.pfloat_tcr = v_pfloat_tcr + member _.pfloat32_tcr = v_pfloat32_tcr + member _.pint_tcr = v_pint_tcr + member _.pint8_tcr = v_pint8_tcr + member _.pint16_tcr = v_pint16_tcr + member _.pint64_tcr = v_pint64_tcr + member _.pnativeint_tcr = v_pnativeint_tcr + member _.puint_tcr = v_puint_tcr + member _.puint8_tcr = v_puint8_tcr + member _.puint16_tcr = v_puint16_tcr + member _.puint64_tcr = v_puint64_tcr + member _.punativeint_tcr = v_punativeint_tcr + member _.byref_tcr = v_byref_tcr + member _.byref2_tcr = v_byref2_tcr + member _.outref_tcr = v_outref_tcr + member _.inref_tcr = v_inref_tcr + member _.nativeptr_tcr = v_nativeptr_tcr + member _.voidptr_tcr = v_voidptr_tcr + member _.ilsigptr_tcr = v_ilsigptr_tcr + member _.fastFunc_tcr = v_fastFunc_tcr + member _.MatchFailureException_tcr = v_mfe_tcr + member _.tcref_IQueryable = v_tcref_IQueryable + member _.tcref_IObservable = v_tcref_IObservable + member _.tcref_IObserver = v_tcref_IObserver + member _.fslib_IEvent2_tcr = v_fslib_IEvent2_tcr + member _.fslib_IDelegateEvent_tcr = v_fslib_IDelegateEvent_tcr + member _.seq_tcr = v_seq_tcr member val seq_base_tcr = mk_MFCompilerServices_tcref fslibCcu "GeneratedSequenceBase`1" @@ -1641,18 +1721,15 @@ type public TcGlobals(compilingFSharpCore: bool, ilg:ILGlobals, fslibCcu: CcuThu member _.TryFindSysAttrib nm = tryFindSysAttrib nm - member val ilxPubCloEnv = - EraseClosures.newIlxPubCloEnv(ilg, addMethodGeneratedAttrs, addFieldGeneratedAttrs, addFieldNeverAttrs) - member _.AddMethodGeneratedAttributes mdef = addMethodGeneratedAttrs mdef - member _.AddPropertyGeneratedAttrs mdef = addPropertyGeneratedAttrs mdef + member _.AddPropertyGeneratedAttributes mdef = addPropertyGeneratedAttrs mdef - member _.AddFieldGeneratedAttrs mdef = addFieldGeneratedAttrs mdef + member _.AddFieldGeneratedAttributes mdef = addFieldGeneratedAttrs mdef - member _.AddPropertyNeverAttrs mdef = addPropertyNeverAttrs mdef + member _.AddPropertyNeverAttributes mdef = addPropertyNeverAttrs mdef - member _.AddFieldNeverAttrs mdef = addFieldNeverAttrs mdef + member _.AddFieldNeverAttributes mdef = addFieldNeverAttrs mdef member _.MkDebuggerTypeProxyAttribute ty = mkDebuggerTypeProxyAttribute ty diff --git a/src/Compiler/TypedTree/TypeProviders.fsi b/src/Compiler/TypedTree/TypeProviders.fsi index 57fd084cd2c..b76018c9494 100755 --- a/src/Compiler/TypedTree/TypeProviders.fsi +++ b/src/Compiler/TypedTree/TypeProviders.fsi @@ -91,155 +91,278 @@ type ProvidedTypeContext = [] type ProvidedType = inherit ProvidedMemberInfo + member IsSuppressRelocate: bool + member IsErased: bool + member IsGenericType: bool + member Namespace: string + member FullName: string + member IsArray: bool + member GetInterfaces: unit -> ProvidedType [] + member Assembly: ProvidedAssembly + member BaseType: ProvidedType + member GetNestedType: string -> ProvidedType + member GetNestedTypes: unit -> ProvidedType [] + member GetAllNestedTypes: unit -> ProvidedType [] + member GetMethods: unit -> ProvidedMethodInfo [] + member GetFields: unit -> ProvidedFieldInfo [] + member GetField: string -> ProvidedFieldInfo + member GetProperties: unit -> ProvidedPropertyInfo [] + member GetProperty: string -> ProvidedPropertyInfo + member GetEvents: unit -> ProvidedEventInfo [] + member GetEvent: string -> ProvidedEventInfo + member GetConstructors: unit -> ProvidedConstructorInfo [] + member GetStaticParameters: ITypeProvider -> ProvidedParameterInfo [] + member GetGenericTypeDefinition: unit -> ProvidedType + member IsVoid: bool + member IsGenericParameter: bool + member IsValueType: bool + member IsByRef: bool + member IsPointer: bool + member IsEnum: bool + member IsInterface: bool + member IsClass: bool + member IsMeasure: bool + member IsSealed: bool + member IsAbstract: bool + member IsPublic: bool + member IsNestedPublic: bool + member GenericParameterPosition: int + member GetElementType: unit -> ProvidedType + member GetGenericArguments: unit -> ProvidedType [] + member GetArrayRank: unit -> int + member RawSystemType: Type + member GetEnumUnderlyingType: unit -> ProvidedType + member MakePointerType: unit -> ProvidedType + member MakeByRefType: unit -> ProvidedType + member MakeArrayType: unit -> ProvidedType + member MakeArrayType: rank: int -> ProvidedType + member MakeGenericType: args: ProvidedType [] -> ProvidedType + member AsProvidedVar: name: string -> ProvidedVar + static member Void: ProvidedType + static member CreateNoContext: Type -> ProvidedType + member TryGetILTypeRef: unit -> ILTypeRef option + member TryGetTyconRef: unit -> obj option + static member ApplyContext: ProvidedType * ProvidedTypeContext -> ProvidedType + member Context: ProvidedTypeContext + interface IProvidedCustomAttributeProvider + static member TaintedEquals: Tainted * Tainted -> bool [] type IProvidedCustomAttributeProvider = + abstract GetHasTypeProviderEditorHideMethodsAttribute: provider: ITypeProvider -> bool + abstract GetDefinitionLocationAttribute: provider: ITypeProvider -> (string * int * int) option + abstract GetXmlDocAttributes: provider: ITypeProvider -> string [] + abstract GetAttributeConstructorArgs: provider: ITypeProvider * attribName: string -> (obj option list * (string * obj option) list) option [] type ProvidedAssembly = + member GetName: unit -> System.Reflection.AssemblyName + member FullName: string + member GetManifestModuleContents: ITypeProvider -> byte [] + member Handle: System.Reflection.Assembly [] type ProvidedMemberInfo = + member Name: string + member DeclaringType: ProvidedType + interface IProvidedCustomAttributeProvider [] type ProvidedMethodBase = + inherit ProvidedMemberInfo + member IsGenericMethod: bool + member IsStatic: bool + member IsFamily: bool + member IsFamilyAndAssembly: bool + member IsFamilyOrAssembly: bool + member IsVirtual: bool + member IsFinal: bool + member IsPublic: bool + member IsAbstract: bool + member IsHideBySig: bool + member IsConstructor: bool + member GetParameters: unit -> ProvidedParameterInfo [] + member GetGenericArguments: unit -> ProvidedType [] + member GetStaticParametersForMethod: ITypeProvider -> ProvidedParameterInfo [] + static member TaintedGetHashCode: Tainted -> int + static member TaintedEquals: Tainted * Tainted -> bool [] type ProvidedMethodInfo = + inherit ProvidedMethodBase + member ReturnType: ProvidedType + member MetadataToken: int [] type ProvidedParameterInfo = + member Name: string + member ParameterType: ProvidedType + member IsIn: bool + member IsOut: bool + member IsOptional: bool + member RawDefaultValue: obj + member HasDefaultValue: bool + interface IProvidedCustomAttributeProvider [] type ProvidedFieldInfo = + inherit ProvidedMemberInfo + + member IsInitOnly: bool + member IsStatic: bool + member IsSpecialName: bool + member IsLiteral: bool + member GetRawConstantValue: unit -> obj + member FieldType: ProvidedType + member IsPublic: bool + member IsFamily: bool + member IsFamilyAndAssembly: bool + member IsFamilyOrAssembly: bool + member IsPrivate: bool + static member TaintedEquals: Tainted * Tainted -> bool [] type ProvidedPropertyInfo = + inherit ProvidedMemberInfo + member GetGetMethod: unit -> ProvidedMethodInfo + member GetSetMethod: unit -> ProvidedMethodInfo + member GetIndexParameters: unit -> ProvidedParameterInfo [] + member CanRead: bool + member CanWrite: bool + member PropertyType: ProvidedType + static member TaintedGetHashCode: Tainted -> int + static member TaintedEquals: Tainted * Tainted -> bool [] type ProvidedEventInfo = + inherit ProvidedMemberInfo + member GetAddMethod: unit -> ProvidedMethodInfo + member GetRemoveMethod: unit -> ProvidedMethodInfo + member EventHandlerType: ProvidedType + static member TaintedGetHashCode: Tainted -> int + static member TaintedEquals: Tainted * Tainted -> bool [] @@ -247,43 +370,72 @@ type ProvidedConstructorInfo = inherit ProvidedMethodBase type ProvidedExprType = + | ProvidedNewArrayExpr of ProvidedType * ProvidedExpr [] + #if PROVIDED_ADDRESS_OF | ProvidedAddressOfExpr of ProvidedExpr #endif + | ProvidedNewObjectExpr of ProvidedConstructorInfo * ProvidedExpr [] + | ProvidedWhileLoopExpr of ProvidedExpr * ProvidedExpr + | ProvidedNewDelegateExpr of ProvidedType * ProvidedVar [] * ProvidedExpr + | ProvidedForIntegerRangeLoopExpr of ProvidedVar * ProvidedExpr * ProvidedExpr * ProvidedExpr + | ProvidedSequentialExpr of ProvidedExpr * ProvidedExpr + | ProvidedTryWithExpr of ProvidedExpr * ProvidedVar * ProvidedExpr * ProvidedVar * ProvidedExpr + | ProvidedTryFinallyExpr of ProvidedExpr * ProvidedExpr + | ProvidedLambdaExpr of ProvidedVar * ProvidedExpr + | ProvidedCallExpr of ProvidedExpr option * ProvidedMethodInfo * ProvidedExpr [] + | ProvidedConstantExpr of obj * ProvidedType + | ProvidedDefaultExpr of ProvidedType + | ProvidedNewTupleExpr of ProvidedExpr [] + | ProvidedTupleGetExpr of ProvidedExpr * int + | ProvidedTypeAsExpr of ProvidedExpr * ProvidedType + | ProvidedTypeTestExpr of ProvidedExpr * ProvidedType + | ProvidedLetExpr of ProvidedVar * ProvidedExpr * ProvidedExpr + | ProvidedVarSetExpr of ProvidedVar * ProvidedExpr + | ProvidedIfThenElseExpr of ProvidedExpr * ProvidedExpr * ProvidedExpr + | ProvidedVarExpr of ProvidedVar [] type ProvidedExpr = + member Type: ProvidedType + /// Convert the expression to a string for diagnostics member UnderlyingExpressionString: string + member GetExprType: unit -> ProvidedExprType option [] type ProvidedVar = + member Type: ProvidedType + member Name: string + member IsMutable: bool + override Equals: obj -> bool + override GetHashCode: unit -> int /// Get the provided expression for a particular use of a method. diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 975b28ef1c5..3397632fc7a 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -496,9 +496,9 @@ type PublicPath = type CompilationPath = | CompPath of ILScopeRef * (string * ModuleOrNamespaceKind) list - member x.ILScopeRef = (let (CompPath(scoref, _)) = x in scoref) + member x.ILScopeRef = let (CompPath(scoref, _)) = x in scoref - member x.AccessPath = (let (CompPath(_, p)) = x in p) + member x.AccessPath = let (CompPath(_, p)) = x in p member x.MangledPath = List.map fst x.AccessPath @@ -508,7 +508,8 @@ type CompilationPath = let a, _ = List.frontAndBack x.AccessPath CompPath(x.ILScopeRef, a) - member x.NestedCompPath n modKind = CompPath(x.ILScopeRef, x.AccessPath@[(n, modKind)]) + member x.NestedCompPath n moduleKind = + CompPath(x.ILScopeRef, x.AccessPath@[(n, moduleKind)]) member x.DemangledPath = x.AccessPath |> List.map (fun (nm, k) -> CompilationPath.DemangleEntityName nm k) @@ -604,7 +605,7 @@ type Entity = // // MUTABILITY: only used during creation and remapping of tycons and // when compiling fslib to fixup compiler forward references to internal items - mutable entity_modul_contents: MaybeLazy + mutable entity_modul_type: MaybeLazy /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 // REVIEW: it looks like entity_cpath subsumes this @@ -778,7 +779,7 @@ type Entity = | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_xmldocsig = v } /// The logical contents of the entity when it is a module or namespace fragment. - member x.ModuleOrNamespaceType = x.entity_modul_contents.Force() + member x.ModuleOrNamespaceType = x.entity_modul_type.Force() /// The logical contents of the entity when it is a type definition. member x.TypeContents = x.entity_tycon_tcaug @@ -987,7 +988,7 @@ type Entity = entity_attribs = Unchecked.defaultof<_> entity_tycon_repr= Unchecked.defaultof<_> entity_tycon_tcaug= Unchecked.defaultof<_> - entity_modul_contents= Unchecked.defaultof<_> + entity_modul_type= Unchecked.defaultof<_> entity_pubpath = Unchecked.defaultof<_> entity_cpath = Unchecked.defaultof<_> entity_il_repr_cache = Unchecked.defaultof<_> @@ -1006,7 +1007,7 @@ type Entity = x.entity_attribs <- tg.entity_attribs x.entity_tycon_repr <- tg.entity_tycon_repr x.entity_tycon_tcaug <- tg.entity_tycon_tcaug - x.entity_modul_contents <- tg.entity_modul_contents + x.entity_modul_type <- tg.entity_modul_type x.entity_pubpath <- tg.entity_pubpath x.entity_cpath <- tg.entity_cpath x.entity_il_repr_cache <- tg.entity_il_repr_cache @@ -2852,7 +2853,7 @@ type Val = | _ -> false /// Get the type of the value including any generic type parameters - member x.TypeScheme = + member x.GeneralizedType = match x.Type with | TType_forall(tps, tau) -> tps, tau | ty -> [], ty @@ -3725,7 +3726,7 @@ type ValRef = member x.Type = x.Deref.Type /// Get the type of the value including any generic type parameters - member x.TypeScheme = x.Deref.TypeScheme + member x.GeneralizedType = x.Deref.GeneralizedType /// Get the type of the value after removing any generic type parameters member x.TauType = x.Deref.TauType @@ -5083,25 +5084,6 @@ type SlotParam = override x.ToString() = "TSlotParam(...)" -/// A type for a module-or-namespace-fragment and the actual definition of the module-or-namespace-fragment -/// The first ModuleOrNamespaceType is the signature and is a binder. However the bindings are not used in the ModuleOrNamespaceContents: it is only referenced from the 'outside' -/// is for use by FCS only to report the "hidden" contents of the assembly prior to applying the signature. -[] -type ModuleOrNamespaceContentsWithSig = - | ModuleOrNamespaceContentsWithSig of - moduleSig: ModuleOrNamespaceType * - contents: ModuleOrNamespaceContents * - range: range - - member x.Type = let (ModuleOrNamespaceContentsWithSig(moduleSig=moduleSig)) = x in moduleSig - - member x.Contents = let (ModuleOrNamespaceContentsWithSig(contents=contents)) = x in contents - - [] - member x.DebugText = x.ToString() - - override x.ToString() = "ModuleOrNamespaceContentsWithSig(...)" - /// Represents open declaration statement. type OpenDeclaration = { /// Syntax after 'open' as it's presented in source code. @@ -5138,9 +5120,6 @@ type OpenDeclaration = /// The contents of a module-or-namespace-fragment definition [] type ModuleOrNamespaceContents = - /// Indicates the module is a module with a signature - | TMWithSig of contentsWithSig: ModuleOrNamespaceContentsWithSig - /// Indicates the module fragment is made of several module fragments in succession | TMDefs of defs: ModuleOrNamespaceContents list @@ -5201,45 +5180,58 @@ type NamedDebugPointKey = compare x.Name y.Name | _ -> -1 -/// Represents a complete typechecked implementation file, including its typechecked signature if any. +/// Represents a complete typechecked implementation file, including its inferred or explicit signature. /// -/// TImplFile (qualifiedNameOfFile, pragmas, implExprWithSig, hasExplicitEntryPoint, isScript, anonRecdTypeInfo) +/// CheckedImplFile (qualifiedNameOfFile, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypeInfo) [] -type TypedImplFile = - | TImplFile of +type CheckedImplFile = + | CheckedImplFile of qualifiedNameOfFile: QualifiedNameOfFile * pragmas: ScopedPragma list * - implExprWithSig: ModuleOrNamespaceContentsWithSig * + signature: ModuleOrNamespaceType * + contents: ModuleOrNamespaceContents * hasExplicitEntryPoint: bool * isScript: bool * anonRecdTypeInfo: StampMap * namedDebugPointsForInlinedCode: Map + member x.Signature = let (CheckedImplFile (signature=res)) = x in res + + member x.Contents = let (CheckedImplFile (contents=res)) = x in res + + member x.QualifiedNameOfFile = let (CheckedImplFile (qualifiedNameOfFile=res)) = x in res + + member x.Pragmas = let (CheckedImplFile (pragmas=res)) = x in res + + member x.HasExplicitEntryPoint = let (CheckedImplFile (hasExplicitEntryPoint=res)) = x in res + + member x.IsScript = let (CheckedImplFile (isScript=res)) = x in res + [] member x.DebugText = x.ToString() - override x.ToString() = "TImplFile (...)" + override x.ToString() = "CheckedImplFile (...)" /// Represents a complete typechecked assembly, made up of multiple implementation files. [] -type TypedImplFileAfterOptimization = - { ImplFile: TypedImplFile +type CheckedImplFileAfterOptimization = + { ImplFile: CheckedImplFile OptimizeDuringCodeGen: bool -> Expr -> Expr } [] member x.DebugText = x.ToString() - override x.ToString() = "TypedImplFileAfterOptimization(...)" + override x.ToString() = "CheckedImplFileAfterOptimization(...)" /// Represents a complete typechecked assembly, made up of multiple implementation files. [] -type TypedAssemblyAfterOptimization = - | TypedAssemblyAfterOptimization of TypedImplFileAfterOptimization list +type CheckedAssemblyAfterOptimization = + | CheckedAssemblyAfterOptimization of CheckedImplFileAfterOptimization list [] member x.DebugText = x.ToString() - override x.ToString() = "TypedAssemblyAfterOptimization(...)" + override x.ToString() = "CheckedAssemblyAfterOptimization(...)" [] type CcuData = @@ -5659,7 +5651,7 @@ type Construct() = entity_typars= LazyWithContext.NotLazy [] entity_tycon_repr = repr entity_tycon_tcaug=TyconAugmentation.Create() - entity_modul_contents = MaybeLazy.Lazy (lazy ModuleOrNamespaceType(Namespace, QueueList.ofList [], QueueList.ofList [])) + entity_modul_type = MaybeLazy.Lazy (lazy ModuleOrNamespaceType(Namespace, QueueList.ofList [], QueueList.ofList [])) // Generated types get internal accessibility entity_pubpath = Some pubpath entity_cpath = Some cpath @@ -5680,7 +5672,7 @@ type Construct() = { entity_logical_name=id.idText entity_range = id.idRange entity_stamp=stamp - entity_modul_contents = mtype + entity_modul_type = mtype entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_typars=LazyWithContext.NotLazy [] entity_tycon_repr = TNoRepr @@ -5752,7 +5744,7 @@ type Construct() = entity_range = id.idRange entity_tycon_tcaug = TyconAugmentation.Create() entity_pubpath = cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath id) - entity_modul_contents = MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType ModuleOrType) + entity_modul_type = MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType ModuleOrType) entity_cpath = cpath entity_typars = LazyWithContext.NotLazy [] entity_tycon_repr = TNoRepr @@ -5792,7 +5784,7 @@ type Construct() = entity_typars=typars entity_tycon_repr = TNoRepr entity_tycon_tcaug=TyconAugmentation.Create() - entity_modul_contents = mtyp + entity_modul_type = mtyp entity_pubpath=cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath (mkSynId m nm)) entity_cpath = cpath entity_il_repr_cache = newCache() @@ -5879,7 +5871,7 @@ type Construct() = /// contents of the module. static member NewModifiedModuleOrNamespace f orig = orig |> Construct.NewModifiedTycon (fun d -> - { d with entity_modul_contents = MaybeLazy.Strict (f (d.entity_modul_contents.Force())) }) + { d with entity_modul_type = MaybeLazy.Strict (f (d.entity_modul_type.Force())) }) /// Create a Val based on an existing one using the function 'f'. /// We require that we be given the parent for the new Val. diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index d6f8039071e..b0020664ff7 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -73,20 +73,6 @@ let mkRawRefTupleTy tys = TType_tuple (tupInfoRef, tys) let mkRawStructTupleTy tys = TType_tuple (tupInfoStruct, tys) -//--------------------------------------------------------------------------- -// Aggregate operations to help transform the components that -// make up the entire compilation unit -//--------------------------------------------------------------------------- - -let mapTImplFile f (TImplFile (fragName, pragmas, moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = - TImplFile (fragName, pragmas, f moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) - -let mapAccImplFile f z (TImplFile (fragName, pragmas, moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = - let moduleExpr, z = f z moduleExpr - TImplFile (fragName, pragmas, moduleExpr, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode), z - -let foldTImplFile f z (TImplFile (implExprWithSig= moduleExpr)) = f z moduleExpr - //--------------------------------------------------------------------------- // Equality relations on locally defined things //--------------------------------------------------------------------------- diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fsi b/src/Compiler/TypedTree/TypedTreeBasics.fsi index 64237ef6b75..a0c9f776373 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fsi +++ b/src/Compiler/TypedTree/TypedTreeBasics.fsi @@ -57,17 +57,6 @@ val mkRawRefTupleTy: tys: TTypes -> TType val mkRawStructTupleTy: tys: TTypes -> TType -val mapTImplFile: - f: (ModuleOrNamespaceContentsWithSig -> ModuleOrNamespaceContentsWithSig) -> TypedImplFile -> TypedImplFile - -val mapAccImplFile: - f: ('a -> ModuleOrNamespaceContentsWithSig -> ModuleOrNamespaceContentsWithSig * 'b) -> - z: 'a -> - TypedImplFile -> - TypedImplFile * 'b - -val foldTImplFile: f: ('a -> ModuleOrNamespaceContentsWithSig -> 'b) -> z: 'a -> TypedImplFile -> 'b - val typarEq: lv1: Typar -> lv2: Typar -> bool /// Equality on type variables, implemented as reference equality. This should be equivalent to using typarEq. diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 868da58b6f3..caaff282912 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -93,17 +93,17 @@ type ValMap<'T>(imap: StampMap<'T>) = // renamings //-------------------------------------------------------------------------- -type TyparInst = (Typar * TType) list +type TyparInstantiation = (Typar * TType) list type TyconRefRemap = TyconRefMap type ValRemap = ValMap let emptyTyconRefRemap: TyconRefRemap = TyconRefMap<_>.Empty -let emptyTyparInst = ([]: TyparInst) +let emptyTyparInst = ([]: TyparInstantiation) [] type Remap = - { tpinst: TyparInst + { tpinst: TyparInstantiation /// Values to remap valRemap: ValRemap @@ -167,7 +167,7 @@ let remapUnionCaseRef tcmap (UnionCaseRef(tcref, nm)) = UnionCaseRef(remapTyconR let remapRecdFieldRef tcmap (RecdFieldRef(tcref, nm)) = RecdFieldRef(remapTyconRef tcmap tcref, nm) let mkTyparInst (typars: Typars) tyargs = - (List.zip typars tyargs: TyparInst) + (List.zip typars tyargs: TyparInstantiation) let generalizeTypar tp = mkTyparTy tp let generalizeTypars tps = List.map generalizeTypar tps @@ -417,9 +417,9 @@ let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss -let mkTyparToTyparRenaming tpsOrig tps = +let mkTyparToTyparRenaming tpsorig tps = let tinst = generalizeTypars tps - mkTyparInst tpsOrig tinst, tinst + mkTyparInst tpsorig tinst, tinst let mkTyconInst (tycon: Tycon) tinst = mkTyparInst tycon.TyparsNoRange tinst let mkTyconRefInst (tcref: TyconRef) tinst = mkTyconInst tcref.Deref tinst @@ -1261,7 +1261,7 @@ let rangeOfExpr (x: Expr) = x.Range //--------------------------------------------------------------------------- -let primMkMatch(spBind, exprm, tree, targets, matchm, ty) = Expr.Match (spBind, exprm, tree, targets, matchm, ty) +let primMkMatch(spBind, mExpr, tree, targets, mMatch, ty) = Expr.Match (spBind, mExpr, tree, targets, mMatch, ty) type MatchBuilder(spBind, inpRange: range) = @@ -1393,10 +1393,10 @@ let NormalizeDeclaredTyparsForEquiRecursiveInference g tps = | ValueSome anyParTy -> anyParTy | ValueNone -> tp) -type TypeScheme = TypeScheme of Typars * TType +type GeneralizedType = GeneralizedType of Typars * TType let mkGenericBindRhs g m generalizedTyparsForRecursiveBlock typeScheme bodyExpr = - let (TypeScheme(generalizedTypars, tauType)) = typeScheme + let (GeneralizedType(generalizedTypars, tauType)) = typeScheme // Normalize the generalized typars let generalizedTypars = NormalizeDeclaredTyparsForEquiRecursiveInference g generalizedTypars @@ -1417,7 +1417,7 @@ let mkGenericBindRhs g m generalizedTyparsForRecursiveBlock typeScheme bodyExpr mkTypeLambda m generalizedTypars (mkTypeChoose m freeChoiceTypars bodyExpr, tauType) let isBeingGeneralized tp typeScheme = - let (TypeScheme(generalizedTypars, _)) = typeScheme + let (GeneralizedType(generalizedTypars, _)) = typeScheme ListSet.contains typarRefEq tp generalizedTypars //------------------------------------------------------------------------- @@ -2806,8 +2806,8 @@ module PrettyTypes = let foldTypars f z (x: Typars) = List.fold (foldTypar f) z x let mapTypars g f (x: Typars) : Typars = List.map (mapTypar g f) x - let foldTyparInst f z (x: TyparInst) = List.fold (foldPair (foldTypar f, f)) z x - let mapTyparInst g f (x: TyparInst) : TyparInst = List.map (mapPair (mapTypar g f, f)) x + let foldTyparInst f z (x: TyparInstantiation) = List.fold (foldPair (foldTypar f, f)) z x + let mapTyparInst g f (x: TyparInstantiation) : TyparInstantiation = List.map (mapPair (mapTypar g f, f)) x let PrettifyInstAndTyparsAndType g x = PrettifyThings g @@ -2815,13 +2815,13 @@ module PrettyTypes = (fun f-> mapTriple (mapTyparInst g f, mapTypars g f, f)) x - let PrettifyInstAndUncurriedSig g (x: TyparInst * UncurriedArgInfos * TType) = + let PrettifyInstAndUncurriedSig g (x: TyparInstantiation * UncurriedArgInfos * TType) = PrettifyThings g (fun f -> foldTriple (foldTyparInst f, foldUnurriedArgInfos f, f)) (fun f -> mapTriple (mapTyparInst g f, List.map (map1Of2 f), f)) x - let PrettifyInstAndCurriedSig g (x: TyparInst * TTypes * CurriedArgInfos * TType) = + let PrettifyInstAndCurriedSig g (x: TyparInstantiation * TTypes * CurriedArgInfos * TType) = PrettifyThings g (fun f -> foldQuadruple (foldTyparInst f, List.fold f, List.fold (List.fold (fold1Of2 f)), f)) (fun f -> mapQuadruple (mapTyparInst g f, List.map f, List.mapSquared (map1Of2 f), f)) @@ -4316,12 +4316,11 @@ module DebugPrint = let z = if isNil args then z else z --- spaceListL (List.map (atomL g) args) z - and implFileL g (TImplFile (implExprWithSig=mexpr)) = - aboveListL [(wordL(tagText "top implementation ")) @@-- mexprL g mexpr] + and implFileL g (CheckedImplFile (signature=implFileTy; contents=implFileContents)) = + aboveListL [(wordL(tagText "top implementation ")) @@-- mexprL g implFileTy implFileContents] - and mexprL g x = - match x with - | ModuleOrNamespaceContentsWithSig(mtyp, defs, _) -> mdefL g defs @@- (wordL(tagText ":") @@- entityTypeL g mtyp) + and mexprL g mtyp defs = + mdefL g defs @@- (wordL(tagText ":") @@- entityTypeL g mtyp) and mdefsL g defs = wordL(tagText "Module Defs") @@-- aboveListL(List.map (mdefL g) defs) @@ -4333,7 +4332,6 @@ module DebugPrint = | TMDefDo(e, _) -> exprL g e | TMDefOpens _ -> wordL (tagText "open ... ") | TMDefs defs -> mdefsL g defs - | TMWithSig mexpr -> mexprL g mexpr and mbindL g x = match x with @@ -4416,9 +4414,6 @@ let wrapModuleOrNamespaceContentsInNamespace (id: Ident) cpath mexpr = let mspec = wrapModuleOrNamespaceType id cpath (Construct.NewEmptyModuleOrNamespaceType Namespace) TMDefRec (false, [], [], [ModuleOrNamespaceBinding.Module(mspec, mexpr)], id.idRange) -// cleanup: make this a property -let SigTypeOfImplFile (TImplFile (implExprWithSig=mexpr)) = mexpr.Type - //-------------------------------------------------------------------------- // Data structures representing what gets hidden and what gets remapped // when a module signature is applied to a module. @@ -4584,7 +4579,6 @@ let rec accEntityRemapFromModuleOrNamespace msigty x acc = | TMDefOpens _ -> acc | TMDefDo _ -> acc | TMDefs defs -> accEntityRemapFromModuleOrNamespaceDefs msigty defs acc - | TMWithSig mexpr -> accEntityRemapFromModuleOrNamespaceType mexpr.Type msigty acc and accEntityRemapFromModuleOrNamespaceDefs msigty mdefs acc = List.foldBack (accEntityRemapFromModuleOrNamespace msigty) mdefs acc @@ -4607,7 +4601,6 @@ let rec accValRemapFromModuleOrNamespace g aenv msigty x acc = | TMDefOpens _ -> acc | TMDefDo _ -> acc | TMDefs defs -> accValRemapFromModuleOrNamespaceDefs g aenv msigty defs acc - | TMWithSig mexpr -> accValRemapFromModuleOrNamespaceType g aenv mexpr.Type msigty acc and accValRemapFromModuleOrNamespaceBind g aenv msigty x acc = match x with @@ -4688,9 +4681,6 @@ let rec accImplHidingInfoAtAssemblyBoundary mdef acc = accImplHidingInfoAtAssemblyBoundary def acc) acc - | TMWithSig mexpr -> - accModuleOrNamespaceHidingInfoAtAssemblyBoundary mexpr.Type acc - | TMDefOpens _openDecls -> acc | TMDefLet(bind, _m) -> accValHidingInfoAtAssemblyBoundary bind.Var acc @@ -5188,7 +5178,6 @@ let rec accFreeInModuleOrNamespace opts mexpr acc = | TMDefDo(e, _) -> accFreeInExpr opts e acc | TMDefOpens _ -> acc | TMDefs defs -> accFreeInModuleOrNamespaces opts defs acc - | TMWithSig(ModuleOrNamespaceContentsWithSig(_, mdef, _)) -> accFreeInModuleOrNamespace opts mdef acc // not really right, but sufficient for how this is used in optimization and accFreeInModuleOrNamespaceBind opts mbind acc = match mbind with @@ -5562,8 +5551,8 @@ and remapExprImpl (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) exp let binds', tmenvinner = copyAndRemapAndBindBindings ctxt compgen tmenv binds Expr.LetRec (binds', remapExprImpl ctxt compgen tmenvinner e, m, Construct.NewFreeVarsCache()) - | Expr.Match (spBind, exprm, pt, targets, m, ty) -> - primMkMatch (spBind, exprm, remapDecisionTree ctxt compgen tmenv pt, + | Expr.Match (spBind, mExpr, pt, targets, m, ty) -> + primMkMatch (spBind, mExpr, remapDecisionTree ctxt compgen tmenv pt, targets |> Array.map (remapTarget ctxt compgen tmenv), m, remapType tmenv ty) @@ -5680,13 +5669,13 @@ and remapLinearExpr ctxt compgen tmenv expr contf = if expr1 === expr1R && expr2 === expr2R then expr else Expr.Sequential (expr1R, expr2R, dir, m))) - | LinearMatchExpr (spBind, exprm, dtree, tg1, expr2, m2, ty) -> + | LinearMatchExpr (spBind, mExpr, dtree, tg1, expr2, m2, ty) -> let dtreeR = remapDecisionTree ctxt compgen tmenv dtree let tg1R = remapTarget ctxt compgen tmenv tg1 let tyR = remapType tmenv ty // tailcall for the linear position remapLinearExpr ctxt compgen tmenv expr2 (contf << (fun expr2R -> - rebuildLinearMatchExpr (spBind, exprm, dtreeR, tg1R, expr2R, m2, tyR))) + rebuildLinearMatchExpr (spBind, mExpr, dtreeR, tg1R, expr2R, m2, tyR))) | LinearOpExpr (op, tyargs, argsFront, argLast, m) -> let opR = remapOp tmenv op @@ -5870,9 +5859,9 @@ and remapMemberInfo ctxt m topValInfo ty tyR tmenv x = // The slotsig in the ImplementedSlotSigs is w.r.t. the type variables in the value's type. // REVIEW: this is a bit gross. It would be nice if the slotsig was standalone assert (Option.isSome topValInfo) - let tpsOrig, _, _, _ = GetMemberTypeInFSharpForm ctxt.g x.MemberFlags (Option.get topValInfo) ty m + let tpsorig, _, _, _ = GetMemberTypeInFSharpForm ctxt.g x.MemberFlags (Option.get topValInfo) ty m let tps, _, _, _ = GetMemberTypeInFSharpForm ctxt.g x.MemberFlags (Option.get topValInfo) tyR m - let renaming, _ = mkTyparToTyparRenaming tpsOrig tps + let renaming, _ = mkTyparToTyparRenaming tpsorig tps let tmenv = { tmenv with tpinst = tmenv.tpinst @ renaming } { x with ApparentEnclosingEntity = x.ApparentEnclosingEntity |> remapTyconRef tmenv.tyconRefRemap @@ -5947,7 +5936,7 @@ and copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs = tcdR.entity_tycon_repr <- tcd.entity_tycon_repr |> remapTyconRepr ctxt tmenvinner2 let typeAbbrevR = tcd.TypeAbbrev |> Option.map (remapType tmenvinner2) tcdR.entity_tycon_tcaug <- tcd.entity_tycon_tcaug |> remapTyconAug tmenvinner2 - tcdR.entity_modul_contents <- MaybeLazy.Strict (tcd.entity_modul_contents.Value + tcdR.entity_modul_type <- MaybeLazy.Strict (tcd.entity_modul_type.Value |> mapImmediateValsAndTycons lookupTycon lookupVal) let exnInfoR = tcd.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner2 match tcdR.entity_opt_data with @@ -5980,8 +5969,7 @@ and allEntitiesOfModDef mdef = | TMDefs defs -> for def in defs do yield! allEntitiesOfModDef def - | TMWithSig(ModuleOrNamespaceContentsWithSig(mty, _, _)) -> - yield! allEntitiesOfModuleOrNamespaceTy mty } + } and allValsOfModDef mdef = seq { match mdef with @@ -5998,18 +5986,7 @@ and allValsOfModDef mdef = | TMDefs defs -> for def in defs do yield! allValsOfModDef def - | TMWithSig(ModuleOrNamespaceContentsWithSig(mty, _, _)) -> - yield! allValsOfModuleOrNamespaceTy mty } - -and remapAndBindModuleOrNamespaceContentsWithSig ctxt compgen tmenv (ModuleOrNamespaceContentsWithSig(mty, mdef, m)) = - let mdef = copyAndRemapModDef ctxt compgen tmenv mdef - let mty, tmenv = copyAndRemapAndBindModTy ctxt compgen tmenv mty - ModuleOrNamespaceContentsWithSig(mty, mdef, m), tmenv - -and remapModuleOrNamespaceContentsWithSig ctxt compgen tmenv (ModuleOrNamespaceContentsWithSig(mty, mdef, m)) = - let mdef = copyAndRemapModDef ctxt compgen tmenv mdef - let mty = remapModTy ctxt compgen tmenv mty - ModuleOrNamespaceContentsWithSig(mty, mdef, m) + } and copyAndRemapModDef ctxt compgen tmenv mdef = let tycons = allEntitiesOfModDef mdef |> List.ofSeq @@ -6048,9 +6025,6 @@ and remapAndRenameModDef ctxt compgen tmenv mdef = | TMDefs defs -> let defs = remapAndRenameModDefs ctxt compgen tmenv defs TMDefs defs - | TMWithSig mexpr -> - let mexpr = remapModuleOrNamespaceContentsWithSig ctxt compgen tmenv mexpr - TMWithSig mexpr and remapAndRenameModBind ctxt compgen tmenv x = match x with @@ -6063,8 +6037,12 @@ and remapAndRenameModBind ctxt compgen tmenv x = let def = remapAndRenameModDef ctxt compgen tmenv def ModuleOrNamespaceBinding.Module(mspec, def) -and remapImplFile ctxt compgen tmenv mv = - mapAccImplFile (remapAndBindModuleOrNamespaceContentsWithSig ctxt compgen) tmenv mv +and remapImplFile ctxt compgen tmenv implFile = + let (CheckedImplFile (fragName, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile + let contentsR = copyAndRemapModDef ctxt compgen tmenv contents + let signatureR, tmenv = copyAndRemapAndBindModTy ctxt compgen tmenv signature + let implFileR = CheckedImplFile (fragName, pragmas, signatureR, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + implFileR, tmenv // Entry points @@ -6550,7 +6528,7 @@ let foldLinearBindingTargetsOfMatch tree (targets: _[]) = treeR, targetsR // Simplify a little as we go, including dead target elimination -let rec simplifyTrivialMatch spBind exprm matchm ty tree (targets : _[]) = +let rec simplifyTrivialMatch spBind mExpr mMatch ty tree (targets : _[]) = match tree with | TDSuccess(es, n) -> if n >= targets.Length then failwith "simplifyTrivialMatch: target out of range" @@ -6567,18 +6545,18 @@ let rec simplifyTrivialMatch spBind exprm matchm ty tree (targets : _[]) = | _ -> res res | _ -> - primMkMatch (spBind, exprm, tree, targets, matchm, ty) + primMkMatch (spBind, mExpr, tree, targets, mMatch, ty) // Simplify a little as we go, including dead target elimination -let mkAndSimplifyMatch spBind exprm matchm ty tree targets = +let mkAndSimplifyMatch spBind mExpr mMatch ty tree targets = let targets = Array.ofList targets match tree with | TDSuccess _ -> - simplifyTrivialMatch spBind exprm matchm ty tree targets + simplifyTrivialMatch spBind mExpr mMatch ty tree targets | _ -> let tree, targets = eliminateDeadTargetsFromMatch tree targets let tree, targets = foldLinearBindingTargetsOfMatch tree targets - simplifyTrivialMatch spBind exprm matchm ty tree targets + simplifyTrivialMatch spBind mExpr mMatch ty tree targets //------------------------------------------------------------------------- // mkExprAddrOfExprAux @@ -7099,10 +7077,6 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = let (TObjExprMethod(_, _, _, _, e, _)) = x exprF z e - and mexprF z x = - match x with - | ModuleOrNamespaceContentsWithSig(_, def, _) -> mdefF z def - and mdefF z x = match x with | TMDefRec(_, _, _, mbinds, _) -> @@ -7113,14 +7087,14 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = | TMDefOpens _ -> z | TMDefDo(e, _) -> exprF z e | TMDefs defs -> List.fold mdefF z defs - | TMWithSig x -> mexprF z x and mbindF z x = match x with | ModuleOrNamespaceBinding.Binding b -> valBindF false z b | ModuleOrNamespaceBinding.Module(_, def) -> mdefF z def - and implF z x = foldTImplFile mexprF z x + let implF z (x: CheckedImplFile) = + mdefF z x.Contents do exprFClosure <- exprF // allocate one instance of this closure do exprNoInterceptFClosure <- exprNoInterceptF // allocate one instance of this closure @@ -8813,7 +8787,7 @@ let canUseUnboxFast g m ty = // // No sequence point is generated for this expression form as this function is only // used for compiler-generated code. -let mkIsInstConditional g m tgty vinpe v e2 e3 = +let mkIsInstConditional g m tgty vinputExpr v e2 e3 = if canUseTypeTestFast g tgty && isRefTy g tgty then @@ -8822,13 +8796,13 @@ let mkIsInstConditional g m tgty vinpe v e2 e3 = let tg3 = mbuilder.AddResultTarget(e3) let dtree = TDSwitch(exprForVal m v, [TCase(DecisionTreeTest.IsNull, tg3)], Some tg2, m) let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) - mkCompGenLet m v (mkIsInst tgty vinpe m) expr + mkCompGenLet m v (mkIsInst tgty vinputExpr m) expr else let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) - let tg2 = TDSuccess([mkCallUnbox g m tgty vinpe], mbuilder.AddTarget(TTarget([v], e2, None))) + let tg2 = TDSuccess([mkCallUnbox g m tgty vinputExpr], mbuilder.AddTarget(TTarget([v], e2, None))) let tg3 = mbuilder.AddResultTarget(e3) - let dtree = TDSwitch(vinpe, [TCase(DecisionTreeTest.IsInst(tyOfExpr g vinpe, tgty), tg2)], Some tg3, m) + let dtree = TDSwitch(vinputExpr, [TCase(DecisionTreeTest.IsInst(tyOfExpr g vinputExpr, tgty), tg2)], Some tg3, m) let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) expr @@ -9110,10 +9084,10 @@ and rewriteExprStructure env expr = let bodyR = RewriteExpr env body mkTypeLambda m tps (bodyR, bodyTy) - | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> + | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> let dtreeR = RewriteDecisionTree env dtree let targetsR = rewriteTargets env targets - mkAndSimplifyMatch spBind exprm m ty dtreeR targetsR + mkAndSimplifyMatch spBind mExpr m ty dtreeR targetsR | Expr.LetRec (binds, e, m, _) -> let bindsR = rewriteBinds env binds @@ -9162,12 +9136,12 @@ and rewriteLinearExpr env expr contf = if argsFront === argsFrontR && argLast === argLastR then expr else rebuildLinearOpExpr (op, tyargs, argsFrontR, argLastR, m))) - | LinearMatchExpr (spBind, exprm, dtree, tg1, expr2, m2, ty) -> + | LinearMatchExpr (spBind, mExpr, dtree, tg1, expr2, m2, ty) -> let dtree = RewriteDecisionTree env dtree let tg1R = rewriteTarget env tg1 // tailcall rewriteLinearExpr env expr2 (contf << (fun expr2R -> - rebuildLinearMatchExpr (spBind, exprm, dtree, tg1R, expr2R, m2, ty))) + rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1R, expr2R, m2, ty))) | Expr.DebugPoint (dpm, innerExpr) -> rewriteLinearExpr env innerExpr (contf << (fun innerExprR -> @@ -9213,30 +9187,28 @@ and rewriteObjExprInterfaceImpl env (ty, overrides) = (ty, List.map (rewriteObjExprOverride env) overrides) and rewriteModuleOrNamespaceContents env x = - match x with - | ModuleOrNamespaceContentsWithSig(mty, def, m) -> ModuleOrNamespaceContentsWithSig(mty, rewriteModuleOrNamespaceDef env def, m) - -and rewriteModuleOrNamespaceDefs env x = List.map (rewriteModuleOrNamespaceDef env) x - -and rewriteModuleOrNamespaceDef env x = match x with | TMDefRec(isRec, opens, tycons, mbinds, m) -> TMDefRec(isRec, opens, tycons, rewriteModuleOrNamespaceBindings env mbinds, m) | TMDefLet(bind, m) -> TMDefLet(rewriteBind env bind, m) | TMDefDo(e, m) -> TMDefDo(RewriteExpr env e, m) | TMDefOpens _ -> x - | TMDefs defs -> TMDefs(rewriteModuleOrNamespaceDefs env defs) - | TMWithSig mexpr -> TMWithSig(rewriteModuleOrNamespaceContents env mexpr) + | TMDefs defs -> TMDefs(List.map (rewriteModuleOrNamespaceContents env) defs) and rewriteModuleOrNamespaceBinding env x = - match x with - | ModuleOrNamespaceBinding.Binding bind -> ModuleOrNamespaceBinding.Binding (rewriteBind env bind) - | ModuleOrNamespaceBinding.Module(nm, rhs) -> ModuleOrNamespaceBinding.Module(nm, rewriteModuleOrNamespaceDef env rhs) - -and rewriteModuleOrNamespaceBindings env mbinds = List.map (rewriteModuleOrNamespaceBinding env) mbinds - -and RewriteImplFile env mv = mapTImplFile (rewriteModuleOrNamespaceContents env) mv + match x with + | ModuleOrNamespaceBinding.Binding bind -> + ModuleOrNamespaceBinding.Binding (rewriteBind env bind) + | ModuleOrNamespaceBinding.Module(nm, rhs) -> + ModuleOrNamespaceBinding.Module(nm, rewriteModuleOrNamespaceContents env rhs) +and rewriteModuleOrNamespaceBindings env mbinds = + List.map (rewriteModuleOrNamespaceBinding env) mbinds +and RewriteImplFile env implFile = + let (CheckedImplFile (fragName, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile + let contentsR = rewriteModuleOrNamespaceContents env contents + let implFileR = CheckedImplFile (fragName, pragmas, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + implFileR //-------------------------------------------------------------------------- // Build a Remap that converts all "local" references to "public" things @@ -9289,7 +9261,7 @@ let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = let tyconAbbrevR = d.TypeAbbrev |> Option.map (remapType tmenvinner) let tyconTcaugR = d.entity_tycon_tcaug |> remapTyconAug tmenvinner let modulContentsR = - MaybeLazy.Strict (d.entity_modul_contents.Value + MaybeLazy.Strict (d.entity_modul_type.Value |> mapImmediateValsAndTycons (remapTyconToNonLocal ctxt tmenv) (remapValToNonLocal ctxt tmenv)) let exnInfoR = d.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner { d with @@ -9297,7 +9269,7 @@ let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = entity_attribs = attribsR entity_tycon_repr = tyconReprR entity_tycon_tcaug = tyconTcaugR - entity_modul_contents = modulContentsR + entity_modul_type = modulContentsR entity_opt_data = match d.entity_opt_data with | Some dd -> @@ -9882,7 +9854,7 @@ let CombineCcuContentFragments m l = let xml = XmlDoc.Merge entity1.XmlDoc entity2.XmlDoc { data1 with entity_attribs = entity1.Attribs @ entity2.Attribs - entity_modul_contents = MaybeLazy.Lazy (lazy (CombineModuleOrNamespaceTypes (path@[entity2.DemangledModuleOrNamespaceName]) entity2.Range entity1.ModuleOrNamespaceType entity2.ModuleOrNamespaceType)) + entity_modul_type = MaybeLazy.Lazy (lazy (CombineModuleOrNamespaceTypes (path@[entity2.DemangledModuleOrNamespaceName]) entity2.Range entity1.ModuleOrNamespaceType entity2.ModuleOrNamespaceType)) entity_opt_data = match data1.entity_opt_data with | Some optData -> Some { optData with entity_xmldoc = xml } @@ -9938,11 +9910,11 @@ let (|TryWithExpr|_|) expr = let (|MatchTwoCasesExpr|_|) expr = match expr with - | Expr.Match (spBind, exprm, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) -> + | Expr.Match (spBind, mExpr, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) -> // How to rebuild this construct let rebuild (cond, ucref, tg1, tg2, tgs) = - Expr.Match (spBind, exprm, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) + Expr.Match (spBind, mExpr, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) Some (cond, ucref, tg1, tg2, tgs, rebuild) diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 045425f3513..17ff3b487fb 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -233,18 +233,18 @@ val mkInvisibleBinds: Vals -> Exprs -> Bindings /// Make a let-rec expression that locally binds values to expressions where self-reference back to the values is possible. val mkLetRecBinds: range -> Bindings -> Expr -> Expr -/// TypeScheme (generalizedTypars, tauTy) +/// GeneralizedType (generalizedTypars, tauTy) /// /// generalizedTypars -- the truly generalized type parameters /// tauTy -- the body of the generalized type. A 'tau' type is one with its type parameters stripped off. -type TypeScheme = TypeScheme of Typars * TType +type GeneralizedType = GeneralizedType of Typars * TType /// Make the right-hand side of a generalized binding, incorporating the generalized generic parameters from the type /// scheme into the right-hand side as type generalizations. -val mkGenericBindRhs: TcGlobals -> range -> Typars -> TypeScheme -> Expr -> Expr +val mkGenericBindRhs: TcGlobals -> range -> Typars -> GeneralizedType -> Expr -> Expr /// Test if the type parameter is one of those being generalized by a type scheme. -val isBeingGeneralized: Typar -> TypeScheme -> bool +val isBeingGeneralized: Typar -> GeneralizedType -> bool /// Make the expression corresponding to 'expr1 && expr2' val mkLazyAnd: TcGlobals -> range -> Expr -> Expr -> Expr @@ -539,7 +539,7 @@ val valRefEq: TcGlobals -> ValRef -> ValRef -> bool //------------------------------------------------------------------------- /// Represents an instantiation where types replace type parameters -type TyparInst = (Typar * TType) list +type TyparInstantiation = (Typar * TType) list /// Represents an instantiation where type definition references replace other type definition references type TyconRefRemap = TyconRefMap @@ -550,7 +550,7 @@ type ValRemap = ValMap /// Represents a combination of substitutions/instantiations where things replace other things during remapping [] type Remap = - { tpinst: TyparInst + { tpinst: TyparInstantiation valRemap: ValRemap tyconRefRemap: TyconRefRemap removeTraitSolutions: bool } @@ -561,19 +561,19 @@ val addTyconRefRemap: TyconRef -> TyconRef -> Remap -> Remap val addValRemap: Val -> Val -> Remap -> Remap -val mkTyparInst: Typars -> TTypes -> TyparInst +val mkTyparInst: Typars -> TTypes -> TyparInstantiation -val mkTyconRefInst: TyconRef -> TypeInst -> TyparInst +val mkTyconRefInst: TyconRef -> TypeInst -> TyparInstantiation -val emptyTyparInst: TyparInst +val emptyTyparInst: TyparInstantiation -val instType: TyparInst -> TType -> TType +val instType: TyparInstantiation -> TType -> TType -val instTypes: TyparInst -> TypeInst -> TypeInst +val instTypes: TyparInstantiation -> TypeInst -> TypeInst -val instTyparConstraints: TyparInst -> TyparConstraint list -> TyparConstraint list +val instTyparConstraints: TyparInstantiation -> TyparConstraint list -> TyparConstraint list -val instTrait: TyparInst -> TraitConstraintInfo -> TraitConstraintInfo +val instTrait: TyparInstantiation -> TraitConstraintInfo -> TraitConstraintInfo val generalTyconRefInst: TyconRef -> TypeInst @@ -584,7 +584,7 @@ val generalizeTyconRef: TcGlobals -> TyconRef -> TTypes * TType val generalizedTyconRef: TcGlobals -> TyconRef -> TType -val mkTyparToTyparRenaming: Typars -> Typars -> TyparInst * TTypes +val mkTyparToTyparRenaming: Typars -> Typars -> TyparInstantiation * TTypes //------------------------------------------------------------------------- // See through typar equations from inference and/or type abbreviation equations. @@ -695,7 +695,7 @@ val tryDestAnonRecdTy: TcGlobals -> TType -> ValueOption TType -> TypeInst -val mkInstForAppTy: TcGlobals -> TType -> TyparInst +val mkInstForAppTy: TcGlobals -> TType -> TyparInstantiation /// Try to get a TyconRef for a type without erasing type abbreviations val tryNiceEntityRefOfTy: TType -> ValueOption @@ -723,11 +723,11 @@ val tryDestRefTupleTy: TcGlobals -> TType -> TType list val actualResultTyOfUnionCase: TypeInst -> UnionCaseRef -> TType -val actualTysOfUnionCaseFields: TyparInst -> UnionCaseRef -> TType list +val actualTysOfUnionCaseFields: TyparInstantiation -> UnionCaseRef -> TType list -val actualTysOfInstanceRecdFields: TyparInst -> TyconRef -> TType list +val actualTysOfInstanceRecdFields: TyparInstantiation -> TyconRef -> TType list -val actualTyOfRecdField: TyparInst -> RecdField -> TType +val actualTyOfRecdField: TyparInstantiation -> RecdField -> TType val actualTyOfRecdFieldRef: RecdFieldRef -> TypeInst -> TType @@ -860,7 +860,7 @@ type TypeEquivEnv = member BindEquivTypars: Typars -> Typars -> TypeEquivEnv - static member FromTyparInst: TyparInst -> TypeEquivEnv + static member FromTyparInst: TyparInstantiation -> TypeEquivEnv static member FromEquivTypars: Typars -> Typars -> TypeEquivEnv @@ -944,13 +944,13 @@ val GetMemberTypeInMemberForm: /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst) val PartitionValTyparsForApparentEnclosingType: - TcGlobals -> Val -> (Typars * Typars * Typars * TyparInst * TType list) option + TcGlobals -> Val -> (Typars * Typars * Typars * TyparInstantiation * TType list) option /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst) -val PartitionValTypars: TcGlobals -> Val -> (Typars * Typars * Typars * TyparInst * TType list) option +val PartitionValTypars: TcGlobals -> Val -> (Typars * Typars * Typars * TyparInstantiation * TType list) option /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst) -val PartitionValRefTypars: TcGlobals -> ValRef -> (Typars * Typars * Typars * TyparInst * TType list) option +val PartitionValRefTypars: TcGlobals -> ValRef -> (Typars * Typars * Typars * TyparInstantiation * TType list) option /// Count the number of type parameters on the enclosing type val CountEnclosingTyparsOfActualParentOfVal: Val -> int @@ -973,14 +973,16 @@ module PrettyTypes = val NeedsPrettyTyparName: Typar -> bool - val NewPrettyTypars: TyparInst -> Typars -> string list -> Typars * TyparInst + val NewPrettyTypars: TyparInstantiation -> Typars -> string list -> Typars * TyparInstantiation val PrettyTyparNames: (Typar -> bool) -> string list -> Typars -> string list val PrettifyType: TcGlobals -> TType -> TType * TyparConstraintsWithTypars val PrettifyInstAndTyparsAndType: - TcGlobals -> TyparInst * Typars * TType -> (TyparInst * Typars * TType) * TyparConstraintsWithTypars + TcGlobals -> + TyparInstantiation * Typars * TType -> + (TyparInstantiation * Typars * TType) * TyparConstraintsWithTypars val PrettifyTypePair: TcGlobals -> TType * TType -> (TType * TType) * TyparConstraintsWithTypars @@ -992,14 +994,18 @@ module PrettyTypes = val PrettifyDiscriminantAndTypePairs: TcGlobals -> ('Discriminant * TType) list -> ('Discriminant * TType) list * TyparConstraintsWithTypars - val PrettifyInst: TcGlobals -> TyparInst -> TyparInst * TyparConstraintsWithTypars + val PrettifyInst: TcGlobals -> TyparInstantiation -> TyparInstantiation * TyparConstraintsWithTypars - val PrettifyInstAndType: TcGlobals -> TyparInst * TType -> (TyparInst * TType) * TyparConstraintsWithTypars + val PrettifyInstAndType: + TcGlobals -> TyparInstantiation * TType -> (TyparInstantiation * TType) * TyparConstraintsWithTypars - val PrettifyInstAndTypes: TcGlobals -> TyparInst * TTypes -> (TyparInst * TTypes) * TyparConstraintsWithTypars + val PrettifyInstAndTypes: + TcGlobals -> TyparInstantiation * TTypes -> (TyparInstantiation * TTypes) * TyparConstraintsWithTypars val PrettifyInstAndSig: - TcGlobals -> TyparInst * TTypes * TType -> (TyparInst * TTypes * TType) * TyparConstraintsWithTypars + TcGlobals -> + TyparInstantiation * TTypes * TType -> + (TyparInstantiation * TTypes * TType) * TyparConstraintsWithTypars val PrettifyCurriedTypes: TcGlobals -> TType list list -> TType list list * TyparConstraintsWithTypars @@ -1008,13 +1014,13 @@ module PrettyTypes = val PrettifyInstAndUncurriedSig: TcGlobals -> - TyparInst * UncurriedArgInfos * TType -> - (TyparInst * UncurriedArgInfos * TType) * TyparConstraintsWithTypars + TyparInstantiation * UncurriedArgInfos * TType -> + (TyparInstantiation * UncurriedArgInfos * TType) * TyparConstraintsWithTypars val PrettifyInstAndCurriedSig: TcGlobals -> - TyparInst * TTypes * CurriedArgInfos * TType -> - (TyparInst * TTypes * CurriedArgInfos * TType) * TyparConstraintsWithTypars + TyparInstantiation * TTypes * CurriedArgInfos * TType -> + (TyparInstantiation * TTypes * CurriedArgInfos * TType) * TyparConstraintsWithTypars /// Describes how generic type parameters in a type will be formatted during printing type GenericParameterStyle = @@ -1222,16 +1228,16 @@ val copyModuleOrNamespaceType: TcGlobals -> ValCopyFlag -> ModuleOrNamespaceType val copyExpr: TcGlobals -> ValCopyFlag -> Expr -> Expr /// Copy an entire implementation file using the given copying flags -val copyImplFile: TcGlobals -> ValCopyFlag -> TypedImplFile -> TypedImplFile +val copyImplFile: TcGlobals -> ValCopyFlag -> CheckedImplFile -> CheckedImplFile /// Copy a method slot signature, including new generic type parameters if the slot signature represents a generic method val copySlotSig: SlotSig -> SlotSig /// Instantiate the generic type parameters in a method slot signature, building a new one -val instSlotSig: TyparInst -> SlotSig -> SlotSig +val instSlotSig: TyparInstantiation -> SlotSig -> SlotSig /// Instantiate the generic type parameters in an expression, building a new one -val instExpr: TcGlobals -> TyparInst -> Expr -> Expr +val instExpr: TcGlobals -> TyparInstantiation -> Expr -> Expr /// The remapping that corresponds to a module meeting its signature /// and also report the set of tycons, tycon representations and values hidden in the process. @@ -1284,9 +1290,6 @@ val wrapModuleOrNamespaceTypeInNamespace: /// Wrap one module or namespace definition in a 'module M = ..' outer wrapper val wrapModuleOrNamespaceType: Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespace -/// Given an implementation, fetch its recorded signature -val SigTypeOfImplFile: TypedImplFile -> ModuleOrNamespaceType - /// Given a namespace, module or type definition, try to produce a reference to that entity. val tryRescopeEntity: CcuThunk -> Entity -> ValueOption @@ -1457,10 +1460,10 @@ module DebugPrint = val decisionTreeL: TcGlobals -> DecisionTree -> Layout /// Debug layout for an implementation file - val implFileL: TcGlobals -> TypedImplFile -> Layout + val implFileL: TcGlobals -> CheckedImplFile -> Layout /// Debug layout for a list of implementation files - val implFilesL: TcGlobals -> TypedImplFile list -> Layout + val implFilesL: TcGlobals -> CheckedImplFile list -> Layout /// Debug layout for class and record fields val recdFieldRefL: RecdFieldRef -> Layout @@ -1483,7 +1486,7 @@ type ExprFolder<'State> = val ExprFolder0: ExprFolder<'State> /// Fold over all the expressions in an implementation file -val FoldImplFile: ExprFolder<'State> -> ('State -> TypedImplFile -> 'State) +val FoldImplFile: ExprFolder<'State> -> ('State -> CheckedImplFile -> 'State) /// Fold over all the expressions in an expression val FoldExpr: ExprFolder<'State> -> ('State -> Expr -> 'State) @@ -2413,7 +2416,7 @@ val RewriteDecisionTree: ExprRewritingEnv -> DecisionTree -> DecisionTree val RewriteExpr: ExprRewritingEnv -> Expr -> Expr -val RewriteImplFile: ExprRewritingEnv -> TypedImplFile -> TypedImplFile +val RewriteImplFile: ExprRewritingEnv -> CheckedImplFile -> CheckedImplFile val IsGenericValWithGenericConstraints: TcGlobals -> Val -> bool diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 010e2939431..00e9ae570f1 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1879,7 +1879,7 @@ and p_tycon_repr x st = match x with | TFSharpRecdRepr fs -> p_byte 1 st; p_byte 0 st; p_rfield_table fs st; false | TFSharpUnionRepr x -> p_byte 1 st; p_byte 1 st; p_array p_unioncase_spec x.CasesTable.CasesByIndex st; false - | TAsmRepr ilty -> p_byte 1 st; p_byte 2 st; p_ILType ilty st; false + | TAsmRepr ilTy -> p_byte 1 st; p_byte 2 st; p_ILType ilTy st; false | TFSharpObjectRepr r -> p_byte 1 st; p_byte 3 st; p_tycon_objmodel_data r st; false | TMeasureableRepr ty -> p_byte 1 st; p_byte 4 st; p_ty ty st; false | TNoRepr -> p_byte 0 st; false @@ -1958,7 +1958,7 @@ and p_entity_spec_data (x: Entity) st = p_kind x.TypeOrMeasureKind st p_int64 (x.entity_flags.PickledBits ||| (if flagBit then EntityFlags.ReservedBitForPickleFormatTyconReprFlag else 0L)) st p_option p_cpath x.entity_cpath st - p_maybe_lazy p_modul_typ x.entity_modul_contents st + p_maybe_lazy p_modul_typ x.entity_modul_type st p_exnc_repr x.ExceptionInfo st if st.oInMem then p_used_space1 (p_xmldoc x.XmlDoc) st @@ -2223,7 +2223,7 @@ and u_entity_spec_data st : Entity = entity_tycon_tcaug=x9 entity_flags=EntityFlags x11 entity_cpath=x12 - entity_modul_contents=MaybeLazy.Lazy x13 + entity_modul_type=MaybeLazy.Lazy x13 entity_il_repr_cache=newCache() entity_opt_data= match x2b, x10b, x15, x8, x4a, x4b, x14 with diff --git a/src/Compiler/Utilities/EditDistance.fs b/src/Compiler/Utilities/EditDistance.fs index 465785b1a26..1173da83880 100644 --- a/src/Compiler/Utilities/EditDistance.fs +++ b/src/Compiler/Utilities/EditDistance.fs @@ -122,7 +122,7 @@ let private calcDamerauLevenshtein (a:string, b:string) = /// Calculates the edit distance between two strings. /// The edit distance is a metric that allows to measure the amount of difference between two strings /// and shows how many edit operations (insert, delete, substitution) are needed to transform one string into the other. -let CalcEditDistance(a:string, b:string) = +let CalculateEditDistance(a:string, b:string) = if a.Length > b.Length then calcDamerauLevenshtein(a, b) else diff --git a/src/Compiler/Utilities/EditDistance.fsi b/src/Compiler/Utilities/EditDistance.fsi index db3a4295c0d..6ec11a2c2c7 100644 --- a/src/Compiler/Utilities/EditDistance.fsi +++ b/src/Compiler/Utilities/EditDistance.fsi @@ -9,4 +9,4 @@ val JaroWinklerDistance: s1: string -> s2: string -> float /// Calculates the edit distance between two strings. /// The edit distance is a metric that allows to measure the amount of difference between two strings /// and shows how many edit operations (insert, delete, substitution) are needed to transform one string into the other. -val CalcEditDistance: a: string * b: string -> int +val CalculateEditDistance: a: string * b: string -> int diff --git a/src/Compiler/Utilities/lib.fs b/src/Compiler/Utilities/lib.fs index b2437cbb2dc..b0e75623531 100755 --- a/src/Compiler/Utilities/lib.fs +++ b/src/Compiler/Utilities/lib.fs @@ -315,7 +315,7 @@ module Zset = let equalOn f x y = (f x) = (f y) /// Buffer printing utility -let bufs f = +let buildString f = let buf = StringBuilder 100 f buf buf.ToString() diff --git a/src/Compiler/Utilities/lib.fsi b/src/Compiler/Utilities/lib.fsi index 3fc3caa70b2..74be4d2ace9 100644 --- a/src/Compiler/Utilities/lib.fsi +++ b/src/Compiler/Utilities/lib.fsi @@ -227,7 +227,7 @@ module Zset = val equalOn: f: ('a -> 'b) -> x: 'a -> y: 'a -> bool when 'b: equality /// Buffer printing utility -val bufs: f: (StringBuilder -> unit) -> string +val buildString: f: (StringBuilder -> unit) -> string /// Writing to output stream via a string buffer. val writeViaBuffer: os: TextWriter -> f: (StringBuilder -> 'a -> unit) -> x: 'a -> unit diff --git a/src/Compiler/lex.fsl b/src/Compiler/lex.fsl index bc06a67f684..45057efa104 100644 --- a/src/Compiler/lex.fsl +++ b/src/Compiler/lex.fsl @@ -61,7 +61,7 @@ let lexemeTrimLeft lexbuf n = lexemeTrimBoth lexbuf n 0 /// Throw a lexing error with a message let fail args (lexbuf:UnicodeLexing.Lexbuf) msg dflt = let m = lexbuf.LexemeRange - args.errorLogger.ErrorR(Error(msg,m)) + args.diagnosticsLogger.ErrorR(Error(msg,m)) dflt //-------------------------- @@ -670,7 +670,7 @@ rule token args skip = parse else WHITESPACE (LexCont.Token(args.ifdefStack, args.stringNest)) } | offwhite+ - { if args.lightStatus.Status then errorR(Error(FSComp.SR.lexTabsNotAllowed(), lexbuf.LexemeRange)) + { if args.indentationSyntaxStatus.Status then errorR(Error(FSComp.SR.lexTabsNotAllowed(), lexbuf.LexemeRange)) if not skip then WHITESPACE (LexCont.Token(args.ifdefStack, args.stringNest)) else token args skip lexbuf } @@ -929,17 +929,17 @@ rule token args skip = parse | "#light" anywhite* | ("#indent" | "#light") anywhite+ "\"on\"" - { if args.lightStatus.ExplicitlySet && args.lightStatus.WarnOnMultipleTokens then + { if args.indentationSyntaxStatus.ExplicitlySet && args.indentationSyntaxStatus.WarnOnMultipleTokens then let s = lexeme lexbuf warning(Error((0, sprintf "%s should only be set once in an F# source file." s), lexbuf.LexemeRange)) // TODO: where should this go? (abelb) //warning(Error((0,"#light should only occur as the first non-comment text in an F# source file."), lexbuf.LexemeRange)) - args.lightStatus.Status <- true + args.indentationSyntaxStatus.Status <- true if not skip then HASH_LIGHT (LexCont.Token(args.ifdefStack, args.stringNest)) else token args skip lexbuf } | ("#indent" | "#light") anywhite+ "\"off\"" - { args.lightStatus.Status <- false + { args.indentationSyntaxStatus.Status <- false if lexbuf.SupportsFeature LanguageFeature.MLCompatRevisions then mlCompatError (FSComp.SR.mlCompatLightOffNoLongerSupported()) lexbuf.LexemeRange else diff --git a/src/Compiler/pars.fsy b/src/Compiler/pars.fsy index 17765843400..7706a8b7b7f 100644 --- a/src/Compiler/pars.fsy +++ b/src/Compiler/pars.fsy @@ -1869,7 +1869,7 @@ memberCore: let tryMkSynMemberDefnMember (withPropertyKeyword: PropertyKeyword option) - (optInline, (optAttrs: SynAttributeList list), (bindingPat, mBindLhs), optReturnType, mEquals, expr, exprm) + (optInline, (optAttrs: SynAttributeList list), (bindingPat, mBindLhs), optReturnType, mEquals, expr, mExpr) = let optInline = $1 || optInline // optional attributes are only applied to getters and setters @@ -1881,7 +1881,7 @@ memberCore: let attrs = attrs @ optAttrs let trivia: SynBindingTrivia = { LetKeyword = None; EqualsRange = mEquals } - let binding = mkSynBinding (xmlDoc, bindingPat) (visNoLongerUsed, optInline, isMutable, mBindLhs, DebugPointAtBinding.NoneAtInvisible, optReturnType, expr, exprm, [], attrs, Some (memFlagsBuilder SynMemberKind.Member), trivia) + let binding = mkSynBinding (xmlDoc, bindingPat) (visNoLongerUsed, optInline, isMutable, mBindLhs, DebugPointAtBinding.NoneAtInvisible, optReturnType, expr, mExpr, [], attrs, Some (memFlagsBuilder SynMemberKind.Member), trivia) let (SynBinding (vis, _, isInline, _, attrs, doc, valSynData, pv, _, _, mBindLhs, spBind, _)) = binding let memberKind = let getset = @@ -1931,7 +1931,7 @@ memberCore: // REDO with the correct member kind let trivia: SynBindingTrivia = { LetKeyword = None; EqualsRange = mEquals } - let binding = mkSynBinding (PreXmlDoc.Empty, bindingPat) (vis, isInline, isMutable, mBindLhs, DebugPointAtBinding.NoneAtInvisible, optReturnType, expr, exprm, [], attrs, Some(memFlagsBuilder memberKind), trivia) + let binding = mkSynBinding (PreXmlDoc.Empty, bindingPat) (vis, isInline, isMutable, mBindLhs, DebugPointAtBinding.NoneAtInvisible, optReturnType, expr, mExpr, [], attrs, Some(memFlagsBuilder memberKind), trivia) let (SynBinding (vis, _, isInline, _, attrs, doc, valSynData, pv, rhsRetInfo, rhsExpr, mBindLhs, spBind, trivia)) = binding let mWholeBindLhs = (mBindLhs, attrs) ||> unionRangeWithListBy (fun (a: SynAttributeList) -> a.Range) @@ -1992,7 +1992,7 @@ memberCore: let bindingPatAdjusted, xmlDocAdjusted = let trivia: SynBindingTrivia = { LetKeyword = None; EqualsRange = mEquals } - let bindingOuter = mkSynBinding (xmlDoc, propertyNameBindingPat) (vis, optInline, isMutable, mWholeBindLhs, spBind, optReturnType, expr, exprm, [], attrs, Some(memFlagsBuilder SynMemberKind.Member), trivia) + let bindingOuter = mkSynBinding (xmlDoc, propertyNameBindingPat) (vis, optInline, isMutable, mWholeBindLhs, spBind, optReturnType, expr, mExpr, [], attrs, Some(memFlagsBuilder SynMemberKind.Member), trivia) let (SynBinding (_, _, _, _, _, doc2, _, bindingPatOuter, _, _, _, _, _)) = bindingOuter diff --git a/src/Compiler/pplex.fsl b/src/Compiler/pplex.fsl index 4b6da64ff55..3806b114846 100644 --- a/src/Compiler/pplex.fsl +++ b/src/Compiler/pplex.fsl @@ -17,7 +17,7 @@ let lexeme (lexbuf : UnicodeLexing.Lexbuf) = UnicodeLexing.Lexbuf.LexemeString l let fail (args : LexArgs) (lexbuf:UnicodeLexing.Lexbuf) e = let m = lexbuf.LexemeRange - args.errorLogger.ErrorR(Error(e,m)) + args.diagnosticsLogger.ErrorR(Error(e,m)) PPParser.EOF } diff --git a/src/FSharp.Core/Linq.fs b/src/FSharp.Core/Linq.fs index d46d9eedb56..5b383f2c3d2 100644 --- a/src/FSharp.Core/Linq.fs +++ b/src/FSharp.Core/Linq.fs @@ -663,7 +663,7 @@ module LeafExpressionConverter = failConvert inp and failConvert inp = - raise (new NotSupportedException(Printf.sprintf "Could not convert the following F# Quotation to a LINQ Expression Tree\n--------\n%A\n-------------\n" inp)) + raise (new NotSupportedException(Printf.sprintf "Could not convert the following F# Quotation to a LINQ Expression Tree\n--------\n%s\n-------------\n" (inp.ToString()))) and transBinOp inp env addConvertLeft args addConvertRight (exprErasedConstructor : _ * _ -> _) = match args with diff --git a/src/FSharp.Core/Query.fs b/src/FSharp.Core/Query.fs index 18fec9dfef8..2701df53b1c 100644 --- a/src/FSharp.Core/Query.fs +++ b/src/FSharp.Core/Query.fs @@ -1799,27 +1799,26 @@ module Query = let linqQuery = TransInnerWithFinalConsume canElim queryProducingSequence let linqQueryAfterEliminatingNestedQueries = EliminateNestedQueries linqQuery -#if DEBUG - let debug() = - Printf.printfn "----------------------queryProducingSequence-------------------------" - Printf.printfn "%A" queryProducingSequence - Printf.printfn "--------------------------linqQuery (before nested)------------------" - Printf.printfn "%A" linqQuery - Printf.printfn "--------------------------linqQuery (after nested)-------------------" - Printf.printfn "%A" linqQueryAfterEliminatingNestedQueries -#endif - +//#if DEBUG +// let debug() = +// Printf.printfn "----------------------queryProducingSequence-------------------------" +// Printf.printfn "%A" queryProducingSequence +// Printf.printfn "--------------------------linqQuery (before nested)------------------" +// Printf.printfn "%A" linqQuery +// Printf.printfn "--------------------------linqQuery (after nested)-------------------" +// Printf.printfn "%A" linqQueryAfterEliminatingNestedQueries +//#endif let result = try LeafExpressionConverter.EvaluateQuotation linqQueryAfterEliminatingNestedQueries with e -> -#if DEBUG - debug() - Printf.printfn "--------------------------error--------------------------------------" - Printf.printfn "%A" (e.ToString()) - Printf.printfn "---------------------------------------------------------------------" -#endif +//#if DEBUG +// debug() +// Printf.printfn "--------------------------error--------------------------------------" +// Printf.printfn "%A" (e.ToString()) +// Printf.printfn "---------------------------------------------------------------------" +//#endif reraise () diff --git a/src/FSharp.Core/QueryExtensions.fs b/src/FSharp.Core/QueryExtensions.fs index f21c93ba648..7da5831e478 100644 --- a/src/FSharp.Core/QueryExtensions.fs +++ b/src/FSharp.Core/QueryExtensions.fs @@ -161,7 +161,7 @@ module internal Adapters = mutableTupleType.MakeGenericType (ty.GetGenericArguments() |> Array.toList |> conv |> Array.ofList) | _ -> assert false - Printf.failwithf "unreachable, ty = %A" ty + failwith "unreachable" let (|RecordFieldGetSimplification|_|) (expr:Expr) = match expr with diff --git a/src/FSharp.Core/quotations.fs b/src/FSharp.Core/quotations.fs index 81d02f40a54..ed8829414d6 100644 --- a/src/FSharp.Core/quotations.fs +++ b/src/FSharp.Core/quotations.fs @@ -328,14 +328,11 @@ and [] match e with | NLambdas nargs (vs, e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) | _ -> combL "NewDelegate" [typeL ty; expr e] - //| CombTerm(_, args) -> combL "??" (exprs args) | VarTerm v -> wordL (tagLocal v.Name) | LambdaTerm(v, b) -> combL "Lambda" [varL v; expr b] | HoleTerm _ -> wordL (tagLocal "_") | CombTerm(QuoteOp _, args) -> combL "Quote" (exprs args) - | _ -> failwithf "Unexpected term in layout %A" x.Tree - - + | _ -> failwithf "Unexpected term" and [] Expr<'T>(term:Tree, attribs) = @@ -1411,7 +1408,7 @@ module Patterns = // For some reason we can get 'null' returned here even when a type with the right name exists... Hence search the slow way... match (assembly.GetTypes() |> Array.tryFind (fun a -> a.FullName = tcName)) with | Some ty -> ty - | None -> invalidArg "tcName" (String.Format(SR.GetString(SR.QfailedToBindTypeInAssembly), tcName, assembly.FullName)) // "Available types are:\n%A" tcName assembly (assembly.GetTypes() |> Array.map (fun a -> a.FullName)) + | None -> invalidArg "tcName" (String.Format(SR.GetString(SR.QfailedToBindTypeInAssembly), tcName, assembly.FullName)) | ty -> ty let decodeNamedTy genericType tsR = mkNamedType (genericType, tsR) @@ -1711,7 +1708,7 @@ module Patterns = if minfo.IsStatic then StaticMethodCallWOp(minfo, minfoW, n) else InstanceMethodCallWOp(minfo, minfoW, n)) // 51 taken above - | _ -> failwithf "u_constSpec, unrecognized tag %d" tag + | _ -> failwith ("u_constSpec, unrecognized tag " + string tag) Unique constSpec let u_ReflectedDefinition = u_tup2 u_MethodBase u_Expr diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected index ed424186d54..a5ac8e2f2be 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected @@ -2081,19 +2081,19 @@ FSharp.Compiler.CodeAnalysis.FSharpParseFileResults: System.String get_FileName( FSharp.Compiler.CodeAnalysis.FSharpParseFileResults: System.String[] DependencyFiles FSharp.Compiler.CodeAnalysis.FSharpParseFileResults: System.String[] get_DependencyFiles() FSharp.Compiler.CodeAnalysis.FSharpParsingOptions -FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean CompilingFsLib +FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean CompilingFSharpCore FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean Equals(FSharp.Compiler.CodeAnalysis.FSharpParsingOptions) FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean Equals(System.Object) FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean Equals(System.Object, System.Collections.IEqualityComparer) FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean IsExe FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean IsInteractive -FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean get_CompilingFsLib() +FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean get_CompilingFSharpCore() FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean get_IsExe() FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Boolean get_IsInteractive() FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.CodeAnalysis.FSharpParsingOptions Default FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.CodeAnalysis.FSharpParsingOptions get_Default() -FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions ErrorSeverityOptions -FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions get_ErrorSeverityOptions() +FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions DiagnosticOptions +FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions get_DiagnosticOptions() FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Int32 CompareTo(FSharp.Compiler.CodeAnalysis.FSharpParsingOptions) FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Int32 CompareTo(System.Object) FSharp.Compiler.CodeAnalysis.FSharpParsingOptions: Int32 CompareTo(System.Object, System.Collections.IComparer) @@ -9010,8 +9010,8 @@ FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValInfo arity FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValInfo get_SynInfo() FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValInfo get_arity() FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValSig NewSynValSig(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynAttributeList], FSharp.Compiler.Syntax.SynIdent, FSharp.Compiler.Syntax.SynValTyparDecls, FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Syntax.SynValInfo, Boolean, Boolean, FSharp.Compiler.Xml.PreXmlDoc, Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Syntax.SynAccess], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Syntax.SynExpr], FSharp.Compiler.Text.Range, FSharp.Compiler.SyntaxTrivia.SynValSigTrivia) -FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValTyparDecls explicitValDecls -FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValTyparDecls get_explicitValDecls() +FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValTyparDecls explicitTypeParams +FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Syntax.SynValTyparDecls get_explicitTypeParams() FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.SyntaxTrivia.SynValSigTrivia get_trivia() FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.SyntaxTrivia.SynValSigTrivia trivia FSharp.Compiler.Syntax.SynValSig: FSharp.Compiler.Text.Range RangeOfId diff --git a/tests/FSharp.Compiler.UnitTests/EditDistance.fs b/tests/FSharp.Compiler.UnitTests/EditDistance.fs index 1e00cc05935..741e9322b73 100644 --- a/tests/FSharp.Compiler.UnitTests/EditDistance.fs +++ b/tests/FSharp.Compiler.UnitTests/EditDistance.fs @@ -23,5 +23,5 @@ module EditDistance = [] [] let EditDistanceTest (str1 : string, str2 : string, expected : int) : unit = - CalcEditDistance(str1,str2) + CalculateEditDistance(str1,str2) |> Assert.shouldBe expected diff --git a/tests/FSharp.Compiler.UnitTests/HashIfExpression.fs b/tests/FSharp.Compiler.UnitTests/HashIfExpression.fs index 42442377a5a..9af4a412632 100644 --- a/tests/FSharp.Compiler.UnitTests/HashIfExpression.fs +++ b/tests/FSharp.Compiler.UnitTests/HashIfExpression.fs @@ -50,7 +50,7 @@ type public HashIfExpression() = let errors = ResizeArray() let warnings = ResizeArray() - let errorLogger = + let diagnosticsLogger = { new DiagnosticsLogger("TestDiagnosticsLogger") with member _.DiagnosticSink(e, sev) = if sev = FSharpDiagnosticSeverity.Error then errors.Add e else warnings.Add e @@ -61,9 +61,9 @@ type public HashIfExpression() = let resourceManager = LexResourceManager () let defines= [] let startPos = Position.Empty - let args = mkLexargs (defines, lightSyntax, resourceManager, [], errorLogger, PathMap.empty) + let args = mkLexargs (defines, lightSyntax, resourceManager, [], diagnosticsLogger, PathMap.empty) - CompileThreadStatic.DiagnosticsLogger <- errorLogger + DiagnosticsThreadStatics.DiagnosticsLogger <- diagnosticsLogger let parser (s : string) = let lexbuf = LexBuffer.FromChars (true, LanguageVersion.Default, s.ToCharArray ()) @@ -76,11 +76,11 @@ type public HashIfExpression() = errors, warnings, parser do // Setup - CompileThreadStatic.BuildPhase <- BuildPhase.Compile + DiagnosticsThreadStatics.BuildPhase <- BuildPhase.Compile interface IDisposable with // Teardown member _.Dispose() = - CompileThreadStatic.BuildPhase <- BuildPhase.DefaultPhase - CompileThreadStatic.DiagnosticsLogger <- CompileThreadStatic.DiagnosticsLogger + DiagnosticsThreadStatics.BuildPhase <- BuildPhase.DefaultPhase + DiagnosticsThreadStatics.DiagnosticsLogger <- DiagnosticsThreadStatics.DiagnosticsLogger [] member _.PositiveParserTestCases()= diff --git a/tests/FSharp.Compiler.UnitTests/SuggestionBuffer.fs b/tests/FSharp.Compiler.UnitTests/SuggestionBuffer.fs index 7ecadd93209..48a9e331844 100644 --- a/tests/FSharp.Compiler.UnitTests/SuggestionBuffer.fs +++ b/tests/FSharp.Compiler.UnitTests/SuggestionBuffer.fs @@ -5,7 +5,7 @@ open Xunit open FSharp.Test module SuggestionBuffer = - open FSharp.Compiler.ErrorResolutionHints + open FSharp.Compiler.DiagnosticResolutionHints [] let NewBufferShouldBeEmpty() = diff --git a/tests/benchmarks/CompilerServiceBenchmarks/Benchmarks.fs b/tests/benchmarks/CompilerServiceBenchmarks/Benchmarks.fs index d8c83f9a6c6..5b244d4481a 100644 --- a/tests/benchmarks/CompilerServiceBenchmarks/Benchmarks.fs +++ b/tests/benchmarks/CompilerServiceBenchmarks/Benchmarks.fs @@ -133,11 +133,11 @@ type CompilerService() = { SourceFiles = [|"CheckExpressions.fs"|] ConditionalDefines = [] - ErrorSeverityOptions = FSharpDiagnosticOptions.Default + DiagnosticOptions = FSharpDiagnosticOptions.Default LangVersionText = "default" IsInteractive = false IndentationAwareSyntax = None - CompilingFsLib = false + CompilingFSharpCore = false IsExe = false } diff --git a/tests/service/data/TestTP/ProvidedTypes.fs b/tests/service/data/TestTP/ProvidedTypes.fs index 7110b912485..e12c6f843d3 100644 --- a/tests/service/data/TestTP/ProvidedTypes.fs +++ b/tests/service/data/TestTP/ProvidedTypes.fs @@ -4729,13 +4729,13 @@ module internal AssemblyReader = (* PE SIGNATURE *) let machine = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 0) let numSections = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 2) - let optHeaderSize = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) - do if optHeaderSize <> 0xe0 && - optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size"; - let x64adjust = optHeaderSize - 0xe0 - let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) + let headerSizeOpt = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) + do if headerSizeOpt <> 0xe0 && + headerSizeOpt <> 0xf0 then failwith "not a PE file - bad optional header size"; + let x64adjust = headerSizeOpt - 0xe0 + let only64 = (headerSizeOpt = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) - let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize + let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + headerSizeOpt let flags = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 18) let isDll = (flags &&& 0x2000) <> 0x0 @@ -6601,7 +6601,7 @@ module internal AssemblyReader = | None -> [| |] | Some(genericArgs) -> genericArgs let tspec = ILTypeSpec(tref, genericArgs) - let ilty = + let ilTy = match tspec.Name with | "System.SByte" | "System.Byte" @@ -6619,8 +6619,8 @@ module internal AssemblyReader = // if it's an array, wrap it - otherwise, just return the IL type match rank with - | Some(r) -> ILType.Array(r, ilty) - | _ -> ilty + | Some(r) -> ILType.Array(r, ilTy) + | _ -> ilTy let sigptr_get_bytes n (bytes:byte[]) sigptr = diff --git a/vsintegration/src/FSharp.Editor/Diagnostics/DocumentDiagnosticAnalyzer.fs b/vsintegration/src/FSharp.Editor/Diagnostics/DocumentDiagnosticAnalyzer.fs index 4f8e55f23fd..915fd0663e7 100644 --- a/vsintegration/src/FSharp.Editor/Diagnostics/DocumentDiagnosticAnalyzer.fs +++ b/vsintegration/src/FSharp.Editor/Diagnostics/DocumentDiagnosticAnalyzer.fs @@ -27,8 +27,9 @@ type internal FSharpDocumentDiagnosticAnalyzer ( ) = - static let errorInfoEqualityComparer = + static let diagnosticEqualityComparer = { new IEqualityComparer with + member _.Equals (x, y) = x.FileName = y.FileName && x.StartLine = y.StartLine && @@ -39,6 +40,7 @@ type internal FSharpDocumentDiagnosticAnalyzer x.Message = y.Message && x.Subcategory = y.Subcategory && x.ErrorNumber = y.ErrorNumber + member _.GetHashCode x = let mutable hash = 17 hash <- hash * 23 + x.StartLine.GetHashCode() @@ -67,22 +69,22 @@ type internal FSharpDocumentDiagnosticAnalyzer | DiagnosticsType.Semantic -> let! _, checkResults = document.GetFSharpParseAndCheckResultsAsync("GetDiagnostics") // In order to eleminate duplicates, we should not return parse errors here because they are returned by `AnalyzeSyntaxAsync` method. - let allErrors = HashSet(checkResults.Diagnostics, errorInfoEqualityComparer) - allErrors.ExceptWith(parseResults.Diagnostics) - return Seq.toArray allErrors + let allDiagnostics = HashSet(checkResults.Diagnostics, diagnosticEqualityComparer) + allDiagnostics.ExceptWith(parseResults.Diagnostics) + return Seq.toArray allDiagnostics | DiagnosticsType.Syntax -> return parseResults.Diagnostics } let results = - HashSet(errors, errorInfoEqualityComparer) - |> Seq.choose(fun error -> - if error.StartLine = 0 || error.EndLine = 0 then - // F# error line numbers are one-based. Compiler returns 0 for global errors (reported by ProjectDiagnosticAnalyzer) + HashSet(errors, diagnosticEqualityComparer) + |> Seq.choose(fun diagnostic -> + if diagnostic.StartLine = 0 || diagnostic.EndLine = 0 then + // F# diagnostic line numbers are one-based. Compiler returns 0 for global errors (reported by ProjectDiagnosticAnalyzer) None else // Roslyn line numbers are zero-based - let linePositionSpan = LinePositionSpan(LinePosition(error.StartLine - 1, error.StartColumn), LinePosition(error.EndLine - 1, error.EndColumn)) + let linePositionSpan = LinePositionSpan(LinePosition(diagnostic.StartLine - 1, diagnostic.StartColumn), LinePosition(diagnostic.EndLine - 1, diagnostic.EndColumn)) let textSpan = sourceText.Lines.GetTextSpan(linePositionSpan) // F# compiler report errors at end of file if parsing fails. It should be corrected to match Roslyn boundaries @@ -97,7 +99,7 @@ type internal FSharpDocumentDiagnosticAnalyzer TextSpan.FromBounds(start, sourceText.Length) let location = Location.Create(filePath, correctedTextSpan , linePositionSpan) - Some(RoslynHelpers.ConvertError(error, location))) + Some(RoslynHelpers.ConvertError(diagnostic, location))) |> Seq.toImmutableArray return results } diff --git a/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/ProvidedTypes.fs b/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/ProvidedTypes.fs index 76c6fa3a12d..ee27b6103ba 100644 --- a/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/ProvidedTypes.fs +++ b/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/ProvidedTypes.fs @@ -4468,13 +4468,13 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader (* PE SIGNATURE *) let machine = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 0) let numSections = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 2) - let optHeaderSize = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) - do if optHeaderSize <> 0xe0 && - optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size"; - let x64adjust = optHeaderSize - 0xe0 - let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) + let headerSizeOpt = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) + do if headerSizeOpt <> 0xe0 && + headerSizeOpt <> 0xf0 then failwith "not a PE file - bad optional header size"; + let x64adjust = headerSizeOpt - 0xe0 + let only64 = (headerSizeOpt = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) - let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize + let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + headerSizeOpt let flags = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 18) let isDll = (flags &&& 0x2000) <> 0x0 @@ -6327,7 +6327,7 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader | None -> [| |] | Some(genericArgs) -> genericArgs let tspec = ILTypeSpec(tref,genericArgs) - let ilty = + let ilTy = match tspec.Name with | "System.SByte" | "System.Byte" @@ -6345,8 +6345,8 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader // if it's an array, wrap it - otherwise, just return the IL type match rank with - | Some(r) -> ILType.Array(r,ilty) - | _ -> ilty + | Some(r) -> ILType.Array(r,ilTy) + | _ -> ilTy let sigptr_get_bytes n (bytes:byte[]) sigptr =