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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48359 -
This commit is contained in:
nickysn 2021-01-24 00:39:31 +00:00
commit dccd4d5b37
13 changed files with 167 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -16765,6 +16765,7 @@ tests/webtbf/tw37476.pp svneol=native#text/pascal
tests/webtbf/tw37763.pp svneol=native#text/pascal
tests/webtbf/tw3790.pp svneol=native#text/plain
tests/webtbf/tw3812.pp svneol=native#text/plain
tests/webtbf/tw38287.pp svneol=native#text/pascal
tests/webtbf/tw38289a.pp svneol=native#text/pascal
tests/webtbf/tw38289b.pp svneol=native#text/pascal
tests/webtbf/tw3930a.pp svneol=native#text/plain

20
compiler/aarch64/aasmcpu.pas
View File

@ -1018,6 +1018,7 @@ implementation
A_TST,
A_FCMP,A_FCMPE,
A_CBZ,A_CBNZ,
A_PRFM,A_PRFUM,
A_RET:
result:=operand_read;
A_STR,A_STUR:
@ -1026,14 +1027,6 @@ implementation
else
{ check for pre/post indexed in spilling_get_operation_type_ref }
result:=operand_read;
A_STLXP,
A_STLXR,
A_STXP,
A_STXR:
if opnr=0 then
result:=operand_write
else
result:=operand_read;
A_STP:
begin
if opnr in [0,1] then
@ -1102,12 +1095,21 @@ implementation
A_FCVTZS,
A_SDIV,
A_SMULL,
A_STLXP,
A_STLXR,
A_STXP,
A_STXR,
A_SUB,
A_SXTB,
A_SXTH,
A_SXTW,
A_UBFIZ,
A_UBFX,
A_UCVTF,
A_UDIV,
A_UMULL:
A_UMULL,
A_UXTB,
A_UXTH:
if opnr=0 then
result:=operand_write
else

3
compiler/aarch64/cgcpu.pas
View File

@ -587,6 +587,9 @@ implementation
manipulated_a: tcgint;
leftover_a: word;
begin
{$ifdef extdebug}
list.concat(tai_comment.Create(strpnew('Generating constant ' + tostr(a))));
{$endif extdebug}
case a of
{ Small positive number }
$0..$FFFF:

10
compiler/scanner.pas
View File

@ -135,6 +135,8 @@ interface
{ if nexttoken<>NOTOKEN, then nexttokenpos holds its filepos }
next_filepos : tfileposinfo;
{ current macro nesting depth }
macro_nesting_depth,
comment_level,
yylexcount : longint;
ignoredirectives : TFPHashList; { ignore directives, used to give warnings only once }
@ -2922,7 +2924,10 @@ type
if assigned(inputfile.next) then
begin
if inputfile.is_macro then
to_dispose:=inputfile
begin
to_dispose:=inputfile;
dec(macro_nesting_depth);
end
else
begin
to_dispose:=nil;
@ -3686,6 +3691,7 @@ type
addfile(hp);
with inputfile do
begin
inc(macro_nesting_depth);
setmacro(p,len);
{ local buffer }
inputbuffer:=buf;
@ -4868,7 +4874,7 @@ type
mac:=tmacro(search_macro(pattern));
if assigned(mac) and (not mac.is_compiler_var) and (assigned(mac.buftext)) then
begin
if yylexcount<max_macro_nesting then
if (yylexcount<max_macro_nesting) and (macro_nesting_depth<max_macro_nesting) then
begin
mac.is_used:=true;
inc(yylexcount);

10
packages/fcl-db/src/sqldb/sqldb.pp
View File

