paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-26 22:49:41 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47896 -
This commit is contained in:
nickysn 2020-12-29 23:50:34 +00:00
commit 57b976535f
23 changed files with 513 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -18108,6 +18108,7 @@ tests/webtbs/tw2886.pp svneol=native#text/plain
tests/webtbs/tw2891.pp svneol=native#text/plain
tests/webtbs/tw28916.pp svneol=native#text/pascal
tests/webtbs/tw2892.pp svneol=native#text/plain
tests/webtbs/tw28927.pp svneol=native#text/pascal
tests/webtbs/tw28934.pp svneol=native#text/plain
tests/webtbs/tw28948.pp svneol=native#text/plain
tests/webtbs/tw28964.pp svneol=native#text/plain
@ -18657,6 +18658,7 @@ tests/webtbs/tw38202.pp svneol=native#text/pascal
tests/webtbs/tw38225.pp svneol=native#text/pascal
tests/webtbs/tw38238.pp svneol=native#text/pascal
tests/webtbs/tw38249.pp svneol=native#text/pascal
tests/webtbs/tw38259.pp svneol=native#text/pascal
tests/webtbs/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain
tests/webtbs/tw3833.pp svneol=native#text/plain

18
compiler/optdfa.pas
View File

@ -508,20 +508,32 @@ unit optdfa;
exitn:
begin
if not(is_void(current_procinfo.procdef.returndef)) then
{ in case of inlining, an exit node can have a successor, in this case, we do not have to
use the faked resultnode }
if assigned(node.successor) then
begin
l:=node.optinfo^.life;
DFASetIncludeSet(l,node.successor.optinfo^.life);
UpdateLifeInfo(node,l);
end
else if assigned(resultnode) and (resultnode.nodetype<>nothingn) then
begin
if not(assigned(node.optinfo^.def)) and
not(assigned(node.optinfo^.use)) then
begin
if assigned(texitnode(node).left) then
begin
node.optinfo^.def:=resultnode.optinfo^.def;
{ this should never happen as
texitnode.pass_typecheck converts the left node into a separate node already
node.optinfo^.def:=resultnode.optinfo^.def;
dfainfo.use:=@node.optinfo^.use;
dfainfo.def:=@node.optinfo^.def;
dfainfo.map:=map;
foreachnodestatic(pm_postprocess,texitnode(node).left,@AddDefUse,@dfainfo);
calclife(node);
calclife(node); }
Internalerror(2020122901);
end
else
begin

10
compiler/optutils.pas
View File

