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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47156 -
This commit is contained in:
nickysn 2020-10-23 00:41:20 +00:00
commit 6899e07cd7
19 changed files with 790 additions and 286 deletions

2
.gitattributes vendored
View File

@ -18533,7 +18533,9 @@ tests/webtbs/tw37806.pp svneol=native#text/pascal
tests/webtbs/tw3782.pp svneol=native#text/plain
tests/webtbs/tw37823.pp svneol=native#text/pascal
tests/webtbs/tw37844.pp svneol=native#text/pascal
tests/webtbs/tw37878.pp svneol=native#text/plain
tests/webtbs/tw37926.pp svneol=native#text/pascal
tests/webtbs/tw37949.pp svneol=native#text/pascal
tests/webtbs/tw3796.pp svneol=native#text/plain
tests/webtbs/tw3805.pp svneol=native#text/plain
tests/webtbs/tw3814.pp svneol=native#text/plain

10
compiler/aarch64/cpubase.pas
View File

@ -48,9 +48,6 @@ unit cpubase;
type
TAsmOp= {$i a64op.inc}
{ See comment for this type in arm/cpubase.pas }
TCommonAsmOps = Set of A_NONE..A_MOV;
{ This should define the array of instructions as string }
op2strtable=array[tasmop] of string[11];
@ -59,6 +56,13 @@ unit cpubase;
firstop = low(tasmop);
{ Last value of opcode enumeration }
lastop = high(tasmop);
{ Last value of opcode for TCommonAsmOps set below }
LastCommonAsmOp = A_MOV;
type
{ See comment for this type in arm/cpubase.pas }
TCommonAsmOps = Set of A_None .. LastCommonAsmOp;
{*****************************************************************************
Registers

14
compiler/aopt.pas
View File

@ -273,28 +273,16 @@ Unit aopt;
Procedure TAsmOptimizer.Optimize;
Var
HP: tai;
pass: longint;
Begin
pass:=0;
BlockStart := tai(AsmL.First);
pass_1;
While Assigned(BlockStart) Do
Begin
if (cs_opt_peephole in current_settings.optimizerswitches) then
begin
if pass = 0 then
PrePeepHoleOpts;
{ Peephole optimizations }
PrePeepHoleOpts;
PeepHoleOptPass1;
{ Only perform them twice in the first pass }
if pass = 0 then
PeepHoleOptPass1;
end;
{ more peephole optimizations }
if (cs_opt_peephole in current_settings.optimizerswitches) then
begin
PeepHoleOptPass2;
{ if pass = last_pass then }
PostPeepHoleOpts;
end;
{ free memory }

20
compiler/aoptobj.pas
View File

@ -2464,13 +2464,28 @@ Unit AoptObj;
procedure TAOptObj.PeepHoleOptPass1;
const
MaxPasses: array[1..4] of Cardinal = (1, 2, 8, 8);
var
p : tai;
stoploop, FirstInstruction, JumpOptsAvailable: boolean;
PassCount, MaxCount: Cardinal;
begin
JumpOptsAvailable := CanDoJumpOpts();
StartPoint := BlockStart;
PassCount := 0;
{ Determine the maximum number of passes allowed based on the compiler switches }
if (cs_opt_level4 in current_settings.optimizerswitches) then
{ it should never take more than 8 passes, but the limit is finite to protect against faulty optimisations }
MaxCount := MaxPasses[4]
else if (cs_opt_level3 in current_settings.optimizerswitches) then
MaxCount := MaxPasses[3]
else if (cs_opt_level2 in current_settings.optimizerswitches) then
MaxCount := MaxPasses[2] { The original double run of Pass 1 }
else
MaxCount := MaxPasses[1];
repeat
stoploop:=true;
@ -2523,7 +2538,10 @@ Unit AoptObj;
p := tai(UpdateUsedRegsAndOptimize(p).Next);
end;
until stoploop or not(cs_opt_level3 in current_settings.optimizerswitches);
Inc(PassCount);
until stoploop or (PassCount >= MaxCount);
end;

12
compiler/arm/cpubase.pas
View File

@ -44,10 +44,6 @@ unit cpubase;
type
TAsmOp= {$i armop.inc}
{This is a bit of a hack, because there are more than 256 ARM Assembly Ops
But FPC currently can't handle more than 256 elements in a set.}
TCommonAsmOps = Set of A_None .. A_UADD16;
{ This should define the array of instructions as string }
op2strtable=array[tasmop] of string[11];
@ -56,6 +52,14 @@ unit cpubase;
firstop = low(tasmop);
{ Last value of opcode enumeration }
lastop = high(tasmop);
{ Last value of opcode for TCommonAsmOps set below }
LastCommonAsmOp = A_UADD16;
type
{This is a bit of a hack, because there are more than 256 ARM Assembly Ops
But FPC currently can't handle more than 256 elements in a set.}
TCommonAsmOps = Set of A_None .. LastCommonAsmOp;
{*****************************************************************************
Registers

2
compiler/armgen/aoptarm.pas
View File

@ -87,7 +87,7 @@ Implementation
begin
result :=
(instr.typ = ait_instruction) and
((op = []) or ((ord(taicpu(instr).opcode)<256) and (taicpu(instr).opcode in op))) and
((op = []) or ((taicpu(instr).opcode<=LastCommonAsmOp) and (taicpu(instr).opcode in op))) and
((cond = []) or (taicpu(instr).condition in cond)) and
((postfix = []) or (taicpu(instr).oppostfix in postfix));
end;

9
compiler/nadd.pas
View File

@ -3572,6 +3572,9 @@ implementation
canbesignedconst, canbeunsignedconst: boolean;
begin
result := false;
{ make sure that if there is a constant, that it's on the right }
if left.nodetype = ordconstn then
swapleftright;
if is_32to64typeconv(left) then
begin
leftoriginallysigned:=is_signed(ttypeconvnode(left).left.resultdef);
@ -3747,11 +3750,7 @@ implementation
{ make sure that if there is a constant, that it's on the right }
if left.nodetype = ordconstn then
begin
temp := right;
right := left;
left := temp;
end;
swapleftright;
{ can we use a shift instead of a mul? }
if not (cs_check_overflow in current_settings.localswitches) and

19
compiler/ncgmat.pas
View File

@ -292,29 +292,18 @@ implementation
procedure tcgunaryminusnode.second_integer;
var
hl: tasmlabel;
opsize: tdef;
begin
secondpass(left);
{$ifdef cpunodefaultint}
opsize:=left.resultdef;
{$else cpunodefaultint}
{ in case of a 32 bit system that can natively execute 64 bit operations }
if (left.resultdef.size<=sinttype.size) then
opsize:=sinttype
else
opsize:={$ifdef cpu16bitalu}s32inttype{$else}s64inttype{$endif};
{$endif cpunodefaultint}
if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opsize,false);
location_reset(location,LOC_REGISTER,def_cgsize(opsize));
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,opsize,left.location.register,location.register);
hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,resultdef,left.location.register,location.register);
if (cs_check_overflow in current_settings.localswitches) then
begin
current_asmdata.getjumplabel(hl);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,OC_NE,torddef(opsize).low.svalue,location.register,hl);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,resultdef,OC_NE,torddef(resultdef).low.svalue,location.register,hl);
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_overflow',[],nil).resetiftemp;
hlcg.a_label(current_asmdata.CurrAsmList,hl);
end;

24
compiler/ncnv.pas
View File

@ -2925,6 +2925,13 @@ implementation
docheckremoveinttypeconvs(tbinarynode(n).left) and
docheckremoveinttypeconvs(tbinarynode(n).right);
end;
unaryminusn:
begin
gotsint:=true;
result:=docheckremoveinttypeconvs(tunarynode(n).left);
end;
notn:
result:=docheckremoveinttypeconvs(tunarynode(n).left);
addn,muln,divn,modn,andn:
begin
if n.nodetype in [divn,modn] then
@ -2980,6 +2987,21 @@ implementation
// ((tordconstnode(tbinarynode(n).right).value and $7fffffff)=tordconstnode(tbinarynode(n).right).value) then
// inserttypeconv_internal(tbinarynode(n).left,n.resultdef);
end;
unaryminusn,notn:
begin
exclude(n.flags,nf_internal);
if not forceunsigned and
is_signed(n.resultdef) then
begin
doremoveinttypeconvs(tunarynode(n).left,signedtype,false,signedtype,unsignedtype);
n.resultdef:=signedtype;
end
else
begin
doremoveinttypeconvs(tunarynode(n).left,unsignedtype,forceunsigned,signedtype,unsignedtype);
n.resultdef:=unsignedtype;
end;
end;
typeconvn:
begin
ttypeconvnode(n).totypedef:=todef;
@ -3271,7 +3293,7 @@ implementation
to 64 bit }
if (resultdef.size <= 4) and
is_64bitint(left.resultdef) and
(left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn]) and
(left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn,notn,unaryminusn]) and
checkremovebiginttypeconvs(left,foundsint,[s8bit,u8bit,s16bit,u16bit,s32bit,u32bit],int64(low(longint)),high(cardinal)) then
doremoveinttypeconvs(left,generrordef,not foundsint,s32inttype,u32inttype);
{$if defined(cpu16bitalu)}

9
compiler/nmem.pas
View File

