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

* synchronized with trunk

Browse Source 
git-svn-id: branches/unicodekvm@48847 -
This commit is contained in:
nickysn 2021-03-01 13:24:49 +00:00
commit 685d608f82
57 changed files with 973 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -14541,6 +14541,7 @@ tests/test/talign1.pp svneol=native#text/plain
tests/test/talign2.pp svneol=native#text/plain
tests/test/taligned1.pp svneol=native#text/pascal
tests/test/tand1.pp svneol=native#text/plain
tests/test/tandorandnot1.pp svneol=native#text/pascal
tests/test/targ1a.pp svneol=native#text/plain
tests/test/targ1b.pp svneol=native#text/plain
tests/test/tarray1.pp svneol=native#text/plain
@ -16791,6 +16792,8 @@ tests/webtbf/tw38287.pp svneol=native#text/pascal
tests/webtbf/tw38289a.pp svneol=native#text/pascal
tests/webtbf/tw38289b.pp svneol=native#text/pascal
tests/webtbf/tw38439.pp svneol=native#text/pascal
tests/webtbf/tw38504.pp svneol=native#text/pascal
tests/webtbf/tw38504b.pp svneol=native#text/pascal
tests/webtbf/tw3930a.pp svneol=native#text/plain
tests/webtbf/tw3931b.pp svneol=native#text/plain
tests/webtbf/tw3969.pp svneol=native#text/plain
@ -18591,6 +18594,7 @@ tests/webtbs/tw36196.pp svneol=native#text/pascal
tests/webtbs/tw3621.pp svneol=native#text/plain
tests/webtbs/tw36212.pp svneol=native#text/pascal
tests/webtbs/tw36215.pp svneol=native#text/pascal
tests/webtbs/tw36250.pp svneol=native#text/plain
tests/webtbs/tw3628.pp svneol=native#text/plain
tests/webtbs/tw3634.pp svneol=native#text/plain
tests/webtbs/tw36381.pp svneol=native#text/plain
@ -18739,6 +18743,8 @@ tests/webtbs/tw3841.pp svneol=native#text/plain
tests/webtbs/tw38412.pp svneol=native#text/pascal
tests/webtbs/tw38413.pp svneol=native#text/pascal
tests/webtbs/tw38429.pp svneol=native#text/pascal
tests/webtbs/tw38497.pp svneol=native#text/pascal
tests/webtbs/tw38527.pp svneol=native#text/plain
tests/webtbs/tw3863.pp svneol=native#text/plain
tests/webtbs/tw3864.pp svneol=native#text/plain
tests/webtbs/tw3865.pp svneol=native#text/plain

4
compiler/Makefile
View File

@ -5052,7 +5052,9 @@ endif
cycledep:
$(MAKE) cycle USEDEPEND=1
extcycle:
$(MAKE) cycle OPT="$(OPT) -n -OG2p3 -glttt -CRriot -dEXTDEBUG" ALLOW_WARNINGS=1
$(MAKE) cycle OPT="$(OPT) -n -glttt -CRriot -dEXTDEBUG" ALLOW_WARNINGS=1
extoptcycle:
$(MAKE) cycle OPT="$(OPT) -n -glttt -CRriot -dEXTDEBUG -dDEBUG_ALL_OPT" ALLOW_WARNINGS=1
cvstest:
$(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se'
ifeq ($(findstring -dFPC_SOFT_FPUX80,$(LOCALOPT)),)

5
compiler/Makefile.fpc
View File

@ -1024,7 +1024,10 @@ cycledep:
# extcycle should still work, but generates
# lots of warnings, so ALLOW_WARNINGS=1 is required
extcycle:
$(MAKE) cycle OPT="$(OPT) -n -OG2p3 -glttt -CRriot -dEXTDEBUG" ALLOW_WARNINGS=1
$(MAKE) cycle RTLOPT="$(RTLOPT) -n -glttt -CRriot -dEXTDEBUG" LOCALOPT="$(LOCALOPT) -n -glttt -CRriot -dEXTDEBUG" ALLOW_WARNINGS=1
extoptcycle:
$(MAKE) cycle RTLOPT="$(RTLOPT) -n -glttt -CRriot -dEXTDEBUG -dDEBUG_ALL_OPT" LOCALOPT="$(LOCALOPT) -n -glttt -CRriot -dEXTDEBUG -dDEBUG_ALL_OPT" ALLOW_WARNINGS=1
cvstest:
$(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se'

11
compiler/aarch64/racpugas.pas
View File

@ -556,6 +556,10 @@ Unit racpugas;
function taarch64attreader.ToConditionCode(const hs: string; is_operand: boolean): tasmcond;
{$push}{$j-}
const
extracond2str: array[C_HS..C_LO] of string[2] = ('CS','CC');
{$pop}
begin
case actopcode of
A_CSEL,A_CSINC,A_CSINV,A_CSNEG,A_CSET,A_CSETM,
@ -568,11 +572,16 @@ Unit racpugas;
begin
{ workaround for DFA bug }
result:=low(tasmcond);
for result:=low(tasmcond) to high(tasmcond) do
for result:=low(uppercond2str) to high(uppercond2str) do
begin
if hs=uppercond2str[result] then
exit;
end;
for result:=low(extracond2str) to high(extracond2str) do
begin
if hs=extracond2str[result] then
exit;
end;
end;
end;
else

4
compiler/aasmcnst.pas
View File

@ -1584,7 +1584,9 @@ implementation
class function ttai_typedconstbuilder.is_smartlink_vectorized_dead_strip: boolean;
begin
result:=tf_smartlink_sections in target_info.flags;
result:=(tf_smartlink_sections in target_info.flags) and
(not(target_info.system in systems_darwin) or
(tf_supports_symbolorderfile in target_info.flags));
end;

15
compiler/cgexcept.pas
View File

@ -129,12 +129,13 @@ unit cgexcept;
be modified, all temps should be allocated on the heap instead of the
stack. }
class procedure tcgexceptionstatehandler.get_exception_temps(list:TAsmList;var t:texceptiontemps);
begin
begin
if not assigned(exceptionreasontype) then
exceptionreasontype:=search_system_proc('fpc_setjmp').returndef;
tg.gethltemp(list,rec_exceptaddr,rec_exceptaddr.size,tt_persistent,t.envbuf);
tg.gethltemp(list,rec_jmp_buf,rec_jmp_buf.size,tt_persistent,t.jmpbuf);
tg.gethltemp(list,ossinttype,ossinttype.size,tt_persistent,t.reasonbuf);
tg.gethltemp(list,exceptionreasontype,exceptionreasontype.size,tt_persistent,t.reasonbuf);
end;
@ -207,7 +208,7 @@ unit cgexcept;
location_reset(tmpresloc,LOC_REGISTER,def_cgsize(setjmpres.def));
tmpresloc.register:=hlcg.getintregister(list,setjmpres.def);
hlcg.gen_load_cgpara_loc(list,setjmpres.def,setjmpres,tmpresloc,true);
hlcg.g_exception_reason_save(list,setjmpres.def,ossinttype,tmpresloc.register,t.reasonbuf);
hlcg.g_exception_reason_save(list,setjmpres.def,exceptionreasontype,tmpresloc.register,t.reasonbuf);
{ if we get 1 here in the function result register, it means that we
longjmp'd back here }
hlcg.a_cmp_const_reg_label(list,setjmpres.def,OC_NE,0,tmpresloc.register,exceptstate.exceptionlabel);
@ -237,9 +238,9 @@ unit cgexcept;
popaddrstack(list);
if not onlyfree then
begin
reasonreg:=hlcg.getintregister(list,osuinttype);
hlcg.g_exception_reason_load(list,osuinttype,osuinttype,t.reasonbuf,reasonreg);
hlcg.a_cmp_const_reg_label(list,osuinttype,OC_EQ,a,reasonreg,endexceptlabel);
reasonreg:=hlcg.getintregister(list,exceptionreasontype);
hlcg.g_exception_reason_load(list,exceptionreasontype,exceptionreasontype,t.reasonbuf,reasonreg);
hlcg.a_cmp_const_reg_label(list,exceptionreasontype,OC_EQ,a,reasonreg,endexceptlabel);
end;
end;

7
compiler/cutils.pas
View File

@ -1298,9 +1298,10 @@ implementation
{ if one of the two is at the end while the other isn't, add a '.0' }
if (i1>length(s1)) and
(i2<=length(s2)) then
s1:=s1+'.0'
else if i2>length(s2) then
s2:=s2+'.0';
s1:=s1+'.0';
if (i2>length(s2)) and
(i1<=length(s1)) then
s2:=s2+'.0';
{ compare non-numerical characters normally }
while (i1<=length(s1)) and
not(s1[i1] in ['0'..'9']) and

6
compiler/dbgdwarf.pas
View File

@ -4521,6 +4521,12 @@ implementation
begin
case def.objecttype of
odt_objcclass,
odt_objcprotocol:
begin
inherited;
exit
end;
odt_cppclass,
odt_object:
begin

12
compiler/defutil.pas
View File

@ -149,6 +149,9 @@ interface
{# Returns true, if p points to an array of const }
function is_array_of_const(p : tdef) : boolean;
{# Returns true if p is an arraydef that describes a constant string }
function is_conststring_array(p : tdef) : boolean;
{# Returns true, if p points any kind of special array
That is if the array is an open array, a variant
@ -796,8 +799,7 @@ implementation
range is also -1 ! (PFV) }
result:=(p.typ=arraydef) and
(tarraydef(p).rangedef=sizesinttype) and
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=-1) and
(ado_OpenArray in tarraydef(p).arrayoptions) and
((tarraydef(p).arrayoptions * [ado_IsVariant,ado_IsArrayOfConst,ado_IsConstructor,ado_IsDynamicArray])=[]);
end;
@ -822,6 +824,12 @@ implementation
(ado_IsArrayOfConst in tarraydef(p).arrayoptions);
end;
function is_conststring_array(p: tdef): boolean;
begin
result:=(p.typ=arraydef) and
(ado_IsConstString in tarraydef(p).arrayoptions);
end;
{ true, if p points to a special array, bitpacked arrays aren't special in this regard though }
function is_special_array(p : tdef) : boolean;
begin

2
compiler/i386/n386add.pas
View File

@ -486,13 +486,13 @@ interface
begin
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EDX);
hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,osuinttype,right.location,NR_EDX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EDX);
reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
reghi:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
if use_ref then
current_asmdata.CurrAsmList.concat(Taicpu.Op_ref_reg_reg(A_MULX,S_L,ref,reglo,reghi))
else
emit_reg_reg_reg(A_MULX,S_L,reg,reglo,reghi);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EDX);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
location.register64.reglo:=reglo;

4
compiler/jvm/hlcgcpu.pas
View File

@ -2292,6 +2292,10 @@ implementation
{ a constructor doesn't actually return a value in the jvm }
if (tabstractprocdef(pd).proctypeoption=potype_constructor) then
totalremovesize:=paraheight
else if jvmimplicitpointertype(realresdef) then
totalremovesize:=paraheight-1
else if is_void(realresdef) then
totalremovesize:=paraheight
else
{ even a byte takes up a full stackslot -> align size to multiple of 4 }
totalremovesize:=paraheight-(align(realresdef.size,4) shr 2);

3
compiler/jvm/jvmdef.pas
View File

@ -517,7 +517,8 @@ implementation
result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or
is_open_array(def) or
is_array_of_const(def) or
is_array_constructor(def);
is_array_constructor(def) or
is_conststring_array(def);
filedef,
recorddef,
setdef:

2
compiler/llvm/llvmpi.pas
View File

@ -88,6 +88,8 @@ implementation
class procedure tllvmexceptionstatehandler.get_exception_temps(list: TAsmList; var t: texceptiontemps);
begin
if not assigned(exceptionreasontype) then
exceptionreasontype:=ossinttype;
tg.gethltemp(list,ossinttype,ossinttype.size,tt_persistent,t.reasonbuf);
end;

9
compiler/m68k/n68kmem.pas
View File

@ -35,7 +35,6 @@ interface
t68kvecnode = class(tcgvecnode)
procedure update_reference_reg_mul(maybe_const_reg: tregister; regsize: tdef; l: aint); override;
procedure update_reference_reg_packed(maybe_const_reg: tregister; regsize: tdef; l:aint); override;
function valid_index_size(size: tcgsize): boolean; override;
//procedure pass_generate_code;override;
end;
@ -55,14 +54,6 @@ implementation
T68KVECNODE
*****************************************************************************}
function t68kvecnode.valid_index_size(size: tcgsize): boolean;
begin
if (CPUM68K_HAS_INDEXWORD in cpu_capabilities[current_settings.cputype]) then
result:=tcgsize2signed[size] in [OS_S16,OS_S32]
else
result:=inherited;
end;
{ this routine must, like any other routine, not change the contents }
{ of base/index registers of references, as these may be regvars. }
{ The register allocator can coalesce one LOC_REGISTER being moved }

42
compiler/nadd.pas
View File

@ -489,6 +489,20 @@ implementation
end;
function IsAndOrAndNot(n1,n2,n3,n4 : tnode): Boolean;
begin
result:=(n4.nodetype=notn) and
tnotnode(n4).left.isequal(n2);
end;
function TransformAndOrAndNot(n1,n2,n3,n4 : tnode): tnode;
begin
result:=caddnode.create_internal(xorn,n3.getcopy,
caddnode.create_internal(andn,caddnode.create_internal(xorn,n3.getcopy,n1.getcopy),n2.getcopy));
end;
function SwapRightWithLeftRight : tnode;
var
hp : tnode;
@ -1689,6 +1703,28 @@ implementation
end;
end;
{$endif cpurox}
{ optimize
(a and b) or (c and not(b))
into
c xor ((c xor a) and b)
}
if (nodetype=orn) and
(left.resultdef.typ=orddef) and
(left.nodetype=andn) and
(right.nodetype=andn) and
{ this test is not needed but it speeds up the test and allows to bail out early }
((taddnode(left).left.nodetype=notn) or (taddnode(left).right.nodetype=notn) or
(taddnode(right).left.nodetype=notn) or (taddnode(right).right.nodetype=notn)
) and
not(might_have_sideeffects(self)) then
begin
if MatchAndTransformNodesCommutative(taddnode(left).left,taddnode(left).right,taddnode(right).left,taddnode(right).right,
@IsAndOrAndNot,@TransformAndOrAndNot,Result) then
exit;
end;
end;
end;
@ -1939,7 +1975,11 @@ implementation
not(tfloatdef(left.resultdef).floattype in [s64comp,s64currency]) then
begin
if cs_excessprecision in current_settings.localswitches then
resultrealdef:=pbestrealtype^
begin
resultrealdef:=pbestrealtype^;
inserttypeconv(right,resultrealdef);
inserttypeconv(left,resultrealdef);
end
else
resultrealdef:=left.resultdef
end

24
compiler/ncgflw.pas
View File

@ -542,7 +542,7 @@ implementation
{ we must also destroy the address frame which guards
the exception object }
cexceptionstatehandler.popaddrstack(list);
hlcg.g_exception_reason_discard(list,osuinttype,excepttemps.reasonbuf);
hlcg.g_exception_reason_discard(list,exceptionreasontype,excepttemps.reasonbuf);
if frametype=ft_except then
begin
cexceptionstatehandler.cleanupobjectstack(list);
@ -875,8 +875,8 @@ implementation
procedure tcgtryfinallynode.emit_jump_out_of_try_finally_frame(list: TasmList; const reason: byte; const finallycodelabel: tasmlabel; var excepttemps: tcgexceptionstatehandler.texceptiontemps; framelabel: tasmlabel);
begin
hlcg.a_label(list,framelabel);
hlcg.g_exception_reason_discard(list,osuinttype,excepttemps.reasonbuf);
hlcg.g_exception_reason_save_const(list,osuinttype,reason,excepttemps.reasonbuf);
hlcg.g_exception_reason_discard(list,exceptionreasontype,excepttemps.reasonbuf);
hlcg.g_exception_reason_save_const(list,exceptionreasontype,reason,excepttemps.reasonbuf);
hlcg.a_jmp_always(list,finallycodelabel);
end;
@ -936,13 +936,13 @@ implementation
procedure handle_breakcontinueexit(const finallycode: tasmlabel; doreraise: boolean);
begin
{ no exception happened, but maybe break/continue/exit }
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_EQ,0,reasonreg,endfinallylabel);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,exceptionreasontype,OC_EQ,0,reasonreg,endfinallylabel);
if fc_exit in finallyexceptionstate.newflowcontrol then
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_EQ,2,reasonreg,oldCurrExitLabel);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,exceptionreasontype,OC_EQ,2,reasonreg,oldCurrExitLabel);
if fc_break in finallyexceptionstate.newflowcontrol then
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_EQ,3,reasonreg,oldBreakLabel);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,exceptionreasontype,OC_EQ,3,reasonreg,oldBreakLabel);
if fc_continue in finallyexceptionstate.newflowcontrol then
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_EQ,4,reasonreg,oldContinueLabel);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,exceptionreasontype,OC_EQ,4,reasonreg,oldContinueLabel);
if doreraise then
cexceptionstatehandler.handle_reraise(current_asmdata.CurrAsmList,excepttemps,finallyexceptionstate,tek_normalfinally)
else
@ -1019,8 +1019,8 @@ implementation
exit;
if not implicitframe then
current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
reasonreg:=hlcg.getintregister(current_asmdata.CurrAsmList,osuinttype);
hlcg.g_exception_reason_load(current_asmdata.CurrAsmList,osuinttype,osuinttype,excepttemps.reasonbuf,reasonreg);
reasonreg:=hlcg.getintregister(current_asmdata.CurrAsmList,exceptionreasontype);
hlcg.g_exception_reason_load(current_asmdata.CurrAsmList,exceptionreasontype,exceptionreasontype,excepttemps.reasonbuf,reasonreg);
handle_breakcontinueexit(finallyNoExceptionLabel,false);
current_asmdata.CurrAsmList.concatList(tmplist);
@ -1058,11 +1058,11 @@ implementation
if not assigned(third) then
begin
{ the value should now be in the exception handler }
reasonreg:=hlcg.getintregister(current_asmdata.CurrAsmList,osuinttype);
hlcg.g_exception_reason_load(current_asmdata.CurrAsmList,osuinttype,osuinttype,excepttemps.reasonbuf,reasonreg);
reasonreg:=hlcg.getintregister(current_asmdata.CurrAsmList,exceptionreasontype);
hlcg.g_exception_reason_load(current_asmdata.CurrAsmList,exceptionreasontype,exceptionreasontype,excepttemps.reasonbuf,reasonreg);
if implicitframe then
begin
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_EQ,0,reasonreg,endfinallylabel);
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,exceptionreasontype,OC_EQ,0,reasonreg,endfinallylabel);
{ finally code only needed to be executed on exception (-> in
if-branch -> fc_inflowcontrol) }
if current_procinfo.procdef.generate_safecall_wrapper then