@ -163,11 +163,12 @@ unit optutils;
var
Continuestack : TFPList;
Breakstack : TFPList;
Exitsuccessor: TNode;
{ sets the successor nodes of a node tree block
returns the first node of the tree if it's a controll flow node }
function DoSet(p : tnode;succ : tnode) : tnode;
var
hp1,hp2 : tnode;
hp1,hp2, oldexitsuccessor: tnode;
i : longint;
begin
result:=nil;
@ -203,11 +204,15 @@ unit optutils;
blockn:
begin
result:=p;
oldexitsuccessor:=Exitsuccessor;
if nf_block_with_exit in p.flags then
Exitsuccessor:=succ;
DoSet(tblocknode(p).statements,succ);
if assigned(tblocknode(p).statements) then
p.successor:=tblocknode(p).statements
else
p.successor:=succ;
Exitsuccessor:=oldexitsuccessor;
end;
forn:
begin
@ -288,7 +293,7 @@ unit optutils;
exitn:
begin
result:=p;
p.successor:=nil;
p.successor:=Exitsuccessor;
end;
casen:
begin
@ -337,6 +342,7 @@ unit optutils;
begin
Breakstack:=TFPList.Create;
Continuestack:=TFPList.Create;
Exitsuccessor:=nil;
DoSet(p,last);
Continuestack.Free;
Breakstack.Free;

9
compiler/ptype.pas
View File

@ -992,6 +992,7 @@ implementation
old_parse_generic: boolean;
recst: trecordsymtable;
hadgendummy : boolean;
alignment: Integer;
begin
old_current_structdef:=current_structdef;
old_current_genericdef:=current_genericdef;
@ -1063,6 +1064,14 @@ implementation
add_typedconst_init_routine(current_structdef);
consume(_END);
end;
if (token=_ID) and (pattern='ALIGN') then
begin
consume(_ID);
alignment:=get_intconst.svalue;
if not(alignment in [1,2,4,8,16,32,64]) then
else
recst.recordalignment:=shortint(alignment);
end;
{ make the record size aligned (has to be done before inserting the
parameters, because that may depend on the record's size) }
recst.addalignmentpadding;

2
compiler/x86/nx86inl.pas
View File

@ -651,7 +651,7 @@ implementation
LOC_MMREGISTER,LOC_CMMREGISTER:
begin
location:=lnode.location;
hlcg.location_force_fpureg(current_asmdata.CurrAsmList,location,resultdef,false);
hlcg.location_force_fpureg(current_asmdata.CurrAsmList,location,lnode.resultdef,false);
end;
else
internalerror(309991);

60
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -4147,10 +4147,12 @@ function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr
// Source codepage is needed for reading non ASCII string literals 'ä'.
// Target codepage is needed for reading non ASCII # literals.
// Target codepage costs time to compute.
var
Value: TResEvalValue;
procedure RangeError(id: TMaxPrecInt);
begin
Result.Free;
Value.Free;
RaiseRangeCheck(id,Expr);
end;
@ -4183,13 +4185,13 @@ var
var
h: RawByteString;
begin
if Result.Kind=revkString then
if Value.Kind=revkString then
begin
// switch to unicodestring
h:=TResEvalString(Result).S;
Result.Free;
Result:=nil; // in case of exception in GetUnicodeStr
Result:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr));
h:=TResEvalString(Value).S;
Value.Free;
Value:=nil; // in case of exception in GetUnicodeStr
Value:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr));
end;
end;
{$ENDIF}
@ -4197,7 +4199,7 @@ var
procedure AddSrc(h: String);
{$ifdef FPC_HAS_CPSTRING}
var
Value: TResEvalString;
ValueAnsi: TResEvalString;
OnlyASCII: Boolean;
i: Integer;
{$ENDIF}
@ -4216,13 +4218,13 @@ var
break;
end;
if Result.Kind=revkString then
if Value.Kind=revkString then
begin
Value:=TResEvalString(Result);
if OnlyASCII and Value.OnlyASCII then
ValueAnsi:=TResEvalString(Value);
if OnlyASCII and ValueAnsi.OnlyASCII then
begin
// concatenate ascii strings
Value.S:=Value.S+h;
ValueAnsi.S:=ValueAnsi.S+h;
exit;
end;
@ -4232,47 +4234,47 @@ var
CP_UTF16:
begin
ForceUTF16;
TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+GetUnicodeStr(h,Expr);
//writeln('AddSrc len(h)=',length(h),' StringCodePage=',StringCodePage(h),' GetCodePage=',GetCodePage(h),' S=',length(TResEvalUTF16(Result).S));
TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr);
//writeln('AddSrc len(h)=',length(h),' StringCodePage=',StringCodePage(h),' GetCodePage=',GetCodePage(h),' S=',length(TResEvalUTF16(Value).S));
end;
CP_UTF16BE:
RaiseNotYetImplemented(20201220222608,Expr);
else
begin
if Value.S<>'' then
if ValueAnsi.S<>'' then
begin
if Value.OnlyASCII then
SetCodePage(Value.S,TargetCP,false);
Value.S:=Value.S+h;
if ValueAnsi.OnlyASCII then
SetCodePage(ValueAnsi.S,TargetCP,false);
ValueAnsi.S:=ValueAnsi.S+h;
end else begin
Value.S:=h;
ValueAnsi.S:=h;
end;
end;
end;
end
else
TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+GetUnicodeStr(h,Expr);
TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr);
{$else}
TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+h;
TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+h;
{$endif}
end;
procedure AddHash(u: longword);
{$ifdef FPC_HAS_CPSTRING}
begin
if Result.Kind=revkString then
TResEvalString(Result).s:=TResEvalString(Result).S+Chr(u)
if Value.Kind=revkString then
TResEvalString(Value).s:=TResEvalString(Value).S+Chr(u)
else
TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u);
TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u);
end;
{$else}
begin
TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u);
TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u);
end;
{$endif}
function ReadHash(Value: TResEvalValue; const S: string; p, l: integer): integer;
function ReadHash(const S: string; p, l: integer): integer;
var
StartP: Integer;
u: longword;
@ -4283,6 +4285,7 @@ var
OldCP: TSystemCodePage;
{$ENDIF}
begin
//writeln('ReadHash S="',S,'" p=',p,' l=',l,' ',StringCodePage(S));
Result:=p;
inc(Result);
if Result>l then
@ -4402,9 +4405,9 @@ begin
TargetCP:=CP_ACP;
SourceCPValid:=false;
SourceCP:=CP_ACP;
Result:=TResEvalString.Create;
Value:=TResEvalString.Create;
{$else}
Result:=TResEvalUTF16.Create;
Value:=TResEvalUTF16.Create;
{$endif}
p:=1;
//writeln('TResExprEvaluator.EvalPrimitiveExprString ',GetObjPath(Expr),' ',Expr.SourceFilename,' ',Expr.SourceLinenumber div 2048,' S=[',S,']');
@ -4442,7 +4445,7 @@ begin
AddSrc(copy(S,StartP,p-StartP));
end;
'#':
p:=ReadHash(Result,S,p,l);
p:=ReadHash(S,p,l);
'^':
begin
// ^A is #1
@ -4460,6 +4463,7 @@ begin
else
RaiseNotYetImplemented(20170523123815,Expr,'ord='+IntToStr(ord(S[p])));
end;
Result:=Value;
{$IFDEF VerbosePasResEval}
//writeln('TResExprEvaluator.EvalPrimitiveExprString Result=',Result.AsString);
{$ENDIF}

