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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47067 -
This commit is contained in:
nickysn 2020-10-08 21:29:04 +00:00
commit 446d824ad6
27 changed files with 4048 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -3898,6 +3898,7 @@ packages/fcl-passrc/tests/tcgenerics.pp svneol=native#text/plain
packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcpaswritestatements.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcresolvegenerics.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain
@ -18406,6 +18407,7 @@ tests/webtbs/tw3578.pp svneol=native#text/plain
tests/webtbs/tw3579.pp svneol=native#text/plain
tests/webtbs/tw35820.pp svneol=native#text/pascal
tests/webtbs/tw3583.pp svneol=native#text/plain
tests/webtbs/tw35841.pp svneol=native#text/pascal
tests/webtbs/tw35862.pp svneol=native#text/pascal
tests/webtbs/tw35878.pp svneol=native#text/plain
tests/webtbs/tw35878a.pp svneol=native#text/plain

13
compiler/ncal.pas
View File

@ -5203,18 +5203,7 @@ implementation
inlineinitstatement:=nil;
inlinecleanupstatement:=nil;
{ we cannot replace the whole block by a single assignment if the call
has an init/cleanup block
we could though (not yet done), convert this into a bew block
consisting of the init code, the single assignment and the cleanup block
This might even enable new transformations }
if not(assigned(callinitblock)) and not(assigned(callcleanupblock)) then
{ if all that's left of the inlined function is an constant assignment
to the result, replace the whole block with the constant only }
n:=optimize_funcret_assignment(inlineblock)
else
n:=nil;
n:=optimize_funcret_assignment(inlineblock);
if assigned(n) then
begin
inlineblock.free;

42
compiler/x86/aoptx86.pas
View File

@ -4166,7 +4166,7 @@ unit aoptx86;
if MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^) and
MatchOpType(taicpu(p),top_reg,top_reg) and
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
MatchInstruction(taicpu(hp1),taicpu(p).opcode,[taicpu(p).opsize]) and
MatchInstruction(hp1,taicpu(p).opcode,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[0]^) and
MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^) then
begin
@ -4174,7 +4174,37 @@ unit aoptx86;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
end
{
replace
pxor reg1,reg1
movapd/s reg1,reg2
dealloc reg1
by
pxor reg2,reg2
}
else if GetNextInstruction(p,hp1) and
{ we mix single and double opperations here because we assume that the compiler
generates vmovapd only after double operations and vmovaps only after single operations }
MatchInstruction(hp1,A_MOVAPD,A_MOVAPS,[S_NO]) and
MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^) and
MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and
(taicpu(p).oper[0]^.typ=top_reg) then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
begin
taicpu(p).loadoper(0,taicpu(hp1).oper[1]^);
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'PXorMovapd2PXor done',p);
RemoveInstruction(hp1);
result:=true;
end;
end;
end;
@ -4193,7 +4223,7 @@ unit aoptx86;
if MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^,taicpu(p).oper[2]^) and
MatchOpType(taicpu(p),top_reg,top_reg,top_reg) and
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
MatchInstruction(taicpu(hp1),taicpu(p).opcode,[taicpu(p).opsize]) and
MatchInstruction(hp1,taicpu(p).opcode,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[0]^) and
MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^,taicpu(hp1).oper[2]^) then
begin
@ -4201,7 +4231,9 @@ unit aoptx86;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
end
else
Result:=OptPass1VOP(p);
end;
function TX86AsmOptimizer.OptPass1Imul(var p: tai): boolean;
@ -6005,7 +6037,7 @@ unit aoptx86;
function TX86AsmOptimizer.SkipSimpleInstructions(var hp1 : tai) : Boolean;
begin
{ we can skip all instructions not messing with the stack pointer }
while assigned(hp1) and {MatchInstruction(taicpu(hp1),[A_LEA,A_MOV,A_MOVQ,A_MOVSQ,A_MOVSX,A_MOVSXD,A_MOVZX,
while assigned(hp1) and {MatchInstruction(hp1,[A_LEA,A_MOV,A_MOVQ,A_MOVSQ,A_MOVSX,A_MOVSXD,A_MOVZX,
A_AND,A_OR,A_XOR,A_ADD,A_SHR,A_SHL,A_IMUL,A_SETcc,A_SAR,A_SUB,A_TEST,A_CMOVcc,
A_MOVSS,A_MOVSD,A_MOVAPS,A_MOVUPD,A_MOVAPD,A_MOVUPS,
A_VMOVSS,A_VMOVSD,A_VMOVAPS,A_VMOVUPD,A_VMOVAPD,A_VMOVUPS],[]) and}

27
compiler/x86/nx86con.pas
View File

@ -41,6 +41,7 @@ implementation
symdef,
defutil,
cpubase,
aasmdata,
cga,cgx86,cgobj,cgbase,cgutils;
{*****************************************************************************
@ -68,14 +69,26 @@ implementation
location.register:=NR_ST;
tcgx86(cg).inc_fpu_stack;
end
else if (value_real=0.0) and not(use_vectorfpu(resultdef)) then
else if value_real=0.0 then
begin
emit_none(A_FLDZ,S_NO);
if (get_real_sign(value_real) < 0) then
emit_none(A_FCHS,S_NO);
location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
location.register:=NR_ST;
tcgx86(cg).inc_fpu_stack;
if use_vectorfpu(resultdef) then
begin
location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef));
location.register:=cg.getmmregister(current_asmdata.CurrAsmList,def_cgsize(resultdef));
if UseAVX then
emit_reg_reg_reg(A_VPXOR,S_NO,location.register,location.register,location.register)
else
emit_reg_reg(A_PXOR,S_NO,location.register,location.register);
end
else
begin
emit_none(A_FLDZ,S_NO);
if (get_real_sign(value_real) < 0) then
emit_none(A_FCHS,S_NO);
location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
location.register:=NR_ST;
tcgx86(cg).inc_fpu_stack;
end;
end
else
inherited pass_generate_code;

18
compiler/x86_64/nx64flw.pas
View File

@ -321,6 +321,12 @@ procedure tx64tryfinallynode.pass_generate_code;
cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
end;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then
Include(oldflowcontrol, fc_exit);
flowcontrol:=[fc_inflowcontrol];
{ generate finally code as a separate procedure }
if not implicitframe then
@ -431,6 +437,12 @@ procedure tx64tryexceptnode.pass_generate_code;
current_procinfo.CurrBreakLabel:=breakexceptlabel;
end;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then
Include(oldflowcontrol, fc_exit);
flowcontrol:=[fc_inflowcontrol];
{ on statements }
if assigned(right) then
@ -521,6 +533,12 @@ errorexit:
{ restore all saved labels }
endexceptlabel:=oldendexceptlabel;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then
Include(oldflowcontrol, fc_exit);
{ restore the control flow labels }
current_procinfo.CurrExitLabel:=oldCurrExitLabel;
if assigned(oldBreakLabel) then

18
packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
View File

@ -44,7 +44,6 @@ type
TArrayStringArray = Array of TStringArray;
PArrayStringArray = ^TArrayStringArray;
// VFS not supported at this time.
// Do not change the order. See NativeFlags constant in GetSQLiteOpenFlags.
TSQLiteOpenFlag = (
@ -69,8 +68,10 @@ Type
private
fhandle: psqlite3;
FOpenFlags: TSQLiteOpenFlags;
FVFS: String;
function GetSQLiteOpenFlags: Integer;
procedure SetOpenFlags(AValue: TSQLiteOpenFlags);
procedure SetVFS(const AValue: String);
protected
procedure DoInternalConnect; override;
procedure DoInternalDisconnect; override;
@ -125,6 +126,7 @@ Type
procedure LoadExtension(const LibraryFile: string);
Published
Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags;
Property VFS : String Read FVFS Write SetVFS;
Property AlwaysUseBigint : Boolean Read GetAlwaysUseBigint Write SetAlwaysUseBigint;
end;
@ -857,16 +859,28 @@ begin
FOpenFlags:=AValue;
end;
procedure TSQLite3Connection.SetVFS(const AValue: String);
begin
if FVFS=AValue then Exit;
CheckDisConnected;
FVFS:=AValue;
end;
procedure TSQLite3Connection.DoInternalConnect;
var
filename: ansistring;
pvfs: PChar;
begin
Inherited;
if DatabaseName = '' then
DatabaseError(SErrNoDatabaseName,self);
InitializeSQLite;
filename := DatabaseName;
checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,Nil));
if FVFS <> '' then
pvfs := PAnsiChar(FVFS)
else
pvfs := Nil;
checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,pvfs));
if (Length(Password)>0) and assigned(sqlite3_key) then
checkerror(sqlite3_key(fhandle,PChar(Password),StrLen(PChar(Password))));
if Params.IndexOfName('foreign_keys') <> -1 then

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

