Movatterモバイル変換

[0]ホーム
URL:

Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly

 Sign up
Appearance settings

Commit385c8a3

Browse files
dsymeKevinRansom
authored andcommitted
Fix 3118: quotation of struct union match (#3227)
* Fix quotation of struct union match* Fix quotation of struct union match ()* fix test
1 parent01068dd commit385c8a3

File tree

5 files changed

+72
-21
lines changed

5 files changed

+72
-21
lines changed

‎src/fsharp/QuotationPickler.fs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -136,9 +136,9 @@ let mkLetRec (ves,body) =
136136
letmkRecdMk(n,tys,args)= CombExpr(RecdMkOp n,tys,args)
137137
letmkRecdGet((d1,d2),tyargs,args)= CombExpr(RecdGetOp(d1,d2),tyargs,args)
138138
letmkRecdSet((d1,d2),tyargs,args)= CombExpr(RecdSetOp(d1,d2),tyargs,args)
139-
letmkSum((d1,d2),tyargs,args)= CombExpr(SumMkOp(d1,d2),tyargs,args)
140-
letmkSumFieldGet((d1,d2,d3),tyargs,arg)= CombExpr(SumFieldGetOp(d1,d2,d3),tyargs,[arg])
141-
letmkSumTagTest((d1,d2),tyargs,arg)= CombExpr(SumTagTestOp(d1,d2),tyargs,[arg])
139+
letmkUnion((d1,d2),tyargs,args)= CombExpr(SumMkOp(d1,d2),tyargs,args)
140+
letmkUnionFieldGet((d1,d2,d3),tyargs,arg)= CombExpr(SumFieldGetOp(d1,d2,d3),tyargs,[arg])
141+
letmkUnionCaseTagTest((d1,d2),tyargs,arg)= CombExpr(SumTagTestOp(d1,d2),tyargs,[arg])
142142
letmkTupleGet(ty,n,e)= CombExpr(TupleGetOp n,[ty],[e])
143143

144144
letmkCoerce(ty,arg)= CombExpr(CoerceOp,[ty],[arg])

‎src/fsharp/QuotationPickler.fsi‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -69,9 +69,9 @@ val mkLet : (VarData * ExprData) * ExprData -> ExprData
6969
val mkRecdMk: NamedTypeData* TypeData list* ExprData list-> ExprData
7070
val mkRecdGet: RecdFieldData* TypeData list* ExprData list-> ExprData
7171
val mkRecdSet: RecdFieldData* TypeData list* ExprData list-> ExprData
72-
valmkSum:(NamedTypeData* string)* TypeData list* ExprData list-> ExprData
73-
valmkSumFieldGet:(NamedTypeData* string* int)* TypeData list* ExprData-> ExprData
74-
valmkSumTagTest:(NamedTypeData* string)* TypeData list* ExprData-> ExprData
72+
valmkUnion:(NamedTypeData* string)* TypeData list* ExprData list-> ExprData
73+
valmkUnionFieldGet:(NamedTypeData* string* int)* TypeData list* ExprData-> ExprData
74+
valmkUnionCaseTagTest:(NamedTypeData* string)* TypeData list* ExprData-> ExprData
7575
val mkTuple: TypeData* ExprData list-> ExprData
7676
val mkTupleGet: TypeData* int* ExprData-> ExprData
7777
val mkCoerce: TypeData* ExprData-> ExprData

‎src/fsharp/QuotationTranslator.fs‎

Lines changed: 32 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -414,7 +414,8 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
414414
letmkR= ConvUnionCaseRef cenv ucref m
415415
lettyargsR= ConvTypes cenv env m tyargs
416416
letargsR= ConvExprs cenv env args
417-
QP.mkSum(mkR,tyargsR,argsR)
417+
QP.mkUnion(mkR,tyargsR,argsR)
418+
418419

419420
| TOp.Tuple tupInfo,tyargs,_->
420421
lettyR= ConvType cenv env m(mkAnyTupledTy cenv.g tupInfo tyargs)
@@ -428,10 +429,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
428429
QP.mkRecdMk(rgtypR,tyargsR,argsR)
429430

430431
| TOp.UnionCaseFieldGet(ucref,n),tyargs,[e]->
431-
lettyargsR= ConvTypes cenv env m tyargs
432-
lettcR,s= ConvUnionCaseRef cenv ucref m
433-
letprojR=(tcR,s,n)
434-
QP.mkSumFieldGet( projR, tyargsR,ConvExpr cenv env e)
432+
ConvUnionFieldGet cenv env m ucref n tyargs e
435433

436434
| TOp.ValFieldGetAddr(_rfref),_tyargs,_->
437435
wfail(Error(FSComp.SR.crefQuotationsCantContainAddressOf(), m))
@@ -443,11 +441,12 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
443441
wfail(Error(FSComp.SR.crefQuotationsCantContainStaticFieldRef(),m))
444442

445443
| TOp.ValFieldGet(rfref),tyargs,args->
446-
ConvRFieldGet cenv env m rfref tyargs args
444+
ConvClassOrRecdFieldGet cenv env m rfref tyargs args
447445

448-
| TOp.TupleFieldGet(tupInfo,n),tyargs,[e]whennot(evalTupInfoIsStruct tupInfo)->
449-
lettyR= ConvType cenv env m(mkRefTupledTy cenv.g tyargs)
450-
QP.mkTupleGet(tyR, n, ConvExpr cenv env e)
446+
| TOp.TupleFieldGet(tupInfo,n),tyargs,[e]->
447+
leteR= ConvLValueExpr cenv env e
448+
lettyR= ConvType cenv env m(mkAnyTupledTy cenv.g tupInfo tyargs)
449+
QP.mkTupleGet(tyR, n, eR)
451450

452451
| TOp.ILAsm(([ I_ldfld(_,_,fspec)]
453452
|[ I_ldfld(_,_,fspec); AI_nop]
@@ -606,10 +605,17 @@ and ConvLdfld cenv env m (fspec: ILFieldSpec) enclTypeArgs args =
606605
letargsR= ConvLValueArgs cenv env args
607606
QP.mkFieldGet((parentTyconR, fspec.Name),tyargsR, argsR)
608607

609-
andConvRFieldGet cenv env m rfref tyargs args=
610-
EmitDebugInfoIfNecessary cenv env m(ConvRFieldGetCore cenv env m rfref tyargs args)
608+
andConvUnionFieldGet cenv env m ucref n tyargs e=
609+
lettyargsR= ConvTypes cenv env m tyargs
610+
lettcR,s= ConvUnionCaseRef cenv ucref m
611+
letprojR=(tcR,s,n)
612+
leteR= ConvLValueExpr cenv env e
613+
QP.mkUnionFieldGet(projR, tyargsR, eR)
614+
615+
andConvClassOrRecdFieldGet cenv env m rfref tyargs args=
616+
EmitDebugInfoIfNecessary cenv env m(ConvClassOrRecdFieldGetCore cenv env m rfref tyargs args)
611617

612-
andprivateConvRFieldGetCore cenv env m rfref tyargs args=
618+
andprivateConvClassOrRecdFieldGetCore cenv env m rfref tyargs args=
613619
lettyargsR= ConvTypes cenv env m tyargs
614620
letargsR= ConvLValueArgs cenv env args
615621
let((parentTyconR,fldOrPropName)as projR)= ConvRecdFieldRef cenv rfref m
@@ -665,7 +671,8 @@ and ConvLValueExprCore cenv env expr =
665671
| Expr.Op(op,tyargs,args,m)->
666672
match op, args, tyargswith
667673
| TOp.LValueOp(LGetAddr,vref),_,_-> ConvValReffalse cenv env m vref[]
668-
| TOp.ValFieldGetAddr(rfref),_,_-> ConvRFieldGet cenv env m rfref tyargs args
674+
| TOp.ValFieldGetAddr(rfref),_,_-> ConvClassOrRecdFieldGet cenv env m rfref tyargs args
675+
| TOp.UnionCaseFieldGetAddr(ucref,n),[e],_-> ConvUnionFieldGet cenv env m ucref n tyargs e
669676
| TOp.ILAsm([ I_ldflda(fspec)],_rtys),_,_-> ConvLdfld cenv env m fspec tyargs args
670677
| TOp.ILAsm([ I_ldsflda(fspec)],_rtys),_,_-> ConvLdfld cenv env m fspec tyargs args
671678
| TOp.ILAsm(([ I_ldelema(_ro,_isNativePtr,shape,_tyarg)]),_),(arr::idxs),[elemty]->
@@ -846,26 +853,32 @@ and ConvDecisionTree cenv env tgs typR x =
846853
match dfltOptwith
847854
| Some d-> ConvDecisionTree cenv env tgs typR d
848855
| None-> wfail(Error(FSComp.SR.crefQuotationsCantContainThisPatternMatch(), m))
856+
849857
letconverted=
850858
(csl,acc)||> List.foldBack(fun(TCase(discrim,dtree))acc->
859+
851860
match discrimwith
852861
| DecisionTreeTest.UnionCase(ucref, tyargs)->
853-
lete1R=ConvExpr cenv env e1
862+
lete1R=ConvLValueExpr cenv env e1
854863
letucR= ConvUnionCaseRef cenv ucref m
855864
lettyargsR= ConvTypes cenv env m tyargs
856-
QP.mkCond(QP.mkSumTagTest(ucR, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
865+
QP.mkCond(QP.mkUnionCaseTagTest(ucR, tyargsR, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
866+
857867
| DecisionTreeTest.Const(Const.Booltrue)->
858868
lete1R= ConvExpr cenv env e1
859869
QP.mkCond(e1R, ConvDecisionTree cenv env tgs typR dtree, acc)
870+
860871
| DecisionTreeTest.Const(Const.Boolfalse)->
861872
lete1R= ConvExpr cenv env e1
862873
// Note, reverse the branches
863874
QP.mkCond(e1R, acc, ConvDecisionTree cenv env tgs typR dtree)
875+
864876
| DecisionTreeTest.Const c->
865877
letty= tyOfExpr cenv.g e1
866878
leteq= mkCallEqualsOperator cenv.g m ty e1(Expr.Const(c, m, ty))
867879
leteqR= ConvExpr cenv env eq
868880
QP.mkCond(eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
881+
869882
| DecisionTreeTest.IsNull->
870883
// Decompile cached isinst tests
871884
match e1with
@@ -880,13 +893,17 @@ and ConvDecisionTree cenv env tgs typR x =
880893
leteq= mkCallEqualsOperator cenv.g m ty e1(Expr.Const(Const.Zero, m, ty))
881894
leteqR= ConvExpr cenv env eq
882895
QP.mkCond(eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
896+
883897
| DecisionTreeTest.IsInst(_srcty, tgty)->
884898
lete1R= ConvExpr cenv env e1
885899
QP.mkCond(QP.mkTypeTest(ConvType cenv env m tgty, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
900+
886901
| DecisionTreeTest.ActivePatternCase_-> wfail(InternalError("DecisionTreeTest.ActivePatternCase test in quoted expression",m))
902+
887903
| DecisionTreeTest.ArrayLength_-> wfail(Error(FSComp.SR.crefQuotationsCantContainArrayPatternMatching(), m))
888904
)
889905
EmitDebugInfoIfNecessary cenv env m converted
906+
890907
| TDSuccess(args,n)->
891908
let(TTarget(vars,rhs,_))= tgs.[n]
892909
// TAST stores pattern bindings in reverse order for some reason

‎tests/fsharp/core/quotes/test.fsx‎

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1679,13 +1679,16 @@ module QuotationConstructionTests =
16791679
check"vcknwwe0ii"(trylet_= Expr.TupleGet(<@@(1,2)@@>,-1)infalsewith:? ArgumentException->true)true
16801680
for i=0to7do
16811681
check"vcknwwe0oo"(match Expr.TupleGet(<@@(1,2,3,4,5,6,7,8)@@>, i)with TupleGet(b,n)-> b=<@@(1,2,3,4,5,6,7,8)@@>&& n= i|_->false)true
1682+
16821683
check"vcknwwe0pp"(match Expr.TypeTest(<@@new obj()@@>, typeof<string>)with TypeTest(e,ty)-> e=<@@new obj()@@>&& ty= typeof<string>|_->false)true
16831684
check"vcknwwe0aa"(match Expr.UnionCaseTest(<@@[]: int list@@>, ucaseof<@@[]: int list@@>)with UnionCaseTest(e,uc)-> e=<@@[]: int list@@>&& uc= ucaseof<@@[]: int list@@>|_->false)true
16841685
check"vcknwwe0ss"(Expr.Value(3))<@@3@@>
16851686
check"vcknwwe0dd"(match Expr.Var(Var.Global("i",typeof<int>))with Var(v)-> v= Var.Global("i",typeof<int>)|_->false)true
16861687
check"vcknwwe0ff"(match Expr.VarSet(Var.Global("i",typeof<int>),<@@4@@>)with VarSet(v,q)-> v= Var.Global("i",typeof<int>)&& q=<@@4@@>|_->false)true
16871688
check"vcknwwe0gg"(match Expr.WhileLoop(<@@true@@>,<@@()@@>)with WhileLoop(g,b)-> g=<@@true@@>&& b=<@@()@@>|_->false)true
16881689

1690+
1691+
16891692
moduleQuotationStructUnionTests=
16901693

16911694
[<Struct>]
@@ -3059,6 +3062,35 @@ module ReflectionOverTypeInstantiations =
30593062
checkType"test cvweler8" t1false
30603063
checkType"test cvweler9" t2true
30613064

3065+
moduleQuotationStructTupleTests=
3066+
letactual=struct(0,0)
3067+
letcode=
3068+
<@match actualwith
3069+
|struct(0,0)->true
3070+
|_->false@>
3071+
3072+
printfn"code =%A" code
3073+
check"wcelwec"(match codewith
3074+
| IfThenElse(Call(None,_,[TupleGet(PropertyGet(None,_,[]),0);_]), IfThenElse(Call(None,_,[TupleGet(PropertyGet(None,_,[]),1);_]), Value_, Value_), Value_)->true
3075+
|_->false)
3076+
true
3077+
3078+
for i=0to7do
3079+
check"vcknwwe0oo"(match Expr.TupleGet(<@@struct(1,2,3,4,5,6,7,8)@@>, i)with TupleGet(b,n)-> b=<@@struct(1,2,3,4,5,6,7,8)@@>&& n= i|_->false)true
3080+
3081+
letactual2:Result<string,string>= Ok"foo"
3082+
letcode2=
3083+
<@match actual2with
3084+
| Ok_->true
3085+
| Error_->false@>
3086+
3087+
printfn"code2 =%A" code2
3088+
check"cewcewwer"
3089+
(match code2with
3090+
| IfThenElse(UnionCaseTest(PropertyGet(None, actual2,[]),_), Value_, Value_)->true
3091+
|_->false)
3092+
true
3093+
30623094

30633095
moduleTestStaticCtor=
30643096
[<ReflectedDefinition>]

‎tests/fsharp/tests.fs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -658,6 +658,8 @@ module CoreTests =
658658

659659
fsc cfg"%s -o:test.exe -r cslib.dll -g" cfg.fsc_flags["test.fsx"]
660660

661+
copy_y cfg(cfg.FSCBinPath++"System.ValueTuple.dll")("."++"System.ValueTuple.dll")
662+
661663
peverify cfg"test.exe"
662664

663665
begin

0 commit comments

Comments
 (0)
[8]ページ先頭
©2009-2025 Movatter.jp