19
packages/fcl-passrc/src/pasresolver.pp
View File

@ -4734,7 +4734,7 @@ end;
procedure TPasResolver.GetParamsOfNameExpr(El: TPasExpr; out
ParentParams: TPRParentParams);
// Checks is El is the name expression of a call or array access
// Checks if El is the name expression of a call or array access
// For example: a.b.El() a.El[]
// Note: TPasParser guarantees that there is at most one TBinaryExpr
// and one TInlineSpecializeExpr between El and TParamsExpr
@ -10176,7 +10176,6 @@ begin
if ParentParams.InlineSpec<>nil then
begin
TypeCnt:=InlParams.Count;
// ToDo: generic functions without params
DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El);
if DeclEl<>nil then
begin
@ -10207,9 +10206,19 @@ begin
begin
TemplTypes:=GetProcTemplateTypes(Proc);
if (TemplTypes<>nil) then
begin
// implicit function specialization without bracket
{$IFDEF VerbosePasResolver}
DeclEl:=El;
while DeclEl.Parent is TPasExpr do
DeclEl:=DeclEl.Parent;
{AllowWriteln}
writeln('TPasResolver.ResolveNameExpr ',WritePasElTree(TPasExpr(DeclEl),' '));
{AllowWriteln-}
{$ENDIF}
RaiseMsg(20191007222004,nCouldNotInferTypeArgXForMethodY,
sCouldNotInferTypeArgXForMethodY,[TPasGenericTemplateType(TemplTypes[0]).Name,Proc.Name],El);
end;
end;
if El.Parent.ClassType=TPasProperty then
@ -10757,7 +10766,7 @@ begin
else if Value.ClassType=TInlineSpecializeExpr then
begin
// e.g. Name<>()
ResolveInlineSpecializeExpr(TInlineSpecializeExpr(Value),rraRead);
ResolveInlineSpecializeExpr(TInlineSpecializeExpr(Value),Access);
end
else if Value.ClassType=TParamsExpr then
begin
@ -27370,7 +27379,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
end
else if ParentNeedsExprResult(Expr) then
begin
// a procedure
// a procedure address
exit;
end;
if rcSetReferenceFlags in Flags then
@ -28235,6 +28244,8 @@ begin
else
Result:=true;
end
else if C=TInlineSpecializeExpr then
Result:=ParentNeedsExprResult(TInlineSpecializeExpr(P))
else if C.InheritsFrom(TPasExpr) then
Result:=true
else if (C=TPasEnumValue)

72
packages/fcl-passrc/src/pastree.pp
View File