@ -9577,59 +9577,42 @@ type
var ValueSet: TResEvalSet): boolean;
var
CaseExprType: TPasType;
bt: TResolverBaseType;
ElTypeResolved: TPasResolverResult;
begin
Result:=false;
if ResolvedEl.BaseType in btAllInteger then
bt:=ResolvedEl.BaseType;
if bt in btAllStrings then
exit(true)
else if bt=btRange then
bt:=ResolvedEl.SubType;
if bt in btAllInteger then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskInt);
Result:=true;
end
else if ResolvedEl.BaseType in btAllBooleans then
else if bt in btAllBooleans then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskBool);
Result:=true;
end
else if ResolvedEl.BaseType in btAllChars then
else if bt in btAllChars then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskChar);
Result:=true;
end
else if ResolvedEl.BaseType in btAllStrings then
Result:=true
else if ResolvedEl.BaseType=btContext then
else if bt=btContext then
begin
CaseExprType:=ResolvedEl.LoTypeEl;
if CaseExprType.ClassType=TPasEnumType then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType);
Result:=true;
end;
end
else if ResolvedEl.BaseType=btRange then
begin
if ResolvedEl.SubType in btAllInteger then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskInt);
Result:=true;
end
else if ResolvedEl.SubType in btAllBooleans then
else if CaseExprType.ClassType=TPasRangeType then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskBool);
Result:=true;
end
else if ResolvedEl.SubType in btAllChars then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskChar);
Result:=true;
end
else if ResolvedEl.SubType=btContext then
begin
CaseExprType:=ResolvedEl.LoTypeEl;
if CaseExprType.ClassType=TPasEnumType then
begin
ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType);
Result:=true;
end;
ComputeElement(TPasRangeType(CaseExprType).RangeExpr.left,ElTypeResolved,[rcConstant]);
Result:=CreateValues(ElTypeResolved,ValueSet);
end;
end;
end;
@ -18853,6 +18836,7 @@ var
Param: TPasExpr;
ParamResolved, IncrResolved: TPasResolverResult;
TypeEl: TPasType;
bt: TResolverBaseType;
begin
if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
exit(cIncompatible);
@ -18872,18 +18856,23 @@ begin
RaiseVarExpected(20170216152319,Expr,ParamResolved.IdentEl);
exit;
end;
if ParamResolved.BaseType in btAllInteger then
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt in btAllInteger then
Result:=cExact
else if ParamResolved.BaseType=btPointer then
else if bt=btPointer then
begin
if ElHasBoolSwitch(Expr,bsPointerMath) then
Result:=cExact;
end
else if ParamResolved.BaseType=btContext then
else if bt=btContext then
begin
TypeEl:=ParamResolved.LoTypeEl;
if (TypeEl.ClassType=TPasPointerType)
and ElHasBoolSwitch(Expr,bsPointerMath) then
Result:=cExact
else if TypeEl.ClassType=TPasRangeType then
Result:=cExact;
end;
if Result=cIncompatible then
@ -19493,18 +19482,22 @@ function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
end;
var
TypeEl: TPasType;
bt: TResolverBaseType;
C: TClass;
begin
Result:=cIncompatible;
if ParamResolved.BaseType in (btAllInteger+btAllBooleans+btAllFloats) then
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt in (btAllInteger+btAllBooleans+btAllFloats) then
Result:=cExact
else if IsFunc and (ParamResolved.BaseType in btAllStringAndChars) then
else if IsFunc and (bt in btAllStringAndChars) then
Result:=cExact
else if ParamResolved.BaseType=btContext then
else if bt=btContext then
begin
TypeEl:=ParamResolved.LoTypeEl;
if TypeEl.ClassType=TPasEnumType then
Result:=cExact
C:=ParamResolved.LoTypeEl.ClassType;
if (C=TPasEnumType) or (C=TPasRangeType) then
Result:=cExact
end;
if Result=cIncompatible then
exit(CheckRaiseTypeArgNo(20170319220517,ArgNo,Param,ParamResolved,'boolean, integer, enum value',RaiseOnError));
@ -19673,6 +19666,8 @@ var
Params: TParamsExpr;
Param: TPasExpr;
ParamResolved: TPasResolverResult;
bt: TResolverBaseType;
C: TClass;
begin
if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then
exit(cIncompatible);
@ -19693,11 +19688,15 @@ begin
Result:=cIncompatible;
if ResolvedElCanBeVarParam(ParamResolved,Expr) then
begin
if ParamResolved.BaseType in (btAllInteger+btAllBooleans+btAllFloats) then
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt in (btAllInteger+btAllBooleans+btAllFloats) then
Result:=cExact
else if ParamResolved.BaseType=btContext then
else if bt=btContext then
begin
if ParamResolved.LoTypeEl is TPasEnumType then
C:=ParamResolved.LoTypeEl.ClassType;
if (C=TPasEnumType) or (C=TPasRangeType) then
Result:=cExact;
end;
end;
@ -29730,8 +29729,8 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer;
DestParams:=DestSpecializedFromItem.Params;
for i:=0 to length(SrcParams)-1 do
begin
SrcParam:=SrcParams[i];
DestParam:=DestParams[i];
SrcParam:=ResolveAliasType(SrcParams[i]);
DestParam:=ResolveAliasType(DestParams[i]);
if (SrcParam is TPasGenericTemplateType)
or (DestParam is TPasGenericTemplateType)
or (SrcParam=DestParam)

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

@ -5847,7 +5847,11 @@ begin
begin
If (Result<>'') then
Result:=Result+', ';
Result:=Result+Params[I].GetDeclaration(Full);
Result:=Result+Params[I].GetDeclaration(Full);
if Assigned(Params[I].format1) then
Result:=Result+':'+Params[I].format1.GetDeclaration(false);
if Assigned(Params[I].format2) then
Result:=Result+':'+Params[I].format2.GetDeclaration(false);
end;
if Kind in [pekSet,pekArrayParams] then
Result := '[' + Result + ']'

120
packages/fcl-passrc/src/paswrite.pp
View File

