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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48248 -
This commit is contained in:
nickysn 2021-01-20 23:34:58 +00:00
commit 062360341c
12 changed files with 172 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
compiler/armgen/aoptarm.pas
View File

@ -531,6 +531,11 @@ Implementation
{ Instruction will become mov r1,r1 }
DebugMsg('Peephole Optimization: Mov2None 2 done', next_hp);
{ Allocate r1 between the instructions; not doing
so may cause problems when removing superfluous
MOVs later (i38055) }
AllocRegBetween(taicpu(p).oper[1]^.reg, p, next_hp, UsedRegs);
if (next_hp = hp1) then
{ Don't let hp1 become a dangling pointer }
hp1 := nil;

1
compiler/options.pas
View File

@ -1830,6 +1830,7 @@ begin
exclude(init_settings.globalswitches,cs_use_heaptrc);
exclude(init_settings.globalswitches,cs_use_lineinfo);
exclude(init_settings.localswitches,cs_checkpointer);
paratargetdbg:=dbg_none;
localvartrashing := -1;
end
else

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

@ -19136,19 +19136,19 @@ begin
exit(cIncompatible);
Params:=TParamsExpr(Expr);
// first param: bool, enum or char
// first param: bool, integer, enum or char
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[]);
Result:=cIncompatible;
if rrfReadable in ParamResolved.Flags then
begin
if ParamResolved.BaseType in (btAllBooleans+btAllChars) then
if ParamResolved.BaseType in btArrayRangeTypes then
Result:=cExact
else if (ParamResolved.BaseType=btContext) and (ParamResolved.LoTypeEl is TPasEnumType) then
Result:=cExact
else if ParamResolved.BaseType=btRange then
begin
if ParamResolved.SubType in btAllBooleans+btAllChars then
if ParamResolved.SubType in btArrayRangeTypes then
Result:=cExact
else if ParamResolved.SubType=btContext then
begin

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

@ -3359,8 +3359,10 @@ begin
' i2: TInt2;',
'begin',
' i:=i2;',
' if i=i2 then ;']);
' if i=i2 then ;',
' i:=ord(i);']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestIntegerRangeHighLowerLowFail;

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