@ -1789,6 +1789,7 @@ function GenericTemplateTypesAsString(List: TFPList): string;
procedure ReleaseProcNameParts(var NameParts: TProcedureNameParts);
function dbgs(const s: TProcTypeModifiers): string; overload;
function WritePasElTree(Expr: TPasExpr; FollowPrefix: string = ''): string;
{$IFDEF HasPTDumpStack}
procedure PTDumpStack;
@ -1903,6 +1904,77 @@ begin
Result:='['+Result+']';
end;
function WritePasElTree(Expr: TPasExpr; FollowPrefix: string): string;
{ TBinary Kind= OpCode=
+Left=TBinary Kind= OpCode=
| +Left=TParamsExpr[]
| | +Value=Prim Kind= Value=
| | +Params[1]=Prim Kind= Value=
+Right=Prim
}
var
C: TClass;
s: string;
ParamsExpr: TParamsExpr;
InlineSpecExpr: TInlineSpecializeExpr;
SubEl: TPasElement;
ArrayValues: TArrayValues;
i: Integer;
begin
if Expr=nil then exit('nil');
C:=Expr.ClassType;
Result:=C.ClassName;
str(Expr.Kind,s);
Result:=Result+' '+s;
str(Expr.OpCode,s);
Result:=Result+' '+s;
if C=TPrimitiveExpr then
Result:=Result+' Value="'+TPrimitiveExpr(Expr).Value+'"'
else if C=TUnaryExpr then
Result:=Result+' Operand='+WritePasElTree(TUnaryExpr(Expr).Operand,FollowPrefix)
else if C=TBoolConstExpr then
Result:=Result+' Value='+BoolToStr(TBoolConstExpr(Expr).Value,'True','False')
else if C=TArrayValues then
begin
ArrayValues:=TArrayValues(Expr);
for i:=0 to length(ArrayValues.Values)-1 do
Result:=Result+sLineBreak+FollowPrefix+'+Values['+IntToStr(i)+']='+WritePasElTree(ArrayValues.Values[i],FollowPrefix+'| ');
end
else if C=TBinaryExpr then
begin
Result:=Result+sLineBreak+FollowPrefix+'+Left='+WritePasElTree(TBinaryExpr(Expr).left,FollowPrefix+'| ');
Result:=Result+sLineBreak+FollowPrefix+'+Right='+WritePasElTree(TBinaryExpr(Expr).right,FollowPrefix+'| ');
end
else if C=TParamsExpr then
begin
ParamsExpr:=TParamsExpr(Expr);
Result:=Result+sLineBreak+FollowPrefix+'+Value='+WritePasElTree(ParamsExpr.Value,FollowPrefix+'| ');
for i:=0 to length(ParamsExpr.Params)-1 do
Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']='+WritePasElTree(ParamsExpr.Params[i],FollowPrefix+'| ');
end
else if C=TInlineSpecializeExpr then
begin
InlineSpecExpr:=TInlineSpecializeExpr(Expr);
Result:=Result+sLineBreak+FollowPrefix+'+Name='+WritePasElTree(InlineSpecExpr.NameExpr,FollowPrefix+'| ');
if InlineSpecExpr.Params<>nil then
for i:=0 to InlineSpecExpr.Params.Count-1 do
begin
Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']=';
SubEl:=TPasElement(InlineSpecExpr.Params[i]);
if SubEl=nil then
Result:=Result+'nil'
else if SubEl is TPasExpr then
Result:=Result+WritePasElTree(TPasExpr(SubEl),FollowPrefix+'| ')
else
Result:=Result+SubEl.Name+':'+SubEl.ClassName;
end;
end
else
Result:=C.ClassName+' Kind=';
end;
Function IndentStrings(S : TStrings; indent : Integer) : string;
Var
I,CurrLen,CurrPos : Integer;

17
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -62,6 +62,10 @@ const
// non fpc hints
nPAParameterInOverrideNotUsed = 4501;
sPAParameterInOverrideNotUsed = 'Parameter "%s" not used';
nPAFieldNotUsed = 4502;
sPAFieldNotUsed = 'Field "%s" not used';
nPAFieldIsAssignedButNeverUsed = 4503;
sPAFieldIsAssignedButNeverUsed = 'Field "%s" is assigned but never used';
// fpc hints: use same IDs as fpc
nPAUnitNotUsed = 5023;
sPAUnitNotUsed = 'Unit "%s" not used in %s';
@ -2827,8 +2831,14 @@ begin
sPAPrivateFieldIsNeverUsed,[El.FullName],El);
end
else if El.ClassType=TPasVariable then
EmitMessage(20170311234201,mtHint,nPALocalVariableNotUsed,
sPALocalVariableNotUsed,[El.Name],El)
begin
if El.Parent is TPasMembersType then
EmitMessage(20201229033108,mtHint,nPAFieldNotUsed,
sPAFieldNotUsed,[El.Name],El)
else
EmitMessage(20170311234201,mtHint,nPALocalVariableNotUsed,
sPALocalVariableNotUsed,[El.Name],El);
end
else
EmitMessage(20170314221334,mtHint,nPALocalXYNotUsed,
sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El);
@ -2842,6 +2852,9 @@ begin
if El.Visibility in [visPrivate,visStrictPrivate] then
EmitMessage(20170311234159,mtHint,nPAPrivateFieldIsAssignedButNeverUsed,
sPAPrivateFieldIsAssignedButNeverUsed,[El.FullName],El)
else if El.Parent is TPasMembersType then
EmitMessage(20201229033618,mtHint,nPAFieldIsAssignedButNeverUsed,
sPAFieldIsAssignedButNeverUsed,[El.Name],El)
else
EmitMessage(20170311233825,mtHint,nPALocalVariableIsAssignedButNeverUsed,
sPALocalVariableIsAssignedButNeverUsed,[El.Name],El);

7
packages/fcl-passrc/src/pparser.pp
View File

@ -2527,11 +2527,16 @@ begin
NextToken;
if CurToken=tkspecialize then
begin
// Obj.specialize ...
if CanSpecialize=aMust then
CheckToken(tkLessThan);
CanSpecialize:=aMust;
NextToken;
end;
end
else if msDelphi in CurrentModeswitches then
CanSpecialize:=aCan
else
CanSpecialize:=aCannot;
if CurToken in [tkIdentifier,tktrue,tkfalse,tkself] then // true and false are sub identifiers as well
begin
aName:=aName+'.'+CurTokenString;

6
packages/fcl-passrc/src/pscanner.pp
View File