@ -122,6 +122,9 @@ type
procedure WriteImplCommand(ACommand: TPasImplCommand);virtual;
procedure WriteImplCommands(ACommands: TPasImplCommands); virtual;
procedure WriteImplIfElse(AIfElse: TPasImplIfElse); virtual;
procedure WriteImplCaseOf(ACaseOf: TPasImplCaseOf); virtual;
procedure WriteImplCaseStatement(ACaseStatement: TPasImplCaseStatement;
AAutoInsertBeginEnd: boolean=true); virtual;
procedure WriteImplForLoop(AForLoop: TPasImplForLoop); virtual;
procedure WriteImplWhileDo(aWhileDo : TPasImplWhileDo); virtual;
procedure WriteImplRepeatUntil(aRepeatUntil : TPasImplRepeatUntil); virtual;
@ -1196,6 +1199,8 @@ begin
end
else if AElement.ClassType = TPasImplIfElse then
WriteImplIfElse(TPasImplIfElse(AElement))
else if AElement.InheritsFrom(TPasImplCaseOf) then
WriteImplCaseOf(TPasImplCaseOf(aElement))
else if AElement.ClassType = TPasImplForLoop then
WriteImplForLoop(TPasImplForLoop(AElement))
else if AElement.InheritsFrom(TPasImplWhileDo) then
@ -1295,6 +1300,72 @@ begin
end;
end;
procedure TPasWriter.WriteImplCaseStatement(ACaseStatement: TPasImplCaseStatement;AAutoInsertBeginEnd:boolean=true);
var
i: Integer;
begin
for i := 0 to ACaseStatement.Expressions.Count - 1 do
begin
if i>0 then add(', ');
add(GetExpr(TPasExpr(ACaseStatement.Expressions[i])))
end;
add(': ');
IncIndent;
//JC: If no body is assigned, omit the whole block
if assigned(ACaseStatement.Body) then
begin
if AAutoInsertBeginEnd then
begin
addLn('begin');
IncIndent;
end;
//JC: if the body already is a begin-end-Block, the begin of that block is omitted
if ACaseStatement.Body is TPasImplBeginBlock then
WriteImplBlock(TPasImplBeginBlock(ACaseStatement.Body))
else
WriteImplElement(ACaseStatement.Body,false);
if AAutoInsertBeginEnd then
begin
DecIndent;
Add('end'); //JC: No semicolon or Linefeed here !
// Otherwise there would be a problem with th else-statement.
end;
end;
DecIndent;
end;
procedure TPasWriter.WriteImplCaseOf(ACaseOf: TPasImplCaseOf);
var
i: Integer;
begin
Add('case %s of', [GetExpr(ACaseOf.CaseExpr)]);
IncIndent;
for i := 0 to ACaseOf.Elements.Count - 1 do
begin
if TPasElement(ACaseOf.Elements[i]) is TPasImplCaseStatement then
begin
if i >0 then
AddLn(';')
else
AddLn;
WriteImplCaseStatement(TPasImplCaseStatement(ACaseOf.Elements[i]),True);
end;
end;
if assigned(ACaseOf.ElseBranch) then
begin
AddLn;
AddLn('else');
IncIndent;
WriteImplBlock(ACaseOf.ElseBranch);
DecIndent;
end
else
AddLn(';');
DecIndent;
AddLn('end;');
end;
procedure TPasWriter.WriteImplRepeatUntil(aRepeatUntil: TPasImplRepeatUntil);
@ -1337,9 +1408,14 @@ end;
procedure TPasWriter.WriteImplRaise(aRaise: TPasImplRaise);
begin
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
if assigned(aRaise.ExceptObject) then
begin
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
end
else
Add('raise');
Addln(';');
end;
@ -1391,15 +1467,21 @@ begin
With aForLoop do
begin
If LoopType=ltIn then
AddLn('for %s in %s do',[GetExpr(VariableName),GetExpr(StartExpr)])
Add('for %s in %s do',[GetExpr(VariableName),GetExpr(StartExpr)])
else
AddLn('for %s:=%s %s %s do',[GetExpr(VariableName),GetExpr(StartExpr),
Add('for %s:=%s %s %s do',[GetExpr(VariableName),GetExpr(StartExpr),
ToNames[Down],GetExpr(EndExpr)]);
IncIndent;
WriteImplElement(Body, True);
DecIndent;
if (Body is TPasImplBlock) and
(Body is TPasImplCommands) then
if assigned(Body) then
begin
AddLn;
IncIndent;
WriteImplElement(Body, True);
DecIndent;
if (Body is TPasImplBlock) and
(Body is TPasImplCommands) then
AddLn(';');
end
else
AddLn(';');
end;
end;
@ -1410,12 +1492,18 @@ procedure TPasWriter.WriteImplWhileDo(aWhileDo: TPasImplWhileDo);
begin
With aWhileDo do
begin
AddLn('While %s do',[GetExpr(ConditionExpr)]);
IncIndent;
WriteImplElement(Body, True);
DecIndent;
if (Body.InheritsFrom(TPasImplBlock)) and
(Body.InheritsFrom(TPasImplCommands)) then
Add('While %s do',[GetExpr(ConditionExpr)]);
if assigned(Body) then
begin
AddLn;
IncIndent;
WriteImplElement(Body, True);
DecIndent;
if (Body.InheritsFrom(TPasImplBlock)) and
(Body.InheritsFrom(TPasImplCommands)) then
AddLn(';');
end
else
AddLn(';');
end;
end;

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

@ -451,7 +451,8 @@ type
procedure ParseArgList(Parent: TPasElement;
Args: TFPList; // list of TPasArgument
EndToken: TToken);
procedure ParseProcedureOrFunction(Parent: TPasElement; Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
procedure ParseProcedureOrFunction(Parent: TPasElement;
Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
procedure ParseProcedureBody(Parent: TPasElement);
function ParseMethodResolution(Parent: TPasElement): TPasMethodResolution;
// Properties for external access
@ -4998,7 +4999,7 @@ begin
ptAnonymousProcedure,ptAnonymousFunction:
case CurToken of
tkIdentifier, // e.g. procedure assembler
tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction:
tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction,tkasm:
UngetToken;
tkColon:
if ProcType=ptAnonymousFunction then
@ -5300,7 +5301,7 @@ begin
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end;
else
resultEl:=Nil;
ResultEl:=Nil;
end;
if OfObjectPossible then
begin
@ -5312,7 +5313,7 @@ begin
end
else if (CurToken = tkIs) then
begin
expectToken(tkIdentifier);
ExpectToken(tkIdentifier);
if (lowerCase(CurTokenString)<>'nested') then
ParseExc(nParserExpectedNested,SParserExpectedNested);
Element.IsNested:=True;

2
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -661,9 +661,11 @@ begin
FFileName:=MainFilename;
FResolver.AddStream(FFileName,TStringStream.Create(FSource.Text));
FScanner.OpenFile(FFileName);
{$ifndef NOCONSOLE} // JC: To get the tests to run with GUI
Writeln('// Test : ',Self.TestName);
for i:=0 to FSource.Count-1 do
Writeln(Format('%:4d: ',[i+1]),FSource[i]);
{$EndIf}
end;
procedure TTestParser.ParseDeclarations;

3325
packages/fcl-passrc/tests/tcpaswritestatements.pas Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -4281,6 +4281,15 @@ begin
' i:=longint(er);',
' if b in sr then ;',
' if er in sr then ;',
' er:=low(TEnumRg);',
' er:=high(TEnumRg);',
' er:=succ(er);',
' er:=pred(er);',
' inc(er);',
' dec(er);',
' case er of',
' c: ;',
' end;',
'']);
ParseProgram;
CheckResolverUnexpectedHints;

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

@ -5524,15 +5524,21 @@ var
Params: TParamsExpr;
Param: TPasExpr;
ParamResolved: TPasResolverResult;
bt: TResolverBaseType;
C: TClass;
begin
Result:=inherited;
Params:=TParamsExpr(Expr);
Param:=Params.Params[1];
ComputeElement(Param,ParamResolved,[]);
Result:=cIncompatible;
if ParamResolved.BaseType=btContext then
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt=btContext then
begin
if ParamResolved.LoTypeEl is TPasEnumType then
C:=ParamResolved.LoTypeEl.ClassType;
if (C=TPasEnumType) or (C=TPasRangeType) then
Result:=cExact
end;
if Result=cIncompatible then
@ -11831,6 +11837,9 @@ var
AddExpr: TJSAdditiveExpressionPlus;
Int: TMaxPrecInt;
aResolver: TPas2JSResolver;
from_bt: TResolverBaseType;
FromTypeEl: TPasType;
ElTypeResolved: TPasResolverResult;
begin
Result:=nil;
Param:=El.Params[0];
@ -11839,8 +11848,16 @@ begin
JSBaseTypeData:=nil;
JSBaseType:=pbtNone;
from_bt:=ParamResolved.BaseType;
FromTypeEl:=ParamResolved.LoTypeEl;
if from_bt=btRange then
begin
from_bt:=ParamResolved.SubType;
aResolver.ComputeElement(TPasRangeType(FromTypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]);
FromTypeEl:=ElTypeResolved.LoTypeEl;
end;
to_bt:=ToBaseTypeData.BaseType;
if to_bt=ParamResolved.BaseType then
if from_bt=to_bt then
begin
Result:=ConvertExpression(Param,AContext);
exit;
@ -11848,14 +11865,14 @@ begin
if to_bt in btAllJSInteger then
begin
if ParamResolved.BaseType in btAllJSInteger then
if from_bt in btAllJSInteger then
begin
// integer to integer -> value
Result:=ConvertExpression(Param,AContext);
Result:=ConvertIntToInt(Result,ParamResolved.BaseType,to_bt,El,AContext);
Result:=ConvertIntToInt(Result,from_bt,to_bt,El,AContext);
exit;
end
else if ParamResolved.BaseType in btAllJSBooleans then
else if from_bt in btAllJSBooleans then
begin
// boolean to integer -> value?1:0
Result:=ConvertExpression(Param,AContext);
@ -11870,7 +11887,7 @@ begin
Result:=CondExpr;
exit;
end
else if ParamResolved.BaseType in btAllJSChars then
else if from_bt in btAllJSChars then
begin
// char to integer
Result:=ConvertExpression(Param,AContext);
@ -11878,9 +11895,9 @@ begin
Result:=ConvertIntToInt(Result,btWord,to_bt,El,AContext);
exit;
end
else if ParamResolved.BaseType=btContext then
else if from_bt=btContext then
begin
if ParamResolved.LoTypeEl.ClassType=TPasEnumType then
if FromTypeEl.ClassType=TPasEnumType then
begin
// e.g. longint(TEnum) -> value
Result:=ConvertExpression(Param,AContext);
@ -11904,7 +11921,7 @@ begin
exit;
end;
end
else if (to_bt=btCurrency) and (ParamResolved.BaseType in btAllJSFloats) then
else if (to_bt=btCurrency) and (from_bt in btAllJSFloats) then
begin
// currency(double) -> double*10000
Result:=ConvertExpression(Param,AContext);
@ -11914,13 +11931,13 @@ begin
end
else if to_bt in btAllJSBooleans then
begin
if ParamResolved.BaseType in btAllJSBooleans then
if from_bt in btAllJSBooleans then
begin
// boolean to boolean -> value
Result:=ConvertExpression(Param,AContext);
exit;
end
else if ParamResolved.BaseType in btAllJSInteger then
else if from_bt in btAllJSInteger then
begin
// integer to boolean -> value!=0
Result:=ConvertExpression(Param,AContext);
@ -11949,7 +11966,7 @@ begin
end
else if to_bt in btAllJSFloats then
begin
if ParamResolved.BaseType in (btAllJSFloats+btAllJSInteger) then
if from_bt in (btAllJSFloats+btAllJSInteger) then
begin
// int to double -> value
Result:=ConvertExpression(Param,AContext);
@ -11975,13 +11992,13 @@ begin
end
else if to_bt in btAllJSStrings then
begin
if ParamResolved.BaseType in btAllJSStringAndChars then
if from_bt in btAllJSStringAndChars then
begin
// string or char to string -> value
Result:=ConvertExpression(Param,AContext);
exit;
end
else if ParamResolved.BaseType=btPointer then
else if from_bt=btPointer then
begin
// string(aPointer) -> value
Result:=ConvertExpression(Param,AContext);
@ -12004,15 +12021,15 @@ begin
end
else if to_bt=btChar then
begin
if ParamResolved.BaseType=btChar then
if from_bt=btChar then
begin
// char to char
Result:=ConvertExpression(Param,AContext);
exit;
end
else if (ParamResolved.BaseType in btAllJSInteger)
or ((ParamResolved.BaseType=btContext)
and (aResolver.ResolveAliasType(ParamResolved.LoTypeEl).ClassType=TPasEnumType))
else if (from_bt in btAllJSInteger)
or ((from_bt=btContext)
and (FromTypeEl.ClassType=TPasEnumType))
then
begin
// Note: convert value first in case it raises an exception
@ -12030,7 +12047,7 @@ begin
end;
exit;
end
else if (ParamResolved.BaseType in (btArrayRangeTypes+[btRange]))
else if (from_bt in (btArrayRangeTypes+[btRange]))
or (IsParamPas2JSBaseType and (JSBaseType=pbtJSValue)) then
begin
// convert value to char -> rtl.getChar(value)
@ -12071,13 +12088,13 @@ begin
exit;
end;
end
else if ParamResolved.BaseType in btAllJSStrings then
else if from_bt in btAllJSStrings then
begin
// pointer(aString) -> value
Result:=ConvertExpression(Param,AContext);
exit;
end
else if ParamResolved.BaseType=btContext then
else if from_bt=btContext then
begin
// convert user type/value to pointer -> value
Result:=ConvertExpression(Param,AContext);
@ -12753,6 +12770,8 @@ var
Minus: TJSAdditiveExpressionMinus;
Add: TJSAdditiveExpressionPlus;
aResolver: TPas2JSResolver;
bt: TResolverBaseType;
C: TClass;
begin
Result:=nil;
aResolver:=AContext.Resolver;
@ -12760,7 +12779,10 @@ begin
RaiseInconsistency(20170210105235,El);
Param:=El.Params[0];
aResolver.ComputeElement(Param,ParamResolved,[]);
if ParamResolved.BaseType=btChar then
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt=btChar then
begin
if Param is TParamsExpr then
begin
@ -12805,7 +12827,7 @@ begin
Result:=CreateCallCharCodeAt(Result,0,El);
exit;
end
else if ParamResolved.BaseType in btAllJSBooleans then
else if bt in btAllJSBooleans then
begin
// ord(bool)
Result:=CheckOrdConstant(aResolver,Param);
@ -12819,9 +12841,10 @@ begin
Result:=Add;
exit;
end
else if ParamResolved.BaseType=btContext then
else if bt=btContext then
begin
if ParamResolved.LoTypeEl.ClassType=TPasEnumType then
C:=ParamResolved.LoTypeEl.ClassType;
if (C=TPasEnumType) or (C=TPasRangeType) then
begin
// ord(enum) -> enum
Result:=ConvertExpression(Param,AContext);
@ -12856,25 +12879,39 @@ function TPasToJSConverter.ConvertBuiltIn_LowHigh(El: TParamsExpr;
end;
var
ResolvedEl: TPasResolverResult;
Param: TPasExpr;
aResolver: TPas2JSResolver;
ResolvedEl: TPasResolverResult;
TypeEl: TPasType;
Ranges: TPasExprArray;
Value: TResEvalValue;
Call: TJSCallExpression;
MinusExpr: TJSAdditiveExpressionMinus;
MinVal, MaxVal: TMaxPrecInt;
bt: TResolverBaseType;
begin
Result:=nil;
if AContext.Resolver=nil then
RaiseInconsistency(20170210120659,El);
Param:=El.Params[0];
AContext.Resolver.ComputeElement(Param,ResolvedEl,[]);
case ResolvedEl.BaseType of
aResolver:=AContext.Resolver;
aResolver.ComputeElement(Param,ResolvedEl,[]);
bt:=ResolvedEl.BaseType;
if bt=btRange then
bt:=ResolvedEl.SubType;
case bt of
btContext:
begin
TypeEl:=ResolvedEl.LoTypeEl;
if TypeEl.ClassType=TPasEnumType then
if TypeEl.ClassType=TPasRangeType then
begin
if IsLow then
Result:=ConvertElement(TPasRangeType(TypeEl).RangeExpr.left,AContext)
else
Result:=ConvertElement(TPasRangeType(TypeEl).RangeExpr.right,AContext);
exit;
end
else if TypeEl.ClassType=TPasEnumType then
begin
CreateEnumValue(TPasEnumType(TypeEl));
exit;
@ -13261,25 +13298,32 @@ var
end;
var
ResolvedEl: TPasResolverResult;
aResolver: TPas2JSResolver;
ResolvedEl, ElTypeResolved: TPasResolverResult;
NeedStrLit: Boolean;
Call: TJSCallExpression;
Bracket: TJSBracketMemberExpression;
Arg: TJSElement;
bt: TResolverBaseType;
TypeEl: TPasType;
begin
Result:=nil;
AContext.Resolver.ComputeElement(El,ResolvedEl,[]);
aResolver:=AContext.Resolver;
aResolver.ComputeElement(El,ResolvedEl,[]);
Add:=nil;
Call:=nil;
Bracket:=nil;
try
NeedStrLit:=false;
if ResolvedEl.BaseType in (btAllJSBooleans+btAllJSInteger-[btCurrency]) then
bt:=ResolvedEl.BaseType;
if bt=btRange then
bt:=ResolvedEl.SubType;
if bt in (btAllJSBooleans+btAllJSInteger-[btCurrency]) then
begin
NeedStrLit:=true;
Add:=ConvertExpression(El,AContext);
end
else if ResolvedEl.BaseType in (btAllJSFloats+[btCurrency]) then
else if bt in (btAllJSFloats+[btCurrency]) then
begin
// convert to rtl.floatToStr(El,width,precision)
Call:=CreateCallExpression(El);
@ -13296,15 +13340,21 @@ begin
Call:=nil;
exit;
end
else if IsStrFunc and (ResolvedEl.BaseType in btAllJSStringAndChars) then
else if IsStrFunc and (bt in btAllJSStringAndChars) then
Add:=ConvertExpression(El,AContext)
else if ResolvedEl.BaseType=btContext then
else if bt=btContext then
begin
if ResolvedEl.LoTypeEl.ClassType=TPasEnumType then
TypeEl:=ResolvedEl.LoTypeEl;
if TypeEl.ClassType=TPasRangeType then
begin
aResolver.ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]);
TypeEl:=ElTypeResolved.LoTypeEl;
end;
if TypeEl.ClassType=TPasEnumType then
begin
// create enumtype[enumvalue]
Bracket:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El));
Bracket.MExpr:=CreateReferencePathExpr(TPasEnumType(ResolvedEl.LoTypeEl),AContext);
Bracket.MExpr:=CreateReferencePathExpr(TPasEnumType(TypeEl),AContext);
Bracket.Name:=ConvertExpression(El,AContext);
Add:=Bracket;
Bracket:=nil;
@ -13389,28 +13439,32 @@ function TPasToJSConverter.ConvertBuiltIn_Val(El: TParamsExpr;
AContext: TConvertContext): TJSElement;
// val(const s: string; out value: valuetype; out Code: integertype)
// for enum it is converted to
// value = rtl.valEnum(s,enumTupe,function(c){ Code=c; })
// value = rtl.valEnum(s,enumType,function(c){ Code=c; })
var
aResolver: TPas2JSResolver;
AssignContext: TAssignContext;
ValueExpr, CodeExpr: TPasExpr;
Call: TJSCallExpression;
Params: TPasExprArray;
EnumType: TPasEnumType;
Fun: TJSFunctionDeclarationStatement;
ExprResolved: TPasResolverResult;
ExprResolved, ElTypeResolved: TPasResolverResult;
ExprArg: TPasArgument;
AssignSt: TJSSimpleAssignStatement;
SetterArgName: String;
ArgJS, SetExpr: TJSElement;
bt: TResolverBaseType;
LoTypeEl: TPasType;
begin
Result:=nil;
aResolver:=AContext.Resolver;
Params:=El.Params;
Call:=nil;
AssignContext:=TAssignContext.Create(El,nil,AContext);
try
//
ValueExpr:=Params[1];
AContext.Resolver.ComputeElement(ValueExpr,AssignContext.LeftResolved,[rcNoImplicitProc]);
aResolver.ComputeElement(ValueExpr,AssignContext.LeftResolved,[rcNoImplicitProc]);
// rtl.valEnum()
Call:=CreateCallExpression(El);
@ -13419,11 +13473,20 @@ begin
// add arg string
Call.AddArg(ConvertExpression(Params[0],AContext));
// add arg enumtype
if AssignContext.LeftResolved.BaseType=btContext then
bt:=AssignContext.LeftResolved.BaseType;
if bt=btRange then
bt:=AssignContext.LeftResolved.SubType;
if bt=btContext then
begin
if AssignContext.LeftResolved.LoTypeEl is TPasEnumType then
LoTypeEl:=AssignContext.LeftResolved.LoTypeEl;
if LoTypeEl.ClassType=TPasRangeType then
begin
EnumType:=TPasEnumType(AssignContext.LeftResolved.LoTypeEl);
aResolver.ComputeElement(TPasRangeType(LoTypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]);
LoTypeEl:=ElTypeResolved.LoTypeEl;
end;
if LoTypeEl.ClassType=TPasEnumType then
begin
EnumType:=TPasEnumType(LoTypeEl);
Call.AddArg(CreateReferencePathExpr(EnumType,AContext));
end else
RaiseNotSupported(Params[1],AContext,20181214145226,GetResolverResultDbg(AssignContext.LeftResolved));
@ -23321,6 +23384,8 @@ var
Call: TJSCallExpression;
DotExpr: TJSDotMemberExpression;
aResolver: TPas2JSResolver;
bt: TResolverBaseType;
C: TClass;
begin
Result:=ConvertExpression(Expr,AContext);
if Result=nil then
@ -23374,19 +23439,22 @@ begin
if aResolver<>nil then
begin
aResolver.ComputeElement(Expr,ExprResolved,[]);
if (ExprResolved.BaseType in btAllJSStringAndChars)
or ((ExprResolved.BaseType=btRange) and (ExprResolved.SubType in btAllJSChars)) then
bt:=ExprResolved.BaseType;
if bt=btRange then
bt:=ExprResolved.SubType;
if bt in btAllJSStringAndChars then
begin
// aChar -> aChar.charCodeAt()
Result:=CreateCallCharCodeAt(Result,0,Expr);
end
else if ExprResolved.BaseType in btAllJSInteger then
else if bt in btAllJSInteger then
begin
// ok
end
else if ExprResolved.BaseType=btContext then
else if bt=btContext then
begin
if ExprResolved.LoTypeEl.ClassType=TPasEnumType then
C:=ExprResolved.LoTypeEl.ClassType;
if (C=TPasEnumType) or (C=TPasRangeType) then
// ok
else
RaiseNotSupported(Expr,AContext,20170415191933);