@ -802,6 +802,7 @@ type
Property Proxy : TSQLConnection Read FProxy;
Published
Property ConnectorType : String Read FConnectorType Write SetConnectorType;
Property Port;
end;
TSQLConnectionClass = Class of TSQLConnection;
@ -1197,8 +1198,12 @@ end;
procedure TCustomSQLStatement.DeAllocateCursor;
begin
if Assigned(FCursor) and Assigned(Database) then
DataBase.DeAllocateCursorHandle(FCursor);
if Assigned(FCursor) then
begin
if Assigned(Database) then
DataBase.DeAllocateCursorHandle(FCursor);
FreeAndNil(FCursor);
end;
end;
function TCustomSQLStatement.ExpandMacros( OrigSQL : String ) : String;
@ -1515,6 +1520,7 @@ begin
end;
finally;
DeAllocateCursorHandle(Cursor);
FreeAndNil(Cursor);
end;
end;

11
tests/webtbf/tw38287.pp Normal file
View File

@ -0,0 +1,11 @@
{$macro on}
var
a,b,s : real;
begin
a:=1;
b:=2;
{$define sum:=a+b }
{$define b:=sum} { DON’T do this !!!}
s:=sum; { Will be infinitely recursively expanded... }
end.

9
utils/fpdoc/dw_basehtml.pp
View File

@ -1012,7 +1012,7 @@ begin
break;
ThisPackage := ThisPackage.NextSibling;
end;
if Length(s) = 0 then
if (Length(s) = 0) and Assigned(Module) then
begin
{ Okay, then we have to try all imported units of the current module }
UnitList := Module.InterfaceSection.UsesList;
@ -1038,6 +1038,8 @@ begin
end
else if Element is TPasEnumValue then
s := ResolveLinkID(Element.Parent.PathName)
else if Element is TPasAliasType then
s := ResolveLinkID(TPasAliasType(Element).DestType.PathName)
else
s := ResolveLinkID(Element.PathName);
@ -1049,7 +1051,10 @@ begin
else
begin
Result := nil;
AppendText(Parent, Element.Name); // unresolved items
if Element is TPasAliasType then
AppendText(Parent, TPasAliasType(Element).DestType.Name)
else
AppendText(Parent, Element.Name); // unresolved items
end;
end;

45
utils/fpdoc/dw_html.pp
View File