@ -3106,7 +3106,8 @@ end;
function TPascalScanner.FetchToken: TToken;
begin
FPreviousToken:=FCurToken;
if Not (FCurToken in [tkWhiteSpace,tkLineEnding]) then
FPreviousToken:=FCurToken;
while true do
begin
Result := DoFetchToken;
@ -5051,8 +5052,7 @@ begin
begin
if ForceCaret or PPisSkipping or
(PreviousToken in [tkeof,tkTab,tkLineEnding,tkComment,tkIdentifier,
tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCaret,
tkWhitespace]) then
tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCaret]) then
begin
Inc(FTokenPos);
Result := tkCaret;

29
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -156,7 +156,7 @@ type
procedure TestGenProc_TypeParamCntOverload;
procedure TestGenProc_TypeParamCntOverloadNoParams;
procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
procedure TestGenProc_ParamSpecWithT; // ToDo: Func<T>(Bird: TBird<T>)
procedure TestGenProc_ParamSpecWithT;
// ToDo: NestedResultAssign
// generic function infer types
@ -186,6 +186,7 @@ type
procedure TestGenMethod_OverloadTypeParamCntDelphi;
procedure TestGenMethod_OverloadArgs;
procedure TestGenMethod_TypeCastParam;
procedure TestGenMethod_TypeCastIdentDot;
end;
implementation
@ -3010,6 +3011,32 @@ begin
ParseUnit;
end;
procedure TTestResolveGenerics.TestGenMethod_TypeCastIdentDot;
begin
StartUnit(false);
Add([
'{$mode delphi}',
'interface',
'type',
' TObject = class end;',
' TBird = class end;',
' TEagle = class(TBird)',
' procedure Run<S>(p: S);',
' procedure Fly;',
' end;',
'implementation',
'procedure TEagle.Run<S>(p: S);',
'begin',
'end;',
'procedure TEagle.Fly;',
'var Bird: TBird;',
'begin',
' TEagle(Bird).Run<word>(3);',
'end;',
'']);
ParseUnit;
end;
initialization
RegisterTests([TTestResolveGenerics]);

4
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -3544,7 +3544,8 @@ begin
' s[9+1]:=''b'';',
' s[10]:='''''''';',
' s[11]:=^g;',
' s[12]:=^H;']);
' s[12]:=^H;',
'']);
ParseProgram;
end;
@ -3622,6 +3623,7 @@ begin
' m=low(char)+high(char);',
' n = string(''A'');',
' o = UnicodeString(''A'');',
//' p = ^C''bird'';',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;

7
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -115,6 +115,7 @@ type
procedure TestNumber;
procedure TestChar;
procedure TestCharString;
procedure TestCaretString;
procedure TestBraceOpen;
procedure TestBraceClose;
procedure TestMul;
@ -831,6 +832,12 @@ begin
TestToken(pscanner.tkChar,'''A''');
end;
procedure TTestScanner.TestCaretString;
begin
TestTokens([tkIdentifier,tkWhiteSpace,tkEqual,tkwhiteSpace,pscanner.tkString,tkSemicolon],'a = ^C''abc'';',false);
end;
procedure TTestScanner.TestNumber;
begin

16
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -945,9 +945,9 @@ begin
'begin',
' DoIt;']);
AnalyzeProgram;
CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "b" not used');
CheckUseAnalyzerHint(mtHint,nPALocalVariableIsAssignedButNeverUsed,
'Local variable "c" is assigned but never used');
CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "b" not used');
CheckUseAnalyzerHint(mtHint,nPAFieldIsAssignedButNeverUsed,
'Field "c" is assigned but never used');
CheckUseAnalyzerUnexpectedHints;
end;
@ -2278,9 +2278,9 @@ begin
Add('begin');
Add(' Point(1);');
AnalyzeProgram;
CheckUseAnalyzerHint(mtHint,nPALocalVariableIsAssignedButNeverUsed,
'Local variable "X" is assigned but never used');
CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used');
CheckUseAnalyzerHint(mtHint,nPAFieldIsAssignedButNeverUsed,
'Field "X" is assigned but never used');
CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used');
CheckUseAnalyzerUnexpectedHints;
end;
@ -2319,7 +2319,7 @@ begin
Add('begin');
Add(' Point();');
AnalyzeProgram;
CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used');
CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used');
CheckUseAnalyzerUnexpectedHints;
end;
@ -2385,7 +2385,7 @@ begin
' specialize Point<word>();',
'']);
AnalyzeProgram;
CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used');
CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used');
CheckUseAnalyzerUnexpectedHints;
end;

81
packages/pastojs/src/fppas2js.pp
View File