14
compiler/ncginl.pas
View File

@ -888,7 +888,8 @@ implementation
internalerror(2013120110);
end;
hlcg.location_force_reg(current_asmdata.CurrAsmList,op1.location,op1.resultdef,resultdef,true);
if not(op1.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
hlcg.location_force_reg(current_asmdata.CurrAsmList,op1.location,op1.resultdef,resultdef,true);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
@ -920,8 +921,10 @@ implementation
{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
if def_cgsize(resultdef) in [OS_64,OS_S64] then
begin
hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
op2.resultdef,alusinttype,true);
if not(op2.location.loc in [LOC_REGISTER,LOC_CREGISTER]) or
not(equal_defs(op2.resultdef,alusinttype)) then
hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
op2.resultdef,alusinttype,true);
cg64.a_op64_reg_reg_reg(current_asmdata.CurrAsmList,op,def_cgsize(resultdef),
joinreg64(op2.location.register,NR_NO),op1.location.register64,
location.register64);
@ -929,8 +932,9 @@ implementation
else
{$endif not cpu64bitalu and not cpuhighleveltarget}
begin
hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
op2.resultdef,resultdef,true);
if not(op2.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
op2.resultdef,resultdef,true);
hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,op,resultdef,
op2.location.register,op1.location.register,
location.register);

10
compiler/ncon.pas
View File

@ -948,20 +948,15 @@ implementation
dogetcopy:=n;
end;
function tstringconstnode.pass_typecheck:tnode;
var
l : aint;
begin
result:=nil;
case cst_type of
cst_conststring :
begin
{ handle and store as array[0..len-1] of char }
if len>0 then
l:=len-1
else
l:=0;
resultdef:=carraydef.create(0,l,s32inttype);
resultdef:=carraydef.create(0,len-1,s32inttype);
tarraydef(resultdef).elementdef:=cansichartype;
include(tarraydef(resultdef).arrayoptions,ado_IsConstString);
end;
@ -981,6 +976,7 @@ implementation
end;
end;
function tstringconstnode.pass_1 : tnode;
begin
result:=nil;

26
compiler/ngtcon.pas
View File

@ -328,6 +328,25 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
{$push}
{$r-}
{$q-}
{ to work around broken x86 shifting, while generating bitmask }
function getbitmask(len: byte): aword;
begin
if len >= (sizeof(result) * 8) then
result:=0
else
result:=aword(1) shl len;
result:=aword(result-1);
end;
{ shift left, and always pad the right bits with zeroes }
function shiftleft(value: aword; count: byte): aword;
begin
if count >= (sizeof(result) * 8) then
result:=0
else
result:=(value shl count) and (not getbitmask(count));
end;
{ (values between quotes below refer to fields of bp; fields not }
{ mentioned are unused by this routine) }
{ bitpacks "value" as bitpacked value of bitsize "packedbitsize" into }
@ -342,16 +361,15 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
if (target_info.endian=endian_big) then
begin
{ bitpacked format: left-aligned (i.e., "big endian bitness") }
{ work around broken x86 shifting }
if (AIntBits<>bp.packedbitsize) and
if (bp.packedbitsize<AIntBits) and
(bp.curbitoffset<AIntBits) then
bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
bp.curval:=bp.curval or (shiftleft(value,AIntBits-bp.packedbitsize) shr bp.curbitoffset);
shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
{ carry-over to the next element? }
if (shiftcount<0) then
begin
if shiftcount>=-AIntBits then
bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
bp.nextval:=(value and getbitmask(-shiftcount)) shl
(AIntBits+shiftcount)
else
bp.nextval:=0;

14
compiler/nmat.pas
View File