@ -3954,6 +3954,7 @@ var
begin
Lines:=El.Tokens;
if Lines=nil then exit;
// ToDo: resolve explicit references
end;
procedure TPas2JSResolver.ResolveNameExpr(El: TPasExpr; const aName: string;
@ -13398,6 +13399,15 @@ begin
Result:=Add;
exit;
end
else if bt in btAllJSInteger then
begin
// ord(integer)
Result:=CheckOrdConstant(aResolver,Param);
if Result<>nil then exit;
// ord(integer) -> integer
Result:=ConvertExpression(Param,AContext);
exit;
end
else if bt=btContext then
begin
C:=ParamResolved.LoTypeEl.ClassType;
@ -17551,6 +17561,7 @@ var
L: TJSLiteral;
AsmLines: TStrings;
Line, Col, StartLine: integer;
Statements: TJSStatementList;
begin
if AContext=nil then ;
AsmLines:=El.Tokens;
@ -17569,6 +17580,15 @@ begin
L:=TJSLiteral.Create(Line+StartLine,Col,El.SourceFilename);
L.Value.CustomValue:=TJSString(s);
Result:=L;
if Pos(';',s)>0 then
begin
// multi statement JS
// for example "if e then asm a;b end;"
// -> if (e){ a;b }
Statements:=TJSStatementList.Create(L.Line,L.Column,L.Source);
Statements.A:=L;
Result:=Statements;
end;
end;
end;

72
packages/pastojs/src/pas2jsfiler.pp
View File

@ -609,6 +609,7 @@ type
public
Owner: TObject;
end;
EPas2JsFilerErrorClass = class of EPas2JsFilerError;
EPas2JsWriteError = class(EPas2JsFilerError);
EPas2JsReadError = class(EPas2JsFilerError);
@ -665,6 +666,7 @@ type
TPCUFiler = class
private
FErrorClass: EPas2JsFilerErrorClass;
FFileVersion: longint;
FGUID: TGUID;
FInitialFlags: TPCUInitialFlags;
@ -676,7 +678,7 @@ type
function GetSourceFiles(Index: integer): TPCUSourceFile;
protected
FElementRefs: TAVLTree; // tree of TPCUFilerElementRef sorted for Element
procedure RaiseMsg(Id: int64; const Msg: string = ''); virtual; abstract; overload;
procedure RaiseMsg(Id: int64; const Msg: string = ''); virtual; overload;
procedure RaiseMsg(Id: int64; El: TPasElement; const Msg: string = ''); overload;
function GetDefaultMemberVisibility(El: TPasElement): TPasMemberVisibility; virtual;
function GetDefaultPasScopeVisibilityContext(Scope: TPasScope): TPasElement; virtual;
@ -703,6 +705,7 @@ type
property SourceFiles[Index: integer]: TPCUSourceFile read GetSourceFiles;
property ElementRefs: TAVLTree read FElementRefs;
property GUID: TGUID read FGUID write FGUID;
property ErrorClass: EPas2JsFilerErrorClass read FErrorClass write FErrorClass;
end;
{ TPCUCustomWriter }
@ -711,6 +714,7 @@ type
private
FOnIsElementUsed: TPas2JSIsElementUsedEvent;
public
constructor Create; override;
procedure WritePCU(aResolver: TPas2JSResolver; aConverter: TPasToJSConverter;
InitFlags: TPCUInitialFlags; aStream: TStream; Compressed: boolean); virtual; abstract;
property OnIsElementUsed: TPas2JSIsElementUsedEvent read FOnIsElementUsed write FOnIsElementUsed;
@ -721,12 +725,15 @@ type
TPCUCustomReader = class(TPCUFiler)
private
FPCUFilename: string;
FSourceFilename: string;
public
constructor Create; override;
procedure ReadPCU(aResolver: TPas2JSResolver; aStream: TStream); virtual; abstract;
function ReadContinue: boolean; virtual; abstract; // true=finished
function ReadCanContinue: boolean; virtual; // true=not finished and no pending used interface
property SourceFilename: string read FSourceFilename write FSourceFilename; // default value for TPasElement.SourceFilename
property PCUFilename: string read FPCUFilename write FPCUFilename; // for nicer error messages
end;
TPCUReaderClass = class of TPCUCustomReader;
@ -768,7 +775,6 @@ type
FBuiltInSymbolsArr: TJSONArray;
protected
FFirstNewExt, FLastNewExt: TPCUFilerElementRef; // not yet stored external references
procedure RaiseMsg(Id: int64; const Msg: string = ''); override; overload;
procedure ResolvePendingElRefs(Ref: TPCUFilerElementRef);
function CheckElScope(El: TPasElement; NotNilId: int64; ScopeClass: TPasScopeClass): TPasScope; virtual;
procedure AddArrayFlag(Obj: TJSONObject; var Arr: TJSONArray;
@ -1239,6 +1245,7 @@ type
procedure ReadPCU(aResolver: TPas2JSResolver; aStream: TStream); override; // sets property JSON, reads header and returns
procedure ReadJSONHeader(aResolver: TPas2JSResolver; Obj: TJSONObject); virtual;
function ReadContinue: boolean; override; // true=finished
function GetPCUExt: string; virtual; // without dot
property FileVersion: longint read FFileVersion;
property JSON: TJSONObject read FJSON;
end;
@ -1857,6 +1864,14 @@ begin
AddLine(Line);
end;
{ TPCUCustomWriter }
constructor TPCUCustomWriter.Create;
begin
inherited Create;
FErrorClass:=EPas2JsWriteError;
end;
{ TPCUReaderPendingSpecialized }
destructor TPCUReaderPendingSpecialized.Destroy;
@ -1877,6 +1892,12 @@ end;
{ TPCUCustomReader }
constructor TPCUCustomReader.Create;
begin
inherited Create;
FErrorClass:=EPas2JsReadError;
end;
function TPCUCustomReader.ReadCanContinue: boolean;
var
Module: TPasModule;
@ -1930,6 +1951,18 @@ begin
Result:=TPCUSourceFile(FSourceFiles[Index]);
end;
procedure TPCUFiler.RaiseMsg(Id: int64; const Msg: string);
var
E: EPas2JsFilerError;
begin
E:=ErrorClass.Create('['+IntToStr(Id)+'] '+Msg);
E.Owner:=Self;
{$IFDEF VerbosePCUFiler}
writeln(ClassName+'/TPCUFiler.RaiseMsg ',E.Message);
{$ENDIF}
raise E;
end;
procedure TPCUFiler.RaiseMsg(Id: int64; El: TPasElement; const Msg: string);
var
Path, s: String;
@ -2215,18 +2248,6 @@ begin
end;
end;
procedure TPCUWriter.RaiseMsg(Id: int64; const Msg: string);
var
E: EPas2JsWriteError;
begin
E:=EPas2JsWriteError.Create('['+IntToStr(Id)+'] '+Msg);
E.Owner:=Self;
{$IFDEF VerbosePCUFiler}
writeln('TPCUWriter.RaiseMsg ',E.Message);
{$ENDIF}
raise E;
end;
function TPCUWriter.CheckElScope(El: TPasElement; NotNilId: int64;
ScopeClass: TPasScopeClass): TPasScope;
var
@ -5781,12 +5802,16 @@ end;
procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
var
E: EPas2JsReadError;
E: EPas2JsFilerError;
s: String;
begin
E:=EPas2JsReadError.Create('['+IntToStr(Id)+'] '+Msg);
s:='['+IntToStr(Id)+'] '+Msg;
if PCUFilename<>'' then
s:=s+' file: '+PCUFilename;
E:=ErrorClass.Create(s);
E.Owner:=Self;
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.RaiseMsg ',E.Message);
writeln(ClassName+'/TPCUReader.RaiseMsg ',E.Message);
{$ENDIF}
raise E;
end;
@ -6317,9 +6342,9 @@ begin
writeln('TPCUReader.ReadHeaderVersion ',FFileVersion);
{$ENDIF}
if FFileVersion<1 then
RaiseMsg(20180130201801,'invalid PCU file version');
RaiseMsg(20180130201801,'invalid file version');
if FFileVersion>PCUVersion then
RaiseMsg(20180130201822,'pcu file was created by a newer compiler.');
RaiseMsg(20180130201822,'file was created by a newer compiler.');
end;
procedure TPCUReader.ReadGUID(Obj: TJSONObject);
@ -10135,6 +10160,15 @@ begin
{$ENDIF}
end;
function TPCUReader.GetPCUExt: string;
begin
Result:=ExtractFileExt(PCUFilename);
if Result='' then
Result:='pcu'
else
System.Delete(Result,1,1); // remove leading dot
end;
{ TPas2JSPrecompileFormats }
function TPas2JSPrecompileFormats.GetItems(Index: integer

1
packages/pastojs/src/pas2jspcucompiler.pp
View File

@ -187,6 +187,7 @@ begin
RaiseInternalError(20180312142954,'');
FPCUReader:=FPCUFormat.ReaderClass.Create;
FPCUReader.SourceFilename:=ExtractFileName(MyFile.PCUFilename);
FPCUReader.PCUFilename:=MyFile.PCUFilename;
if MyFile.ShowDebug then
MyFile.Log.LogMsg(nParsingFile,[QuoteStr(MyFile.PCUFilename)]);

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

@ -337,6 +337,7 @@ type
Procedure TestProc_External;
Procedure TestProc_ExternalOtherUnit;
Procedure TestProc_Asm;
Procedure TestProc_AsmSubBlock;
Procedure TestProc_Assembler;
Procedure TestProc_VarParam;
Procedure TestProc_VarParamString;
@ -4139,6 +4140,65 @@ begin
]));
end;
procedure TTestModule.TestProc_AsmSubBlock;
begin
StartProgram(true,[supTObject]);
Add([
'{$mode delphi}',
'type',
' TBird = class end;',
'procedure Run(w: word);',
'begin;',
' if true then asm console.log(); end;',
' if w>3 then asm',
' var a = w+1;',
' w = a+3;',
' end;',
' while (w>7) do asm',
' w+=3; w*=2;',
' end;',
' try',
' except',
' on E: TBird do',
' asm console.log(E); end;',
' on E: TObject do',
' asm var i=3; i--; end;',
' else asm Fly; High; end;',
' end;',
'end;',
'begin']);
ConvertProgram;
CheckSource('TestProc_AsmSubBlock',
LinesToStr([ // statements
'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
'});',
'this.Run = function (w) {',
' if (true) console.log();',
' if (w > 3) {',
' var a = w+1;',
' w = a+3;',
' };',
' while (w > 7) {',
' w+=3; w*=2;',
' };',
' try {} catch ($e) {',
' if ($mod.TBird.isPrototypeOf($e)) {',
' var E = $e;',
' console.log(E);',
' } else if (pas.system.TObject.isPrototypeOf($e)) {',
' var E = $e;',
' var i=3; i--;',
' } else {',
' Fly; High;',
' }',
' };',
'};',
'']),
LinesToStr([
''
]));
end;
procedure TTestModule.TestProc_Assembler;
begin
StartProgram(false);
@ -7122,7 +7182,9 @@ begin
'begin',
' i:=i2;',
' i:=default(TMyInt);',
' if i=i2 then ;']);
' if i=i2 then ;',
' i:=ord(i2);',
'']);
ConvertProgram;
CheckSource('TestIntegerRange',
LinesToStr([
@ -7143,6 +7205,7 @@ begin
'$mod.i = $mod.i2;',
'$mod.i = -1;',
'if ($mod.i === $mod.i2) ;',
'$mod.i = $mod.i2;',
'']));
end;
@ -7257,6 +7320,7 @@ begin
' i:=system.high(i);',
' i:=system.pred(i);',
' i:=system.succ(i);',
' i:=system.ord(i);',
'']);
ConvertProgram;
CheckResolverUnexpectedHints;
@ -7273,6 +7337,7 @@ begin
'$mod.i = 255;',
'$mod.i = $mod.i - 1;',
'$mod.i = $mod.i + 1;',
'$mod.i = $mod.i;',
'']));
end;