@ -2399,6 +2399,7 @@ const
TempRefSetPathName = 's';
TempRefParamName = 'a';
IdentChars = ['0'..'9', 'A'..'Z', 'a'..'z','_'];
AwaitSignature2 = 'function await(aType,TJSPromise):aType';
function CodePointToJSString(u: longword): TJSString;
begin
@ -5956,12 +5957,10 @@ end;
function TPas2JSResolver.BI_AWait_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
// await(T; p: TJSPromise): T;
// await(T; p: TJSPromise): T
// await(T; jsvalue): T
// await(AsyncFuncWithResultT): T
// await(AsyncProc);
// await(Proc);
// await(const Expr: T): T
const
Signature2 = 'function await(aType,TJSPromise):aType';
var
Params: TParamsExpr;
Param: TPasExpr;
@ -5991,6 +5990,48 @@ begin
// must be the only parameter
Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
if Result=cIncompatible then exit;
TypeEl:=ParamResolved.LoTypeEl;
if (ParamResolved.IdentEl is TPasResultElement) then
begin
// await(AsyncFuncCall)
if not TPasFunctionType(ParamResolved.IdentEl.Parent).IsAsync then
begin
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.BI_AWait_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved));
{$ENDIF}
if RaiseOnError then
RaiseMsg(20201229232446,nXExpectedButYFound,sXExpectedButYFound,['async function',GetResolverResultDescription(ParamResolved)],Expr)
else
exit(cIncompatible);
end;
end
else if (ParamResolved.BaseType=btContext)
and (TypeEl is TPasProcedureType) then
begin
// await(AsyncFuncTypeVar)
if not TPasProcedureType(TypeEl).IsAsync then
begin
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.BI_AWait_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved));
{$ENDIF}
if RaiseOnError then
RaiseMsg(20201229232541,nXExpectedButYFound,sXExpectedButYFound,['async function',GetResolverResultDescription(ParamResolved)],Expr)
else
exit(cIncompatible);
end;
end
else
begin
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.BI_AWait_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved));
{$ENDIF}
if RaiseOnError then
RaiseMsg(20201229224920,nXExpectedButYFound,sXExpectedButYFound,['async function',GetResolverResultDescription(ParamResolved)],Expr)
else
exit(cIncompatible);
end;
end
else if ParamResolved.BaseType=btProc then
begin
@ -6028,7 +6069,7 @@ begin
begin
if RaiseOnError then
RaiseMsg(20200520090749,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[Signature2],Params);
sWrongNumberOfParametersForCallTo,[AwaitSignature2],Params);
exit(cIncompatible);
end;
@ -6062,14 +6103,21 @@ begin
exit(CheckRaiseTypeArgNo(20200520091707,2,Param,Param2Resolved,
'instance of TJSPromise',RaiseOnError));
if (Param2Resolved.BaseType<>btContext)
or not (Param2Resolved.LoTypeEl is TPasClassType)
or not IsExternalClass_Name(TPasClassType(Param2Resolved.LoTypeEl),'Promise') then
exit(CheckRaiseTypeArgNo(20200520091707,2,Param,Param2Resolved,
if (Param2Resolved.BaseType=btContext)
and (Param2Resolved.LoTypeEl is TPasClassType)
and IsExternalClass_Name(TPasClassType(Param2Resolved.LoTypeEl),'Promise') then
// await(T,aPromise)
else if IsJSBaseType(Param2Resolved,pbtJSValue) then
// await(T,jsvalue)
else if (Param2Resolved.IdentEl is TPasArgument)
and (Param2Resolved.LoTypeEl=nil) then
// await(T,UntypedArg)
else
exit(CheckRaiseTypeArgNo(20200520091708,2,Param,Param2Resolved,
'TJSPromise',RaiseOnError));
end;
Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError,Signature2);
Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError,AwaitSignature2);
end;
end;
@ -6084,11 +6132,18 @@ begin
Param:=Params.Params[0];
if length(Params.Params)=1 then
begin
// await(expr)
// await(AsyncFuncCall)
if CheckCallAsyncFuncResult(Param,ResolvedEl) then
begin
// await(CallAsynFuncResultT): T
if (ResolvedEl.BaseType=btContext)
and (ResolvedEl.LoTypeEl is TPasClassType)
and IsExternalClass_Name(TPasClassType(ResolvedEl.LoTypeEl),'Promise') then
// async function returns a promise, await resolve all promises -> need final type as first param
RaiseMsg(20201229235932,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[AwaitSignature2],Param);
exit;
// await(expr:T):T
end;
end
else
begin

50
packages/pastojs/tests/tcgenerics.pas
View File