@ -97,7 +97,7 @@ implementation
systems,
verbose,globals,cutils,compinnr,
globtype,constexp,
symconst,symtype,symdef,
symconst,symtype,symdef,symcpu,
defcmp,defutil,
htypechk,pass_1,
cgbase,
@ -966,10 +966,18 @@ implementation
exit;
resultdef:=left.resultdef;
if (left.resultdef.typ=floatdef) or
is_currency(left.resultdef) then
if is_currency(left.resultdef) then
begin
end
else if left.resultdef.typ=floatdef then
begin
if not(tfloatdef(left.resultdef).floattype in [s64comp,s64currency]) and
(cs_excessprecision in current_settings.localswitches) then
begin
inserttypeconv(left,pbestrealtype^);
resultdef:=left.resultdef
end;
end
{$ifdef SUPPORT_MMX}
else if (cs_mmx in current_settings.localswitches) and
is_mmx_able_array(left.resultdef) then

8
compiler/nset.pas
View File

@ -247,6 +247,7 @@ implementation
begin
result:=nil;
resultdef:=pasbool1type;
typecheckpass(right);
set_varstate(right,vs_read,[vsf_must_be_valid]);
@ -269,6 +270,13 @@ implementation
if not assigned(left.resultdef) then
internalerror(20021126);
{ avoid any problems with type parameters later on }
if is_typeparam(left.resultdef) or is_typeparam(right.resultdef) then
begin
resultdef:=cundefinedtype;
exit;
end;
t:=self;
if isbinaryoverloaded(t,[]) then
begin

36
compiler/nutils.pas
View File

@ -186,11 +186,22 @@ interface
type
TMatchProc2 = function(n1,n2 : tnode) : Boolean is nested;
TTransformProc2 = function(n1,n2 : tnode) : tnode is nested;
TMatchProc4 = function(n1,n2,n3,n4 : tnode) : Boolean is nested;
TTransformProc4 = function(n1,n2,n3,n4 : tnode) : tnode is nested;
{ calls matchproc with n1 and n2 as parameters, if it returns true, transformproc is called, does the same with the nodes swapped,
the result of transformproc is assigned to res }
function MatchAndTransformNodesCommutative(n1,n2 : tnode;matchproc : TMatchProc2;transformproc : TTransformProc2;var res : tnode) : Boolean;
{ calls matchproc with n1, n2, n3 and n4 as parameters being considered as the leafs of commutative nodes so all 8 possible
combinations are tested, if it returns true, transformproc is called,
the result of transformproc is assigned to res
this allows to find pattern like (3*a)+(3*b) and transfrom them into 3*(a+b)
}
function MatchAndTransformNodesCommutative(n1,n2,n3,n4 : tnode;matchproc : TMatchProc4;transformproc : TTransformProc4;var res : tnode) : Boolean;
implementation
uses
@ -1642,4 +1653,29 @@ implementation
result:=false;
end;
function MatchAndTransformNodesCommutative(n1,n2,n3,n4 : tnode;matchproc : TMatchProc4;transformproc : TTransformProc4;var res : tnode) : Boolean;
begin
res:=nil;
result:=true;
if matchproc(n1,n2,n3,n4) then
res:=transformproc(n1,n2,n3,n4)
else if matchproc(n1,n2,n4,n3) then
res:=transformproc(n1,n2,n4,n3)
else if matchproc(n2,n1,n3,n4) then
res:=transformproc(n2,n1,n3,n4)
else if matchproc(n2,n1,n4,n3) then
res:=transformproc(n2,n1,n4,n3)
else if matchproc(n3,n4,n1,n2) then
res:=transformproc(n3,n4,n1,n2)
else if matchproc(n4,n3,n1,n2) then
res:=transformproc(n4,n3,n1,n2)
else if matchproc(n3,n4,n2,n1) then
res:=transformproc(n3,n4,n2,n1)
else if matchproc(n4,n3,n2,n1) then
res:=transformproc(n4,n3,n2,n1)
else
result:=false;
end;
end.

4
compiler/psabiehpi.pas
View File

@ -522,7 +522,9 @@ implementation
class procedure tpsabiehexceptionstatehandler.get_exception_temps(list: TAsmList; var t: texceptiontemps);
begin
tg.gethltemp(list,ossinttype,ossinttype.size,tt_persistent,t.reasonbuf);
if not assigned(exceptionreasontype) then
exceptionreasontype:=ossinttype;
tg.gethltemp(list,exceptionreasontype,exceptionreasontype.size,tt_persistent,t.reasonbuf);
end;

1
compiler/pstatmnt.pas
View File

@ -991,6 +991,7 @@ implementation
sym:=clocalvarsym.create('$exceptsym',vs_value,ot,[]);
end;
excepTSymtable:=tstt_excepTSymtable.create;
excepTSymtable.defowner:=current_procinfo.procdef;
excepTSymtable.insert(sym);
symtablestack.push(excepTSymtable);
end

2
compiler/psub.pas
View File

@ -466,7 +466,7 @@ implementation
cifnode.create(caddnode.create(equaln,
ccallnode.createintern('fpc_setjmp',
ccallparanode.create(cloadnode.create(tlabelsym(p).jumpbuf,tlabelsym(p).jumpbuf.owner),nil)),
cordconstnode.create(1,sinttype,true))
cordconstnode.create(1,search_system_proc('fpc_setjmp').returndef,true))
,cgotonode.create(tlabelsym(p)),nil)
);
end;

4
compiler/symconst.pas
View File

@ -572,7 +572,9 @@ type
ado_IsConstString, // string constant
ado_IsBitPacked, // bitpacked array
ado_IsVector, // Vector
ado_IsGeneric // the index of the array is generic (meaning that the size is not yet known)
ado_IsGeneric, // the index of the array is generic (meaning that the size is not yet known)
ado_OpenArray // open array, replaces the old hack with high being -1 for an open array:
// this is still true, but this flag is set as well
);
tarraydefoptions=set of tarraydefoption;

18
compiler/symdef.pas
View File

@ -1213,7 +1213,10 @@ interface
{ several types to simulate more or less C++ objects for GDB }
vmttype,
vmtarraytype,
pvmttype : tdef; { type of classrefs, used for stabs }
{ type of classrefs, used for stabs }
pvmttype,
{ return type of the setjmp function }
exceptionreasontype : tdef;
{ pointer to the anchestor of all classes }
class_tobject : tobjectdef;
@ -4154,6 +4157,7 @@ implementation
symtable:=tarraysymtable.create(self);
end;
constructor tarraydef.create_vector(l ,h: asizeint; def: tdef);
begin
self.create(l,h,def);
@ -4163,7 +4167,8 @@ implementation
constructor tarraydef.create_openarray;
begin
self.create(0,-1,sizesinttype)
self.create(0,-1,sizesinttype);
include(arrayoptions,ado_OpenArray);
end;
@ -4367,7 +4372,7 @@ implementation
end;
{ Tarraydef.size may never be called for an open array! }
if (highrange=-1) and (lowrange=0) then
if ado_OpenArray in arrayoptions then
internalerror(99080501);
if not (ado_IsBitPacked in arrayoptions) then
cachedelesize:=elesize
@ -4383,7 +4388,10 @@ implementation
if (cachedelecount = 0) then
begin
size := -1;
if ado_isconststring in arrayoptions then
size := 0
else
size := -1;
exit;
end;
@ -4472,7 +4480,7 @@ implementation
end
else if (ado_IsDynamicArray in arrayoptions) then
GetTypeName:='{Dynamic} Array Of '+elementdef.typename
else if ((highrange=-1) and (lowrange=0)) then
else if (ado_OpenArray in arrayoptions) then
GetTypeName:='{Open} Array Of '+elementdef.typename
else
begin

6
compiler/systems/i_darwin.pas
View File

@ -194,7 +194,7 @@ const
name : 'Darwin/iPhoneSim for i386';
shortname : 'iPhoneSim';
flags : [tf_p_ext_support,tf_files_case_sensitive,tf_smartlink_sections,tf_dwarf_relative_addresses,tf_dwarf_only_local_labels,
tf_pic_uses_got,tf_pic_default,tf_has_winlike_resources,tf_use_hlcfi,tf_supports_hidden_symbols];
tf_pic_uses_got,tf_pic_default,tf_has_winlike_resources,tf_use_hlcfi,tf_supports_symbolorderfile,tf_supports_hidden_symbols];
cpu : cpu_i386;
unit_env : 'BSDUNITS';
extradefines : 'UNIX;BSD;HASUNIX;DARWIN'; // also define darwin for code compatibility
@ -263,7 +263,7 @@ const
name : 'Darwin for PowerPC64';
shortname : 'Darwin';
flags : [tf_p_ext_support,tf_files_case_sensitive,tf_smartlink_sections,tf_dwarf_relative_addresses,tf_dwarf_only_local_labels,
tf_pic_default,tf_has_winlike_resources,tf_supports_symbolorderfile,tf_supports_hidden_symbols];
tf_pic_default,tf_has_winlike_resources,tf_supports_hidden_symbols];
cpu : cpu_powerpc64;
unit_env : 'BSDUNITS';
extradefines : 'UNIX;BSD;HASUNIX';
@ -400,7 +400,7 @@ const
name : 'Darwin/iPhoneSim for x86_64';
shortname : 'iPhoneSim';
flags : [tf_p_ext_support,tf_files_case_sensitive,tf_smartlink_sections,tf_dwarf_relative_addresses,tf_dwarf_only_local_labels,
tf_pic_default,tf_has_winlike_resources,tf_use_hlcfi,tf_supports_hidden_symbols];
tf_pic_default,tf_has_winlike_resources,tf_use_hlcfi,tf_supports_symbolorderfile,tf_supports_hidden_symbols];
cpu : cpu_x86_64;
unit_env : 'BSDUNITS';
extradefines : 'UNIX;BSD;HASUNIX;DARWIN'; // also define darwin for code compatibility

10
compiler/systems/i_linux.pas
View File

@ -227,17 +227,17 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 0;
constalignmax : 4;
constalignmax : 16;
varalignmin : 0;
varalignmax : 4;
varalignmax : 16;
localalignmin : 4;
localalignmax : 4;
localalignmax : 8;
recordalignmin : 0;
recordalignmax : 4;
recordalignmax : 16;
maxCrecordalign : 2;
);
first_parm_offset : 8;
stacksize : 32*1024*1024;
stacksize : 8*1024*1024;
stackalign : 4;
abi : abi_default;
llvmdatalayout : 'todo';

3
compiler/utils/ppuutils/ppudump.pp
View File

@ -3284,7 +3284,8 @@ const
{ ado_IsConstString } 'ConstString',
{ ado_IsBitPacked } 'BitPacked',
{ ado_IsVector } 'Vector',
{ ado_IsGeneric } 'Generic'
{ ado_IsGeneric } 'Generic',
{ ado_OpenArray } 'OpenArray'
);
var
symoptions: tarraydefoptions;

363
compiler/x86/aoptx86.pas
View File