12
packages/rtl-extra/fpmake.pp
View File

@ -27,8 +27,6 @@ Const
WinsockOSes = [win32,win64,wince,os2,emx,netware,netwlibc];
WinSock2OSes = [win32,win64,wince];
SocketsOSes = UnixLikes+AllAmigaLikeOSes+[netware,netwlibc,os2,emx,wince,win32,win64];
Socksyscall = [beos,freebsd,haiku,linux,netbsd,openbsd,dragonfly];
Socklibc = unixlikes-socksyscall;
gpmOSes = [Linux,Android];
AllTargetsextra = ObjectsOSes + UComplexOSes + MatrixOSes+
SerialOSes +PrinterOSes+SocketsOSes+gpmOSes;
@ -36,6 +34,7 @@ Const
Var
P : TPackage;
T : TTarget;
Socksyscall, Socklibc : set of Tos;
begin
With Installer do
@ -51,6 +50,15 @@ begin
if Defaults.CPU=jvm then
P.OSes := P.OSes - [java,android];
Socksyscall := [beos,freebsd,haiku,linux,netbsd,dragonfly];
Socklibc := unixlikes-socksyscall;
{$ifdef FPC_USE_SYSCALL}
if Defaults.OS=openbsd then
begin
system.include(Socksyscall,openbsd);
system.exclude(Socklibc,openbsd);
end;
{$endif}
P.Email := '';
P.Description := 'Rtl-extra, RTL not needed for bootstrapping';
P.NeedLibC:= false;