@ -77,7 +77,8 @@ type
// ToDo: FuncName:= instead of Result:=
// generic methods
procedure TestGenMethod_ObjFPC;
procedure TestGenMethod_ImplicitSpec_ObjFPC;
procedure TestGenMethod_Delphi;
// generic array
procedure TestGen_Array_OtherUnit;
@ -2135,7 +2136,7 @@ begin
'']));
end;
procedure TTestGenerics.TestGenMethod_ObjFPC;
procedure TTestGenerics.TestGenMethod_ImplicitSpec_ObjFPC;
begin
StartProgram(false);
Add([
@ -2166,7 +2167,7 @@ begin
' o.{@C}Run(''foo'',''bar'');',
'']);
ConvertProgram;
CheckSource('TestGenMethod_ObjFPC',
CheckSource('TestGenMethod_ImplicitSpec_ObjFPC',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
@ -2192,6 +2193,49 @@ begin
'']));
end;
procedure TTestGenerics.TestGenMethod_Delphi;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class',
' procedure Run<S>;',
' end; ',
'procedure TObject.Run<S>;',
'begin',
'end;',
'var o: TObject;',
'begin',
' o.Run<word>;',
' o.Run<word>();',
' with o do begin',
' Run<word>;',
' Run<word>();',
' end;',
'']);
ConvertProgram;
CheckSource('TestGenMethod_Delphi',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Run$G1 = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.o.Run$G1();',
'$mod.o.Run$G1();',
'var $with = $mod.o;',
'$with.Run$G1();',
'$with.Run$G1();',
'']));
end;
procedure TTestGenerics.TestGen_Array_OtherUnit;
begin
WithTypeInfo:=true;

148
packages/pastojs/tests/tcmodules.pas
View File

@ -883,8 +883,11 @@ type
Procedure TestAwait_NonPromiseWithTypeFail;
Procedure TestAwait_AsyncCallTypeMismatch;
Procedure TestAWait_OutsideAsyncFail;
Procedure TestAWait_Result;
Procedure TestAWait_IntegerFail;
Procedure TestAWait_ExternalClassPromise;
Procedure TestAWait_JSValue;
Procedure TestAWait_Result;
Procedure TestAWait_ResultPromiseMissingTypeFail;
Procedure TestAsync_AnonymousProc;
Procedure TestAsync_ProcType;
Procedure TestAsync_ProcTypeAsyncModMismatchFail;
@ -32619,48 +32622,21 @@ begin
ConvertProgram;
end;
procedure TTestModule.TestAWait_Result;
procedure TTestModule.TestAWait_IntegerFail;
begin
StartProgram(false);
Add([
'{$modeswitch externalclass}',
'type',
' TJSPromise = class external name ''Promise''',
' end;',
'function Crawl(d: double = 1.3): word; ',
'function Run: word;',
'begin',
'end;',
'function Run(d: double = 1.6): word; async;',
'procedure Fly(w: word); async;',
'begin',
' Result:=await(1);',
' Result:=await(Crawl);',
' Result:=await(Crawl(4.5));',
' Result:=await(Run);',
' Result:=await(Run(6.7));',
' await(Run());',
'end;',
'begin',
' Run(1);']);
' Fly(1);']);
SetExpectedPasResolverError('async function expected, but Result:Word found',nXExpectedButYFound);
ConvertProgram;
CheckSource('TestAWait_Result',
LinesToStr([ // statements
'this.Crawl = function (d) {',
' var Result = 0;',
' return Result;',
'};',
'this.Run = async function (d) {',
' var Result = 0;',
' Result = await 1;',
' Result = await $mod.Crawl(1.3);',
' Result = await $mod.Crawl(4.5);',
' Result = await $mod.Run(1.6);',
' Result = await $mod.Run(6.7);',
' return Result;',
'};',
'']),
LinesToStr([
'$mod.Run(1);'
]));
SetExpectedPasResolverError('Await without promise',nAwaitWithoutPromise);
end;
procedure TTestModule.TestAWait_ExternalClassPromise;
@ -32723,6 +32699,110 @@ begin
CheckResolverUnexpectedHints();
end;
procedure TTestModule.TestAWait_JSValue;
begin
StartProgram(false);
Add([
'{$modeswitch externalclass}',
'type',
' TJSPromise = class external name ''Promise''',
' end;',
'function Fly(w: word): jsvalue; async;',
'begin',
'end;',
'function Run(d: jsvalue; var e): word; async;',
'begin',
' Result:=await(word,d);', // promise needs type
' d:=await(Fly(4));', // async non promise must omit the type
' Result:=await(word,e);', // promise needs type
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestAWait_JSValue',
LinesToStr([ // statements
'this.Fly = async function (w) {',
' var Result = undefined;',
' return Result;',
'};',
'this.Run = async function (d, e) {',
' var Result = 0;',
' Result = await d;',
' d = await $mod.Fly(4);',
' Result = await e.get();',
' return Result;',
'};',
'']),
LinesToStr([
]));
CheckResolverUnexpectedHints();
end;
procedure TTestModule.TestAWait_Result;
begin
StartProgram(false);
Add([
'{$modeswitch externalclass}',
'type',
' TJSPromise = class external name ''Promise''',
' end;',
'function Crawl(d: double = 1.3): TJSPromise; ',
'begin',
'end;',
'function Run(d: double = 1.6): word; async;',
'begin',
' Result:=await(word,Crawl);',
' Result:=await(word,Crawl(4.5));',
' Result:=await(Run);',
' Result:=await(Run(6.7));',
'end;',
'begin',
' Run(1);']);
ConvertProgram;
CheckSource('TestAWait_Result',
LinesToStr([ // statements
'this.Crawl = function (d) {',
' var Result = null;',
' return Result;',
'};',
'this.Run = async function (d) {',
' var Result = 0;',
' Result = await $mod.Crawl(1.3);',
' Result = await $mod.Crawl(4.5);',
' Result = await $mod.Run(1.6);',
' Result = await $mod.Run(6.7);',
' return Result;',
'};',
'']),
LinesToStr([
'$mod.Run(1);'
]));
CheckResolverUnexpectedHints();
end;
procedure TTestModule.TestAWait_ResultPromiseMissingTypeFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$modeswitch externalclass}',
'type',
' TJSPromise = class external name ''Promise''',
' end;',
'function Run: TJSPromise; async;',
'begin',
'end;',
'procedure Fly(w: word); async;',
'begin',
' await(Run());',
'end;',
'begin',
' Fly(1);']);
SetExpectedPasResolverError('Wrong number of parameters specified for call to "function await(aType,TJSPromise):aType"',
nWrongNumberOfParametersForCallTo);
ConvertProgram;
end;
procedure TTestModule.TestAsync_AnonymousProc;
begin
StartProgram(false);