@ -3360,67 +3360,168 @@ unit aoptx86;
if (taicpu(p).oper[1]^.reg <> NR_STACK_POINTER_REG) and
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[1]^.reg) then
begin
{ changes
lea offset1(regX), reg1
lea offset2(reg1), reg1
to
lea offset1+offset2(regX), reg1 }
{ Check common LEA/LEA conditions }
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) or
((taicpu(p).oper[0]^.ref^.base=taicpu(p).oper[0]^.ref^.base) and
(taicpu(p).oper[0]^.ref^.index=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
(taicpu(p).oper[1]^.reg = taicpu(hp1).oper[1]^.reg) 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^.relsymbol = nil) and
(taicpu(hp1).oper[0]^.ref^.segment = NR_NO) and
(taicpu(hp1).oper[0]^.ref^.symbol = nil) and
(
(taicpu(p).oper[0]^.ref^.base = NR_NO) or { Don't call RegModifiedBetween unnecessarily }
not(RegModifiedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1))
) and (
(taicpu(p).oper[0]^.ref^.index = taicpu(p).oper[0]^.ref^.base) or { Don't call RegModifiedBetween unnecessarily }
(taicpu(p).oper[0]^.ref^.index = NR_NO) or
not(RegModifiedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1))
) then
begin
DebugMsg(SPeepholeOptimization + 'LeaLea2Lea done',p);
if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg then
{ changes
lea (regX,scale), reg1
lea offset(reg1,reg1), reg1
to
lea offset(regX,scale*2), reg1
and
lea (regX,scale1), reg1
lea offset(reg1,scale2), reg1
to
lea offset(regX,scale1*scale2), reg1
... so long as the final scale does not exceed 8
(Similarly, allow the first instruction to be "lea (regX,regX),reg1")
}
if (taicpu(p).oper[0]^.ref^.offset = 0) and
(taicpu(hp1).oper[0]^.ref^.index = taicpu(p).oper[1]^.reg) and
(
(
(taicpu(p).oper[0]^.ref^.base = NR_NO)
) or (
(taicpu(p).oper[0]^.ref^.scalefactor <= 1) and
(
(taicpu(p).oper[0]^.ref^.base = taicpu(p).oper[0]^.ref^.index) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index, p, hp1))
)
)
) and (
(
{ lea (reg1,scale2), reg1 variant }
(taicpu(hp1).oper[0]^.ref^.base = NR_NO) and
(
(
(taicpu(p).oper[0]^.ref^.base = NR_NO) and
(taicpu(hp1).oper[0]^.ref^.scalefactor * taicpu(p).oper[0]^.ref^.scalefactor <= 8)
) or (
{ lea (regX,regX), reg1 variant }
(taicpu(p).oper[0]^.ref^.base <> NR_NO) and
(taicpu(hp1).oper[0]^.ref^.scalefactor <= 4)
)
)
) or (
{ lea (reg1,reg1), reg1 variant }
(taicpu(hp1).oper[0]^.ref^.base = taicpu(p).oper[1]^.reg) and
(taicpu(hp1).oper[0]^.ref^.scalefactor <= 1)
)
) 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 2 done',p);
{ Make everything homogeneous to make calculations easier }
if (taicpu(p).oper[0]^.ref^.base <> NR_NO) 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);
if taicpu(p).oper[0]^.ref^.index <> NR_NO then
{ Convert lea (regX,regX),reg1 to lea (regX,2),reg1 }
taicpu(p).oper[0]^.ref^.scalefactor := 2
else
taicpu(p).oper[0]^.ref^.index := taicpu(p).oper[0]^.ref^.base;
taicpu(p).oper[0]^.ref^.base := NR_NO;
end;
if (taicpu(hp1).oper[0]^.ref^.base = NR_NO) then
begin
{ Just to prevent miscalculations }
if (taicpu(hp1).oper[0]^.ref^.scalefactor = 0) then
taicpu(hp1).oper[0]^.ref^.scalefactor := taicpu(p).oper[0]^.ref^.scalefactor
else
taicpu(hp1).oper[0]^.ref^.scalefactor := taicpu(hp1).oper[0]^.ref^.scalefactor * taicpu(p).oper[0]^.ref^.scalefactor;
end
else
begin
taicpu(hp1).oper[0]^.ref^.base := NR_NO;
taicpu(hp1).oper[0]^.ref^.scalefactor := taicpu(p).oper[0]^.ref^.scalefactor * 2;
end;
taicpu(hp1).oper[0]^.ref^.index := taicpu(p).oper[0]^.ref^.index;
RemoveCurrentP(p);
result:=true;
exit;
end
else
{ changes
lea offset1(regX), reg1
lea offset2(reg1), reg1
to
lea offset1+offset2(regX), reg1 }
else if
(
(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^.index = NR_NO) or
(taicpu(p).oper[0]^.ref^.base = NR_NO)
) or (
(taicpu(p).oper[0]^.ref^.scalefactor <= 1) and
(
(taicpu(p).oper[0]^.ref^.index = NR_NO) or
(
(taicpu(p).oper[0]^.ref^.index = taicpu(p).oper[0]^.ref^.base) and
(
(taicpu(hp1).oper[0]^.ref^.index = NR_NO) or
(taicpu(hp1).oper[0]^.ref^.base = NR_NO)
)
)
)
)
)
) then
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;
DebugMsg(SPeepholeOptimization + 'LeaLea2Lea 1 done',p);
if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg 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
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;
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:
@ -3890,76 +3991,92 @@ unit aoptx86;
begin
Result:=false;
if MatchOpType(taicpu(p),top_reg) and
GetNextInstruction(p, hp1) and
((MatchInstruction(hp1, A_TEST, [S_B]) and
MatchOpType(taicpu(hp1),top_reg,top_reg) and
(taicpu(hp1).oper[0]^.reg = taicpu(hp1).oper[1]^.reg)) or
(MatchInstruction(hp1, A_CMP, [S_B]) and
MatchOpType(taicpu(hp1),top_const,top_reg) and
(taicpu(hp1).oper[0]^.val=0))
) and
(taicpu(p).oper[0]^.reg = taicpu(hp1).oper[1]^.reg) and
GetNextInstruction(hp1, hp2) and
MatchInstruction(hp2, A_Jcc, []) then
{ Change from: To:
set(C) %reg j(~C) label
test %reg,%reg/cmp $0,%reg
je label
set(C) %reg j(C) label
test %reg,%reg/cmp $0,%reg
jne label
}
if MatchOpType(taicpu(p),top_reg) and GetNextInstruction(p, hp1) then
begin
next := tai(p.Next);
if ((MatchInstruction(hp1, A_TEST, [S_B]) and
MatchOpType(taicpu(hp1),top_reg,top_reg) and
(taicpu(hp1).oper[0]^.reg = taicpu(hp1).oper[1]^.reg)) or
(MatchInstruction(hp1, A_CMP, [S_B]) and
MatchOpType(taicpu(hp1),top_const,top_reg) and
(taicpu(hp1).oper[0]^.val=0))
) and
(taicpu(p).oper[0]^.reg = taicpu(hp1).oper[1]^.reg) and
GetNextInstruction(hp1, hp2) and
MatchInstruction(hp2, A_Jcc, []) then
{ Change from: To:
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, next);
UpdateUsedRegs(TmpUsedRegs, tai(hp1.next));
set(C) %reg j(~C) label
test %reg,%reg/cmp $0,%reg
je label
JumpC := taicpu(hp2).condition;
Unconditional := False;
if conditions_equal(JumpC, C_E) then
SetC := inverse_cond(taicpu(p).condition)
else if conditions_equal(JumpC, C_NE) then
SetC := taicpu(p).condition
else
{ We've got something weird here (and inefficent) }
set(C) %reg j(C) label
test %reg,%reg/cmp $0,%reg
jne label
}
begin
DebugMsg('DEBUG: Inefficient jump - check code generation', p);
SetC := C_NONE;
next := tai(p.Next);
{ JAE/JNB will always branch (use 'condition_in', since C_AE <> C_NB normally) }
if condition_in(C_AE, JumpC) then
Unconditional := True
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, next);
UpdateUsedRegs(TmpUsedRegs, tai(hp1.next));
JumpC := taicpu(hp2).condition;
Unconditional := False;
if conditions_equal(JumpC, C_E) then
SetC := inverse_cond(taicpu(p).condition)
else if conditions_equal(JumpC, C_NE) then
SetC := taicpu(p).condition
else
{ Not sure what to do with this jump - drop out }
Exit;
end;
{ We've got something weird here (and inefficent) }
begin
DebugMsg('DEBUG: Inefficient jump - check code generation', p);
SetC := C_NONE;
RemoveInstruction(hp1);
{ JAE/JNB will always branch (use 'condition_in', since C_AE <> C_NB normally) }
if condition_in(C_AE, JumpC) then
Unconditional := True
else
{ Not sure what to do with this jump - drop out }
Exit;
end;
if Unconditional then
MakeUnconditional(taicpu(hp2))
else
RemoveInstruction(hp1);
if Unconditional then
MakeUnconditional(taicpu(hp2))
else
begin
if SetC = C_NONE then
InternalError(2018061402);
taicpu(hp2).SetCondition(SetC);
end;
if not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp2, TmpUsedRegs) then
begin
RemoveCurrentp(p, hp2);
Result := True;
end;
DebugMsg(SPeepholeOptimization + 'SETcc/TESTCmp/Jcc -> Jcc',p);
end
else if MatchInstruction(hp1, A_MOV, [S_B]) and
MatchOpType(taicpu(hp1),top_reg,top_reg) and
MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[0]^) then
begin
if SetC = C_NONE then
InternalError(2018061402);
taicpu(hp2).SetCondition(SetC);
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.Next));
if not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp1, TmpUsedRegs) then
begin
AllocRegBetween(taicpu(p).oper[0]^.reg,p,hp1,UsedRegs);
taicpu(p).oper[0]^.reg:=taicpu(hp1).oper[1]^.reg;
RemoveInstruction(hp1);
DebugMsg(SPeepholeOptimization + 'SETcc/Mov -> SETcc',p);
Result := true;
end;
end;
if not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp2, TmpUsedRegs) then
begin
RemoveCurrentp(p, hp2);
Result := True;
end;
DebugMsg(SPeepholeOptimization + 'SETcc/TESTCmp/Jcc -> Jcc',p);
end;
end;
@ -5251,6 +5368,25 @@ unit aoptx86;
if not MatchOpType(taicpu(hp1), top_reg, top_reg) then
Break;
if not SuperRegistersEqual(taicpu(hp1).oper[0]^.reg, ThisReg) then
begin
{ Because hp1 was obtained via GetNextInstructionUsingReg
and ThisReg doesn't appear in the first operand, it
must appear in the second operand and hence gets
overwritten }
if (InstrMax = -1) and
Reg1WriteOverwritesReg2Entirely(taicpu(hp1).oper[1]^.reg, ThisReg) then
begin
{ The two MOVZX instructions are adjacent, so remove the first one }
DebugMsg(SPeepholeOptimization + 'Movzx2Nop 5', p);
RemoveCurrentP(p);
Result := True;
Exit;
end;
Break;
end;
{ The objective here is to try to find a combination that
removes one of the MOV/Z instructions. }
case taicpu(hp1).opsize of
@ -5363,8 +5499,7 @@ unit aoptx86;
((TargetSize = S_W) and (taicpu(hp1).opsize in [S_W, S_BW])) then
begin
{ Convert the output MOVZX to a MOV }
if (taicpu(hp1).oper[0]^.typ = top_reg) and
SuperRegistersEqual(taicpu(hp1).oper[1]^.reg, ThisReg) then
if SuperRegistersEqual(taicpu(hp1).oper[1]^.reg, ThisReg) then
begin
{ Or remove it completely! }
DebugMsg(SPeepholeOptimization + 'Movzx2Nop 2', hp1);

22
installer/install.dat
View File