@ -1744,7 +1744,6 @@ end;
procedure THTMLWriter.CreateClassMainPage(aClass : TPasClassType);
procedure AppendGenericTypes(CodeEl : TDomElement; AList : TFPList; isSpecialize : Boolean);
Var
I : integer;
begin
@ -1759,6 +1758,16 @@ procedure THTMLWriter.CreateClassMainPage(aClass : TPasClassType);
AppendSym(CodeEl, '>');
end;
procedure AppendGeneric(ACodeEl : TDomElement ; AGenericObject: TPasClassType);
begin
if AGenericObject.GenericTemplateTypes.Count>0 then
begin
AppendKw(ACodeEl, ' generic ');
AppendText(ACodeEl, ' ' + UTF8Decode(AGenericObject.Name) + ' ');
AppendGenericTypes(ACodeEl,AGenericObject.GenericTemplateTypes,false);
end;
end;
procedure AppendInterfaceInfo(ACodeEl : TDomElement ; AThisClass: TPasClassType);
var
i:Integer;
@ -1777,7 +1786,7 @@ procedure THTMLWriter.CreateClassMainPage(aClass : TPasClassType);
var
ParaEl,TableEl, TREl, TDEl, CodeEl: TDOMElement;
ThisClass, PrevClass: TPasClassType;
ThisClass, PrevClass: TPasType;
ThisTreeNode: TPasElementNode;
begin
//WriteLn('@ClassPageBody.CreateMainPage Class=', AClass.Name);
@ -1799,11 +1808,14 @@ begin
TDEl := CreateTD(TREl);
CodeEl := CreateCode(CreatePara(TDEl));
AppendKw(CodeEl, 'type');
if not Assigned(AClass.GenericTemplateTypes) then
Dolog('ERROR generic init: %s', [AClass.name]);
if AClass.GenericTemplateTypes.Count>0 then
AppendKw(CodeEl, ' generic ');
AppendText(CodeEl, ' ' + UTF8Decode(AClass.Name) + ' ');
if AClass.GenericTemplateTypes.Count>0 then
AppendGenericTypes(CodeEl,AClass.GenericTemplateTypes,false);
AppendGeneric(CodeEl, AClass)
else
AppendText(CodeEl, ' ' + UTF8Decode(AClass.Name) + ' ');
AppendSym(CodeEl, '=');
AppendText(CodeEl, ' ');
AppendKw(CodeEl, UTF8Decode(ObjKindNames[AClass.ObjKind]));
@ -1816,16 +1828,23 @@ begin
else
ThisTreeNode := TreeClass.GetPasElNode(AClass);
if not Assigned(ThisTreeNode) Then
DoLog('EROOR Tree Class information: '+ThisClass.PathName);
DoLog('ERROR Tree Class information: '+ThisClass.PathName);
if Assigned(AClass.AncestorType) then
begin
AppendSym(CodeEl, '(');
// Show parent class information
//TODO: Specialized generic classes is not processed now.
// TLazFixedRoundBufferListMemBase as example
AppendHyperlink(CodeEl, AClass.AncestorType);
AppendInterfaceInfo(CodeEl, AClass);
if (AClass.AncestorType is TPasSpecializeType) then
begin
AppendText(CodeEl, 'specialize ');
AppendHyperlink(CodeEl, TPasSpecializeType(AClass.AncestorType).DestType);
AppendText(CodeEl, '<,>');
end
else
begin
AppendHyperlink(CodeEl, AClass.AncestorType);
AppendInterfaceInfo(CodeEl, AClass);
end;
AppendSym(CodeEl, ')');
end;
// Class members
@ -1847,8 +1866,8 @@ begin
// Show class item
AppendHyperlink(CodeEl, ThisClass);
if Assigned(PrevClass) then // Interfaces from prevClass
AppendInterfaceInfo(CodeEl, PrevClass);
if Assigned(PrevClass) and (PrevClass Is TPasClassType) then // Interfaces from prevClass
AppendInterfaceInfo(CodeEl, TPasClassType(PrevClass));
AppendShortDescrCell(TREl, ThisClass);
if Assigned(ThisTreeNode) then

10
utils/fpdoc/dw_markdown.pp
View File

@ -421,7 +421,7 @@ begin
break;
ThisPackage := ThisPackage.NextSibling;
end;
if Length(s) = 0 then
if (Length(s) = 0) and Assigned(Module) then
begin
{ Okay, then we have to try all imported units of the current module }
UnitList := Module.InterfaceSection.UsesList;
@ -1577,7 +1577,7 @@ procedure TMarkdownWriter.CreateClassMainPage(aClass : TPasClassType);
var
i: Integer;
ThisInterface,
ThisClass: TPasClassType;
ThisClass: TPasType;
ThisTreeNode: TPasElementNode;
DocNode: TDocNode;
@ -1627,12 +1627,12 @@ begin
// Show class item
if Assigned(ThisClass) Then
AppendHyperlink(ThisClass);
if Assigned(ThisClass) and (ThisClass.Interfaces.count>0) then
if Assigned(ThisClass) and (AClass.Interfaces.count>0) then
begin
AppendText('(');
for i:=0 to ThisClass.interfaces.count-1 do
for i:=0 to AClass.interfaces.count-1 do
begin
ThisInterface:=TPasClassType(ThisClass.Interfaces[i]);
ThisInterface:= TPasType(AClass.Interfaces[i]);
if I>0 then
AppendText(', ');
AppendHyperlink( ThisInterface);

59
utils/fpdoc/dwriter.pp
View File