5
packages/rtl-extra/src/bsd/osdefs.inc
View File

@ -27,4 +27,9 @@
{$ifdef darwin}
{$define FPC_USE_LIBC}
{$endif}
{$ifdef openbsd}
{$ifndef FPC_USE_SYSCALL}
{$define FPC_USE_LIBC}
{$endif}
{$endif}

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

@ -5,7 +5,7 @@
}
{$ifdef FPC} {$mode delphi} {$endif}
uses Windows, SysUtils, Classes, registry;
uses SysUtils, Classes, registry;
{$ifdef FPC}
{$WARN implicit_string_cast_loss off}

8
tests/webtbs/tw37060.pp
View File

@ -4,7 +4,7 @@ program fp37060;
uses sockets, Classes, SysUtils;
procedure BuildBadAddrs4(out bad_addrs: TStringList);
procedure BuildBadAddrs4(var bad_addrs: TStringList);
begin
bad_addrs.Add('1.1.1.1.1'); // too many octets
bad_addrs.Add('0xa.3.4.5'); //hex in octets
@ -32,7 +32,7 @@ begin
bad_addrs.Add('&7.&5.30.4'); // octal
end;
procedure BuildGoodAddrs4(out good_addrs: TStringList);
procedure BuildGoodAddrs4(var good_addrs: TStringList);
begin
good_addrs.Add('127.0.0.1|127.0.0.1');
good_addrs.Add('0.0.0.0|0.0.0.0');
@ -40,7 +40,7 @@ begin
good_addrs.Add('255.255.255.255|255.255.255.255');
end;
procedure BuildBadAddrs6(out bad_addrs: TStringList);
procedure BuildBadAddrs6(var bad_addrs: TStringList);
begin
// start with some obviously bad formats.
bad_addrs.Add('');
@ -193,7 +193,7 @@ begin
bad_addrs.Add('127.0.0.2');
end;
procedure BuildGoodAddrs6(out addrlist: TStringList);
procedure BuildGoodAddrs6(var addrlist: TStringList);
begin
// Each str is two parts, separated by a pipe. The left part is the input
// address to be parsed, and the right is the expected result of taking the