@ -368,8 +368,6 @@ package=utils-pas2fpmos2.zip[up2fpos2.zip],Generate fpmake.pp for Pascal source
package=utils-pas2jnios2.zip[p2jnos2.zip],Generate JNI bridge for Pascal code
# OS/2 31
package=utils-pas2utos2.zip[p2utos2.zip],Pascal source to FPC Unit test generator
# OS/2 32
package=ufcl-pdfos2.zip[ufcpdos2.zip],PDF generating and TTF file info library
#
# OS/2 packages 2nd part
@ -438,8 +436,6 @@ package=utils-rmwaitos2.zip[rmwos2.zip],Remove (delete) file(s) with optional re
package=utils-lexyaccos2.zip[lexyos2.zip],Compiler generator for TP and compatibles
# OS/2-2 31
package=utils-fpcmos2.zip[fpcmos2.zip],Generate Makefiles out of Makefile.fpc files
# OS/2-2 32
package=utils-unicodeos2.zip[ucodeos2.zip],Transformation of Unicode consortium data for FPC
@ -457,6 +453,12 @@ package=utils-pas2jsos2.zip[p2jsos2.zip],Convert Pascal sources to Javascript
package=utils-webidlos2.zip[widlos2.zip],Web IDL parser and converter to Object Pascal classes
# OS/2-3 4
package=utils-json2pasos2.zip[js2pos2.zip],Create Object Pascal classes from JSON files
# OS/2-3 5
package=ufcl-pdfos2.zip[ufcpdos2.zip],PDF generating and TTF file info library
# OS/2-2 6
package=utils-unicodeos2.zip[ucodeos2.zip],Transformation of Unicode consortium data for FPC
# OS/2-3 7
package=utplylibos2.zip[utpllos2.zip],Units for sources created with the compiler generator
#
# EMX packages
@ -531,8 +533,6 @@ package=utils-pas2fpmemx.zip[up2fpemx.zip],Generate fpmake.pp for Pascal source
package=utils-pas2jniemx.zip[p2jnemx.zip],Generate JNI bridge for Pascal code
# EMX 31
package=utils-pas2utemx.zip[p2utemx.zip],Pascal source to FPC Unit test generator
# EMX 32
package=ufcl-pdfemx.zip[ufcpdemx.zip],PDF generating and TTF file info library
#
# EMX packages 2nd part
@ -601,8 +601,6 @@ package=utils-rmwaitemx.zip[rmwemx.zip],Remove (delete) file(s) with optional re
package=utils-lexyaccemx.zip[ulexyemx.zip],Compiler generator for TP and compatibles
# EMX-2 31
package=utils-fpcmemx.zip[fpcmemx.zip],Generate Makefiles out of Makefile.fpc files
# EMX-3 32
package=utils-unicodeemx.zip[ucodeemx.zip],Transformation of Unicode consortium data for FPC
#
@ -618,6 +616,12 @@ package=utils-pas2jsemx.zip[p2jsemx.zip],Convert Pascal sources to Javascript
package=utils-webidlemx.zip[widlemx.zip],Web IDL parser and converter to Object Pascal classes
# EMX-3 4
package=utils-json2pasemx.zip[js2pemx.zip],Create Object Pascal classes from JSON files
# EMX-3 5
package=ufcl-pdfemx.zip[ufcpdemx.zip],PDF generating and TTF file info library
# EMX-2 6
package=utils-unicodeemx.zip[ucodeemx.zip],Transformation of Unicode consortium data for FPC
# EMX-3 7
package=utplylibemx.zip[utpllemx.zip],Units for sources created with the compiler generator
#
@ -743,6 +747,8 @@ package=units-x11-3.3.1.source.zip[ux11src.zip],X Window (X11) interface units
package=units-fcl-pdf-3.3.1.source.zip[ufcpdsrc.zip],PDF generating and TTF file info library
# Source-2 30
package=units-dblib-3.3.1.source.zip,Headers for the MS SQL Server RDBMS
# Source-2 31
package=units-tplylib.source.zip[utpllsrc.zip],Units for sources created with the compiler generator
#

2
packages/fcl-db/src/export/fpxmlxsdexport.pp
View File

@ -2990,7 +2990,7 @@ begin
}
CreateXSD := True;
DecimalSeparator := char(''); //Don't override decimal separator by default
DecimalSeparator := #0; //Don't override decimal separator by default
if Source is TXMLXSDFormatSettings then
begin

22
packages/fcl-net/src/amiga/resolve.inc
View File

@ -48,7 +48,7 @@ Type
{ remember, classic style calls are also used on MorphOS, so don't test for AMIGA68K }
{$ifndef AMIGAOS4}
function gethostbyname(Name: PChar location 'a0'): PHostEntry; syscall SocketBase 210;
function fpgethostbyname(Name: PChar location 'a0'): PHostEntry; syscall SocketBase 210;
function getnetbyname(Name: PChar location 'a0'): PNetEntry; syscall SocketBase 222;
function getnetbyaddr(Net: Longint location 'd0'; NetType: Longint location 'd1'): PNetEntry; syscall SocketBase 228;
function getservbyname(Name: PChar location 'a0'; Protocol: PChar location 'a1'): PServEntry; syscall SocketBase 234;
@ -63,7 +63,7 @@ function getservent: PServEntry; syscall SocketBase 564;
{$else AMIGAOS4}
function gethostbyname(const Name: PChar): PHostEntry; syscall ISocket 196;
function fpgethostbyname(const Name: PChar): PHostEntry; syscall ISocket 196;
function getnetbyname(Name: PChar): PNetEntry; syscall ISocket 204;
function getnetbyaddr(Net: Longint; NetType: Longint): PNetEntry; syscall ISocket 208;
function getservbyname(Name: PChar; Protocol: PChar): PServEntry; syscall ISocket 212;
@ -77,12 +77,24 @@ procedure endservent; syscall ISocket 484;
function getservent: PServEntry; syscall ISocket 488;
{$endif AMIGAOS4}
function gethostbyname(Name: PChar): PHostEntry;
begin
if Assigned(SocketBase) then
gethostbyname := fpgethostbyname(Name)
else
gethostbyname := nil;
end;
function gethostbyaddr(Addr: PChar; Len: Longint; HType: Longint): PHostentry;
var
addr1,
addr2: in_addr;
IP: PPLongInt;
begin
gethostbyaddr := nil;
if not Assigned(SocketBase) then
Exit;
//
Addr1 := in_addr(PHostAddr(Addr)^);
Addr2.s_addr := htonl(Addr1.s_addr);
gethostbyaddr := Pointer(bsd_GetHostByAddr(Pointer(@Addr2.s_addr), Len, HType));
@ -101,12 +113,14 @@ end;
function GetDNSError: integer;
begin
GetDNSError:=bsd_Errno;
GetDNSError := 0;
if assigned(SocketBase) then
GetDNSError:=bsd_Errno;
end;
Function InitResolve : Boolean;
begin
Result:=True;
Result:=Assigned(SocketBase);
end;
Function FinalResolve : Boolean;

23
packages/fcl-net/src/aros/resolve.inc
View File

@ -48,7 +48,7 @@ Type
{ C style calls, linked in from Libc }
function gethostbyname(Name: PChar): PHostEntry; syscall SocketBase 35;
function fpgethostbyname(Name: PChar): PHostEntry; syscall SocketBase 35;
function getnetbyname(Name: PChar): PNetEntry; syscall SocketBase 37;
function getnetbyaddr(Net: Longint; NetType: Longint): PNetEntry; syscall SocketBase 38;
function getservbyname(Name: PChar; Protocol: PChar): PServEntry; syscall SocketBase 39;
@ -61,12 +61,25 @@ procedure setservent(StayOpen: longint); syscall SocketBase 92;
procedure endservent; syscall SocketBase 93;
function getservent: PServEntry; syscall SocketBase 94;
function gethostbyname(Name: PChar): PHostEntry;
begin
if Assigned(SocketBase) then
gethostbyname := fpgethostbyname(Name)
else
gethostbyname := nil;
end;
function gethostbyaddr(Addr: PChar; Len: Longint; HType: Longint): PHostentry;
var
addr1,
addr2: in_addr;
IP: PPLongInt;
begin
gethostbyaddr := nil;
if not Assigned(SocketBase) then
Exit;
//
Addr1 := in_addr(PHostAddr(Addr)^);
Addr2.s_addr := htonl(Addr1.s_addr);
gethostbyaddr := Pointer(bsd_GetHostByAddr(Pointer(@Addr2.s_addr), Len, HType));
@ -78,19 +91,21 @@ begin
repeat
ip^^ := ntohl(ip^^);
Inc(IP);
until ip^ = nil;
until ip^ = nil;
end;
end;
end;
function GetDNSError: integer;
begin
GetDNSError:=bsd_Errno;
GetDNSError := 0;
if assigned(SocketBase) then
GetDNSError := bsd_Errno;
end;
Function InitResolve : Boolean;
begin
Result:=True;
Result := Assigned(SocketBase);
end;
Function FinalResolve : Boolean;

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

@ -6229,16 +6229,43 @@ begin
end;
procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
procedure InsertInFront(NewParent: TPasElement; List: TFPList
{$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
var
i: Integer;
p: TPasElement;
begin
p:=El.Parent;
if NewParent=p.Parent then
begin
// e.g. a:array of longint; -> insert a$a in front of a
i:=List.Count-1;
while (i>=0) and (List[i]<>Pointer(p)) do
dec(i);
if i<0 then
List.Add(El)
else
List.Insert(i,El);
end
else
begin
List.Add(El);
end;
El.AddRef{$IFDEF CheckPasTreeRefCount}aID{$ENDIF};
El.Parent:=NewParent;
end;
var
Decl: TPasDeclarations;
EnumScope: TPasEnumTypeScope;
p: TPasElement;
MembersType: TPasMembersType;
begin
EmitTypeHints(Parent,El);
if (El.Name<>'') or (AnonymousElTypePostfix='') then exit;
if Parent.Name='' then
RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
if not (Parent.Parent is TPasDeclarations) then
RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
if El.Parent<>Parent then
RaiseNotYetImplemented(20190215085011,Parent);
// give anonymous sub type a name
@ -6246,11 +6273,27 @@ begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishSubElementType parent="',GetObjName(Parent),'" named anonymous type "',GetObjName(El),'"');
{$ENDIF}
Decl:=TPasDeclarations(Parent.Parent);
Decl.Declarations.Add(El);
El.AddRef{$IFDEF CheckPasTreeRefCount}('TPasDeclarations.Declarations'){$ENDIF};
El.Parent:=Decl;
Decl.Types.Add(El);
p:=Parent.Parent;
repeat
if p is TPasDeclarations then
begin
Decl:=TPasDeclarations(p);
InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
Decl.Types.Add(El);
break;
end
else if p is TPasMembersType then
begin
MembersType:=TPasMembersType(p);
InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
break;
end
else
p:=p.Parent;
if p=nil then
RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
until false;
if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then
begin
// anonymous enumtype
@ -7819,6 +7862,8 @@ begin
CheckUseAsType(El.VarType,20190123095916,El);
if El.Expr<>nil then
CheckAssignCompatibility(El,El.Expr,true);
if El.VarType.Parent=El then
FinishSubElementType(El,El.VarType);
end
else if El.Expr<>nil then
begin
@ -12278,12 +12323,17 @@ begin
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(20160929205732,El);
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
if El.Name<>'' then
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple)
else
begin
// anonymous enumtype
end;
EnumScope:=TPasEnumTypeScope(PushScope(El,TPasEnumTypeScope));
// add canonical set
if El.Parent is TPasSetType then
begin
// anonymous enumtype, e.g. "set of ()"
// set of anonymous enumtype, e.g. "set of ()"
CanonicalSet:=TPasSetType(El.Parent);
CanonicalSet.AddRef{$IFDEF CheckPasTreeRefCount}('TPasEnumTypeScope.CanonicalSet'){$ENDIF};
end
@ -21051,8 +21101,8 @@ begin
writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ...');
{AllowWriteln-}
{$ENDIF}
if not IsValidIdent(CurName) then
RaiseNotYetImplemented(20170328000033,ErrorEl,CurName);
// Note: CurName can be a non Pascal name, when specializing an autogenerated anonymous type
//if not IsValidIdent(CurName) then ;
if CurScopeEl<>nil then
begin
NeedPop:=true;

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

@ -7176,8 +7176,9 @@ begin
// libc-linker path (always for Linux, since required for LLVM and SEH; this does not
// force the linking of anything by itself, but just adds a search directory)
if APackage.NeedLibC or
(Defaults.OS=linux) then
// Do not add it if -Xd option is used
if (APackage.NeedLibC or (Defaults.OS=linux)) and
((not Defaults.HaveOptions) or (Defaults.Options.IndexOf('-Xd')=-1)) then
begin
if FCachedlibcPath='' then
begin

4
packages/hash/examples/sha1performancetest.pas
View File

@ -6,7 +6,7 @@ uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
SysUtils,Classes,sha1,dateutils;
SysUtils,Classes,sha1;
var
StartTime: TDateTime;
@ -24,6 +24,6 @@ begin
ss := LowerCase(SHA1Print(SHA1string(s)));
EndTime:=now;
writeln('Performance test finished. Elapsed time:');
writeln(TimeToStr(EndTime-StartTime));
writeln((EndTime-StartTime)*3600*24:0:3,' s');
end.

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

@ -2159,7 +2159,6 @@ type
AContext: TConvertContext): TJSElement; virtual;
Function CreateRTTIMemberProperty(Members: TFPList; Index: integer;
AContext: TConvertContext): TJSElement; virtual;
Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual;
Function CreateRTTIMembers(El: TPasMembersType; Src: TJSSourceElements;
FuncContext: TFunctionContext; MembersSrc: TJSSourceElements;
MembersFuncContext: TFunctionContext; RTTIExpr: TJSElement;
@ -9790,15 +9789,12 @@ begin
if RightRefDecl is TPasProcedure then
begin
Proc:=TPasProcedure(RightRefDecl);
if coShortRefGlobals in Options then
if not aResolver.ProcHasSelf(Proc) then
begin
if not aResolver.ProcHasSelf(Proc) then
begin
// a.StaticProc -> $lp(defaultargs)
// ToDo: check if left side has only types (no call nor field)
Result:=ConvertIdentifierExpr(RightEl,TPrimitiveExpr(RightEl).Value,aContext);
exit;
end;
// a.StaticProc -> pas.unit1.aclass.StaticProc(defaultargs)
// ToDo: check if left side has only types (no call nor field)
Result:=ConvertIdentifierExpr(RightEl,TPrimitiveExpr(RightEl).Value,aContext);
exit;
end;
end;
@ -19965,23 +19961,6 @@ var
ObjLit.Expr:=JS;
end;
function VarTypeInfoAlreadyCreated(VarType: TPasType): boolean;
var
i: Integer;
PrevMember: TPasElement;
begin
i:=Index-1;
while (i>=0) do
begin
PrevMember:=TPasElement(Members[i]);
if (PrevMember is TPasVariable) and (TPasVariable(PrevMember).VarType=VarType)
and IsElementUsed(PrevMember) then
exit(true);
dec(i);
end;
Result:=false;
end;
var
JSTypeInfo: TJSElement;
aName: String;
@ -19994,10 +19973,7 @@ begin
V:=TPasVariable(Members[Index]);
VarType:=V.VarType;
if (VarType<>nil) and (VarType.Name='') then
begin
if not VarTypeInfoAlreadyCreated(VarType) then
CreateRTTIAnonymous(VarType,AContext);
end;
RaiseNotSupported(VarType,AContext,20210223022919);
JSTypeInfo:=CreateTypeInfoRef(VarType,AContext,V);
OptionsEl:=nil;
@ -20315,37 +20291,6 @@ begin
end;
end;
procedure TPasToJSConverter.CreateRTTIAnonymous(El: TPasType;
AContext: TConvertContext);
// if El has any anonymous types, create the RTTI
var
C: TClass;
JS: TJSElement;
GlobalCtx: TFunctionContext;
Src: TJSSourceElements;
begin
if El.Name<>'' then
RaiseNotSupported(El,AContext,20170905162324,'inconsistency');
GlobalCtx:=AContext.GetGlobalFunc;
if GlobalCtx=nil then
RaiseNotSupported(El,AContext,20181229130835);
if not (GlobalCtx.JSElement is TJSSourceElements) then
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateRTTIAnonymous GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement));
{$ENDIF}
RaiseNotSupported(El,AContext,20181229130926);
end;
Src:=TJSSourceElements(GlobalCtx.JSElement);
C:=El.ClassType;
if C=TPasArrayType then
begin
JS:=ConvertArrayType(TPasArrayType(El),AContext);
AddToSourceElements(Src,JS);
end;
end;
function TPasToJSConverter.CreateRTTIMembers(El: TPasMembersType;
Src: TJSSourceElements; FuncContext: TFunctionContext;
MembersSrc: TJSSourceElements; MembersFuncContext: TFunctionContext;

16
packages/pastojs/tests/tcgenerics.pas
View File

@ -170,8 +170,8 @@ begin
'']),
LinesToStr([ // $mod.$main
'$mod.TPoint$G1.x = $mod.p.x + 10;',
'$mod.p.Fly();',
'$mod.p.Fly();',
'$mod.TPoint$G1.Fly();',
'$mod.TPoint$G1.Fly();',
'']));
end;
@ -256,6 +256,11 @@ begin
' this.x = $impl.TBird.$new();',
' this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
' };',
' this.a$a$clone = function (a) {',
' var r = [];',
' for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
' return r;',
' };',
' this.$eq = function (b) {',
' return true;',
' };',
@ -752,7 +757,7 @@ begin
' $mod.TPoint$G1.x = this.x + 5;',
' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 6;',
' this.Fly();',
' $mod.TPoint$G1.Fly();',
' this.Fly();',
' this.Run();',
' $mod.TPoint$G1.Run();',
' };',
@ -1169,6 +1174,11 @@ begin
' this.x = $impl.TBird.$new();',
' this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
' };',
' this.a$a$clone = function (a) {',
' var r = [];',
' for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
' return r;',
' };',
' }, "TAnt<UnitA.TBird>");',
' $mod.$implcode = function () {',
' rtl.recNewT($impl, "TBird", function () {',

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