@ -256,6 +256,8 @@ Type
FModule: TPasModule;
FPageInfos: TFPObjectList; // list of TPageInfo objects
FLinkUnresolvedCnt: Integer;
FOutputPageNames: TStringList;
function GetOutputPageNames: TStrings;
function GetPageCount: Integer;
function LinkFix(ALink:String):String;
Protected
@ -286,6 +288,7 @@ Type
function ModuleHasClasses(AModule: TPasModule): Boolean;
// Allocate pages etc.
Procedure DoWriteDocumentation; override;
Function MustGeneratePage(aFileName : String) : Boolean; virtual;
Property PageInfos : TFPObjectList Read FPageInfos;
Property SubPageNames: Boolean Read FSubPageNames;
@ -298,6 +301,7 @@ Type
Property Module: TPasModule Read FModule Write FModule;
Property CurDirectory: String Read FCurDirectory Write FCurDirectory; // relative to curdir of process
property BaseDirectory: String read FBaseDirectory Write FBaseDirectory; // relative path to package base directory
Property OutputPageNames : TStrings Read GetOutputPageNames;
end;
TFPDocWriterClass = Class of TFPDocWriter;
@ -328,7 +332,7 @@ function SortPasElements(Item1, Item2: Pointer): Integer;
implementation
uses fpdocstrs;
uses strutils, fpdocstrs;
function SortPasElements(Item1, Item2: Pointer): Integer;
begin
@ -418,6 +422,16 @@ begin
Result := PageInfos.Count;
end;
function TMultiFileDocWriter.GetOutputPageNames: TStrings;
begin
If (FoutputPageNames=Nil) then
begin
FOutputPageNames:=TStringList.Create;
FOutputPageNames.Sorted:=True;
end;
Result:=FOutputPageNames;
end;
procedure TMultiFileDocWriter.OutputResults();
begin
DoLog('Unresolved links: %d', [FLinkUnresolvedCnt]);
@ -826,22 +840,59 @@ begin
with TPageInfo(PageInfos[i]) do
begin
FileName:= Allocator.GetFilename(Element, SubpageIndex);
FinalFilename := GetFileBaseDir(Engine.Output) + FileName;
CreatePath(FinalFilename);
WriteDocPage(FileName,ELement,SubPageIndex);
if MustGeneratePage(FileName) then
begin
FinalFilename := GetFileBaseDir(Engine.Output) + FileName;
CreatePath(FinalFilename);
WriteDocPage(FileName,ELement,SubPageIndex);
end;
end;
end;
function TMultiFileDocWriter.MustGeneratePage(aFileName: String): Boolean;
begin
Result:=Not Assigned(FOutputPageNames);
if Not Result then
Result:=FOutputPageNames.IndexOf(aFileName)<>-1;
Writeln(afilename ,': ',result);
end;
class procedure TMultiFileDocWriter.Usage(List: TStrings);
begin
List.AddStrings(['--use-subpagenames', SUsageSubNames]);
List.AddStrings(['--only-pages=LIST', SUsageOnlyPages]);
end;
function TMultiFileDocWriter.InterPretOption(const Cmd, Arg: String): boolean;
Var
I : Integer;
FN : String;
begin
Writeln('Cmd : ',Cmd);
Result := True;
if Cmd = '--use-subpagenames' then
FSubPageNames:= True
else
if Cmd = '--only-pages' then
begin
Result:=Arg<>'';
if Result then
begin
if Arg[1]='@' then
begin
FN:=Copy(Arg,2,Length(Arg)-1);
OutputPageNames.LoadFromFile(FN);
end
else
begin
For I:=1 to WordCount(Arg,[',']) do
OutputPageNames.Add(ExtractWord(I,Arg,[',']));
end;
Writeln('OutputPagenames ',OutputPagenames.CommaText);
end
end
else
Result:=inherited InterPretOption(Cmd, Arg);
end;

4
utils/fpdoc/fpdoc.lpi
View File

@ -158,8 +158,8 @@
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-dCheckPasTreeRefCount
-dDebugRefCount"/>
<CustomOptions Value="-dCheckPasTreeRefCountx
-dDebugRefCountx"/>
<OtherDefines Count="1">
<Define0 Value="CheckPasTreeRefCount"/>
</OtherDefines>