2
packages/winunits-base/src/activex.pp
View File

@ -4541,7 +4541,7 @@ type
procedure CoTaskMemFree(_para1:PVOID);stdcall; external 'ole32.dll' name 'CoTaskMemFree';
{$ifndef wince}
function CreateDataAdviseHolder(_para1:IDataAdviseHolder):HRESULT;stdcall; external 'ole32.dll' name 'CreateDataAdviseHolder';
function CreateDataAdviseHolder(out _para1:IDataAdviseHolder):HRESULT;stdcall; external 'ole32.dll' name 'CreateDataAdviseHolder';
function CreateDataCache(_para1:IUnknown; const _para2:TCLSID; const _para3:TIID; out _para4):HRESULT;stdcall; external 'ole32.dll' name 'CreateDataCache';
{$endif wince}

6
tests/test/cg/tm128.pp
View File

@ -1,14 +1,10 @@
{$ASSERTIONS ON}
{$packrecords c}
{$push}
{$codealign recordmin=16}
type
tm128 = record
case byte of
1 : (m128_f32 : array[0..3] of single;)
end;
{$pop}
end align 16;
type
tm128_unaligned = record

39
tests/webtbs/tw28927.pp Normal file
View File

@ -0,0 +1,39 @@
type
TRecord1 = record
end align 16;
TRecord2 = record
end align 8;
TRecord3 = record
end align 4;
TRecord1Outer = record
b : Byte;
Record1 : TRecord1;
end;
TRecord2Outer = record
b : Byte;
Record2 : TRecord2;
end;
TRecord3Outer = record
b : Byte;
Record3 : TRecord3;
end;
var
Record1Outer : TRecord1Outer;
Record2Outer : TRecord2Outer;
Record3Outer : TRecord3Outer;
begin
if PtrUInt(@Record1Outer.Record1) mod 16<>0 then
halt(1);
if PtrUInt(@Record2Outer.Record2) mod 8<>0 then
halt(2);
if PtrUInt(@Record3Outer.Record3) mod 4<>0 then
halt(3);
writeln('ok');
end.

17
tests/webtbs/tw38259.pp Normal file
View File

@ -0,0 +1,17 @@
{ %OPT=-O3 -Sew -vw }
{$mode objfpc}
{$inline on}
procedure test; inline;
begin
exit;
end;
function f: longint;
begin
test; // tt.pp(11,3) Warning: Function result variable does not seem to be initialized
result:=4;
end;
begin
end.

4
utils/pas2js/docs/translation.html
View File

@ -3060,9 +3060,9 @@ End.
Pas2js supports the JS operators async and await to simplify the use of Promise.
The await operator corresponds to three intrinsic Pas2js functions:
<ul>
<li><i>function await(AsyncFunctionWithResultT): T;</i> // implicit promise</li>
<li><i>function await(AsyncFunctionWithResultT()): T;</i> // implicit promise, the inner () can be omitted</li>
<li><i>function await(aType; p: TJSPromise): aType;</i> // explicit promise requires the resolved type</li>
<li><i>function await(const Expr: T): T;</i> // implicit promise</li>
<li><i>function await(aType; j: jsvalue): aType;</i> // explicit promise requires the resolved type</li>
</ul>
The await function can only be used inside a procedure with the async modifier.<br>
Example for the explicit promise: