paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 23:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48292 -
This commit is contained in:
nickysn 2021-01-21 23:16:12 +00:00
commit 4165c893be
9 changed files with 248 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -18702,6 +18702,7 @@ tests/webtbs/tw38316.pp svneol=native#text/plain
tests/webtbs/tw3833.pp svneol=native#text/plain
tests/webtbs/tw38337.pp svneol=native#text/plain
tests/webtbs/tw38339.pp svneol=native#text/plain
tests/webtbs/tw38351.pp -text svneol=native#text/pascal
tests/webtbs/tw3840.pp svneol=native#text/plain
tests/webtbs/tw3841.pp svneol=native#text/plain
tests/webtbs/tw3863.pp svneol=native#text/plain

2
compiler/systems/t_amiga.pas
View File

@ -262,6 +262,7 @@ begin
Add(' .data : {');
Add(' PROVIDE(_DATA_BASE_ = .);');
Add(' *(.data .data.* .gnu.linkonce.d.*)');
Add(' *(fpc.resources)');
Add(' VBCC_CONSTRUCTORS_ELF');
Add(' }');
Add(' .ctors : { *(.ctors .ctors.*) }');
@ -293,6 +294,7 @@ begin
Add(' .plt : { *(.plt) }');
Add(' .bss : {');
Add(' *(.bss .bss.* .gnu.linkonce.b.*)');
Add(' *(fpc.reshandles)');
Add(' *(COMMON)');
Add(' }');
Add(' .bss68k : { *(BSS bss) }');

2
packages/fcl-base/src/bufstream.pp
View File

@ -812,7 +812,7 @@ begin
lNewOffset:=FCacheStreamPosition+Offset;
end;
end;
if lNewOffset>0 then begin
if lNewOffset>=0 then begin
FCacheStreamPosition:=lNewOffset;
Result:=lNewOffset;
end else begin

4
packages/fpmkunit/src/fpmkunit.pp
View File

@ -8621,7 +8621,9 @@ Var
WriteBarrier;
AThread.FDone:=False;
RTLeventSetEvent(AThread.NotifyStartTask);
end;
end
else
sleep(100);
if not PackageAvailable then
Finished := True;
end;

6
rtl/amiga/powerpc/execf.inc
View File

@ -35,6 +35,10 @@ function SetSignal(newSignals: longword; signalMask: longword): longword; syscal
procedure AddPort(port: PMsgPort); syscall IExec 300;
function CreateMsgPort(): PMsgPort; syscall IExec 308;
procedure DeleteMsgPort(Port: PMsgPort); syscall IExec 316;
function GetMsg(port: PMsgPort): PMessage; syscall IExec 324;
procedure PutMsg(port: PMsgPort; message: PMessage); syscall IExec 328;
procedure RemPort(port: PMsgPort); syscall IExec 332;
@ -58,6 +62,8 @@ procedure DropInterface(_interface: POS4Interface); syscall IExec 456;
function OpenDevice(devName: PChar; unitNumber: longword;ioRequest: PIORequest; flags: longword): longint; syscall IExec 504;
function CloseDevice(ioRequest: PIORequest): Pointer; syscall IExec 508;
function CreateIORequest(const IOReplyPort: PMsgPort; Size: LongWord): PIORequest; syscall IExec 512;
procedure DeleteIORequest(IORequest: PIORequest); syscall IExec 516;
function DoIO(ioRequest: PIORequest): shortint; syscall IExec 528;

8
tests/test/packages/fcl-registry/tregistry2.pp
View File

@ -1,3 +1,5 @@
{ %TARGET=win32,win64,wince,linux }
{
This unit tests mostly TRegIniFile to work properly and be Delphi compatible.
This test also runs on non-Windows platforms where XML registry is used.
@ -5,7 +7,11 @@
}
{$ifdef FPC} {$mode delphi} {$endif}
uses SysUtils, Classes, registry;
uses
{$ifdef unix}
cwstring,
{$endif unix}
SysUtils, Classes, registry;
{$ifdef FPC}
{$WARN implicit_string_cast_loss off}

355
tests/utils/testsuite/utests.pp
View File

@ -162,7 +162,7 @@ const
RunIDVal : qword;
Error : word;
begin
system.val (RunId,RunIdVal,error);
system.val (Trim(RunId),RunIdVal,error);
if (error<>0) then
result:='ErrorTable'
else if (RunIdVal <= LastOldTestRun) then
@ -1153,7 +1153,7 @@ Const
SGetRunData = 'SELECT TU_ID,TU_DATE,TC_NAME,TO_NAME,' +
'TU_SUBMITTER,TU_MACHINE,TU_COMMENT,TV_VERSION,'+
'TU_CATEGORY_FK,TU_SVNCOMPILERREVISION,TU_SVNRTLREVISION,'+
'TU_COMPILERDATE,'+
'TU_COMPILERDATE,TU_COMPILERFULLVERSION,'+
'TU_SVNPACKAGESREVISION,TU_SVNTESTSREVISION,'+
'(TU_SUCCESSFULLYFAILED+TU_SUCCESFULLYCOMPILED+TU_SUCCESSFULLYRUN) AS OK,'+
'(TU_FAILEDTOCOMPILE+TU_FAILEDTORUN+TU_FAILEDTOFAIL) as Failed,'+
@ -1169,12 +1169,70 @@ Const
Var
Q1,Q2 : TSQLQuery;
Q1, Q2 : TSQLQuery;
F : TField;
SC : string;
Date1, Date2: TDateTime;
AddNewPar : boolean;
CompilerDate1, CompilerDate2: TDateTime;
SC, FRight : string;
Date1, Date2 : TDateTime;
AddNewPar, same_date : boolean;
CompilerDate1, CompilerDate2 : TDateTime;
procedure EmitOneRow(RowTitle,FieldLeft,FieldRight : String; is_same : boolean);
var
FieldColor : string;
begin
if (FieldRight='') then
FieldColor:=''
else if is_same then
FieldColor:='style="color:green;"'
else
FieldColor:='style="color:red;"';
With FHTMLWriter do
begin
RowNext;
if FieldColor<>'' then
begin
TagStart('TD',FieldColor);
end
else
CellStart;
LDumpLn(RowTitle);
if FieldColor<>'' then
begin
CellEnd;
TagStart('TD',FieldColor);
end
else
CellNext;
LDumpLn(FieldLeft);
if FieldColor<>'' then
begin
CellEnd;
TagStart('TD',FieldColor);
end
else
CellNext;
LDumpLn(FieldRight);
CellEnd;
end;
end;
procedure EmitOneRow(RowTitle,FieldLeft,FieldRight : String);
var
is_same : boolean;
begin
is_same:=(FieldLeft=FieldRight);
EmitOneRow(RowTitle,FieldLeft,FieldRight,is_same);
end;
procedure EmitRow(RowTitle,FieldName : String);
var
FieldLeft, FieldRight : String;
begin
FieldLeft:=Q1.FieldByName(FieldName).AsString;
if Q2=nil then
FieldRight:=''
else
FieldRight:=Q2.FieldByName(FieldName).AsString;
EmitOneRow(RowTitle,FieldLeft,FieldRight);
end;
begin
Result:=(FRunID<>'');
If Result then
@ -1210,172 +1268,99 @@ begin
CellNext;
EmitInput('run2id',FCompareRunID);
CellEnd;
RowNext;
CellStart;
DumpLn('Operating system:');
CellNext;
DumpLn(Q1.FieldByName('TO_NAME').AsString);
CellNext;
if Q2 <> nil then
DumpLn(Q2.FieldByName('TO_NAME').AsString);
CellEnd;
RowNext;
CellStart;
DumpLn('Processor:');
CellNext;
DumpLn(Q1.FieldByName('TC_NAME').AsString);
CellNext;
if Q2 <> nil then
DumpLn(Q2.FieldByName('TC_NAME').AsString);
CellEnd;
RowNext;
CellStart;
DumpLn('Version:');
CellNext;
DumpLn(Q1.FieldByNAme('TV_VERSION').AsString);
CellNext;
if Q2 <> nil then
DumpLn(Q2.FieldByNAme('TV_VERSION').AsString);
CellEnd;
RowNext;
CellStart;
DumpLn('Fails/OK/Total:');
CellNext;
Dump(Q1.FieldByName('Failed').AsString);
Dump('/'+Q1.FieldByName('OK').AsString);
DumpLn('/'+Q1.FieldByName('Total').AsString);
CellNext;
if Q2 <> nil then
begin
Dump(Q2.FieldByName('Failed').AsString);
Dump('/'+Q2.FieldByName('Ok').AsString);
DumpLn('/'+Q2.FieldByName('Total').AsString);
end;
CellEnd;
RowNext;
CellStart;
DumpLn('Comment:');
CellNext;
DumpLn(Q1.FieldByName('TU_COMMENT').AsString);
CellNext;
if Q2 <> nil then
DumpLn(Q2.FieldByName('TU_COMMENT').AsString);
CellEnd;
RowNext;
CellStart;
DumpLn('Machine:');
CellNext;
DumpLn(Q1.FieldByName('TU_MACHINE').AsString);
CellNext;
if Q2 <> nil then
DumpLn(Q2.FieldByName('TU_MACHINE').AsString);
CellEnd;
if GetCategoryName(FCategory)<>'All' then
EmitRow('Operating system:','TO_NAME');
EmitRow('Processor:','TC_NAME');
EmitRow('Version:','TV_VERSION');
if Q2 = nil then
FRight:=''
else
begin
RowNext;
CellStart;
DumpLn('Category:');
CellNext;
DumpLn(GetCategoryName(Q1.FieldByName('TU_CATEGORY_FK').AsString));
CellNext;
if Q2 <> nil then
DumpLn(GetCategoryName(Q2.FieldByName('TU_CATEGORY_FK').AsString));
CellEnd;
FRight:=Q2.FieldByName('Failed').AsString+
'/'+Q2.FieldByName('Ok').AsString+
'/'+Q2.FieldByName('Total').AsString;
end;
EmitOneRow('Fails/OK/Total:',
Q1.FieldByName('Failed').AsString+
'/'+Q1.FieldByName('OK').AsString+
'/'+Q1.FieldByName('Total').AsString,
FRight);
EmitRow('Version:','TV_VERSION');
EmitRow('Full version:','TU_COMPILERFULLVERSION');
EmitRow('Comment:','TU_COMMENT');
EmitRow('Machine:','TU_MACHINE');
if GetCategoryName(FCategory)<>'All' then
EmitRow('Category:','TU_CATEGORY_FK');
If GetCategoryName(FCategory)<>'DB' then
begin
RowNext;
CellStart;
DumpLn('SVN Revisions:');
CellNext;
SC:=Q1.FieldByName('svnrev').AsString;
if (SC<>'') then
FormatSVNData(SC);
LDumpLn(SC);
CellNext;
if Q2 <> nil then
begin
SC:=Q2.FieldByName('svnrev').AsString;
FormatSVNData(SC);
LDumpLn(SC);
end;
CellEnd;
end;
RowNext;
CellStart;
DumpLn('Submitter:');
CellNext;
DumpLn(Q1.FieldByName('TU_SUBMITTER').AsString);
CellNext;
SC:=Q1.FieldByName('svnrev').AsString;
if (SC<>'') then
FormatSVNData(SC);
if Q2 <> nil then
DumpLn(Q2.FieldByName('TU_SUBMITTER').AsString);
CellEnd;
RowNext;
CellStart;
DumpLn('Date:');
CellNext;
F := Q1.FieldByName('TU_DATE');
Date1 := F.AsDateTime;
DumpLn(F.AsString);
F := Q1.FieldByName('TU_COMPILERDATE');
begin
FRight:=Q2.FieldByName('svnrev').AsString;
FormatSVNData(FRight);
end
else
FRight:='';
EmitOneRow('SVN revisions:',SC,FRight);
end;
EmitRow('Submitter:','TU_SUBMITTER');
F := Q1.FieldByName('TU_DATE');
Date1 := F.AsDateTime;
SC:=F.AsString;
F := Q1.FieldByName('TU_COMPILERDATE');
Try
CompilerDate1 := F.AsDateTime;
if not SameDate(Date1,CompilerDate1) then
SC:=SC+' <> '+F.AsString;
Except
{ Not a valid date, do nothing }
end;
if Q2 = nil then
FRight:=''
else
begin
F := Q2.FieldByName('TU_DATE');
Date2 := F.AsDateTime;
FRight:= F.AsString;
F := Q2.FieldByName('TU_COMPILERDATE');
Try
CompilerDate1 := F.AsDateTime;
if not SameDate(Date1,CompilerDate1) then
DumpLn(' <> '+F.AsString);
CompilerDate2 := F.AsDateTime;
if not SameDate(Date2,CompilerDate2) then
FRight:=FRight+' <> '+F.AsString;
Except
{ Not a valid date, do nothing }
end;
CellNext;
if Q2 <> nil then
begin
F := Q2.FieldByName('TU_DATE');
Date2 := F.AsDateTime;
DumpLn(F.AsString);
F := Q2.FieldByName('TU_COMPILERDATE');
Try
CompilerDate2 := F.AsDateTime;
if not SameDate(Date2,CompilerDate2) then
DumpLn(' <> '+F.AsString);
Except
{ Not a valid date, do nothing }
end;
end;
CellEnd;
RowNext;
CellStart;
DumpLn('Previous run:');
CellNext;
FPreviousRunID:=GetPreviousRunID(FRunID);
if FPreviousRunID<>'' then
EmitHiddenVar('previousrunid',FPreviousRunID);
DumpLn(FPreviousRunID);
CellNext;
if (FCompareRunID<>'') then
begin
FPrevious2RunID:=GetPreviousRunID(FCompareRunID);
DumpLn(FPrevious2RunID);
if FPrevious2RunID <> '' then
EmitHiddenVar('previous2runid',FPrevious2RunID);
end;
CellEnd;
RowNext;
CellStart;
DumpLn('Next run:');
CellNext;
FNextRunID:=GetNextRunID(FRunID);
if FNextRunID<>'' then
EmitHiddenVar('nextrunid',FNextRunID);
DumpLn(FNextRunID);
CellNext;
if (FCompareRunID<>'') then
begin
FNext2RunID:=GetNextRunID(FCompareRunID);
DumpLn(FNext2RunID);
if FNext2RunID <> '' then
EmitHiddenVar('next2runid',FNext2RunID);
end;
CellEnd;
end;
same_date:=(Copy(SC,1,10)=Copy(FRight,1,10));
EmitOneRow('Date:',SC,FRight,same_date);
FPreviousRunID:=GetPreviousRunID(FRunID);
if FPreviousRunID<>'' then
EmitHiddenVar('previousrunid',FPreviousRunID);
SC:=FPreviousRunID;
if (FCompareRunID<>'') then
begin
FPrevious2RunID:=GetPreviousRunID(FCompareRunID);
FRight:=FPrevious2RunID;
if FPrevious2RunID <> '' then
EmitHiddenVar('previous2runid',FPrevious2RunID);
end
else
FRight:='';
EmitOneRow('Previous run:',SC,FRight);
FNextRunID:=GetNextRunID(FRunID);
if FNextRunID<>'' then
EmitHiddenVar('nextrunid',FNextRunID);
SC:=FNextRunID;
if (FCompareRunID<>'') then
begin
FNext2RunID:=GetNextRunID(FCompareRunID);
FRight:=FNext2RunID;
if FNext2RunID <> '' then
EmitHiddenVar('next2runid',FNext2RunID);
end;
EmitOneRow('Next run:',SC,FRight);
RowEnd;
TableEnd;
ParagraphStart;
@ -1558,7 +1543,7 @@ begin
finally
Free;
end;
If Not (FRunCount=0) and not (FNoSkipped or FOnlyFailed) then
If Not (FRunCount=0) and not (FNoSkipped and FOnlyFailed) then
begin
ParaGraphStart;
TagStart('IMG',Format('Src="'+TestsuiteCGIURL+
@ -2950,10 +2935,6 @@ Procedure TTestSuite.DoDrawPie(Img : TFPCustomImage; Skipped,Failed,Total : Inte
Var
Cnv : TFPImageCanvas;
W,H,FH,CR,ra : Integer;
A1,A2,FR,SR,PR : Double;
R : TRect;
F : TFreeTypeFont;
Procedure AddPie(X,Y,R : Integer; AStart,AStop : Double; Col : TFPColor);
@ -2961,14 +2942,14 @@ Var
DX,Dy : Integer;
begin
DX:=Round(R*Cos(A1));
DY:=Round(R*Sin(A1));
DX:=Round(R*Cos(AStart));
DY:=Round(R*Sin(AStart));
Cnv.Line(X,Y,X+DX,Y-DY);
DX:=Round(Ra*Cos(A2));
DY:=Round(Ra*Sin(A2));
DX:=Round(R*Cos(AStop));
DY:=Round(R*Sin(AStop));
Cnv.Line(X,Y,X+DX,Y-Dy);
DX:=Round(R/2*Cos((A1+A2)/2));
DY:=Round(R/2*Sin((A1+A2)/2));
DX:=Round(R/2*Cos((AStart+AStop)/2));
DY:=Round(R/2*Sin((AStart+AStop)/2));
Cnv.Brush.FpColor:=Col;
Cnv.FloodFill(X+DX,Y-DY);
end;
@ -2979,7 +2960,11 @@ Var
Result:=(2*Pi*(F/T))
end;
Var
W,H,FH,CR,RA : Integer;
A1,A2,FR,SR,PR : Double;
R : TRect;
F : TFreeTypeFont;
begin
F:=TFreeTypeFont.Create;
@ -3044,7 +3029,12 @@ begin
Writeln(stdout,'Setting brush style');
system.flush(stdout);
end;
cnv.brush.FPColor:=colRed;
cnv.brush.FPColor:=colDkGray;
SR:=Skipped/Total;
FR:=Failed/Total;
PR:=1-SR-FR;
cnv.font.FPColor:=colDkGray;
Cnv.Textout(1,FH*2,Format('%d Skipped (%3.1f%%)',[Skipped,SR*100]));
// cnv.pen.width:=1;
// Writeln('Drawing ellipse');
Cnv.Ellipse(R);
@ -3053,15 +3043,16 @@ begin
Writeln(stdout,'Setting text');
system.flush(stdout);
end;
Cnv.Textout(1,FH*2,Format('%d Skipped (%3.1f%%)',[Skipped,SR*100]));
A1:=(Pi*2*(failed/total));
A2:=A1+(Pi*2*(Skipped/Total));
AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColYellow);
A1:=0;
A2:=A1+FractionAngle(Failed,Total);
cnv.font.FPColor:=colRed;
Cnv.Textout(1,FH*3,Format('%d Failed (%3.1f%%)',[Failed,FR*100]));
AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColRed);
cnv.font.FPColor:=colGreen;
Cnv.Textout(1,FH,Format('%d Passed (%3.1f%%)',[Total-Skipped-Failed,PR*100]));
// Writeln('Palette size : ',Img.Palette.Count);
A1:=A2;
A2:=A1+(Pi*2*((Total-(Skipped+Failed))/Total));
Cnv.Textout(1,FH*3,Format('%d Passed (%3.1f%%',[Total-Skipped-Failed,PR*100]));
A2:=A1+FractionAngle(Total-(Skipped+Failed),Total);
AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColGreen);
// Writeln('Palette size : ',Img.Palette.Count);
// Writeln('All done');