34
utils/fpdoc/fpdocclasstree.pp
View File

@ -16,17 +16,17 @@ Type
TPasElementNode = Class
Private
FElement : TPasClassType;
FElement : TPasType;
FParentNode: TPasElementNode;
FChildren : TFPObjectList;
function GetChild(aIndex : Integer): TPasElementNode;
function GetChildCount: Integer;
Public
Constructor Create (aElement : TPasClassType);
Constructor Create (aElement : TPasType);
Destructor Destroy; override;
Procedure AddChild(C : TPasElementNode);
Procedure SortChildren;
Property Element : TPasClassType Read FElement;
Property Element : TPasType Read FElement;
Property ParentNode : TPasElementNode read FParentNode;
Property Children [aIndex : Integer] : TPasElementNode Read GetChild;
Property ChildCount : Integer Read GetChildCount;
@ -45,7 +45,7 @@ Type
FRootObjectName : string;
FRootObjectPathName : string;
Protected
function AddToList(aElement: TPasClassType): TPasElementNode;
function AddToList(aElement: TPasType): TPasElementNode;
Public
Constructor Create(AEngine:TFPDocEngine; APackage : TPasPackage;
AObjectKind : TPasObjKindSet = okWithFields);
@ -85,7 +85,7 @@ begin
Result:=0
end;
constructor TPasElementNode.Create(aElement: TPasClassType);
constructor TPasElementNode.Create(aElement: TPasType);
begin
FElement:=aElement;
end;
@ -154,30 +154,42 @@ begin
Inherited;
end;
function TClassTreeBuilder.AddToList ( aElement: TPasClassType
function TClassTreeBuilder.AddToList ( aElement: TPasType
) : TPasElementNode;
Var
aParentNode : TPasElementNode;
aName : String;
aElementClass: TPasClassType;
begin
Result:= nil;
if not (aElement.ObjKind in FObjectKind) then exit;
Result:= nil; aElementClass:=nil;
if (aElement is TPasClassType) then
aElementClass:= TPasClassType(aElement);
if Assigned(aElementClass) and not (aElementClass.ObjKind in FObjectKind) then exit;
if not Assigned(aElementClass) and not (aElement is TPasAliasType) then exit;
aParentNode:= nil;
if aElement=Nil then
aName:=FRootObjectName
else if (aElement is TPasAliasType) then
aName:=TPasAliasType(aElement).DestType.FullName
else
aName:=aElement.PathName;
Result:=TPasElementNode(FElementList.Items[aName]);
if (Result=Nil) then
begin
if aElement.AncestorType is TPasClassType then
aParentNode:=AddToList(aElement.AncestorType as TPasClassType);
if Assigned(aElementClass) and (
(aElementClass.AncestorType is TPasClassType) or
(aElementClass.AncestorType is TPasAliasType)
) then
aParentNode:=AddToList(aElementClass.AncestorType);
if not Assigned(aParentNode) then
aParentNode:=FRootNode;
Result:=TPasElementNode.Create(aElement);
if (aElement is TPasAliasType) then
Result:=TPasElementNode.Create(TPasAliasType(TPasType(aElement)).DestType)
else
Result:=TPasElementNode.Create(aElement);
aParentNode.AddChild(Result);
Result.FParentNode := aParentNode;
FElementList.Add(aName,Result);

1
utils/fpdoc/fpdocstrs.pp
View File

@ -189,6 +189,7 @@ resourcestring
SUsageOption310 = '--write-project=file';
SUsageOption320 = ' Write all command-line options to a project file';
SUsageSubNames = 'Use the file subnames instead the indexes as postfixes';
SUsageOnlyPages = 'Only write pages in LIST, LIST is comma-separated list of filenames or @filename where the named file contains 1 file per line.';
SUsageFormats = 'The following output formats are supported by this fpdoc:';
SUsageBackendHelp = 'Specify an output format, combined with --help to get more help for this backend.';