@ -1052,10 +1052,15 @@ implementation
int64(Tarraydef(left.resultdef).lowrange),
int64(Tarraydef(left.resultdef).highrange),
true
))
));
end
else
inserttypeconv(right,htype)
begin
inserttypeconv(right,htype);
{ insert type conversion so cse can pick it up }
if (htype.size<ptrsinttype.size) and is_integer(htype) and not(cs_check_range in current_settings.localswitches) then
inserttypeconv_internal(right,ptrsinttype);
end;
end;
stringdef:
if is_open_string(left.resultdef) then

12
compiler/nutils.pas
View File

@ -872,7 +872,17 @@ implementation
exit;
p := tunarynode(p).left;
end;
vecn,
vecn:
begin
inc(result,node_complexity(tbinarynode(p).left));
inc(result);
if (result >= NODE_COMPLEXITY_INF) then
begin
result := NODE_COMPLEXITY_INF;
exit;
end;
p := tbinarynode(p).right;
end;
statementn:
begin
inc(result,node_complexity(tbinarynode(p).left));

412
compiler/x86/aoptx86.pas
View File

@ -3156,6 +3156,8 @@ unit aoptx86;
l : ASizeInt;
ref: Integer;
saveref: treference;
TempReg: TRegister;
Multiple: TCGInt;
begin
Result:=false;
{ removes seg register prefixes from LEA operations, as they
@ -3202,158 +3204,257 @@ unit aoptx86;
exit;
end;
end;
if GetNextInstruction(p,hp1) and
MatchInstruction(hp1,A_MOV,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and
MatchOpType(Taicpu(hp1),top_reg,top_reg) and
(taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) then
(hp1.typ=ait_instruction) then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
if MatchInstruction(hp1,A_MOV,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and
MatchOpType(Taicpu(hp1),top_reg,top_reg) and
(taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) then
begin
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'LeaMov2Lea done',p);
RemoveInstruction(hp1);
result:=true;
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
begin
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'LeaMov2Lea done',p);
RemoveInstruction(hp1);
result:=true;
exit;
end;
end;
{ changes
lea <ref1>, reg1
<op> ...,<ref. with reg1>,...
to
<op> ...,<ref1>,... }
if (taicpu(p).oper[1]^.reg<>current_procinfo.framepointer) and
(taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) and
not(MatchInstruction(hp1,A_LEA,[])) then
begin
{ find a reference which uses reg1 }
if (taicpu(hp1).ops>=1) and (taicpu(hp1).oper[0]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[0]^) then
ref:=0
else if (taicpu(hp1).ops>=2) and (taicpu(hp1).oper[1]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^) then
ref:=1
else
ref:=-1;
if (ref<>-1) and
{ reg1 must be either the base or the index }
((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) xor (taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg)) then
begin
{ reg1 can be removed from the reference }
saveref:=taicpu(hp1).oper[ref]^.ref^;
if taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg then
taicpu(hp1).oper[ref]^.ref^.base:=NR_NO
else if taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg then
taicpu(hp1).oper[ref]^.ref^.index:=NR_NO
else
Internalerror(2019111201);
{ check if the can insert all data of the lea into the second instruction }
if ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) or (taicpu(hp1).oper[ref]^.ref^.scalefactor <= 1)) and
((taicpu(p).oper[0]^.ref^.base=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.base=NR_NO)) and
((taicpu(p).oper[0]^.ref^.index=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.index=NR_NO)) and
((taicpu(p).oper[0]^.ref^.symbol=nil) or (taicpu(hp1).oper[ref]^.ref^.symbol=nil)) and
((taicpu(p).oper[0]^.ref^.relsymbol=nil) or (taicpu(hp1).oper[ref]^.ref^.relsymbol=nil)) and
((taicpu(p).oper[0]^.ref^.scalefactor <= 1) or (taicpu(hp1).oper[ref]^.ref^.scalefactor <= 1)) and
(taicpu(p).oper[0]^.ref^.segment=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.segment=NR_NO)
{$ifdef x86_64}
and (abs(taicpu(hp1).oper[ref]^.ref^.offset+taicpu(p).oper[0]^.ref^.offset)<=$7fffffff)
and (((taicpu(p).oper[0]^.ref^.base<>NR_RIP) and (taicpu(p).oper[0]^.ref^.index<>NR_RIP)) or
((taicpu(hp1).oper[ref]^.ref^.base=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.index=NR_NO))
)
{$endif x86_64}
then
begin
{ reg1 might not used by the second instruction after it is remove from the reference }
if not(RegInInstruction(taicpu(p).oper[1]^.reg,taicpu(hp1))) then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
{ reg1 is not updated so it might not be used afterwards }
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
begin
DebugMsg(SPeepholeOptimization + 'LeaOp2Op done',p);
if taicpu(p).oper[0]^.ref^.base<>NR_NO then
taicpu(hp1).oper[ref]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
if taicpu(p).oper[0]^.ref^.index<>NR_NO then
taicpu(hp1).oper[ref]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
if taicpu(p).oper[0]^.ref^.symbol<>nil then
taicpu(hp1).oper[ref]^.ref^.symbol:=taicpu(p).oper[0]^.ref^.symbol;
if taicpu(p).oper[0]^.ref^.relsymbol<>nil then
taicpu(hp1).oper[ref]^.ref^.relsymbol:=taicpu(p).oper[0]^.ref^.relsymbol;
if taicpu(p).oper[0]^.ref^.scalefactor > 1 then
taicpu(hp1).oper[ref]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
inc(taicpu(hp1).oper[ref]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
RemoveCurrentP(p, hp1);
result:=true;
exit;
end
end;
end;
{ recover }
taicpu(hp1).oper[ref]^.ref^:=saveref;
end;
end;
end;
{ changes
lea offset1(regX), reg1
lea offset2(reg1), reg1
to
lea offset1+offset2(regX), reg1 }
{ for now, we do not mess with the stack pointer, thought it might be usefull to remove
unneeded lea sequences on the stack pointer, it needs to be tested in detail }
if (taicpu(p).oper[1]^.reg <> NR_STACK_POINTER_REG) and
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[1]^.reg) and
MatchInstruction(hp1,A_LEA,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[1]^) and
(taicpu(p).oper[0]^.ref^.relsymbol=nil) and
(taicpu(p).oper[0]^.ref^.segment=NR_NO) and
(taicpu(p).oper[0]^.ref^.symbol=nil) and
(((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) and
(taicpu(p).oper[0]^.ref^.index=NR_NO) and
(taicpu(p).oper[0]^.ref^.index=taicpu(hp1).oper[0]^.ref^.index) and
(taicpu(p).oper[0]^.ref^.scalefactor=taicpu(hp1).oper[0]^.ref^.scalefactor)
) or
((taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.index=NR_NO)
) or
((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
(taicpu(hp1).oper[0]^.ref^.scalefactor in [0,1]) and
(taicpu(p).oper[0]^.ref^.base=NR_NO) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1)))
) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
(taicpu(p).oper[0]^.ref^.relsymbol=taicpu(hp1).oper[0]^.ref^.relsymbol) and
(taicpu(p).oper[0]^.ref^.segment=taicpu(hp1).oper[0]^.ref^.segment) and
(taicpu(p).oper[0]^.ref^.symbol=taicpu(hp1).oper[0]^.ref^.symbol) then
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[1]^.reg) then
begin
DebugMsg(SPeepholeOptimization + 'LeaLea2Lea done',p);
if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg then
{ changes
lea offset1(regX), reg1
lea offset2(reg1), reg1
to
lea offset1+offset2(regX), reg1 }
if MatchInstruction(hp1,A_LEA,[taicpu(p).opsize]) and
MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[1]^) and
(taicpu(p).oper[0]^.ref^.relsymbol=nil) and
(taicpu(p).oper[0]^.ref^.segment=NR_NO) and
(taicpu(p).oper[0]^.ref^.symbol=nil) and
(((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.scalefactor <= 1) and
(taicpu(p).oper[0]^.ref^.index=NR_NO) and
(taicpu(p).oper[0]^.ref^.index=taicpu(hp1).oper[0]^.ref^.index) and
(taicpu(p).oper[0]^.ref^.scalefactor=taicpu(hp1).oper[0]^.ref^.scalefactor)
) or
((taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.index=NR_NO)
) or
((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
(taicpu(hp1).oper[0]^.ref^.scalefactor <= 1) and
(taicpu(p).oper[0]^.ref^.base=NR_NO) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1)))
) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
(taicpu(p).oper[0]^.ref^.relsymbol=taicpu(hp1).oper[0]^.ref^.relsymbol) and
(taicpu(p).oper[0]^.ref^.segment=taicpu(hp1).oper[0]^.ref^.segment) and
(taicpu(p).oper[0]^.ref^.symbol=taicpu(hp1).oper[0]^.ref^.symbol) then
begin
taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.base;
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset*max(taicpu(hp1).oper[0]^.ref^.scalefactor,1));
{ if the register is used as index and base, we have to increase for base as well
and adapt base }
if taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg then
DebugMsg(SPeepholeOptimization + 'LeaLea2Lea done',p);
if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg then
begin
taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
end;
end
else
begin
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
end;
if taicpu(p).oper[0]^.ref^.index<>NR_NO then
begin
taicpu(hp1).oper[0]^.ref^.base:=taicpu(hp1).oper[0]^.ref^.index;
taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
taicpu(hp1).oper[0]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
end;
RemoveCurrentP(p);
result:=true;
exit;
end;
{ changes
lea <ref1>, reg1
<op> ...,<ref. with reg1>,...
to
<op> ...,<ref1>,... }
if (taicpu(p).oper[1]^.reg<>current_procinfo.framepointer) and
(taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) and
GetNextInstruction(p,hp1) and
(hp1.typ=ait_instruction) and
not(MatchInstruction(hp1,A_LEA,[])) then
begin
{ find a reference which uses reg1 }
if (taicpu(hp1).ops>=1) and (taicpu(hp1).oper[0]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[0]^) then
ref:=0
else if (taicpu(hp1).ops>=2) and (taicpu(hp1).oper[1]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^) then
ref:=1
else
ref:=-1;
if (ref<>-1) and
{ reg1 must be either the base or the index }
((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) xor (taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg)) then
begin
{ reg1 can be removed from the reference }
saveref:=taicpu(hp1).oper[ref]^.ref^;
if taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg then
taicpu(hp1).oper[ref]^.ref^.base:=NR_NO
else if taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg then
taicpu(hp1).oper[ref]^.ref^.index:=NR_NO
else
Internalerror(2019111201);
{ check if the can insert all data of the lea into the second instruction }
if ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) or (taicpu(hp1).oper[ref]^.ref^.scalefactor in [0,1])) and
((taicpu(p).oper[0]^.ref^.base=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.base=NR_NO)) and
((taicpu(p).oper[0]^.ref^.index=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.index=NR_NO)) and
((taicpu(p).oper[0]^.ref^.symbol=nil) or (taicpu(hp1).oper[ref]^.ref^.symbol=nil)) and
((taicpu(p).oper[0]^.ref^.relsymbol=nil) or (taicpu(hp1).oper[ref]^.ref^.relsymbol=nil)) and
((taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) or (taicpu(hp1).oper[ref]^.ref^.scalefactor in [0,1])) and
(taicpu(p).oper[0]^.ref^.segment=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.segment=NR_NO)
{$ifdef x86_64}
and (abs(taicpu(hp1).oper[ref]^.ref^.offset+taicpu(p).oper[0]^.ref^.offset)<=$7fffffff)
and (((taicpu(p).oper[0]^.ref^.base<>NR_RIP) and (taicpu(p).oper[0]^.ref^.index<>NR_RIP)) or
((taicpu(hp1).oper[ref]^.ref^.base=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.index=NR_NO))
)
{$endif x86_64}
then
begin
{ reg1 might not used by the second instruction after it is remove from the reference }
if not(RegInInstruction(taicpu(p).oper[1]^.reg,taicpu(hp1))) then
taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.base;
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset*max(taicpu(hp1).oper[0]^.ref^.scalefactor,1));
{ if the register is used as index and base, we have to increase for base as well
and adapt base }
if taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
{ reg1 is not updated so it might not be used afterwards }
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
begin
DebugMsg(SPeepholeOptimization + 'LeaOp2Op done',p);
if taicpu(p).oper[0]^.ref^.base<>NR_NO then
taicpu(hp1).oper[ref]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
if taicpu(p).oper[0]^.ref^.index<>NR_NO then
taicpu(hp1).oper[ref]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
if taicpu(p).oper[0]^.ref^.symbol<>nil then
taicpu(hp1).oper[ref]^.ref^.symbol:=taicpu(p).oper[0]^.ref^.symbol;
if taicpu(p).oper[0]^.ref^.relsymbol<>nil then
taicpu(hp1).oper[ref]^.ref^.relsymbol:=taicpu(p).oper[0]^.ref^.relsymbol;
if not(taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) then
taicpu(hp1).oper[ref]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
inc(taicpu(hp1).oper[ref]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
RemoveCurrentP(p, hp1);
result:=true;
exit;
end
taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
end;
end
else
begin
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
end;
if taicpu(p).oper[0]^.ref^.index<>NR_NO then
begin
taicpu(hp1).oper[0]^.ref^.base:=taicpu(hp1).oper[0]^.ref^.index;
taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
taicpu(hp1).oper[0]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
end;
RemoveCurrentP(p);
result:=true;
exit;
end;
{ Change:
leal/q $x(%reg1),%reg2
...
shll/q $y,%reg2
To:
leal/q $(x+2^y)(%reg1,2^y),%reg2 (if y <= 3)
}
if MatchInstruction(hp1, A_SHL, [taicpu(p).opsize]) and
MatchOpType(taicpu(hp1), top_const, top_reg) and
(taicpu(hp1).oper[0]^.val <= 3) then
begin
Multiple := 1 shl taicpu(hp1).oper[0]^.val;
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(hp1.Next));
TempReg := taicpu(hp1).oper[1]^.reg; { Store locally to reduce the number of dereferences }
if
{ This allows the optimisation in some circumstances even if the lea instruction already has a scale factor
(this works even if scalefactor is zero) }
((Multiple * taicpu(p).oper[0]^.ref^.scalefactor) <= 8) and
{ Ensure offset doesn't go out of bounds }
(abs(taicpu(p).oper[0]^.ref^.offset * Multiple) <= $7FFFFFFF) and
not (RegInUsedRegs(NR_DEFAULTFLAGS,TmpUsedRegs)) and
MatchOperand(taicpu(p).oper[1]^, TempReg) and
(
(
not SuperRegistersEqual(taicpu(p).oper[0]^.ref^.base, TempReg) and
(
(taicpu(p).oper[0]^.ref^.index = NR_NO) or
(taicpu(p).oper[0]^.ref^.index = NR_INVALID) or
(
{ Check for lea $x(%reg1,%reg1),%reg2 and treat as it it were lea $x(%reg1,2),%reg2 }
(taicpu(p).oper[0]^.ref^.index = taicpu(p).oper[0]^.ref^.base) and
(taicpu(p).oper[0]^.ref^.scalefactor <= 1)
)
)
) or (
(
(taicpu(p).oper[0]^.ref^.base = NR_NO) or
(taicpu(p).oper[0]^.ref^.base = NR_INVALID)
) and
not SuperRegistersEqual(taicpu(p).oper[0]^.ref^.index, TempReg)
)
) then
begin
repeat
with taicpu(p).oper[0]^.ref^ do
begin
{ Convert lea $x(%reg1,%reg1),%reg2 to lea $x(%reg1,2),%reg2 }
if index = base then
begin
if Multiple > 4 then
{ Optimisation will no longer work because resultant
scale factor will exceed 8 }
Break;
base := NR_NO;
scalefactor := 2;
DebugMsg(SPeepholeOptimization + 'lea $x(%reg1,%reg1),%reg2 -> lea $x(%reg1,2),%reg2 for following optimisation', p);
end
else if (base <> NR_NO) and (base <> NR_INVALID) then
begin
{ Scale factor only works on the index register }
index := base;
base := NR_NO;
end;
{ For safety }
if scalefactor <= 1 then
begin
DebugMsg(SPeepholeOptimization + 'LeaShl2Lea 1', p);
scalefactor := Multiple;
end
else
begin
DebugMsg(SPeepholeOptimization + 'LeaShl2Lea 2', p);
scalefactor := scalefactor * Multiple;
end;
offset := offset * Multiple;
end;
RemoveInstruction(hp1);
Result := True;
Exit;
{ This repeat..until loop exists for the benefit of Break }
until True;
end;
{ recover }
taicpu(hp1).oper[ref]^.ref^:=saveref;
end;
end;
end;
@ -5970,26 +6071,27 @@ unit aoptx86;
function TX86AsmOptimizer.OptPass2Lea(var p : tai) : Boolean;
begin
Result:=false;
if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) and
MatchReference(taicpu(p).oper[0]^.ref^,taicpu(p).oper[1]^.reg,NR_INVALID) and
(taicpu(p).oper[0]^.ref^.index<>NR_NO) then
if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) then
begin
taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.base);
taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.index);
taicpu(p).opcode:=A_ADD;
DebugMsg(SPeepholeOptimization + 'Lea2AddBase done',p);
result:=true;
end
if MatchReference(taicpu(p).oper[0]^.ref^,taicpu(p).oper[1]^.reg,NR_INVALID) and
(taicpu(p).oper[0]^.ref^.index<>NR_NO) then
begin
taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.base);
taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.index);
taicpu(p).opcode:=A_ADD;
DebugMsg(SPeepholeOptimization + 'Lea2AddBase done',p);
result:=true;
end
else if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) and
MatchReference(taicpu(p).oper[0]^.ref^,NR_INVALID,taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.base<>NR_NO) then
begin
taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.index);
taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.base);
taicpu(p).opcode:=A_ADD;
DebugMsg(SPeepholeOptimization + 'Lea2AddIndex done',p);
result:=true;
else if MatchReference(taicpu(p).oper[0]^.ref^,NR_INVALID,taicpu(p).oper[1]^.reg) and
(taicpu(p).oper[0]^.ref^.base<>NR_NO) then
begin
taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.index);
taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.base);
taicpu(p).opcode:=A_ADD;
DebugMsg(SPeepholeOptimization + 'Lea2AddIndex done',p);
result:=true;
end;
end;
end;