33
tests/webtbs/tw38351.pp Normal file
View File

@ -0,0 +1,33 @@
{$MODE OBJFPC}
{$APPTYPE CONSOLE}
uses Classes, BufStream, Sysutils;
procedure TestBufferedFileStream;
var
F: TStream;
pf: File;
begin
Assign(pf,'tw38351.tmp');
Rewrite(pf,1);
Seek(pf,100);
Close(pf);
F := TBufferedFileStream.Create('tw38351.tmp', fmOpenRead);
try
Writeln(F.Position);
if F.Position<>0 then
halt(1);
Writeln(F.Seek(0, soBeginning)); // TFileStream = 0, TBufferedFileStream = -1
Writeln(F.Position);
if F.Position<>0 then
halt(1);
finally
F.Free;
DeleteFile('tw38351.tmp');
end;
end;
begin
TestBufferedFileStream;
writeln('ok');
end.

37
utils/fpdoc/dwriter.pp
View File

@ -257,7 +257,7 @@ Type
FPageInfos: TFPObjectList; // list of TPageInfo objects
FLinkUnresolvedCnt: Integer;
function GetPageCount: Integer;
function LinkFix(ALink:String):String;
Protected
FAllocator: TFileAllocator;
Procedure LinkUnresolvedInc();
@ -431,24 +431,13 @@ end;
function TMultiFileDocWriter.ResolveLinkID(const Name: String): DOMString;
var
res,s: String;
res: String;
begin
res:=Engine.ResolveLink(Module,Name, True);
// engine can return backslashes on Windows
if Length(res) > 0 then
begin
s:=Copy(Res, 1, Length(CurDirectory) + 1);
if (S= CurDirectory + '/') or (s= CurDirectory + '\') then
begin
// TODO: I didn`t see a call to this code on a processing the lcl ana lazutil. What is that?
Res := Copy(Res, Length(CurDirectory) + 2, Length(Res));
//writeLn('INFO: ResolveLinkID "\" - ', Res);
end
else if not IsLinkAbsolute(Res) then
Res := BaseDirectory + Res;
end;
Result:=UTF8Decode(Res);
res:= LinkFix(res);
Result:=UTF8Decode(res);
end;
function TMultiFileDocWriter.ResolveLinkIDUnStrict(const Name: String
@ -474,9 +463,27 @@ begin
// have cut last element
res:= Engine.ResolveLink(Module, Copy(Name, 1, IdLast-1), True);
end;
res:= LinkFix(res);
Result:=UTF8Decode(res);
end;
function TMultiFileDocWriter.LinkFix(ALink: String): String;
var
res, s:String;
begin
res:= ALink;
if Length(res) > 0 then
begin
// If the link is in the same directory as current dir, then remove the directory part.
s:=Copy(res, 1, Length(CurDirectory) + 1);
if (S= CurDirectory + '/') or (s= CurDirectory + '\') then
res := Copy(res, Length(CurDirectory) + 2, Length(res))
else if not IsLinkAbsolute(res) then
res := BaseDirectory + res;
end;
Result:= res;
end;
{ Used for:
- <link> elements in descriptions
- "see also" entries