@ -380,6 +380,7 @@ type
Procedure TestEnum_ForIn;
Procedure TestEnum_ScopedNumber;
Procedure TestEnum_InFunction;
Procedure TestEnum_Name_Anonymous_Unit;
Procedure TestSet_Enum;
Procedure TestSet_Operators;
Procedure TestSet_Operator_In;
@ -522,6 +523,7 @@ type
Procedure TestClasS_CallInheritedConstructor;
Procedure TestClass_ClassVar_Assign;
Procedure TestClass_CallClassMethod;
Procedure TestClass_CallClassMethodStatic; // ToDo
Procedure TestClass_Property;
Procedure TestClass_Property_ClassMethod;
Procedure TestClass_Property_Indexed;
@ -5949,6 +5951,34 @@ begin
'']));
end;
procedure TTestModule.TestEnum_Name_Anonymous_Unit;
begin
StartUnit(true);
Add([
'interface',
'var color: (red, green);',
'implementation',
'initialization',
' color:=green;',
'']);
ConvertUnit;
CheckSource('TestEnum_Name_Anonymous_Unit',
LinesToStr([
'this.color$a = {',
' "0": "red",',
' red: 0,',
' "1": "green",',
' green: 1',
'};',
'this.color = 0;',
'']),
LinesToStr([ // this.$init
'$mod.color = $mod.color$a.green;',
'']),
LinesToStr([ // implementation
'']) );
end;
procedure TTestModule.TestSet_Enum;
begin
StartProgram(false);
@ -9455,7 +9485,7 @@ begin
' arr2[6,3]:=i;',
' i:=arr2[5,2];',
' arr2:=arr2;',// clone multi dim static array
//' arr3:=arr3;',// clone anonymous multi dim static array
' arr3:=arr3;',// clone anonymous multi dim static array
'']);
ConvertProgram;
CheckSource('TestArray_StaticMultiDim',
@ -9467,6 +9497,11 @@ begin
'};',
'this.Arr = rtl.arraySetLength(null, 0, 3);',
'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
'this.Arr3$a$clone = function (a) {',
' var r = [];',
' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
' return r;',
'};',
'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
'this.i = 0;'
]),
@ -9483,6 +9518,7 @@ begin
'$mod.Arr2[1][2] = $mod.i;',
'$mod.i = $mod.Arr2[0][1];',
'$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
'$mod.Arr3 = $mod.Arr3$a$clone($mod.Arr3);',
'']));
end;
@ -9504,6 +9540,7 @@ begin
'begin',
' arr2[5]:=arr;',
' arr2:=arr2;',// clone multi dim static array
' arr3:=arr3;',// clone multi dim anonymous static array
'end;',
'begin',
'']);
@ -9517,6 +9554,11 @@ begin
' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
' return r;',
'};',
'var Arr3$a$clone = function (a) {',
' var r = [];',
' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
' return r;',
'};',
'this.DoIt = function () {',
' var Arr = rtl.arraySetLength(null, 0, 3);',
' var Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
@ -9524,6 +9566,7 @@ begin
' var i = 0;',
' Arr2[0] = Arr.slice(0);',
' Arr2 = TArrayArrayInt$1$clone(Arr2);',
' Arr3 = Arr3$a$clone(Arr3);',
'};',
'']),
LinesToStr([ // $mod.$main
@ -11157,26 +11200,28 @@ end;
procedure TTestModule.TestRecord_Assign;
begin
StartProgram(false);
Add('type');
Add(' TEnum = (red,green);');
Add(' TEnums = set of TEnum;');
Add(' TSmallRec = record');
Add(' N: longint;');
Add(' end;');
Add(' TBigRec = record');
Add(' Int: longint;');
Add(' D: double;');
Add(' Arr: array of longint;');
Add(' Arr2: array[1..2] of longint;');
Add(' Small: TSmallRec;');
Add(' Enums: TEnums;');
Add(' end;');
Add('var');
Add(' r, s: TBigRec;');
Add('begin');
Add(' r:=s;');
Add(' r:=default(TBigRec);');
Add(' r:=default(s);');
Add([
'type',
' TEnum = (red,green);',
' TEnums = set of TEnum;',
' TSmallRec = record',
' N: longint;',
' end;',
' TBigRec = record',
' Int: longint;',
' D: double;',
' Arr: array of longint;',
' Arr2: array[1..2] of longint;',
' Small: TSmallRec;',
' Enums: TEnums;',
' end;',
'var',
' r, s: TBigRec;',
'begin',
' r:=s;',
' r:=default(TBigRec);',
' r:=default(s);',
'']);
ConvertProgram;
CheckSource('TestRecord_Assign',
LinesToStr([ // statements
@ -12091,9 +12136,9 @@ begin
'$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
'$mod.TRec.SetInt($mod.TRec.Fx);',
'$mod.TRec.Fy = $mod.r.Fx + 1;',
'if ($mod.r.GetInt() === 2) ;',
'$mod.r.SetInt($mod.r.GetInt() + 2);',
'$mod.r.SetInt($mod.r.Fx);',
'if ($mod.TRec.GetInt() === 2) ;',
'$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
'$mod.TRec.SetInt($mod.r.Fx);',
'']));
end;
@ -12557,8 +12602,8 @@ begin
' $mod.TPoint.Fly();',
'})();',
'$mod.TPoint.x = $mod.r.x + 10;',
'$mod.r.Fly();',
'$mod.r.Fly();',
'$mod.TPoint.Fly();',
'$mod.TPoint.Fly();',
'']));
end;
@ -13474,6 +13519,63 @@ begin
'']));
end;
procedure TTestModule.TestClass_CallClassMethodStatic;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' public',
' class function Fly: tobject; static;',
' end;',
'class function tobject.Fly: tobject;',
'begin',
' Result.Fly;',
' Result.Fly();',
' Fly;',
' Fly();',
' Fly.Fly;',
' Fly.Fly();',
'end;',
'var Obj: tobject;',
'begin',
' obj.Fly;',
' obj.Fly();',
' with obj do begin',
' Fly;',
' Fly();',
' end;',
'']);
ConvertProgram;
CheckSource('TestClass_CallClassMethodStatic',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Fly = function () {',
' var Result = null;',
' $mod.TObject.Fly();',
' $mod.TObject.Fly();',
' $mod.TObject.Fly();',
' $mod.TObject.Fly();',
' $mod.TObject.Fly();',
' $mod.TObject.Fly();',
' return Result;',
' };',
'});',
'this.Obj = null;'
]),
LinesToStr([ // $mod.$main
'$mod.TObject.Fly();',
'$mod.TObject.Fly();',
'var $with = $mod.Obj;',
'$with.Fly();',
'$with.Fly();',
'']));
end;
procedure TTestModule.TestClass_Property;
begin
StartProgram(false);
@ -22610,21 +22712,21 @@ begin
'this.c = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.b.SetSpeed($mod.b.GetSpeed() + 12);',
'$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
'var $with = $mod.b;',
'$with.SetSpeed($with.GetSpeed() + 32);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 34);',
'$mod.c.SetSpeed($mod.c.GetSpeed() + 12);',
'$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
'var $with1 = $mod.c;',
'$with1.SetSpeed($with1.GetSpeed() + 32);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 34);',
'$mod.TBird.SetSpeed($mod.TBird.GetSpeed() + 12);',
'$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
'$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
'var $with2 = $mod.TBird;',
@ -24410,7 +24512,7 @@ begin
'']),
LinesToStr([ // $mod.$main
'$mod.THelper.Fly.call({',
' p: $mod.o.GetField(),',
' p: $mod.TObject.GetField(),',
' get: function () {',
' return this.p;',
' },',
@ -24428,7 +24530,7 @@ begin
' this.p = v;',
' }',
'}, 12);',
'var $with1 = $mod.o.GetField();',
'var $with1 = $mod.TObject.GetField();',
'$mod.THelper.Fly.call({',
' get: function () {',
' return $with1;',
@ -29490,6 +29592,9 @@ begin
CheckSource('TestRTTI_Class_Field',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
' eltype: rtl.byte',
' });',
' this.$init = function () {',
' this.FPropA = "";',
' this.VarLI = 0;',
@ -29521,9 +29626,6 @@ begin
' $r.addField("VarShI", rtl.shortint);',
' $r.addField("VarBy", rtl.byte);',
' $r.addField("VarExt", rtl.longint);',
' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
' eltype: rtl.byte',
' });',
' $r.addField("ArrA", $mod.$rtti["TObject.ArrB$a"]);',
' $r.addField("ArrB", $mod.$rtti["TObject.ArrB$a"]);',
'});',
@ -30558,6 +30660,9 @@ begin
CheckSource('TestRTTI_Record',
LinesToStr([ // statements
'rtl.recNewT(this, "TFloatRec", function () {',
' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
' eltype: rtl.char',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.c = [];',
@ -30572,9 +30677,6 @@ begin
' this.d = rtl.arrayRef(s.d);',
' return this;',
' };',
' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
' eltype: rtl.char',
' });',
' var $r = $mod.$rtti.$Record("TFloatRec", {});',
' $r.addField("c", $mod.$rtti["TFloatRec.d$a"]);',
' $r.addField("d", $mod.$rtti["TFloatRec.d$a"]);',

22
packages/rtl-extra/src/amiga/sockets.pp
View File

@ -201,12 +201,18 @@ end;
function fpgeterrno: longint; inline;
begin
fpgeterrno := bsd_Errno;
if Assigned(SocketBase) then
fpgeterrno := bsd_Errno
else
fpgeterrno := 0;
end;
function fpClose(d: LongInt): LongInt; inline;
begin
fpClose := bsd_CloseSocket(d);
if Assigned(SocketBase) then
fpClose := bsd_CloseSocket(d)
else
fpClose := -1;
end;
function fpaccept(s: cint; addrx: PSockaddr; Addrlen: PSocklen): cint;
@ -289,8 +295,16 @@ end;
function fpsocket(domain: cint; xtype: cint; protocol: cint): cint;
begin
fpsocket := bsd_socket(domain, xtype, protocol);
internal_socketerror := fpgeterrno;
if Assigned(SocketBase) then
begin
fpsocket := bsd_socket(domain, xtype, protocol);
internal_socketerror := fpgeterrno;
end
else
begin
fpsocket := -1;
internal_socketerror := ESockEPROTONOSUPPORT;
end;
end;

38
packages/rtl-extra/src/aros/sockets.pp
View File

@ -88,7 +88,7 @@ const
SOL_SOCKET = $FFFF;
const
EsockEINTR = 4; // EsysEINTR;
EsockEINTR = 4; // EsysEINTR;
EsockEBADF = 9; // EsysEBADF;
EsockEFAULT = 14; // EsysEFAULT;
EsockEINVAL = 22; //EsysEINVAL;
@ -155,18 +155,24 @@ end;
function fpgeterrno: longint; inline;
begin
fpgeterrno := bsd_Errno;
if Assigned(SocketBase) then
fpgeterrno := bsd_Errno
else
fpgeterrno := 0;
end;
function fpClose(d: LongInt): LongInt; inline;
begin
fpClose := bsd_CloseSocket(d);
if Assigned(SocketBase) then
fpClose := bsd_CloseSocket(d)
else
fpClose := -1;
end;
function fpaccept(s: cint; addrx: PSockaddr; Addrlen: PSocklen): cint;
begin
fpaccept := bsd_accept(s,addrx,addrlen);
internal_socketerror := fpgeterrno;
internal_socketerror := fpgeterrno;
end;
function fpbind(s:cint; addrx: psockaddr; addrlen: tsocklen): cint;
@ -177,8 +183,16 @@ end;
function fpconnect(s:cint; name: psockaddr; namelen: tsocklen): cint;
begin
fpconnect := bsd_connect(s, name, namelen);
internal_socketerror := fpgeterrno;
if Assigned(SocketBase) then
begin
fpconnect := bsd_connect(s, name, namelen);
internal_socketerror := fpgeterrno;
end
else
begin
fpconnect := -1;
internal_socketerror := ESockEPROTONOSUPPORT;
end;
end;
function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint;
@ -243,8 +257,16 @@ end;
function fpsocket(domain: cint; xtype: cint; protocol: cint): cint;
begin
fpsocket := bsd_socket(domain, xtype, protocol);
internal_socketerror := fpgeterrno;
if Assigned(SocketBase) then
begin
fpsocket := bsd_socket(domain, xtype, protocol);
internal_socketerror := fpgeterrno;
end
else
begin
internal_socketerror := ESockEPROTONOSUPPORT;
fpsocket := -1;
end;
end;

2
packages/tplylib/fpmake.pp
View File

@ -13,7 +13,7 @@ begin
{$endif ALLPACKAGES}
P:=AddPackage('tplylib');
P.ShortName:='tplylib';
P.ShortName:='tpll';
{$ifdef ALLPACKAGES}
P.Directory:=ADirectory;
{$endif ALLPACKAGES}

8
rtl/linux/arm/sighnd.inc
View File

@ -41,6 +41,7 @@ end;
{$endif not(defined(CPUTHUMB)) and not(defined(CPUTHUMB2))}
{$if FPC_FULLVERSION >= 30200}
{$if defined(CPU_HAS_THUMB))}
Procedure SignalToHandleErrorAddrFrame_Thumb(Errno : longint;addr : CodePointer; frame : Pointer); nostackframe; assembler;
asm
.thumb_func
@ -61,7 +62,8 @@ asm
.code 32
{$endif not(defined(CPUTHUMB)) and not(defined(CPUTHUMB2))}
end;
{$endif}
{$endif defined(CPU_HAS_THUMB))}
{$endif FPC_FULLVERSION >= 30200}
procedure SignalToRunerror(Sig: longint; { _a2,_a3,_a4 : dword; } SigContext: PSigInfo; uContext : PuContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
@ -110,7 +112,11 @@ begin
else
{$endif not(defined(CPUTHUMB)) and not(defined(CPUTHUMB2))}
begin
{$if defined(CPU_HAS_THUMB))}
ucontext^.uc_mcontext.arm_pc:=ptruint(@SignalToHandleErrorAddrFrame_Thumb);
{$else defined(CPU_HAS_THUMB))}
halt(217);
{$endif defined(CPU_HAS_THUMB))}
end;
{$else}
ucontext^.uc_mcontext.arm_pc:=ptruint(@SignalToHandleErrorAddrFrame_ARM);

54
rtl/objpas/math.pp
View File

@ -1159,7 +1159,7 @@ function sum(const data : array of Single) : float;inline;
function sum(const data : PSingle;Const N : longint) : float;
var
i : longint;
i : SizeInt;
begin
sum:=0.0;
for i:=0 to N-1 do
@ -1186,7 +1186,7 @@ function sum(const data : array of Double) : float; inline;
function sum(const data : PDouble;Const N : longint) : float;
var
i : longint;
i : SizeInt;
begin
sum:=0.0;
for i:=0 to N-1 do
@ -1213,7 +1213,7 @@ function sum(const data : array of Extended) : float; inline;
function sum(const data : PExtended;Const N : longint) : float;
var
i : longint;
i : SizeInt;
begin
sum:=0.0;
for i:=0 to N-1 do
@ -1223,7 +1223,7 @@ function sum(const data : PExtended;Const N : longint) : float;
function sumInt(const data : PInt64;Const N : longint) : Int64;
var
i : longint;
i : SizeInt;
begin
sumInt:=0;
for i:=0 to N-1 do
@ -1248,7 +1248,7 @@ function mean(const data: array of Int64):Float;
function sumInt(const data : PInteger; Const N : longint) : Int64;
var
i : longint;
i : SizeInt;
begin
sumInt:=0;
for i:=0 to N-1 do
@ -1279,7 +1279,7 @@ function mean(const data: array of Integer):Float;
function sumofsquares(const data : PSingle; Const N : Integer) : float;
var
i : longint;
i : SizeInt;
begin
sumofsquares:=0.0;
for i:=0 to N-1 do
@ -1295,7 +1295,7 @@ end;
procedure sumsandsquares(const data : PSingle; Const N : Integer;
var sum,sumofsquares : float);
var
i : Integer;
i : SizeInt;
temp : float;
begin
sumofsquares:=0.0;
@ -1317,7 +1317,7 @@ procedure sumsandsquares(const data : PSingle; Const N : Integer;
function sumofsquares(const data : PDouble; Const N : Integer) : float;
var
i : longint;
i : SizeInt;
begin
sumofsquares:=0.0;
for i:=0 to N-1 do
@ -1333,7 +1333,7 @@ end;
procedure sumsandsquares(const data : PDouble; Const N : Integer;
var sum,sumofsquares : float);
var
i : Integer;
i : SizeInt;
temp : float;
begin
sumofsquares:=0.0;
@ -1355,7 +1355,7 @@ procedure sumsandsquares(const data : PDouble; Const N : Integer;
function sumofsquares(const data : PExtended; Const N : Integer) : float;
var
i : longint;
i : SizeInt;
begin
sumofsquares:=0.0;
for i:=0 to N-1 do
@ -1371,7 +1371,7 @@ end;
procedure sumsandsquares(const data : PExtended; Const N : Integer;
var sum,sumofsquares : float);
var
i : Integer;
i : SizeInt;
temp : float;
begin
sumofsquares:=0.0;
@ -1411,7 +1411,7 @@ end;
{$ifdef FPC_HAS_TYPE_SINGLE}
procedure MeanAndTotalVariance
(const data: PSingle; N: LongInt; var mu, variance: float);
var i: LongInt;
var i: SizeInt;
begin
mu := Mean( data, N );
variance := 0;
@ -1511,7 +1511,7 @@ procedure momentskewkurtosis(
out kurtosis: float
);
var
i: integer;
i: SizeInt;
value : psingle;
deviation, deviation2: single;
reciprocalN: float;
@ -1562,7 +1562,7 @@ function norm(const data : PSingle; Const N : Integer) : float;
{$ifdef FPC_HAS_TYPE_DOUBLE}
procedure MeanAndTotalVariance
(const data: PDouble; N: LongInt; var mu, variance: float);
var i: LongInt;
var i: SizeInt;
begin
mu := Mean( data, N );
variance := 0;
@ -1666,7 +1666,7 @@ procedure momentskewkurtosis(
out kurtosis: float
);
var
i: integer;
i: SizeInt;
value : pdouble;
deviation, deviation2: double;
reciprocalN: float;
@ -1717,7 +1717,7 @@ function norm(const data : PDouble; Const N : Integer) : float;
{$ifdef FPC_HAS_TYPE_EXTENDED}
procedure MeanAndTotalVariance
(const data: PExtended; N: LongInt; var mu, variance: float);
var i: LongInt;
var i: SizeInt;
begin
mu := Mean( data, N );
variance := 0;
@ -1810,7 +1810,7 @@ end;
procedure momentskewkurtosis(
const data: pExtended;
Const N: integer;
Const N: Integer;
out m1: float;
out m2: float;
out m3: float;
@ -1870,7 +1870,7 @@ function norm(const data : PExtended; Const N : Integer) : float;
function MinIntValue(const Data: array of Integer): Integer;
var
I: Integer;
I: SizeInt;
begin
Result := Data[Low(Data)];
For I := Succ(Low(Data)) To High(Data) Do
@ -1879,7 +1879,7 @@ end;
function MaxIntValue(const Data: array of Integer): Integer;
var
I: Integer;
I: SizeInt;
begin
Result := Data[Low(Data)];
For I := Succ(Low(Data)) To High(Data) Do
@ -1893,7 +1893,7 @@ end;
function MinValue(const Data: PInteger; Const N : Integer): Integer;
var
I: Integer;
I: SizeInt;
begin
Result := Data[0];
For I := 1 To N-1 do
@ -1907,7 +1907,7 @@ end;
function maxvalue(const data : PInteger; Const N : Integer) : Integer;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
maxvalue:=data[0];
@ -1924,7 +1924,7 @@ end;
function minvalue(const data : PSingle; Const N : Integer) : Single;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
minvalue:=data[0];
@ -1941,7 +1941,7 @@ end;
function maxvalue(const data : PSingle; Const N : Integer) : Single;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
maxvalue:=data[0];
@ -1959,7 +1959,7 @@ end;
function minvalue(const data : PDouble; Const N : Integer) : Double;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
minvalue:=data[0];
@ -1976,7 +1976,7 @@ end;
function maxvalue(const data : PDouble; Const N : Integer) : Double;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
maxvalue:=data[0];
@ -1994,7 +1994,7 @@ end;
function minvalue(const data : PExtended; Const N : Integer) : Extended;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
minvalue:=data[0];
@ -2011,7 +2011,7 @@ end;
function maxvalue(const data : PExtended; Const N : Integer) : Extended;
var
i : longint;
i : SizeInt;
begin
{ get an initial value }
maxvalue:=data[0];

34
tests/test/tandorandnot1.pp Normal file
View File

@ -0,0 +1,34 @@
{ test (a and b) or (c and not(b)) into c xor ((c xor a) and b) optimization with random values }
var
i,a,b,c,_a,_b,_c : word;
begin
for i:=1 to 1000 do
begin
a:=random(65536);
_a:=a;
b:=random(65536);
_b:=b;
c:=random(65536);
_c:=c;
if (a and b) or (c and not(b))<>_c xor ((_c xor _a) and _b) then
begin
writeln('Error: ','a=',a,'b=',b,'c=',c);
halt(1);
end;
if (a and b) or (not(b) and c)<>_c xor ((_c xor _a) and _b) then
begin
writeln('Error: ','a=',a,'b=',b,'c=',c);
halt(1);
end;
if (not(b) and c) or (a and b)<>_c xor ((_c xor _a) and _b) then
begin
writeln('Error: ','a=',a,'b=',b,'c=',c);
halt(1);
end;
if (not(b) and c) or (b and a)<>_c xor ((_c xor _a) and _b) then
begin
writeln('Error: ','a=',a,'b=',b,'c=',c);
halt(1);
end;
end;
end.

4
tests/test/tmt1.pp
View File

@ -11,9 +11,9 @@ uses
;
const
{$ifdef cpuarm}
{$if defined(cpuarm) or defined(cpuavr) or defined(cpui8086) or defined(cpum68k) or defined(cpumips) or defined(cpuz80)}
{$define slowcpu}
{$endif cpuarm}
{$endif}
{$ifdef slowcpu}
threadcount = 40;

12
tests/utils/dotest.pp
View File

@ -839,7 +839,7 @@ end;
function RunCompiler(const ExtraPara: string):boolean;
var
args,LocalExtraArgs,
wpoargs : string;
wpoargs,wposuffix : string;
passnr,
passes : longint;
execres : boolean;
@ -880,6 +880,7 @@ begin
if Config.NeedOptions<>'' then
AppendOptions(Config.NeedOptions,args);
wpoargs:='';
wposuffix:='';
if (Config.WpoPasses=0) or
(Config.WpoParas='') then
passes:=1
@ -891,6 +892,7 @@ begin
begin
if (passes>1) then
begin
wposuffix:='_'+tostr(passnr);
wpoargs:=' -OW'+config.wpoparas+' -FW'+TestOutputFileName('',PPFile[current],'wp'+tostr(passnr));
if (passnr>1) then
wpoargs:=wpoargs+' -Ow'+config.wpoparas+' -Fw'+TestOutputFileName('',PPFile[current],'wp'+tostr(passnr-1));
@ -899,12 +901,12 @@ begin
{ also get the output from as and ld that writes to stderr sometimes }
StartTicks:=GetMicroSTicks;
{$ifndef macos}
execres:=ExecuteRedir(CompilerBin,args+wpoargs,'',CompilerLogFile,'stdout');
execres:=ExecuteRedir(CompilerBin,args+wpoargs,'',CompilerLogFile+wposuffix,'stdout');
{$else macos}
{Due to that Toolserver is not reentrant, we have to asm and link via script.}
execres:=ExecuteRedir(CompilerBin,'-s '+args+wpoargs,'',CompilerLogFile,'stdout');
execres:=ExecuteRedir(CompilerBin,'-s '+args+wpoargs,'',CompilerLogFile+wposuffix,'stdout');
if execres then
execres:=ExecuteRedir(TestOutputDir + ':ppas','','',CompilerLogFile,'stdout');
execres:=ExecuteRedir(TestOutputDir + ':ppas','','',CompilerLogFile+wpo_suffix,'stdout');
{$endif macos}
EndTicks:=GetMicroSTicks;
Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
@ -913,6 +915,8 @@ begin
Verbose(V_Normal,'Compilation took '+ToStr(EndTicks-StartTicks)+' us');
end;
if passes > 1 then
CopyFile(CompilerLogFile+wposuffix,CompilerLogFile,true);
{ Error during execution? }
if (not execres) and (ExecuteResult=0) then
begin

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

@ -0,0 +1,11 @@
{ %fail }
Var
MyVar : char;
Procedure MyProc;
Begin
MyVar := ''; (* <-- two single-quotes *)
End;
Begin
End.

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

@ -0,0 +1,11 @@
{ %fail }
Var
MyVar : char;
Procedure MyProc;
Begin
MyVar := char('');
End;
Begin
End.

7
tests/webtbs/tw28713.pp
View File

@ -6,7 +6,14 @@ type
TWordArray = array [0..1023]of Word;
WordRec = packed record
{$ifdef FPC}
{$ifdef FPC_LITTLE_ENDIAN}
LoByte,HiByte:Byte
{$endif}
{$ifdef FPC_BIG_ENDIAN}
HiByte,LoByte:Byte
{$endif}
{$endif}
end;
var

15
tests/webtbs/tw36250.pp Normal file
View File

@ -0,0 +1,15 @@
{ %norun }
{ %target=darwin,ios,iphonesim}
{ %opt=-gw3 }
{$mode objfpc}{$h+}
{$ModeSwitch objectivec2}
function NSStringToString(ns: NSString): String;
begin
Result := '';
end;
begin
WriteLn(NSStringToString(nil));
end.

24
tests/webtbs/tw38497.pp Normal file
View File

@ -0,0 +1,24 @@
program project1;
{$mode delphi}
type
TAlphabet = (A, B, C);
TAlphabets = set of TAlphabet;
procedure Test<TEnum, TSet>(E: TEnum; S: TSet);
var
I: TEnum;
B: Boolean;
begin
B := [E] <= S;
if E in S then
WriteLn(E);
for I := Low(TEnum) to High(TEnum) do
if I in S then
WriteLn(I);
end;
begin
Test<TAlphabet, TAlphabets>(A, [A, B]);
end.

15
tests/webtbs/tw38527.pp Normal file
View File

@ -0,0 +1,15 @@
{%OPT=-O2}
{$mode objfpc}
function F(n: SizeUint): SizeUint;
begin
result := 4 * n + 4 * n;
end;
begin
writeln('Reference F(5): ', 4 * 5 + 4 * 5);
writeln(' Actual F(5): ', F(5));
if (F(5) <> 40) then
halt(1);
end.

5
tests/webtbs/tw8177.pp
View File

@ -6,10 +6,7 @@ program ValidateStrToInt;
{$mode delphi}
{$ENDIF}
{$ifdef cpuarm}
{$define slowcpu}
{$endif}
{$ifdef cpumips}
{$if defined(cpuarm) or defined(cpuavr) or defined(cpui8086) or defined(cpum68k) or defined(cpumips) or defined(cpuz80)}
{$define slowcpu}
{$endif}
{$ifdef android}

2
utils/json2pas/fpmake.pp
View File

@ -17,7 +17,7 @@ begin
P:=AddPackage('utils-json2pas');
P.Dependencies.Add('fcl-json');
P.ShortName:='js2p';
P.ShortName:='jsnp';
P.OSes:=AllOSes-[embedded,msdos,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc];
if Defaults.CPU=jvm then
P.OSes := P.OSes - [java,android];