215
packages/odbc/src/odbcsql.inc
View File

@ -90,6 +90,7 @@ type
PSQLREAL = ^SQLREAL;
PSQLDOUBLE = ^SQLDOUBLE;
PSQLFLOAT = ^SQLFLOAT;
PSQLPOINTER = ^SQLPOINTER;
PSQLHANDLE = ^SQLHANDLE;
const
@ -304,6 +305,7 @@ const
SQL_OV_ODBC3 = 3;
SQL_OV_ODBC2 = 2;
SQL_OV_ODBC3_80 = 380;
SQL_ATTR_ODBC_VERSION = 200;
{ Options for SQLDriverConnect }
@ -528,17 +530,20 @@ const
SQL_GET_BOOKMARK =13; // GetStmtOption Only */
SQL_ROW_NUMBER =14 ; // GetStmtOption Only */
SQL_ATTR_CURSOR_TYPE = SQL_CURSOR_TYPE;
{ statement attributes for ODBC 3.0 }
SQL_ATTR_ASYNC_ENABLE = 4;
SQL_ATTR_CONCURRENCY = SQL_CONCURRENCY;
SQL_ATTR_CURSOR_TYPE = SQL_CURSOR_TYPE;
SQL_ATTR_FETCH_BOOKMARK_PTR = 16;
SQL_ATTR_MAX_ROWS = SQL_MAX_ROWS;
SQL_ATTR_PARAMSET_SIZE = 22;
SQL_ATTR_QUERY_TIMEOUT = SQL_QUERY_TIMEOUT;
SQL_ATTR_ROW_NUMBER = SQL_ROW_NUMBER;
SQL_ATTR_ROW_STATUS_PTR = 25;
SQL_ATTR_ROWS_FETCHED_PTR = 26;
SQL_ATTR_ROW_NUMBER = SQL_ROW_NUMBER;
SQL_ATTR_MAX_ROWS = SQL_MAX_ROWS;
SQL_ATTR_USE_BOOKMARKS = SQL_USE_BOOKMARKS;
//* connection attributes */
{ connection attributes }
SQL_ACCESS_MODE =101;
SQL_AUTOCOMMIT =102;
SQL_LOGIN_TIMEOUT =103;
@ -553,7 +558,7 @@ const
SQL_PACKET_SIZE =112;
//* connection attributes with new names */
{ connection attributes with new names }
SQL_ATTR_ACCESS_MODE =SQL_ACCESS_MODE;
SQL_ATTR_AUTOCOMMIT =SQL_AUTOCOMMIT;
SQL_ATTR_CONNECTION_DEAD =1209; //* GetConnectAttr only */
@ -703,13 +708,15 @@ const
#define SQL_PRED_CHAR 1
#define SQL_PRED_BASIC 2
#endif
}
/* values of UNNAMED field in descriptor */
#if (ODBCVER >= 0x0300)
#define SQL_NAMED 0
#define SQL_UNNAMED 1
#endif
{ values of UNNAMED field in descriptor }
{$ifdef ODBCVER3}
SQL_NAMED = 0;
SQL_UNNAMED = 1;
{$endif}
{
/* values of ALLOC_TYPE field in descriptor */
#if (ODBCVER >= 0x0300)
#define SQL_DESC_ALLOC_AUTO 1
@ -761,13 +768,11 @@ const
SQL_BEST_ROWID = 1;
SQL_ROWVER = 2;
{
#define SQL_PC_UNKNOWN 0
#if (ODBCVER >= 0x0300)
#define SQL_PC_NON_PSEUDO 1
#endif
#define SQL_PC_PSEUDO 2
}
SQL_PC_UNKNOWN = 0;
{$ifdef ODBCVER3}
SQL_PC_NON_PSEUDO = 1;
{$endif}
SQL_PC_PSEUDO = 2;
//* Reserved value for the IdentifierType argument of SQLSpecialColumns() */
{$ifdef ODBCVER3}
@ -790,6 +795,66 @@ const
// SQL_INDEX_BTREE = ???;
// SQL_INDEX_CONTENT = ???;
(* SQLGetFunctions() values to identify ODBC APIs *)
SQL_API_SQLALLOCCONNECT = 1;
SQL_API_SQLALLOCENV = 2;
SQL_API_SQLALLOCHANDLE = 1001;
SQL_API_SQLALLOCSTMT = 3;
SQL_API_SQLBINDCOL = 4;
SQL_API_SQLBINDPARAM = 1002;
SQL_API_SQLCANCEL = 5;
SQL_API_SQLCLOSECURSOR = 1003;
SQL_API_SQLCOLATTRIBUTE = 6;
SQL_API_SQLCOLUMNS = 40;
SQL_API_SQLCONNECT = 7;
SQL_API_SQLCOPYDESC = 1004;
SQL_API_SQLDATASOURCES = 57;
SQL_API_SQLDESCRIBECOL = 8;
SQL_API_SQLDISCONNECT = 9;
SQL_API_SQLENDTRAN = 1005;
SQL_API_SQLERROR = 10;
SQL_API_SQLEXECDIRECT = 11;
SQL_API_SQLEXECUTE = 12;
SQL_API_SQLFETCH = 13;
SQL_API_SQLFETCHSCROLL = 1021;
SQL_API_SQLFREECONNECT = 14;
SQL_API_SQLFREEENV = 15;
SQL_API_SQLFREEHANDLE = 1006;
SQL_API_SQLFREESTMT = 16;
SQL_API_SQLGETCONNECTATTR = 1007;
SQL_API_SQLGETCONNECTOPTION = 42;
SQL_API_SQLGETCURSORNAME = 17;
SQL_API_SQLGETDATA = 43;
SQL_API_SQLGETDESCFIELD = 1008;
SQL_API_SQLGETDESCREC = 1009;
SQL_API_SQLGETDIAGFIELD = 1010;
SQL_API_SQLGETDIAGREC = 1011;
SQL_API_SQLGETENVATTR = 1012;
SQL_API_SQLGETFUNCTIONS = 44;
SQL_API_SQLGETINFO = 45;
SQL_API_SQLGETSTMTATTR = 1014;
SQL_API_SQLGETSTMTOPTION = 46;
SQL_API_SQLGETTYPEINFO = 47;
SQL_API_SQLNUMRESULTCOLS = 18;
SQL_API_SQLPARAMDATA = 48;
SQL_API_SQLPREPARE = 19;
SQL_API_SQLPUTDATA = 49;
SQL_API_SQLROWCOUNT = 20;
SQL_API_SQLSETCONNECTATTR = 1016;
SQL_API_SQLSETCONNECTOPTION = 50;
SQL_API_SQLSETCURSORNAME = 21;
SQL_API_SQLSETDESCFIELD = 1017;
SQL_API_SQLSETDESCREC = 1018;
SQL_API_SQLSETENVATTR = 1019;
SQL_API_SQLSETPARAM = 22;
SQL_API_SQLSETSTMTATTR = 1020;
SQL_API_SQLSETSTMTOPTION = 51;
SQL_API_SQLSPECIALCOLUMNS = 52;
SQL_API_SQLSTATISTICS = 53;
SQL_API_SQLTABLES = 54;
SQL_API_SQLTRANSACT = 23;
SQL_API_SQLCANCELHANDLE = 1022;
{
/* Information requested by SQLGetInfo() */
#if (ODBCVER >= 0x0300)
@ -870,6 +935,9 @@ const
SQL_MAXIMUM_IDENTIFIER_LENGTH = SQL_MAX_IDENTIFIER_LEN;
{$endif} { ODBCVER >= 0x0300 }
{ Extended definitions for SQLGetInfo }
SQL_NEED_LONG_DATA_LEN = 111;
{/* SQL_ALTER_TABLE bitmasks */
#if (ODBCVER >= 0x0200)
#define SQL_AT_ADD_COLUMN 0x00000001L
@ -897,8 +965,12 @@ const
*#define SQL_AT_CONSTRAINT_NON_DEFERRABLE 0x00080000L
#endif /* ODBCVER >= 0x0300 */
}
SQL_API_ALL_FUNCTIONS = 0;
SQL_API_ODBC3_ALL_FUNCTIONS = 999;
{
/* SQL_ASYNC_MODE values */
#if (ODBCVER >= 0x0300)
#define SQL_AM_NONE 0
@ -978,6 +1050,10 @@ const
SQL_SS_DELETIONS = 2;
SQL_SS_UPDATES = 4;
{ SQLBindParameter extensions }
SQL_DEFAULT_PARAM = -5;
SQL_IGNORE = -6;
{ SQLColAttributes defines }
SQL_COLUMN_COUNT = 0;
SQL_COLUMN_NAME = 1;
@ -1038,6 +1114,11 @@ const
SQL_DESC_UPDATABLE = SQL_COLUMN_UPDATABLE;
{$endif}
{ defines for diagnostics fields }
SQL_DIAG_CURSOR_ROW_COUNT = -1249;
SQL_DIAG_ROW_NUMBER = -1248;
SQL_DIAG_COLUMN_NUMBER = -1247;
{ SQLColAttributes subdefines for SQL_COLUMN_UPDATABLE }
SQL_ATTR_READONLY = 0;
SQL_ATTR_WRITE = 1;
@ -1057,6 +1138,14 @@ const
ODBC_CONFIG_SYS_DSN = 5;
ODBC_REMOVE_SYS_DSN = 6;
{ Defines for SQLTables }
{$ifdef ODBCVER3}
SQL_ALL_CATALOGS = '%';
SQL_ALL_SCHEMAS = '%';
SQL_ALL_TABLE_TYPES = '%';
{$endif}
{$ifdef DYNLOADINGODBC}
type TSQLAllocHandle =function(HandleType: SQLSMALLINT;
@ -1113,6 +1202,8 @@ type TSQLExecDirect=function (StatementHandle:SQLHSTMT;
TSQLExecDirectW=function (StatementHandle:SQLHSTMT;
StatementText:PSQLWCHAR;TextLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLParamData=function(StatementHandle:SQLHSTMT; ValuePtrPtr: PSQLPOINTER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLPrepare=function (StatementHandle:SQLHSTMT;
StatementText:PSQLCHAR;TextLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
TSQLPrepareW=function (StatementHandle:SQLHSTMT;
@ -1167,6 +1258,10 @@ type TSQLSetDescRec=function (DescriptorHandle:SQLHDESC;
Length:SQLLEN; Precision, Scale: SQLSMALLINT;
DataPtr:SQLPOINTER; StringLengthPtr,IndicatorPtr:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLGetFunctions=function(ConnectionHandle: SQLHDBC;
FunctionId: SQLUSMALLINT;
Supported: PSQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLGetInfo=function (ConnectionHandle:SQLHDBC;
InfoType:SQLUSMALLINT;InfoValue:SQLPOINTER;
BufferLength:SQLSMALLINT;StringLength:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
@ -1198,7 +1293,11 @@ type TSQLDrivers=function (EnvironmentHandle:SQLHENV;
DriverAttributes:PSQLCHAR;BufferLength2:SQLSMALLINT;
AttributesLength2:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLSetConnectAttr=function (ConnectionHandle:SQLHDBC;
type TSQLGetConnectAttr=function (ConnectionHandle:SQLHDBC;
Attribute: SQLINTEGER; Value: SQLPOINTER;
BufferLength: SQLINTEGER; StringLengthPtr: PSQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
TSQLSetConnectAttr=function (ConnectionHandle:SQLHDBC;
Attribute:SQLINTEGER; Value:SQLPOINTER;
StringLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
@ -1206,7 +1305,7 @@ type TSQLGetCursorName=function (StatementHandle:SQLHSTMT;
CursorName:PSQLCHAR; BufferLength:SQLSMALLINT;
NameLength:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLSetCursorName=function (StatementHandle:SQLHSTMT;
TSQLSetCursorName=function (StatementHandle:SQLHSTMT;
CursorName:PSQLCHAR; NameLength:SQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLRowCount=function (StatementHandle:SQLHSTMT;
@ -1219,6 +1318,13 @@ type TSQLBindParameter=function (hstmt:SQLHSTMT;
rgbValue:SQLPOINTER;cbValueMax:SQLLEN;
pcbValue:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLDescribeParam=function (StatementHandle: SQLHSTMT;
ParameterNumber: SQLUSMALLINT;
DataTypePtr: PSQLSMALLINT;
ParameterSizePtr: PSQLULEN;
DecimalDigitsPtr: PSQLSMALLINT;
NullablePtr: PSQLSMALLINT): SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLFreeStmt=function (StatementHandle:SQLHSTMT;
Option:SQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
@ -1246,7 +1352,7 @@ type TSQLColumns=function ( hstmt : SQLHSTMT;
szTableOwner : PSQLCHAR;cbTableOwner : SQLSMALLINT;
szTableName : PSQLCHAR;cbTableName : SQLSMALLINT;
szColumnName : PSQLCHAR;cbColumnName : SQLSMALLINT ) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
TSQLColumnsW=function ( hstmt : SQLHSTMT;
TSQLColumnsW=function ( hstmt : SQLHSTMT;
szTableQualifier : PSQLWCHAR;cbTableQualifier : SQLSMALLINT;
szTableOwner : PSQLWCHAR;cbTableOwner : SQLSMALLINT;
szTableName : PSQLWCHAR;cbTableName : SQLSMALLINT;
@ -1259,6 +1365,21 @@ type TSQLSpecialColumns=function (StatementHandle:SQLHSTMT;
NameLength3:SQLSMALLINT;Scope:SQLUSMALLINT;
Nullable:SQLUSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLForeignKeysA=function(StatementHandle: SQLHSTMT;
PKCatalogName: PSQLCHAR; NameLength1: SQLSMALLINT;
PKSchemaName: PSQLCHAR; NameLength2: SQLSMALLINT;
PKTableName: PSQLCHAR; NameLength3: SQLSMALLINT;
FKCatalogName: PSQLCHAR; NameLength4: SQLSMALLINT;
FKSchemaName: PSQLCHAR; NameLength5: SQLSMALLINT;
FKTableName: PSQLCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
TSQLForeignKeysW=function(StatementHandle: SQLHSTMT;
PKCatalogName: PSQLWCHAR; NameLength1: SQLSMALLINT;
PKSchemaName: PSQLWCHAR; NameLength2: SQLSMALLINT;
PKTableName: PSQLWCHAR; NameLength3: SQLSMALLINT;
FKCatalogName: PSQLWCHAR; NameLength4: SQLSMALLINT;
FKSchemaName: PSQLWCHAR; NameLength5: SQLSMALLINT;
FKTableName: PSQLWCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
type TSQLProcedures=function ( hstmt : SQLHSTMT;
szTableQualifier : PSQLCHAR;cbTableQualifier : SQLSMALLINT;
szTableOwner : PSQLCHAR;cbTableOwner : SQLSMALLINT;
@ -1304,6 +1425,7 @@ type TSQLStatistics = function (hstmt: SQLHSTMT;
var SQLAllocHandle:tSQLAllocHandle;
var SQLSetEnvAttr:tSQLSetEnvAttr;
var SQLFreeHandle:tSQLFreeHandle;
var SQLGetFunctions:TSQLGetFunctions;
var SQLGetInfo:tSQLGetInfo;
var SQLGetDiagRecA:TSQLGetDiagRec;
SQLGetDiagRecW:TSQLGetDiagRecW;
@ -1315,6 +1437,7 @@ var SQLDriverConnectA:TSQLDriverConnect;
SQLDriverConnectW:TSQLDriverConnectW;
var SQLExecDirectA:TSQLExecDirect;
SQLExecDirectW:TSQLExecDirectW;
var SQLParamData:TSQLParamData;
var SQLPrepareA:TSQLPrepare;
SQLPrepareW:TSQLPrepareW;
var SQLCloseCursor:TSQLCloseCursor;
@ -1328,7 +1451,7 @@ var SQLExtendedFetch:TSQLExtendedFetch;
var SQLGetData:TSQLGetData;
var SQLSetStmtAttr:TSQLSetStmtAttr;
var SQLGetStmtAttr:TSQLGetStmtAttr;
//var SQLSetDescField:TSQLSetDescField;
var SQLSetDescField:TSQLSetDescField;
var SQLSetDescRec:TSQLSetDescRec;
var SQLBulkOperations:TSQLBulkOperations;
var SQLPutData:TSQLPutData;
@ -1336,11 +1459,13 @@ var SQLBindCol:TSQLBindCol;
var SQLSetPos:TSQLSetPos;
var SQLDataSources:TSQLDataSources;
var SQLDrivers:TSQLDrivers;
var SQLGetConnectAttr:TSQLGetConnectAttr;
var SQLSetConnectAttr:TSQLSetConnectAttr;
var SQLGetCursorName:TSQLGetCursorName;
var SQLSetCursorName:TSQLSetCursorName;
var SQLRowCount:TSQLRowCount;
var SQLBindParameter:TSQLBindParameter;
var SQLDescribeParam:TSQLDescribeParam;
var SQLFreeStmt:TSQLFreeStmt;
var SQLColAttribute:TSQLColAttribute;
var SQLEndTran:TSQLEndTran;
@ -1349,6 +1474,8 @@ var SQLTablesA:TSQLTables;
var SQLColumnsA:TSQLColumns;
SQLColumnsW:TSQLColumnsW;
var SQLSpecialColumns:TSQLSpecialColumns;
var SQLForeignKeysA:TSQLForeignKeysA;
SQLForeignKeysW:TSQLForeignKeysW;
var SQLPrimaryKeysA:TSQLPrimaryKeys;
SQLPrimaryKeysW:TSQLPrimaryKeysW;
var SQLProceduresA:TSQLProcedures;
@ -1461,6 +1588,9 @@ var
StatementHandle:SQLHSTMT;
StatementText: PSQLWCHAR;
TextLength: SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLParamData(
StatementHandle:SQLHSTMT;
ValuePtrPtr: PSQLPOINTER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLPrepare(
StatementHandle:SQLHSTMT;
StatementText:PSQLCHAR;
@ -1531,6 +1661,10 @@ var
RecNumber:SQLSMALLINT; DescType, SubType:SQLSMALLINT;
Length:SQLLEN; Precision, Scale: SQLSMALLINT;
DataPtr:SQLPOINTER; StringLengthPtr,IndicatorPtr:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLGetFunctions(
ConnectionHandle: SQLHDBC;
FunctionId: SQLUSMALLINT;
Supported: PSQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLGetInfo(
ConnectionHandle:SQLHDBC;
InfoType:SQLUSMALLINT;
@ -1574,6 +1708,9 @@ var
DriverAttributes:PSQLCHAR;
BufferLength2:SQLSMALLINT;
AttributesLength2:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLGetConnectAttr(ConnectionHandle: SQLHDBC;
Attribute: SQLINTEGER; Value: SQLPOINTER;
BufferLength: SQLINTEGER; StringLengthPtr: PSQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLSetConnectAttr(
ConnectionHandle:SQLHDBC;
Attribute:SQLINTEGER; Value:SQLPOINTER;
@ -1600,6 +1737,13 @@ var
rgbValue:SQLPOINTER;
cbValueMax:SQLLEN;
pcbValue:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLDescribeParam(
StatementHandle: SQLHSTMT;
ParameterNumber: SQLUSMALLINT;
DataTypePtr: PSQLSMALLINT;
ParameterSizePtr: PSQLULEN;
DecimalDigitsPtr: PSQLSMALLINT;
NullablePtr: PSQLSMALLINT): SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
function SQLFreeStmt(
StatementHandle:SQLHSTMT;
Option:SQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
@ -1663,6 +1807,20 @@ var
NameLength3:SQLSMALLINT;
Scope:SQLUSMALLINT;
Nullable:SQLUSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
function SQLForeignKeys(StatementHandle: SQLHSTMT;
PKCatalogName: PSQLCHAR; NameLength1: SQLSMALLINT;
PKSchemaName: PSQLCHAR; NameLength2: SQLSMALLINT;
PKTableName: PSQLCHAR; NameLength3: SQLSMALLINT;
FKCatalogName: PSQLCHAR; NameLength4: SQLSMALLINT;
FKSchemaName: PSQLCHAR; NameLength5: SQLSMALLINT;
FKTableName: PSQLCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
function SQLForeignKeysW(StatementHandle: SQLHSTMT;
PKCatalogName: PSQLWCHAR; NameLength1: SQLSMALLINT;
PKSchemaName: PSQLWCHAR; NameLength2: SQLSMALLINT;
PKTableName: PSQLWCHAR; NameLength3: SQLSMALLINT;
FKCatalogName: PSQLWCHAR; NameLength4: SQLSMALLINT;
FKSchemaName: PSQLWCHAR; NameLength5: SQLSMALLINT;
FKTableName: PSQLWCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
function SQLProcedures( hstmt : SQLHSTMT;
szTableQualifier : PSQLCHAR;
cbTableQualifier : SQLSMALLINT;
@ -1751,6 +1909,7 @@ begin
pointer(SQLAllocHandle) := GetProcedureAddress(ODBCLibraryHandle,'SQLAllocHandle');
pointer(SQLSetEnvAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetEnvAttr');
pointer(SQLFreeHandle) := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeHandle');
pointer(SQLGetFunctions) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetFunctions');
pointer(SQLGetInfo) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetInfo');
pointer(SQLSpecialColumns) := GetProcedureAddress(ODBCLibraryHandle,'SQLSpecialColumns');
pointer(SQLGetDiagField) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetDiagField');
@ -1764,7 +1923,7 @@ begin
pointer(SQLGetData) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetData');
pointer(SQLSetStmtAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetStmtAttr');
pointer(SQLGetStmtAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetStmtAttr');
//pointer(SQLSetDescField) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
pointer(SQLSetDescField) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
pointer(SQLSetDescRec) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescRec');
pointer(SQLBulkOperations) := GetProcedureAddress(ODBCLibraryHandle,'SQLBulkOperations');
pointer(SQLPutData) := GetProcedureAddress(ODBCLibraryHandle,'SQLPutData');
@ -1772,11 +1931,14 @@ begin
pointer(SQLSetPos) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetPos');
pointer(SQLDataSources) := GetProcedureAddress(ODBCLibraryHandle,'SQLDataSources');
pointer(SQLDrivers) := GetProcedureAddress(ODBCLibraryHandle,'SQLDrivers');
pointer(SQLGetConnectAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetConnectAttr');
pointer(SQLSetConnectAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetConnectAttr');
pointer(SQLGetCursorName) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetCursorName');
pointer(SQLSetCursorName) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetCursorName');
pointer(SQLRowCount) := GetProcedureAddress(ODBCLibraryHandle,'SQLRowCount');
pointer(SQLBindParameter) := GetProcedureAddress(ODBCLibraryHandle,'SQLBindParameter');
pointer(SQLDescribeParam) :=GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeParam');
pointer(SQLParamData) :=GetProcedureAddress(ODBCLibraryHandle,'SQLParamData');
pointer(SQLFreeStmt) := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeStmt');
pointer(SQLColAttribute) := GetProcedureAddress(ODBCLibraryHandle,'SQLColAttribute');
pointer(SQLEndTran) := GetProcedureAddress(ODBCLibraryHandle,'SQLEndTran');
@ -1789,6 +1951,7 @@ begin
pointer(SQLDescribeColA) := GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeCol');
pointer(SQLTablesA) := GetProcedureAddress(ODBCLibraryHandle,'SQLTables');
pointer(SQLColumnsA) := GetProcedureAddress(ODBCLibraryHandle,'SQLColumns');
pointer(SQLForeignKeysA) := GetProcedureAddress(ODBCLibraryHandle,'SQLForeignKeys');
pointer(SQLPrimaryKeysA) := GetProcedureAddress(ODBCLibraryHandle,'SQLPrimaryKeys');
pointer(SQLProceduresA) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedures');
pointer(SQLProcedureColumnsA) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedureColumns');
@ -1816,6 +1979,7 @@ begin
pointer(SQLDescribeColW) := GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeColW');
pointer(SQLTablesW) := GetProcedureAddress(ODBCLibraryHandle,'SQLTablesW');
pointer(SQLColumnsW) := GetProcedureAddress(ODBCLibraryHandle,'SQLColumnsW');
pointer(SQLForeignKeysW) := GetProcedureAddress(ODBCLibraryHandle,'SQLForeignKeysW');
pointer(SQLPrimaryKeysW) := GetProcedureAddress(ODBCLibraryHandle,'SQLPrimaryKeysW');
pointer(SQLProceduresW) := GetProcedureAddress(ODBCLibraryHandle,'SQLProceduresW');
pointer(SQLProcedureColumnsW) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedureColumnsW');
@ -1824,6 +1988,7 @@ begin
SQLAllocHandle := GetProcedureAddress(ODBCLibraryHandle,'SQLAllocHandle');
SQLSetEnvAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetEnvAttr');
SQLFreeHandle := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeHandle');
SQLGetFunctions := GetProcedureAddress(ODBCLibraryHandle,'SQLGetFunctions');
SQLGetInfo := GetProcedureAddress(ODBCLibraryHandle,'SQLGetInfo');
SQLProcedures := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedures');
SQLColumns := GetProcedureAddress(ODBCLibraryHandle,'SQLColumns');
@ -1834,6 +1999,7 @@ begin
SQLDisconnect := GetProcedureAddress(ODBCLibraryHandle,'SQLDisconnect');
SQLDriverConnect := GetProcedureAddress(ODBCLibraryHandle,'SQLDriverConnect');
SQLExecDirect := GetProcedureAddress(ODBCLibraryHandle,'SQLExecDirect');
SQLParamData := GetProcedureAddress(ODBCLibraryHandle,'SQLParamData');
SQLPrepare := GetProcedureAddress(ODBCLibraryHandle,'SQLPrepare');
SQLCloseCursor := GetProcedureAddress(ODBCLibraryHandle,'SQLCloseCursor');
SQLExecute := GetProcedureAddress(ODBCLibraryHandle,'SQLExecute');
@ -1845,7 +2011,7 @@ begin
SQLGetData := GetProcedureAddress(ODBCLibraryHandle,'SQLGetData');
SQLSetStmtAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetStmtAttr');
SQLGetStmtAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLGetStmtAttr');
//SQLSetDescField := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
SQLSetDescField := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
SQLSetDescRec := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescRec');
SQLBulkOperations := GetProcedureAddress(ODBCLibraryHandle,'SQLBulkOperations');
SQLPutData := GetProcedureAddress(ODBCLibraryHandle,'SQLPutData');
@ -1853,6 +2019,7 @@ begin
SQLSetPos := GetProcedureAddress(ODBCLibraryHandle,'SQLSetPos');
SQLDataSources := GetProcedureAddress(ODBCLibraryHandle,'SQLDataSources');
SQLDrivers := GetProcedureAddress(ODBCLibraryHandle,'SQLDrivers');
SQLGetConnectAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLGetConnectAttr');
SQLSetConnectAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetConnectAttr');
SQLGetCursorName := GetProcedureAddress(ODBCLibraryHandle,'SQLGetCursorName');
SQLSetCursorName := GetProcedureAddress(ODBCLibraryHandle,'SQLSetCursorName');

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

@ -18465,7 +18465,7 @@ begin
aResolver:=AContext.Resolver;
Proc:=TPasProcedure(ResolvedEl.IdentEl);
if not (Proc.Parent is TPasMembersType)
if (not (Proc.Parent is TPasMembersType))
or (ptmStatic in Proc.ProcType.Modifiers) then
begin
// not an "of object" method -> simply use the function

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

@ -1028,10 +1028,11 @@ type
protected
// specialize
FPendingSpecialize: TPCUReaderPendingSpecialized; // chain of TPCUReaderPendingSpecialized
function FindPendingSpecialize(Id: integer): TPCUReaderPendingSpecialized;
function AddPendingSpecialize(Id: integer; const SpecName: string): TPCUReaderPendingSpecialized;
function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing
function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing, Note: needs ResolvePendingIdentifierScopes
procedure DeletePendingSpecialize(PendSpec: TPCUReaderPendingSpecialized);
procedure PromiseSpecialize(SpecId: integer; El: TPasElement; const SpecName: string); virtual;
function PromiseSpecialize(SpecId: integer; const SpecName: string; RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized; virtual;
procedure ResolveSpecializedElements(Complete: boolean);
protected
// json
@ -5418,9 +5419,20 @@ begin
RaiseMsg(20200514130809,SpecData.Element,GetObjPath(RefEl));
end;
function TPCUReader.FindPendingSpecialize(Id: integer
): TPCUReaderPendingSpecialized;
begin
Result:=FPendingSpecialize;
while (Result<>nil) and (Result.Id<>Id) do
Result:=Result.Next;
end;
function TPCUReader.AddPendingSpecialize(Id: integer; const SpecName: string
): TPCUReaderPendingSpecialized;
begin
if FindPendingSpecialize(Id)<>nil then
RaiseMsg(20201022214051,SpecName+'='+IntToStr(Id));
Result:=TPCUReaderPendingSpecialized.Create;
if FPendingSpecialize<>nil then
begin
@ -5444,21 +5456,26 @@ var
GenericEl: TPasGenericType;
begin
Result:=false;
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.CreateSpecializedElement Gen=',GetObjPath(PendSpec.GenericEl));
{$ENDIF}
if PendSpec.RefEl=nil then
begin
if PendSpec.GenericEl=nil then
RaiseMsg(20200531101241,PendSpec.SpecName)
else
RaiseMsg(20200531101105,PendSpec.GenericEl);// nothing uses this specialize
RaiseMsg(20200531101105,PendSpec.GenericEl,PendSpec.SpecName);// nothing uses this specialize
end;
if PendSpec.GenericEl=nil then
RaiseMsg(20200531101333,PendSpec.RefEl);
RaiseMsg(20200531101333,PendSpec.RefEl,PendSpec.SpecName);
Obj:=PendSpec.Obj;
if Obj=nil then
RaiseMsg(20200531101128,PendSpec.GenericEl); // specialize missing in JSON
RaiseMsg(20200531101128,PendSpec.GenericEl,PendSpec.SpecName); // specialize missing in JSON
// resolve params
RefParams:=PendSpec.Params;
if RefParams=nil then
RaiseMsg(20201022215141,PendSpec.GenericEl,PendSpec.SpecName);
for i:=0 to RefParams.Count-1 do
begin
Param:=TPCUReaderPendingSpecializedParam(RefParams[i]);
@ -5501,25 +5518,18 @@ begin
PendSpec.Free;
end;
procedure TPCUReader.PromiseSpecialize(SpecId: integer; El: TPasElement;
const SpecName: string);
var
PendSpec: TPCUReaderPendingSpecialized;
function TPCUReader.PromiseSpecialize(SpecId: integer; const SpecName: string;
RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized;
begin
PendSpec:=FPendingSpecialize;
while PendSpec<>nil do
begin
if PendSpec.Id=SpecId then
break;
PendSpec:=PendSpec.Next;
end;
Result:=FindPendingSpecialize(SpecId);
if Result=nil then
Result:=AddPendingSpecialize(SpecId,SpecName)
else if Result.SpecName<>SpecName then
RaiseMsg(20200531093342,ErrorEl,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+Result.SpecName+'"');
if PendSpec=nil then
PendSpec:=AddPendingSpecialize(SpecId,SpecName)
else if PendSpec.SpecName<>SpecName then
RaiseMsg(20200531093342,El,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+PendSpec.SpecName+'"');
if PendSpec.RefEl=nil then
PendSpec.RefEl:=El;
if Result.RefEl=nil then
Result.RefEl:=RefEl;
// Note: cannot specialize before ResolvePendingIdentifierScopes;
end;
procedure TPCUReader.ResolveSpecializedElements(Complete: boolean);
@ -5541,7 +5551,7 @@ begin
if Ref<>nil then
PendSpec.RefEl:=GetReferrerEl(Ref.Pending);
end;
if PendSpec.RefEl<>nil then
if (PendSpec.RefEl<>nil) and (PendSpec.GenericEl<>nil) then
begin
if CreateSpecializedElement(PendSpec) then
Changed:=true
@ -5554,8 +5564,20 @@ begin
if Complete then
UnresolvedSpec:=FPendingSpecialize;
if UnresolvedSpec<>nil then
begin
{$IF defined(VerbosePJUFiler) or defined(VerbosePas2JS)}
PendSpec:=FPendingSpecialize;
while PendSpec<>nil do
begin
{AllowWriteln}
writeln('TPCUReader.ResolveSpecializedElements PENDING: ',PendSpec.SpecName+' Id='+IntToStr(PendSpec.Id)+' RefEl='+GetObjPath(PendSpec.RefEl)+' GenericEl='+GetObjPath(PendSpec.GenericEl));;
{AllowWriteln-}
PendSpec:=PendSpec.Next;
end;
{$ENDIF}
// a pending specialize cannot resolve its params
RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl));
RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl)+' GenericEl='+GetObjPath(UnresolvedSpec.GenericEl));
end;
end;
procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
@ -5738,15 +5760,15 @@ end;
function TPCUReader.AddElReference(Id: integer; ErrorEl: TPasElement;
El: TPasElement): TPCUFilerElementRef;
var
{$IF defined(VerbosePCUFiler) or defined(memcheck)}
Node: TAVLTreeNode;
{$ENDIF}
Ref: TPCUFilerElementRef;
RefItem: TPCUFilerPendingElRef;
PendingElRef: TPCUReaderPendingElRef;
PendingElListRef: TPCUReaderPendingElListRef;
PendingElArrRef: TPCUReaderPendingElArrRef;
{$IF defined(VerbosePCUFiler) or defined(memcheck)}
Node: TAVLTreeNode;
PendingElScopeRef: TPCUReaderPendingElScopeRef;
{$ENDIF}
begin
if Id<=0 then
RaiseMsg(20180207151233,ErrorEl);
@ -6575,7 +6597,7 @@ begin
if not ReadString(Obj,'SpecName',SpecName,GenEl) then
RaiseMsg(20200531085133,GenEl);
PendSpec:=AddPendingSpecialize(Id,SpecName);
PendSpec:=PromiseSpecialize(Id,SpecName,nil,GenEl);
PendSpec.Obj:=Obj;
PendSpec.GenericEl:=GenEl;
@ -6596,6 +6618,11 @@ begin
PendParam.Index:=i;
PendParam.Id:=Id;
end;
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.ReadSpecialization Id=',PendSpec.Id,' GenEl=',GetObjPath(PendSpec.GenericEl),' SpecName=',PendSpec.SpecName,' ElRef=',GetObjPath(PendSpec.RefEl));
{$ENDIF}
// Note: cannot specialize before ResolvePendingIdentifierScopes;
end;
procedure TPCUReader.ReadExternalReferences(Obj: TJSONObject; El: TPasElement);
@ -8121,7 +8148,7 @@ procedure TPCUReader.ReadSpecializeType(Obj: TJSONObject;
var
GenType: TPasGenericType;
GenericTemplateTypes: TFPList;
ExpName: string;
SpecName: string;
i, SpecId: Integer;
Data: TPasSpecializeTypeData;
begin
@ -8153,12 +8180,12 @@ begin
PromiseSetElReference(SpecId,@Set_SpecializeTypeData,Data,El);
// check old specialized name
if not ReadString(Obj,'SpecName',ExpName,El) then
if not ReadString(Obj,'SpecName',SpecName,El) then
RaiseMsg(20200219122919,El);
if ExpName='' then
if SpecName='' then
RaiseMsg(20200530134152,El);
PromiseSpecialize(SpecId,El,ExpName);
PromiseSpecialize(SpecId,SpecName,El,El);
end;
procedure TPCUReader.ReadInlineSpecializeExpr(Obj: TJSONObject;

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

@ -84,6 +84,8 @@ type
procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredProcTypeScope(const Path: string; Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredArrayScope(const Path: string; Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredPrecompiledJS(const Path: string; OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags); virtual;
@ -218,13 +220,11 @@ type
procedure TestPC_GenericFunction_AnonymousProc;
procedure TestPC_GenericClass;
procedure TestPC_GenericMethod;
// ToDo: GenericMethod Calls, ProcTypes
procedure TestPC_SpecializeClassSameUnit;
procedure TestPC_Specialize_LocalTypeInUnit;
// ToDo: specialize local generic type via class forward
// ToDo: inline specialize local generic type in unit interface
// ToDo: inline specialize local generic type in unit implementation
// ToDo: inline specialize local generic type in proc decl
// ToDo: inline specialize local generic type in proc body
procedure TestPC_Specialize_ClassForward;
procedure TestPC_InlineSpecialize_LocalTypeInUnit;
// ToDo: specialize extern generic type in unit interface
// ToDo: specialize extern generic type in unit implementation
// ToDo: specialize extern generic type in proc decl
@ -253,7 +253,7 @@ var
Ref1: TPasScopeReference absolute Item1;
Ref2: TPasScopeReference absolute Item2;
begin
Result:=CompareText(Ref1.Element.Name,Ref2.Element.Name);
Result:=CompareText(GetObjPath(Ref1.Element),GetObjPath(Ref2.Element));
if Result<>0 then exit;
Result:=ComparePointer(Ref1.Element,Ref2.Element);
end;
@ -644,11 +644,31 @@ procedure TCustomTestPrecompile.CheckRestoredDeclarations(const Path: string;
and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil);
end;
function GetSubPath(const Path: string; OrigIndex: integer; OrigDecl: TPasElement): string;
begin
Result:=Path+'['+IntToStr(OrigIndex)+']';
if OrigDecl.Name<>'' then
Result:=Result+'"'+OrigDecl.Name+'"'
else
Result:=Result+'?noname?';
end;
{ procedure WriteList;
var
i: Integer;
begin
writeln('CheckRestoredDeclarations.WriteList');
for i:=0 to Orig.Declarations.Count-1 do
if i<Rest.Declarations.Count then
writeln(' ',i,' Orig=',TPasElement(Orig.Declarations[i]).Name,' Rest=',TPasElement(Rest.Declarations[i]).Name);
end;}
var
OrigIndex, RestIndex: Integer;
OrigDecl, RestDecl: TPasElement;
SubPath: String;
begin
//WriteList;
// check non specializations
RestIndex:=0;
for OrigIndex:=0 to Orig.Declarations.Count-1 do
@ -656,12 +676,8 @@ begin
OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
if IsSpecialization(OrigDecl) then
continue;
SubPath:=Path+'['+IntToStr(OrigIndex)+']';
if OrigDecl.Name<>'' then
SubPath:=SubPath+'"'+OrigDecl.Name+'"'
else
SubPath:=SubPath+'?noname?';
// skip to next non specializations in restored declarations
SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
// skip to next non specialization in restored declarations
while RestIndex<Rest.Declarations.Count do
begin
RestDecl:=TPasElement(Rest.Declarations[RestIndex]);
@ -682,11 +698,7 @@ begin
OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
if not IsSpecialization(OrigDecl) then
continue;
SubPath:=Path+'['+IntToStr(OrigIndex)+']';
if OrigDecl.Name<>'' then
SubPath:=SubPath+'"'+OrigDecl.Name+'"'
else
SubPath:=SubPath+'?noname?';
SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
// search specialization with same name
RestIndex:=0;
repeat
@ -699,14 +711,33 @@ begin
until false;
if (OrigIndex<Rest.Declarations.Count) and (OrigIndex<>RestIndex) then
begin
// move restored element to original place to generate the same JS
Rest.Declarations.Move(RestIndex,OrigIndex);
//writeln('TCustomTestPrecompile.CheckRestoredDeclarations Orig[',OrigIndex,']=',GetObjName(OrigDecl),' Rest[',RestIndex,']=',GetObjName(RestDecl));
if RestIndex>OrigIndex then
Rest.Declarations.Move(RestIndex,OrigIndex)
else
Rest.Declarations.Exchange(RestIndex,OrigIndex);
//writeln('TCustomTestPrecompile.CheckRestoredDeclarations RestIndex=',RestIndex,' ->',OrigIndex);
//WriteList;
end;
// check
CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
end;
AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count);
//WriteList;
for OrigIndex:=0 to Orig.Declarations.Count-1 do
begin
OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
RestDecl:=TPasElement(Rest.Declarations[OrigIndex]);
if OrigDecl.Name<>RestDecl.Name then
begin
SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
AssertEquals(SubPath+'.Name',GetObjPath(OrigDecl),GetObjPath(RestDecl));
end;
end;
end;
procedure TCustomTestPrecompile.CheckRestoredSection(const Path: string; Orig,
@ -889,6 +920,8 @@ procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
begin
CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
@ -962,6 +995,9 @@ begin
end;
CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string;
@ -998,6 +1034,29 @@ begin
begin
// ImplProc
end;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredProcTypeScope(const Path: string;
Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags);
begin
if Path='' then ;
if Flags=[] then ;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredArrayScope(const Path: string;
Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags);
begin
if Path='' then ;
if Flags=[] then ;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredPrecompiledJS(const Path: string;
@ -1224,6 +1283,10 @@ begin
CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags)
else if C=TPas2JSProcedureScope then
CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest),Flags)
else if C=TPas2JSArrayScope then
CheckRestoredArrayScope(Path+'[TPas2JSArrayScope]',TPas2JSArrayScope(Orig),TPas2JSArrayScope(Rest),Flags)
else if C=TPas2JSProcTypeScope then
CheckRestoredProcTypeScope(Path+'[TPas2JSProcTypeScope]',TPas2JSProcTypeScope(Orig),TPas2JSProcTypeScope(Rest),Flags)
else if C=TPasPropertyScope then
CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest),Flags)
else if C=TPasGenericParamsScope then
@ -3241,27 +3304,97 @@ begin
' TBird<T> = class',
' a: T;',
' end;',
//' TDoubleBird = TBIrd<double>;',
//'var',
//' db: TDoubleBird;',
' TDoubleBird = TBIrd<double>;',
'var',
' db: TDoubleBird;',
'procedure Fly;',
'implementation',
'type',
' TWordBird = TBird<word>;',
'procedure Run;',
//'type TShortIntBird = TBird<shortint>;',
'type TShortIntBird = TBird<shortint>;',
'var',
//' shb: TShortIntBird;',
' shb: TShortIntBird;',
' wb: TWordBird;',
'begin',
//' shb.a:=3;',
' shb.a:=3;',
' wb.a:=4;',
'end;',
'procedure Fly;',
//'type TByteBird = TBird<byte>;',
//'var bb: TByteBird;',
'type TByteBird = TBird<byte>;',
'var bb: TByteBird;',
'begin',
//' bb.a:=5;',
' bb.a:=5;',
' Run;',
'end;',
'begin',
'']);
WriteReadUnit;
end;
procedure TTestPrecompile.TestPC_Specialize_ClassForward;
begin
StartUnit(false);
Add([
'{$mode delphi}',
'interface',
'type',
' TObject = class',
' end;',
' TBird<T> = class;',
' TAnt = class',
' b: TBird<word>;',
' end;',
' TBird<T> = class',
' a: TAnt;',
' end;',
'procedure Fly;',
'implementation',
'procedure Fly;',
'var b: TBird<Double>;',
'begin',
' b.a:=nil;',
'end;',
'begin',
'']);
WriteReadUnit;
end;
procedure TTestPrecompile.TestPC_InlineSpecialize_LocalTypeInUnit;
begin
StartUnit(false);
Add([
'{$mode delphi}',
'interface',
'type',
' TObject = class',
' constructor Create;',
' end;',
' TBird<T> = class',
' a: T;',
' end;',
'var',
' db: TBIrd<double>;',
'procedure Fly;',
'implementation',
'constructor TObject.Create;',
'begin',
'end;',
'var wb: TBird<word>;',
'procedure Run;',
'var',
' shb: TBird<shortint>;',
' bb: TBird<boolean>;',
'begin',
' shb.a:=3;',
' wb.a:=4;',
' bb.a:=true;',
' TBird<string>.Create;',
'end;',
'procedure Fly;',
'var lb: TBird<longint>;',
'begin',
' lb.a:=5;',
' Run;',
'end;',
'begin',

20
rtl/inc/iso7185.pp
View File

@ -44,6 +44,8 @@ unit iso7185;
Procedure Get(Var t: Text);
Procedure Put(Var t: Text);
procedure Get;
Procedure Put;
Procedure Get(Var f: TypedFile);
Procedure Put(Var f: TypedFile);
@ -204,6 +206,24 @@ unit iso7185;
end;
procedure Get;[IOCheck];
var
c : char;
Begin
Read(input,c);
End;
Procedure Put;[IOCheck];
type
FileFunc = Procedure(var t : TextRec);
begin
inc(TextRec(Output).BufPos);
If TextRec(Output).BufPos>=TextRec(Output).BufSize Then
FileFunc(TextRec(Output).InOutFunc)(TextRec(Output));
end;
procedure Get(var f:TypedFile);[IOCheck];
Begin
if not(system.eof(f)) then

8
tests/webtbs/tw37878.pp Normal file
View File

@ -0,0 +1,8 @@
{$mode objfpc}
var i64: int64; w: word;
begin
{$Q+}
w := 4096;
i64 := 8191;
i64 := i64 - 2*int64(w);
end.

6
tests/webtbs/tw37949.pp Normal file
View File

@ -0,0 +1,6 @@
{$MODE ISO}
program p(input, output);
begin
get;
put
end.