19
packages/pastojs/src/pas2jslibcompiler.pp
View File

@ -67,6 +67,8 @@ Type
FOnWriteJSCallBack: TWriteJSCallBack;
FOnWriteJSData: Pointer;
FReadBufferLen: Cardinal;
function GetLogEncoding: String;
procedure SetLogEncoding(AValue: String);
Protected
Function DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean; override;
Procedure GetLastError(AError : PAnsiChar; Var AErrorLength : Longint;
@ -80,6 +82,7 @@ Type
Function LibraryRun(ACompilerExe, AWorkingDir : PAnsiChar; CommandLine : PPAnsiChar; DoReset : Boolean) :Boolean; {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
Property LastError : String Read FLastError Write FLastError;
Property LastErrorClass : String Read FLastErrorClass Write FLastErrorClass;
property LogEncoding: String read GetLogEncoding write SetLogEncoding;
Property OnLibLogCallBack : TLibLogCallBack Read FOnLibLogCallBack Write FOnLibLogCallBack;
Property OnLibLogData : Pointer Read FOnLibLogData Write FOnLibLogData;
Property OnWriteJSCallBack : TWriteJSCallBack Read FOnWriteJSCallBack Write FOnWriteJSCallBack;
@ -107,6 +110,7 @@ Function RunPas2JSCompiler(P : PPas2JSCompiler; ACompilerExe, AWorkingDir : PAns
Procedure FreePas2JSCompiler(P : PPas2JSCompiler); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
Function GetPas2JSCompiler : PPas2JSCompiler; {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
Procedure GetPas2JSCompilerLastError(P : PPas2JSCompiler; AError : PAnsiChar; Var AErrorLength : Longint; AErrorClass : PAnsiChar; Var AErrorClassLength : Longint); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
procedure SetPas2JSLogEncoding(P : PPas2JSCompiler; Enconding: PAnsiChar); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
implementation
@ -120,6 +124,16 @@ begin
Result:=OnReadDir(FOnReadDirData,Dir,PAnsiChar(Dir.Path));
end;
function TLibraryPas2JSCompiler.GetLogEncoding: String;
begin
Result := Log.Encoding;
end;
procedure TLibraryPas2JSCompiler.SetLogEncoding(AValue: String);
begin
Log.Encoding := AValue;
end;
function TLibraryPas2JSCompiler.DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean;
Var
@ -344,5 +358,10 @@ begin
TLibraryPas2JSCompiler(P).GetLastError(AError,AErrorLength,AErrorClass,AErrorClassLength);
end;
procedure SetPas2JSLogEncoding(P : PPas2JSCompiler; Enconding: PAnsiChar); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
begin
TLibraryPas2JSCompiler(P).LogEncoding := Enconding;
end;
end.

2
packages/pastojs/tests/tcfiler.pas
View File

@ -2730,7 +2730,7 @@ begin
'implementation',
'generic function Run<T>(a: T): T;',
'var b: T;',
' var i: word;',
' i: word;',
'begin',
' b:=a;',
' Result:=b;',

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

@ -358,12 +358,14 @@ type
Procedure TestAnonymousProc_NestedAssignResult;
Procedure TestAnonymousProc_Class;
Procedure TestAnonymousProc_ForLoop;
Procedure TestAnonymousProc_AsmDelphi;
// enums, sets
Procedure TestEnum_Name;
Procedure TestEnum_Number;
Procedure TestEnum_ConstFail;
Procedure TestEnum_Functions;
Procedure TestEnumRg_Functions;
Procedure TestEnum_AsParams;
Procedure TestEnumRange_Array;
Procedure TestEnum_ForIn;
@ -5256,6 +5258,51 @@ begin
]));
end;
procedure TTestModule.TestAnonymousProc_AsmDelphi;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TProc = reference to procedure;',
' TFunc = reference to function(x: word): word;',
'procedure Run;',
'asm',
'end;',
'procedure Walk(p: TProc; f: TFunc);',
'begin',
' Walk(procedure asm end, function(b:word): word asm return 1+b; end);',
'end;',
'begin',
' Walk(procedure',
' asm',
' console.log("a");',
' end,',
' function(x: word): word asm',
' console.log("c");',
' end);',
'']);
ConvertProgram;
CheckSource('TestAnonymousProc_AsmDelphi',
LinesToStr([ // statements
'this.Run = function () {',
'};',
'this.Walk = function (p, f) {',
' $mod.Walk(function () {',
' }, function (b) {',
' return 1+b;',
' });',
'};',
'']),
LinesToStr([
'$mod.Walk(function () {',
' console.log("a");',
'}, function (x) {',
' console.log("c");',
'});',
'']));
end;
procedure TTestModule.TestEnum_Name;
begin
StartProgram(false);
@ -5373,7 +5420,6 @@ begin
' s:=str(e:3);',
' writestr(s,e:3,red);',
' val(s,e,i);',
' e:=TMyEnum(i);',
' i:=longint(e);']);
ConvertProgram;
CheckSource('TestEnum_Functions',
@ -5424,7 +5470,93 @@ begin
'$mod.e = rtl.valEnum($mod.s, $mod.TMyEnum, function (v) {',
' $mod.i = v;',
'});',
'$mod.i=$mod.e;',
'']));
end;
procedure TTestModule.TestEnumRg_Functions;
begin
StartProgram(false);
Add([
'type',
' TEnum = (Red, Green, Blue);',
' TEnumRg = Green..Blue;',
'procedure DoIt(var e: TEnumRg; var i: word);',
'var',
' v: longint;',
' s: string;',
'begin',
' val(s,e,v);',
' val(s,e,i);',
'end;',
'var',
' e: TEnumRg;',
' i: longint;',
' s: string;',
'begin',
' i:=ord(green);',
' i:=ord(e);',
' e:=low(tenumrg);',
' e:=low(e);',
' e:=high(tenumrg);',
' e:=high(e);',
' e:=pred(blue);',
' e:=pred(e);',
' e:=succ(green);',
' e:=succ(e);',
' e:=tenumrg(1);',
' e:=tenumrg(i);',
' s:=str(e);',
' str(e,s);',
' str(red,s);',
' s:=str(e:3);',
' writestr(s,e:3,blue);',
' val(s,e,i);',
' i:=longint(e);']);
ConvertProgram;
CheckSource('TestEnumRg_Functions',
LinesToStr([ // statements
'this.TEnum = {',
' "0":"Red",',
' Red:0,',
' "1":"Green",',
' Green:1,',
' "2":"Blue",',
' Blue:2',
' };',
'this.DoIt = function (e, i) {',
' var v = 0;',
' var s = "";',
' e.set(rtl.valEnum(s, $mod.TEnum, function (w) {',
' v = w;',
' }));',
' e.set(rtl.valEnum(s, $mod.TEnum, i.set));',
'};',
'this.e = this.TEnum.Green;',
'this.i = 0;',
'this.s = "";',
'']),
LinesToStr([
'$mod.i=$mod.TEnum.Green;',
'$mod.i=$mod.e;',
'$mod.e=$mod.TEnum.Green;',
'$mod.e=$mod.TEnum.Green;',
'$mod.e=$mod.TEnum.Blue;',
'$mod.e=$mod.TEnum.Blue;',
'$mod.e=$mod.TEnum.Blue-1;',
'$mod.e=$mod.e-1;',
'$mod.e=$mod.TEnum.Green+1;',
'$mod.e=$mod.e+1;',
'$mod.e=1;',
'$mod.e=$mod.i;',
'$mod.s = $mod.TEnum[$mod.e];',
'$mod.s = $mod.TEnum[$mod.e];',
'$mod.s = $mod.TEnum[$mod.TEnum.Red];',
'$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3);',
'$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3)+$mod.TEnum[$mod.TEnum.Blue];',
'$mod.e = rtl.valEnum($mod.s, $mod.TEnum, function (v) {',
' $mod.i = v;',
'});',
'$mod.i=$mod.e;',
'']));
end;
@ -5824,23 +5956,28 @@ end;
procedure TTestModule.TestSet_Operator_In;
begin
StartProgram(false);
Add('type');
Add(' TColor = (Red, Green, Blue);');
Add(' TColors = set of tcolor;');
Add('var');
Add(' vC: tcolor;');
Add(' vT: tcolors;');
Add(' B: boolean;');
Add('begin');
Add(' b:=red in vt;');
Add(' b:=vc in vt;');
Add(' b:=green in [red..blue];');
Add(' b:=vc in [red..blue];');
Add(' ');
Add(' if red in vt then ;');
Add(' while vC in vt do ;');
Add(' repeat');
Add(' until vC in vt;');
Add([
'type',
' TColor = (Red, Green, Blue);',
' TColors = set of tcolor;',
' TColorRg = green..blue;',
'var',
' vC: tcolor;',
' vT: tcolors;',
' B: boolean;',
' rg: TColorRg;',
'begin',
' b:=red in vt;',
' b:=vc in vt;',
' b:=green in [red..blue];',
' b:=vc in [red..blue];',
' ',
' if red in vt then ;',
' while vC in vt do ;',
' repeat',
' until vC in vt;',
' if rg in [green..blue] then ;',
'']);
ConvertProgram;
CheckSource('TestSet_Operator_In',
LinesToStr([ // statements
@ -5854,8 +5991,9 @@ begin
' };',
'this.vC = 0;',
'this.vT = {};',
'this.B = false;'
]),
'this.B = false;',
'this.rg = this.TColor.Green;',
'']),
LinesToStr([
'$mod.B = $mod.TColor.Red in $mod.vT;',
'$mod.B = $mod.vC in $mod.vT;',
@ -5866,6 +6004,7 @@ begin
'};',
'do {',
'} while (!($mod.vC in $mod.vT));',
'if ($mod.rg in rtl.createSet(null, $mod.TColor.Green, $mod.TColor.Blue)) ;',
'']));
end;

59
rtl/inc/except.inc
View File

@ -101,40 +101,43 @@ begin
writeln ('In PushExceptObject');
{$endif}
_ExceptObjectStack:=@ExceptObjectStack;
New(NewObj);
NewObj:=AllocMem(sizeof(TExceptObject));
NewObj^.Next:=_ExceptObjectStack^;
_ExceptObjectStack^:=NewObj;
NewObj^.FObject:=Obj;
NewObj^.Addr:=AnAddr;
NewObj^.refcount:=0;
if assigned(get_frame) then
begin
NewObj^.refcount:=0;
{ Backtrace }
curr_frame:=AFrame;
curr_addr:=AnAddr;
frames:=nil;
framecount:=0;
framebufsize:=0;
{ The frame pointer of this procedure is used as initial stack bottom value. }
prev_frame:=get_frame;
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
(curr_frame<StackTop) do
Begin
prev_frame:=curr_frame;
get_caller_stackinfo(curr_frame,curr_addr);
if (curr_addr=nil) or
(curr_frame=nil) then
break;
if (framecount>=framebufsize) then
begin
inc(framebufsize,16);
reallocmem(frames,framebufsize*sizeof(codepointer));
end;
frames[framecount]:=curr_addr;
inc(framecount);
End;
NewObj^.framecount:=framecount;
NewObj^.frames:=frames;
{ Backtrace }
curr_frame:=AFrame;
curr_addr:=AnAddr;
frames:=nil;
framecount:=0;
framebufsize:=0;
{ The frame pointer of this procedure is used as initial stack bottom value. }
prev_frame:=get_frame;
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
(curr_frame<StackTop) do
Begin
prev_frame:=curr_frame;
get_caller_stackinfo(curr_frame,curr_addr);
if (curr_addr=nil) or
(curr_frame=nil) then
break;
if (framecount>=framebufsize) then
begin
inc(framebufsize,16);
reallocmem(frames,framebufsize*sizeof(codepointer));
end;
frames[framecount]:=curr_addr;
inc(framecount);
End;
NewObj^.framecount:=framecount;
NewObj^.frames:=frames;
end;
Result:=NewObj;
end;

20
rtl/inc/system.inc
View File

@ -1399,7 +1399,7 @@ end;
Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
var
i : Longint;
i : ObjpasInt;
prevfp : Pointer;
is_dev : boolean;
Begin
@ -1435,7 +1435,7 @@ End;
procedure dump_stack(var f: text; skipframes: longint);
var
i,count: longint;
i,count: ObjpasInt;
frames: array [0..255] of codepointer;
begin
if do_isdevice(textrec(f).handle) then
@ -1459,7 +1459,7 @@ end;
procedure DumpExceptionBackTrace(var f:text);
var
FrameNumber,
FrameCount : longint;
FrameCount : ObjpasInt;
Frames : PCodePointer;
begin
if RaiseList=nil then
@ -1525,7 +1525,7 @@ end;
// if "s" goes out of scope in the parent procedure, the pointer is dangling.
var p : ppchar;
i : LongInt;
i : ObjpasInt;
begin
if High(s)<Low(s) Then Exit(NIL);
Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
@ -1560,7 +1560,7 @@ end;
Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
var
i,nr : longint;
i,nr : ObjpasInt;
Buf : ^char;
p : ppchar;
@ -1731,7 +1731,7 @@ end;
{ Allow slash and backslash as separators }
procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
var
i : longint;
i : ObjpasInt;
len : sizeint;
newp : pchar;
begin
@ -1753,7 +1753,7 @@ end;
procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
var
i : longint;
i : ObjpasInt;
len : sizeint;
newp : pwidechar;
begin
@ -1776,7 +1776,7 @@ end;
procedure DoDirSeparators(var p:shortstring);
var
i : longint;
i : ObjpasInt;
begin
for i:=1 to length(p) do
if p[i] in AllowDirectorySeparators then
@ -1787,7 +1787,7 @@ end;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure DoDirSeparators(var ps:RawByteString);
var
i : longint;
i : ObjpasInt;
p : pchar;
unique : boolean;
begin
@ -1810,7 +1810,7 @@ end;
{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
procedure DoDirSeparators(var ps:UnicodeString);
var
i : longint;
i : ObjpasInt;
p : pwidechar;
unique : boolean;
begin

8
rtl/objpas/classes/classesh.inc
View File

@ -1124,7 +1124,7 @@ type
procedure WriteWord(w : Word);
procedure WriteDWord(d : Cardinal);
procedure WriteQWord(q : QWord);
Procedure WriteAnsiString (const S : String);
Procedure WriteAnsiString (const S : String); virtual;
property Position: Int64 read GetPosition write SetPosition;
property Size: Int64 read GetSize write SetSize64;
end;
@ -1260,9 +1260,9 @@ type
Destructor Destroy; override;
function ReadUnicodeString(Count: Longint): UnicodeString;
procedure WriteUnicodeString(const AString: UnicodeString);
function ReadAnsiString(Count: Longint): AnsiString;
procedure WriteAnsiString(const AString: AnsiString);
function ReadString(Count: Longint): string;
function ReadAnsiString(Count: Longint): AnsiString; overload;
procedure WriteAnsiString(const AString: AnsiString); override;
function ReadString(Count: Longint): string;
procedure WriteString(const AString: string);
property DataString: string read GetDataString;
Property UnicodeDataString : UnicodeString Read GetUnicodeDataString;

2
rtl/objpas/classes/streams.inc
View File

@ -1655,6 +1655,7 @@ begin
NewLen:=Size-FPosition;
If NewLen>Count then NewLen:=Count;
Result:=FEncoding.GetAnsiString(FBytes,FPosition,NewLen);
Inc(FPosition,NewLen);
end;
procedure TStringStream.WriteAnsiString(const AString: AnsiString);
@ -1704,6 +1705,7 @@ begin
begin
SetLength(Result, NewLen);
Move(FBytes[FPosition],Result[1],NewLen);
inc(FPosition,Newlen);
end;
end;

1
rtl/objpas/sysconst.pp
View File

@ -100,6 +100,7 @@ const
SSafecallException = 'Exception in safecall method';
SiconvError = 'iconv error';
SThreadError = 'Thread error';
SSeekFailed = 'Seek operation failed';
STooManyOpenFiles = 'Too many open files';
SUnKnownRunTimeError = 'Unknown Run-Time error : %3.3d';

77
rtl/objpas/sysutils/filutil.inc
View File

@ -670,3 +670,80 @@ begin
Result:= False;
end;
{$endif}
Function GetFileContents(Const aFileName : RawByteString) : TBytes;
Var
H : Thandle;
begin
H:=FileOpen(aFileName,fmOpenRead or fmShareDenyWrite);
if H<0 then
Raise EFileNotFoundException.Create(SFileNotFound);
try
Result:=GetFileContents(H);
finally
FileClose(H);
end;
end;
Function GetFileContents(Const aFileName : UnicodeString) : TBytes;
Var
H : Thandle;
begin
H:=FileOpen(aFileName,fmOpenRead or fmShareDenyWrite);
if H<0 then
Raise EFileNotFoundException.Create(SFileNotFound);
try
Result:=GetFileContents(H);
finally
FileClose(H);
end;
end;
Function GetFileContents(Const aHandle : THandle) : TBytes;
Var
aLen,aOffset,aRead : Int64;
aBuf : PByte;
begin
aLen:=FileSeek(aHandle,0,fsFromEnd);
if aLen<0 then
Raise EInOutError.Create(SSeekFailed);
if FileSeek(aHandle,0,fsFromBeginning)<0 then
Raise EInOutError.Create(SSeekFailed);
SetLength(Result,aLen);
aOffset:=0;
Repeat
aBuf:=@Result[aOffset];
aRead:=FileRead(aHandle,aBuf^,aLen-aOffset);
aOffset:=aOffset+aRead;
Until (aOffset>=aLen) or (aRead<=0);
if aRead<0 then
RaiseLastOSError;
end;
Function GetFileAsString(Const aFileName : RawByteString; aEncoding : TEncoding) : RawByteString;
begin
Result:=aEncoding.GetAnsiString(GetFileContents(aFileName));
end;
Function GetFileAsString(Const aFileName : RawByteString) : RawByteString;
begin
Result:=GetFileAsString(aFileName,TEncoding.SystemEncoding);
end;
Function GetFileAsString(Const aFileName : UnicodeString) : UnicodeString;
begin
Result:=GetFileAsString(aFileName, TEncoding.Unicode);
end;
Function GetFileAsString(Const aFileName : UnicodeString; aEncoding : TEncoding) : UnicodeString;
begin
Result:=aEncoding.GetString(GetFileContents(aFileName))
end;

9
rtl/objpas/sysutils/filutilh.inc
View File

@ -229,3 +229,12 @@ Function FileGetDate (Handle : THandle) : Int64;
Function FileSetDate (Handle : THandle;Age : Int64) : Longint;
Function GetFileHandle(var f : File):THandle;
Function GetFileHandle(var f : Text):THandle;
Function GetFileContents(Const aFileName : RawByteString) : TBytes;
Function GetFileContents(Const aFileName : UnicodeString) : TBytes;
Function GetFileContents(Const aHandle : THandle) : TBytes;
Function GetFileAsString(Const aFileName : RawByteString) : RawByteString;
Function GetFileAsString(Const aFileName : RawByteString; aEncoding : TEncoding) : RawByteString;
Function GetFileAsString(Const aFileName : UnicodeString) : UnicodeString;
Function GetFileAsString(Const aFileName : UnicodeString; aEncoding : TEncoding) : UnicodeString;

12
rtl/unix/bunxovl.inc
View File

@ -248,10 +248,16 @@ begin
end;
{$endif}
const
{ read/write permission for everyone }
MODE_FPOPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
Function FpOpen (path : pChar; flags : cInt):cInt; {$ifdef VER2_0}inline;{$endif}
begin
FpOpen:=FpOpen(path,flags,438);
FpOpen:=FpOpen(path,flags,MODE_FPOPEN);
end;
Function FpOpen (const path : RawByteString; flags : cInt):cInt; {$ifdef VER2_0}inline;{$endif}
@ -259,14 +265,14 @@ var
SystemPath: RawByteString;
Begin
SystemPath:=ToSingleByteFileSystemEncodedFileName(path);
FpOpen:=FpOpen(pchar(SystemPath),flags,438);
FpOpen:=FpOpen(pchar(SystemPath),flags,MODE_FPOPEN);
end;
Function FpOpen (path : String; flags : cInt):cInt;
begin
path:=path+#0;
FpOpen:=FpOpen(@path[1],flags,438);
FpOpen:=FpOpen(@path[1],flags,MODE_FPOPEN);
end;
Function FpOpen (path : String; flags : cInt; Mode: TMode):cInt;

18
tests/webtbs/tw35841.pp Normal file
View File

@ -0,0 +1,18 @@
{ %norun }
{$mode objfpc}
procedure p;
begin
try
writeln
except
try
writeln;
Exit;
finally
writeln;
end;
end;
end;
begin
end.

3
utils/pas2js/pas2jslib.pp
View File

@ -17,7 +17,8 @@ exports
AddPas2JSDirectoryEntry,
SetPas2JSUnitAliasCallBack,
SetPas2JSCompilerLogCallBack,
GetPas2JSCompilerLastError;
GetPas2JSCompilerLastError,
SetPas2JSLogEncoding;
end.