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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48846 -
This commit is contained in:
nickysn 2021-03-01 13:21:24 +00:00
commit 940738a3a1
81 changed files with 3120 additions and 427 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
.gitattributes vendored
View File

@ -9076,7 +9076,11 @@ packages/rtl-unicode/src/inc/cp936.pas svneol=native#text/pascal
packages/rtl-unicode/src/inc/cp949.pas svneol=native#text/pascal
packages/rtl-unicode/src/inc/cp950.pas svneol=native#text/pascal
packages/rtl-unicode/src/inc/cpbuildu.pp svneol=native#text/plain
packages/rtl-unicode/src/inc/eastasianwidth.pp svneol=native#text/plain
packages/rtl-unicode/src/inc/eastasianwidth_code.inc svneol=native#text/plain
packages/rtl-unicode/src/inc/freebidi.pp svneol=native#text/plain
packages/rtl-unicode/src/inc/graphemebreakproperty.pp svneol=native#text/plain
packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc svneol=native#text/plain
packages/rtl-unicode/src/inc/ucadata.inc svneol=native#text/pascal
packages/rtl-unicode/src/inc/ucadata_be.inc svneol=native#text/pascal
packages/rtl-unicode/src/inc/ucadata_le.inc svneol=native#text/pascal
@ -14535,6 +14539,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
@ -16211,6 +16216,7 @@ tests/test/units/strings/tstrings1.pp svneol=native#text/plain
tests/test/units/strutils/taddchar.pp svneol=native#text/plain
tests/test/units/strutils/taddcharr.pp svneol=native#text/plain
tests/test/units/strutils/tbintohex.pp svneol=native#text/plain
tests/test/units/strutils/tboyer.pp svneol=native#text/pascal
tests/test/units/strutils/tdec2numb.pp svneol=native#text/plain
tests/test/units/strutils/thex2dec.pp svneol=native#text/plain
tests/test/units/strutils/thextobin.pp svneol=native#text/plain
@ -16783,6 +16789,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
@ -18583,6 +18591,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
@ -18731,6 +18740,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
@ -19835,7 +19846,11 @@ utils/unicode/cldrtest.pas svneol=native#text/pascal
utils/unicode/cldrtxt.pas svneol=native#text/plain
utils/unicode/cldrxml.pas svneol=native#text/pascal
utils/unicode/data/readme.txt svneol=native#text/plain
utils/unicode/eawparser.lpi svneol=native#text/plain
utils/unicode/eawparser.lpr svneol=native#text/pascal
utils/unicode/fpmake.pp svneol=native#text/plain
utils/unicode/gbpparser.lpi svneol=native#text/plain
utils/unicode/gbpparser.lpr svneol=native#text/pascal
utils/unicode/grbtree.pas svneol=native#text/pascal
utils/unicode/helper.pas svneol=native#text/pascal
utils/unicode/parse-collations.bat svneol=native#text/plain

4
compiler/Makefile
View File

@ -5085,7 +5085,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

@ -1036,7 +1036,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

@ -4540,6 +4540,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;

24
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 }
@ -75,8 +66,11 @@ implementation
var
hreg: tregister;
scaled: boolean;
regcgsize: tcgsize;
begin
scaled:=false;
regcgsize:=def_cgsize(regsize);
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: called')));
if l<>1 then
begin
@ -86,8 +80,10 @@ implementation
((CPUM68K_HAS_INDEXSCALE8 in cpu_capabilities[current_settings.cputype]) and (l in [2,4,8]))) then
begin
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: mul')));
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_S32);
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_IMUL,def_cgsize(regsize),l,maybe_const_reg,hreg);
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,regcgsize,OS_ADDR,maybe_const_reg,hreg);
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_IMUL,OS_ADDR,l,hreg);
regcgsize:=OS_ADDR;
maybe_const_reg:=hreg;
end
else
@ -104,7 +100,7 @@ implementation
begin
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: copytoa')));
hreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,def_cgsize(regsize),OS_ADDR,maybe_const_reg,hreg);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,regcgsize,OS_ADDR,maybe_const_reg,hreg);
maybe_const_reg:=hreg;
end;
location.reference.base:=maybe_const_reg;
@ -118,13 +114,13 @@ implementation
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,location.reference,hreg);
reference_reset_base(location.reference,hreg,0,location.reference.temppos,location.reference.alignment,location.reference.volatility);
end;
if def_cgsize(regsize) in [OS_8,OS_16] then
if regcgsize in [OS_8,OS_16] then
begin
{ index registers are always sign extended on m68k, so we have to zero extend by hand,
if the index variable is unsigned, and its width is less than the whole register }
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: index zero extend')));
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,def_cgsize(regsize),OS_ADDR,maybe_const_reg,hreg);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,regcgsize,OS_ADDR,maybe_const_reg,hreg);
maybe_const_reg:=hreg;
end;
{ insert new index register }

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

@ -547,7 +547,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);
@ -880,8 +880,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;
@ -941,13 +941,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
@ -1024,8 +1024,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);
@ -1063,11 +1063,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

@ -250,6 +250,7 @@ implementation
begin
result:=nil;
resultdef:=pasbool1type;
typecheckpass(right);
set_varstate(right,vs_read,[vsf_must_be_valid]);
@ -272,6 +273,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

@ -574,7 +574,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

@ -3286,7 +3286,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;

7
packages/fcl-process/src/amicommon/pipes.inc
View File

@ -27,9 +27,12 @@ end;
Function TInputPipeStream.GetNumBytesAvailable: DWord;
var
fib: TFileInfoBlock;
begin
Result := 0;
if Boolean(ExamineFH(BPTR(Handle), @fib)) then
Result := fib.fib_size;
end;
function TInputPipeStream.GetPosition: Int64;
@ -53,5 +56,5 @@ begin
FileClose(FHandle);
if DeleteIt then
AmigaDos.dosDeleteFile(@(Filename[0]));
end;
end;
end;

77
packages/fcl-process/src/amicommon/process.inc
View File

@ -65,6 +65,13 @@ end;
var
UID: Integer = 0;
{$ifdef MorphOS}
const
BUF_LINE = 0; // flush on \n, etc
BUF_FULL = 1; // never flush except when needed
BUF_NONE = 2; // no buffering
{$endif}
Procedure TProcess.Execute;
var
I: integer;
@ -74,6 +81,10 @@ var
Params: string;
TempName: string;
cos: BPTR;
{$ifdef MorphOS}
inA, inB, OutA, OutB: BPTR;
Res: Integer;
{$endif}
begin
if (ApplicationName = '') and (CommandLine = '') and (Executable = '') then
raise EProcess.Create (SNoCommandline);
@ -114,17 +125,61 @@ begin
ChDir (FCurrentDirectory);
end;
try
cos := BPTR(0);
repeat
Inc(UID);
TempName := 'T:PrO_'+ HexStr(FindTask(nil)) + '_' + IntToHex(UID,8);
until not FileExists(TempName);
//sysdebugln('TProcess start: "' + ExecName + ' ' + Params+'" >' + TempName);
cos := AmigaDos.DosOpen(PChar(TempName), MODE_READWRITE);
FExitCode := LongInt(amigados.Execute(PChar(ExecName + ' ' + Params), BPTR(0), cos));
DosSeek(cos, 0, OFFSET_BEGINNING);
CreateStreams(0, THandle(cos),0);
//FExitCode := ExecuteProcess (ExecName, Params);
{$ifdef MorphOS}
if (poUsePipes in Options) and (not (poWaitOnExit in Options)) then
begin
FProcessID := 0;
// Pipenames, should be unique
TempName := 'PIPE:PrO_' + HexStr(Self) + HexStr(GetTickCount, 8);
inA := DOSOpen(PChar(TempName), MODE_OLDFILE);
inB := DOSOpen(PChar(TempName), MODE_NEWFILE);
TempName := TempName + 'o';
outA := DOSOpen(PChar(TempName), MODE_OLDFILE);
outB := DOSOpen(PChar(TempName), MODE_NEWFILE);
// set buffer for all pipes
SetVBuf(inA, nil, BUF_NONE, -1);
SetVBuf(inB, nil, BUF_LINE, -1);
SetVBuf(outA, nil, BUF_NONE, -1);
SetVBuf(outB, nil, BUF_LINE, -1);
// the actual Start of the command with given parameter and streams
Res := SystemTags(PChar(ExecName + ' ' + Params),
[SYS_Input, AsTag(outA),
SYS_Output, AsTag(inB),
SYS_Asynch, AsTag(True),
TAG_END]);
// the two streams will be destroyed by system, we do not need to care about
// the other two we will destroy when the PipeStreams they are attached to are destroyed
if Res <> -1 then
begin
FProcessID := 1;
CreateStreams(THandle(outB), THandle(inA),0);
end
else
begin
// if the command did not start, we need to delete all Streams
if outB <> BPTR(0) then DosClose(outB);
if outA <> BPTR(0) then DosClose(outA);
if inB <> BPTR(0) then DosClose(inB);
if inA <> BPTR(0) then DosClose(inA);
end;
end
else
{$endif}
begin
// if no streams needed we still use the old sychronous way
FProcessID := 0;
cos := BPTR(0);
repeat
Inc(UID);
TempName := 'T:PrO_'+ HexStr(FindTask(nil)) + '_' + IntToHex(UID,8);
until not FileExists(TempName);
//sysdebugln('TProcess start: "' + ExecName + ' ' + Params+'" >' + TempName);
cos := AmigaDos.DosOpen(PChar(TempName), MODE_READWRITE);
FExitCode := LongInt(amigados.Execute(PChar(ExecName + ' ' + Params), BPTR(0), cos));
DosSeek(cos, 0, OFFSET_BEGINNING);
CreateStreams(0, THandle(cos),0);
end;
//FExitCode := ExecuteProcess (ExecName, Params);
except
(* Normalize the raised exception so that it is aligned to other platforms. *)
On E: EOSError do

22
packages/fcl-process/src/pipes.pp
View File

@ -91,10 +91,30 @@ begin
end;
Function TInputPipeStream.Read (Var Buffer; Count : Longint) : longint;
{$ifdef MorphOS}
var
i: Integer;
Runner: PByte;
{$endif}
begin
{$ifdef MorphOS}
FillChar(Buffer, Count, 0);
if FGetS(Handle, @Buffer, Count) = nil then
Result := 0
else
begin
Result := 0;
Runner := @Buffer;
repeat
if Runner^ = 0 then
Break;
Inc(Result);
until Result >= Count;
end;
{$else}
Result:=Inherited Read(Buffer,Count);
Inc(FPos,Result);
{$endif}
end;
function TInputPipeStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;

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

@ -7177,8 +7177,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;

13
packages/rtl-objpas/src/inc/dateutil.inc
View File

@ -44,6 +44,19 @@ const
DaySaturday = 6;
DaySunday = 7;
MonthJanuary = 1;
MonthFebruary = 2;
MonthMarch = 3;
MonthApril = 4;
MonthMay = 5;
MonthJune = 6;
MonthJuly = 7;
MonthAugust = 8;
MonthSeptember = 9;
MonthOctober = 10;
MonthNovember = 11;
MonthDecember = 12;
// Fraction of a day
OneHour = TDateTime(1)/HoursPerDay;
OneMinute = TDateTime(1)/MinsPerDay;

6
packages/rtl-objpas/src/inc/strutils.pp
View File

@ -429,8 +429,7 @@ begin
AddMatch(i+1);
//Only first match ?
if not aMatchAll then break;
inc(i,OldPatternSize);
inc(i,OldPatternSize);
inc(i,DeltaJumpTable2[0]);
end else begin
i:=i + Max(DeltaJumpTable1[ord(s[i])],DeltaJumpTable2[j]);
end;
@ -582,8 +581,7 @@ begin
AddMatch(i+1);
//Only first match ?
if not aMatchAll then break;
inc(i,OldPatternSize);
inc(i,OldPatternSize);
inc(i,DeltaJumpTable2[0]);
end else begin
i:=i + Max(DeltaJumpTable1[Ord(lCaseArray[Ord(s[i])])],DeltaJumpTable2[j]);
end;

16
packages/rtl-unicode/fpmake.pp
View File

@ -16,11 +16,13 @@ Const
CPUnits = [aix,amiga,aros,android,beos,darwin,iphonesim,ios,emx,gba,nds,freebsd,go32v2,haiku,linux,morphos,netbsd,netware,netwlibc,openbsd,os2,solaris,watcom,wii,win32,win64,wince,dragonfly,freertos];
utf8bidiOSes = [netware,netwlibc];
freebidiOSes = [netware,netwlibc];
GraphemeBreakPropertyOSes = AllOSes-[embedded,zxspectrum,msxdos,amstradcpc];
EastAsianWidthOSes = AllOSes-[embedded,zxspectrum,msxdos,amstradcpc];
// Character not movable because fpwidestring depends on it.
// CharacterOSes = [android,darwin,freebsd,linux,netbsd,openbsd,solaris,win32,win64,dragonfly];
UnicodeAllOSes = CollationOSes + utf8bidiOSes + freebidiOSes + CPUnits;
UnicodeAllOSes = CollationOSes + utf8bidiOSes + freebidiOSes + CPUnits + GraphemeBreakPropertyOSes + EastAsianWidthOSes;
// Amiga has a crt in its RTL dir, but it is commented in the makefile
@ -138,6 +140,18 @@ begin
T:=P.Targets.AddImplicitUnit('cp950.pas',CPUnits);
// T:=P.Targets.AddUnit('character.pp',characterOSes);
T:=P.Targets.AddUnit('graphemebreakproperty.pp',GraphemeBreakPropertyOSes);
with T.Dependencies do
begin
AddInclude('graphemebreakproperty_code.inc');
end;
T:=P.Targets.AddUnit('eastasianwidth.pp',EastAsianWidthOSes);
with T.Dependencies do
begin
AddInclude('eastasianwidth_code.inc');
end;
end
end;

55
packages/rtl-unicode/src/inc/eastasianwidth.pp Normal file
View File

@ -0,0 +1,55 @@
{ EastAsianWidth Unicode data unit.
Copyright (C) 2021 Nikolay Nikolov <nickysn@users.sourceforge.net>
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.
}
unit eastasianwidth;
{$MODE objfpc}
interface
type
TEastAsianWidth = (
eawN,
eawA,
eawF,
eawH,
eawNa,
eawW);
function GetEastAsianWidth(Ch: UCS4Char): TEastAsianWidth;
implementation
function GetEastAsianWidth(Ch: UCS4Char): TEastAsianWidth;
begin
{$I eastasianwidth_code.inc}
end;
end.

300
packages/rtl-unicode/src/inc/eastasianwidth_code.inc Normal file
View File

@ -0,0 +1,300 @@
{ do not edit, this file is autogenerated by the eawparser tool }
if(Ch=12288)or
((Ch>=65281)and(Ch<=65376))or
((Ch>=65504)and(Ch<=65510))then result:=eawF else
if(Ch=8361)or
((Ch>=65377)and(Ch<=65470))or
((Ch>=65474)and(Ch<=65479))or
((Ch>=65482)and(Ch<=65487))or
((Ch>=65490)and(Ch<=65495))or
((Ch>=65498)and(Ch<=65500))or
((Ch>=65512)and(Ch<=65518))then result:=eawH else
if((Ch>=32)and(Ch<=126))or
((Ch>=162)and(Ch<=163))or
((Ch>=165)and(Ch<=166))or
(Ch=172)or
(Ch=175)or
((Ch>=10214)and(Ch<=10221))or
((Ch>=10629)and(Ch<=10630))then result:=eawNa else
case Ch of
161..168,
170,
173..180,
182..186,
188..191,
198,
208,
215..216,
222..225,
230,
232..234,
236..237,
240,
242..243,
247..250,
252,
254,
257,
273,
275,
283,
294..295,
299,
305..307,
312,
319..322,
324,
328..331,
333,
338..339,
358..359,
363,
462,
464,
466,
468,
470,
472,
474,
476,
593,
609,
708,
711,
713..715,
717,
720,
728..731,
733,
735,
768..879,
913..929,
931..937,
945..961,
963..969,
1025,
1040..1103,
1105,
8208,
8211..8214,
8216..8217,
8220..8221,
8224..8226,
8228..8231,
8240,
8242..8243,
8245,
8251,
8254,
8308,
8319,
8321..8324,
8364,
8451,
8453,
8457,
8467,
8470,
8481..8482,
8486,
8491,
8531..8532,
8539..8542,
8544..8555,
8560..8569,
8585,
8592..8601,
8632..8633,
8658,
8660,
8679,
8704,
8706..8707,
8711..8712,
8715,
8719,
8721,
8725,
8730,
8733..8736,
8739,
8741,
8743..8748,
8750,
8756..8759,
8764..8765,
8776,
8780,
8786,
8800..8801,
8804..8807,
8810..8811,
8814..8815,
8834..8835,
8838..8839,
8853,
8857,
8869,
8895,
8978,
9312..9449,
9451..9547,
9552..9587,
9600..9615,
9618..9621,
9632..9633,
9635..9641,
9650..9651,
9654..9655,
9660..9661,
9664..9665,
9670..9672,
9675,
9678..9681,
9698..9701,
9711,
9733..9734,
9737,
9742..9743,
9756,
9758,
9792,
9794,
9824..9825,
9827..9829,
9831..9834,
9836..9837,
9839,
9886..9887,
9919,
9926..9933,
9935..9939,
9941..9953,
9955,
9960..9961,
9963..9969,
9972,
9974..9977,
9979..9980,
9982..9983,
10045,
10102..10111,
11094..11097,
12872..12879,
57344..63743,
65024..65039,
65533,
127232..127242,
127248..127277,
127280..127337,
127344..127373,
127375..127376,
127387..127404,
917760..917999,
983040..1048573,
1048576..1114109:result:=eawA;
4352..4447,
8986..8987,
9001..9002,
9193..9196,
9200,
9203,
9725..9726,
9748..9749,
9800..9811,
9855,
9875,
9889,
9898..9899,
9917..9918,
9924..9925,
9934,
9940,
9962,
9970..9971,
9973,
9978,
9981,
9989,
9994..9995,
10024,
10060,
10062,
10067..10069,
10071,
10133..10135,
10160,
10175,
11035..11036,
11088,
11093,
11904..11929,
11931..12019,
12032..12245,
12272..12283,
12289..12350,
12353..12438,
12441..12543,
12549..12589,
12593..12686,
12688..12730,
12736..12771,
12784..12830,
12832..12871,
12880..13054,
13056..19903,
19968..42124,
42128..42182,
43360..43388,
44032..55203,
63744..64255,
65040..65049,
65072..65106,
65108..65126,
65128..65131,
94176,
94208..100332,
100352..101106,
110592..110593,
126980,
127183,
127374,
127377..127386,
127488..127490,
127504..127547,
127552..127560,
127568..127569,
127744..127776,
127789..127797,
127799..127868,
127870..127891,
127904..127946,
127951..127955,
127968..127984,
127988,
127992..128062,
128064,
128066..128252,
128255..128317,
128331..128334,
128336..128359,
128378,
128405..128406,
128420,
128507..128591,
128640..128709,
128716,
128720..128722,
128747..128748,
128756..128758,
129296..129310,
129312..129319,
129328,
129331..129342,
129344..129355,
129360..129374,
129408..129425,
129472,
131072..196605,
196608..262141:result:=eawW;
else result:=eawN end

180
packages/rtl-unicode/src/inc/graphemebreakproperty.pp Normal file
View File

@ -0,0 +1,180 @@
{ GraphemeBreakProperty Unicode data unit.
Copyright (C) 2021 Nikolay Nikolov <nickysn@users.sourceforge.net>
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.
}
unit graphemebreakproperty;
{$MODE objfpc}
interface
type
TGraphemeBreakProperty = (
gbpOther,
gbpPrepend,
gbpCR,
gbpLF,
gbpControl,
gbpExtend,
gpbRegional_Indicator,
gbpSpacingMark,
gbpL,
gbpV,
gbpT,
gbpLV,
gbpLVT,
gbpE_Base,
gbpE_Modifier,
gbpZWJ,
gbpGlue_After_Zwj,
gbpE_Base_GAZ);
{ TUnicodeStringExtendedGraphemeClustersEnumerator }
TUnicodeStringExtendedGraphemeClustersEnumerator = class
private
FStr: UnicodeString;
FCurrentIndexStart: SizeInt;
FCurrentIndexEnd: SizeInt;
FNextIndexEnd: SizeInt;
FNextGBP: TGraphemeBreakProperty;
FNextCodePoint: UCS4Char;
FCurrentGBP: TGraphemeBreakProperty;
FCurrentCodePoint: UCS4Char;
FRI_Sequence_Length: Integer;
FE_Base_EBG_Extend_Sequence: Boolean;
function GetCurrent: UnicodeString;
procedure FetchNextChar;
public
constructor Create(const S: UnicodeString);
function GetEnumerator: TUnicodeStringExtendedGraphemeClustersEnumerator;
function MoveNext: Boolean;
property Current: UnicodeString read GetCurrent;
end;
function GetGraphemeBreakProperty(Ch: UCS4Char): TGraphemeBreakProperty;
implementation
function GetGraphemeBreakProperty(Ch: UCS4Char): TGraphemeBreakProperty;
begin
{$I graphemebreakproperty_code.inc}
end;
{ TUnicodeStringExtendedGraphemeClustersEnumerator }
function TUnicodeStringExtendedGraphemeClustersEnumerator.GetCurrent: UnicodeString;
begin
Result := Copy(FStr, FCurrentIndexStart, FCurrentIndexEnd - FCurrentIndexStart + 1);
end;
procedure TUnicodeStringExtendedGraphemeClustersEnumerator.FetchNextChar;
begin
Inc(FNextIndexEnd);
if FNextIndexEnd <= Length(FStr) then
begin
FNextCodePoint := Ord(FStr[FNextIndexEnd]);
{ high surrogate, followed by low surrogate? }
if (FNextCodePoint >= $D800) and (FNextCodePoint <= $DBFF) and ((FNextIndexEnd + 1) <= Length(FStr)) and
(Ord(FStr[FNextIndexEnd + 1]) >= $DC00) and (Ord(FStr[FNextIndexEnd + 1]) <= $DFFF) then
begin
Inc(FNextIndexEnd);
FNextCodePoint := $10000 + (((FNextCodePoint - $D800) shl 10) or (Ord(FStr[FNextIndexEnd]) - $DC00));
end;
end
else
FNextCodePoint := 0;
FNextGBP := GetGraphemeBreakProperty(FNextCodePoint);
end;
constructor TUnicodeStringExtendedGraphemeClustersEnumerator.Create(const S: UnicodeString);
begin
FStr := S;
FCurrentIndexStart := 0;
FCurrentIndexEnd := 0;
FNextIndexEnd := 0;
FRI_Sequence_Length := 0;
FE_Base_EBG_Extend_Sequence := False;
FetchNextChar;
end;
function TUnicodeStringExtendedGraphemeClustersEnumerator.GetEnumerator: TUnicodeStringExtendedGraphemeClustersEnumerator;
begin
Result := Self;
end;
function TUnicodeStringExtendedGraphemeClustersEnumerator.MoveNext: Boolean;
begin
FCurrentIndexStart := FCurrentIndexEnd + 1;
if FCurrentIndexStart > Length(FStr) then
Exit(false);
repeat
FCurrentGBP := FNextGBP;
FCurrentCodePoint := FNextCodePoint;
FCurrentIndexEnd := FNextIndexEnd;
if FCurrentGBP = gpbRegional_Indicator then
Inc(FRI_Sequence_Length)
else
FRI_Sequence_Length := 0;
FE_Base_EBG_Extend_Sequence := (FCurrentGBP in [gbpE_Base, gbpE_Base_GAZ]) or (FE_Base_EBG_Extend_Sequence and (FCurrentGBP = gbpExtend));
FetchNextChar;
if FNextIndexEnd > Length(FStr) then
Exit(True);
{ Do not break between a CR and LF. Otherwise, break before and after controls. }
if (FCurrentGBP = gbpCR) and (FNextGBP = gbpLF) then
continue
else if (FCurrentGBP in [gbpControl, gbpCR, gbpLF]) or (FNextGBP in [gbpControl, gbpCR, gbpLF]) then
Exit(True)
{ Do not break Hangul syllable sequences. }
else if ((FCurrentGBP = gbpL) and (FNextGBP in [gbpL, gbpV, gbpLV, gbpLVT])) or
((FCurrentGBP in [gbpLV, gbpV]) and (FNextGBP in [gbpV, gbpT])) or
((FCurrentGBP in [gbpLVT, gbpT]) and (FNextGBP = gbpT)) then
continue
{ Do not break before extending characters or ZWJ. }
else if FNextGBP in [gbpExtend, gbpZWJ] then
continue
{ Only for extended grapheme clusters:
Do not break before SpacingMarks, or after Prepend characters. }
else if (FCurrentGBP = gbpPrepend) or (FNextGBP = gbpSpacingMark) then
continue
{ Do not break within emoji modifier sequences or emoji zwj sequences. }
else if ((FCurrentGBP = gbpZWJ) and (FNextGBP in [gbpGlue_After_Zwj, gbpE_Base_GAZ])) or
(FE_Base_EBG_Extend_Sequence and (FNextGBP = gbpE_Modifier)) then
continue
{ Do not break within emoji flag sequences. That is, do not break between regional indicator (RI) symbols if there is an odd number of RI characters before the break point. }
else if (FCurrentGBP = gpbRegional_Indicator) and (FNextGBP = gpbRegional_Indicator) and Odd(FRI_Sequence_Length) then
continue
{ Otherwise, break everywhere. }
else
Exit(True);
until False;
end;
end.

511
packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc Normal file
View File

@ -0,0 +1,511 @@
{ do not edit, this file is autogenerated by the gbpparser tool }
if Ch=13then result:=gbpCR else
if Ch=10then result:=gbpLF else
if Ch=8205then result:=gbpZWJ else
if(Ch>=127462)and(Ch<=127487)then result:=gpbRegional_Indicator else
if(Ch>=127995)and(Ch<=127999)then result:=gbpE_Modifier else
if(Ch>=128102)and(Ch<=128105)then result:=gbpE_Base_GAZ else
if(Ch>=44032)and(Ch<=55203)then begin if((Ch-44032)mod 28)=0then result:=gbpLV else result:=gbpLVT end else
if((Ch>=4352)and(Ch<=4447))or
((Ch>=43360)and(Ch<=43388))then result:=gbpL else
if((Ch>=4448)and(Ch<=4519))or
((Ch>=55216)and(Ch<=55238))then result:=gbpV else
if((Ch>=4520)and(Ch<=4607))or
((Ch>=55243)and(Ch<=55291))then result:=gbpT else
if(Ch=10084)or
(Ch=128139)or
(Ch=128488)then result:=gbpGlue_After_Zwj else
if((Ch>=1536)and(Ch<=1541))or
(Ch=1757)or
(Ch=1807)or
(Ch=2274)or
(Ch=3406)or
(Ch=69821)or
((Ch>=70082)and(Ch<=70083))then result:=gbpPrepend else
if((Ch>=0)and(Ch<=31))or
((Ch>=127)and(Ch<=159))or
(Ch=173)or
(Ch=1564)or
(Ch=6158)or
(Ch=8203)or
((Ch>=8206)and(Ch<=8207))or
((Ch>=8232)and(Ch<=8238))or
((Ch>=8288)and(Ch<=8303))or
((Ch>=55296)and(Ch<=57343))or
(Ch=65279)or
((Ch>=65520)and(Ch<=65531))or
((Ch>=113824)and(Ch<=113827))or
((Ch>=119155)and(Ch<=119162))or
((Ch>=917504)and(Ch<=917535))or
((Ch>=917632)and(Ch<=917759))or
((Ch>=918000)and(Ch<=921599))then result:=gbpControl else
if(Ch=9757)or
(Ch=9977)or
((Ch>=9994)and(Ch<=9997))or
(Ch=127877)or
((Ch>=127939)and(Ch<=127940))or
((Ch>=127946)and(Ch<=127947))or
((Ch>=128066)and(Ch<=128067))or
((Ch>=128070)and(Ch<=128080))or
(Ch=128110)or
((Ch>=128112)and(Ch<=128120))or
(Ch=128124)or
((Ch>=128129)and(Ch<=128131))or
((Ch>=128133)and(Ch<=128135))or
(Ch=128170)or
(Ch=128373)or
(Ch=128378)or
(Ch=128400)or
((Ch>=128405)and(Ch<=128406))or
((Ch>=128581)and(Ch<=128583))or
((Ch>=128587)and(Ch<=128591))or
(Ch=128675)or
((Ch>=128692)and(Ch<=128694))or
(Ch=128704)or
((Ch>=129304)and(Ch<=129310))or
(Ch=129318)or
(Ch=129328)or
((Ch>=129331)and(Ch<=129337))or
((Ch>=129340)and(Ch<=129342))then result:=gbpE_Base else
case Ch of
768..879,
1155..1161,
1425..1469,
1471,
1473..1474,
1476..1477,
1479,
1552..1562,
1611..1631,
1648,
1750..1756,
1759..1764,
1767..1768,
1770..1773,
1809,
1840..1866,
1958..1968,
2027..2035,
2070..2073,
2075..2083,
2085..2087,
2089..2093,
2137..2139,
2260..2306,
2362,
2364,
2369..2376,
2381,
2385..2391,
2402..2403,
2433,
2492,
2494,
2497..2500,
2509,
2519,
2530..2531,
2561..2562,
2620,
2625..2626,
2631..2632,
2635..2637,
2641,
2672..2673,
2677,
2689..2690,
2748,
2753..2757,
2759..2760,
2765,
2786..2787,
2817,
2876,
2878..2879,
2881..2884,
2893,
2902..2903,
2914..2915,
2946,
3006,
3008,
3021,
3031,
3072,
3134..3136,
3142..3144,
3146..3149,
3157..3158,
3170..3171,
3201,
3260,
3263,
3266,
3270,
3276..3277,
3285..3286,
3298..3299,
3329,
3390,
3393..3396,
3405,
3415,
3426..3427,
3530,
3535,
3538..3540,
3542,
3551,
3633,
3636..3642,
3655..3662,
3761,
3764..3769,
3771..3772,
3784..3789,
3864..3865,
3893,
3895,
3897,
3953..3966,
3968..3972,
3974..3975,
3981..3991,
3993..4028,
4038,
4141..4144,
4146..4151,
4153..4154,
4157..4158,
4184..4185,
4190..4192,
4209..4212,
4226,
4229..4230,
4237,
4253,
4957..4959,
5906..5908,
5938..5940,
5970..5971,
6002..6003,
6068..6069,
6071..6077,
6086,
6089..6099,
6109,
6155..6157,
6277..6278,
6313,
6432..6434,
6439..6440,
6450,
6457..6459,
6679..6680,
6683,
6742,
6744..6750,
6752,
6754,
6757..6764,
6771..6780,
6783,
6832..6846,
6912..6915,
6964,
6966..6970,
6972,
6978,
7019..7027,
7040..7041,
7074..7077,
7080..7081,
7083..7085,
7142,
7144..7145,
7149,
7151..7153,
7212..7219,
7222..7223,
7376..7378,
7380..7392,
7394..7400,
7405,
7412,
7416..7417,
7616..7669,
7675..7679,
8204,
8400..8432,
11503..11505,
11647,
11744..11775,
12330..12335,
12441..12442,
42607..42610,
42612..42621,
42654..42655,
42736..42737,
43010,
43014,
43019,
43045..43046,
43204..43205,
43232..43249,
43302..43309,
43335..43345,
43392..43394,
43443,
43446..43449,
43452,
43493,
43561..43566,
43569..43570,
43573..43574,
43587,
43596,
43644,
43696,
43698..43700,
43703..43704,
43710..43711,
43713,
43756..43757,
43766,
44005,
44008,
44013,
64286,
65024..65039,
65056..65071,
65438..65439,
66045,
66272,
66422..66426,
68097..68099,
68101..68102,
68108..68111,
68152..68154,
68159,
68325..68326,
69633,
69688..69702,
69759..69761,
69811..69814,
69817..69818,
69888..69890,
69927..69931,
69933..69940,
70003,
70016..70017,
70070..70078,
70090..70092,
70191..70193,
70196,
70198..70199,
70206,
70367,
70371..70378,
70400..70401,
70460,
70462,
70464,
70487,
70502..70508,
70512..70516,
70712..70719,
70722..70724,
70726,
70832,
70835..70840,
70842,
70845,
70847..70848,
70850..70851,
71087,
71090..71093,
71100..71101,
71103..71104,
71132..71133,
71219..71226,
71229,
71231..71232,
71339,
71341,
71344..71349,
71351,
71453..71455,
71458..71461,
71463..71467,
72752..72758,
72760..72765,
72767,
72850..72871,
72874..72880,
72882..72883,
72885..72886,
92912..92916,
92976..92982,
94095..94098,
113821..113822,
119141,
119143..119145,
119150..119170,
119173..119179,
119210..119213,
119362..119364,
121344..121398,
121403..121452,
121461,
121476,
121499..121503,
121505..121519,
122880..122886,
122888..122904,
122907..122913,
122915..122916,
122918..122922,
125136..125142,
125252..125258,
917536..917999:result:=gbpExtend;
2307,
2363,
2366..2368,
2377..2380,
2382..2383,
2434..2435,
2495..2496,
2503..2504,
2507..2508,
2563,
2622..2624,
2691,
2750..2752,
2761,
2763..2764,
2818..2819,
2880,
2887..2888,
2891..2892,
3007,
3009..3010,
3014..3016,
3018..3020,
3073..3075,
3137..3140,
3202..3203,
3262,
3264..3265,
3267..3268,
3271..3272,
3274..3275,
3330..3331,
3391..3392,
3398..3400,
3402..3404,
3458..3459,
3536..3537,
3544..3550,
3570..3571,
3635,
3763,
3902..3903,
3967,
4145,
4155..4156,
4182..4183,
4228,
6070,
6078..6085,
6087..6088,
6435..6438,
6441..6443,
6448..6449,
6451..6456,
6681..6682,
6741,
6743,
6765..6770,
6916,
6965,
6971,
6973..6977,
6979..6980,
7042,
7073,
7078..7079,
7082,
7143,
7146..7148,
7150,
7154..7155,
7204..7211,
7220..7221,
7393,
7410..7411,
43043..43044,
43047,
43136..43137,
43188..43203,
43346..43347,
43395,
43444..43445,
43450..43451,
43453..43456,
43567..43568,
43571..43572,
43597,
43755,
43758..43759,
43765,
44003..44004,
44006..44007,
44009..44010,
44012,
69632,
69634,
69762,
69808..69810,
69815..69816,
69932,
70018,
70067..70069,
70079..70080,
70188..70190,
70194..70195,
70197,
70368..70370,
70402..70403,
70463,
70465..70468,
70471..70472,
70475..70477,
70498..70499,
70709..70711,
70720..70721,
70725,
70833..70834,
70841,
70843..70844,
70846,
70849,
71088..71089,
71096..71099,
71102,
71216..71218,
71227..71228,
71230,
71340,
71342..71343,
71350,
71456..71457,
71462,
72751,
72766,
72873,
72881,
72884,
94033..94078,
119142,
119149:result:=gbpSpacingMark;
else result:=gbpOther 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}

2
rtl/embedded/Makefile
View File

@ -374,7 +374,7 @@ CPU_SPECIFIC_COMMON_UNITS=
ifeq ($(ARCH),arm)
CPU_SPECIFIC_COMMON_UNITS=sysutils math classes fgl macpas typinfo types rtlconsts getopts lineinfo
ifeq ($(SUBARCH),armv7m)
CPU_UNITS=lm3fury lm3tempest stm32f10x_ld stm32f10x_md stm32f10x_hd stm32f10x_xl stm32f10x_conn stm32f10x_cl lpc13xx lpc1768 lm4f120 sam3x8e xmc4500 cortexm3 cortexm4 # thumb2_bare
CPU_UNITS=lm3fury lm3tempest stm32f10x_ld stm32f10x_md stm32f10x_hd stm32f10x_xl stm32f10x_conn stm32f10x_cl lpc13xx lpc1768 sam3x8e xmc4500 cortexm3 cortexm4 # thumb2_bare
CPU_UNITS_DEFINED=1
endif
ifeq ($(SUBARCH),armv7em)

2
rtl/embedded/Makefile.fpc
View File

@ -71,7 +71,7 @@ CPU_SPECIFIC_COMMON_UNITS=
ifeq ($(ARCH),arm)
CPU_SPECIFIC_COMMON_UNITS=sysutils math classes fgl macpas typinfo types rtlconsts getopts lineinfo
ifeq ($(SUBARCH),armv7m)
CPU_UNITS=lm3fury lm3tempest stm32f10x_ld stm32f10x_md stm32f10x_hd stm32f10x_xl stm32f10x_conn stm32f10x_cl lpc13xx lpc1768 lm4f120 sam3x8e xmc4500 cortexm3 cortexm4 # thumb2_bare
CPU_UNITS=lm3fury lm3tempest stm32f10x_ld stm32f10x_md stm32f10x_hd stm32f10x_xl stm32f10x_conn stm32f10x_cl lpc13xx lpc1768 sam3x8e xmc4500 cortexm3 cortexm4 # thumb2_bare
CPU_UNITS_DEFINED=1
endif
ifeq ($(SUBARCH),armv7em)

14
rtl/embedded/arm/cortexm4f_start.inc
View File

@ -43,6 +43,14 @@ asm
str r1, [r0]
{$endif REMAP_VECTTAB}
{$if defined(FPUARM_HAS_VFP_EXTENSION)}
ldr r0, .Lcpacr
ldr r1, [r0]
orr r1, r1, #0xf00000
str r1, [r0]
dsb
isb
{$endif defined(FPUARM_HAS_VFP_EXTENSION)}
bl PASCALMAIN
b HaltProc
@ -56,10 +64,14 @@ asm
.long _data
.L_edata:
.long _edata
{$if defined(FPUARM_HAS_VFP_EXTENSION)}
.Lcpacr:
.long 0xE000ED88
{$endif defined(FPUARM_HAS_VFP_EXTENSION)}
{$ifdef REMAP_VECTTAB}
.Lvtor:
.long 0xE000ED08
.Ltext_start:
.long _text_start
{$endif REMAP_VECTTAB}
end;
end;

14
rtl/freertos/arm/cortexm4f_start.inc
View File

@ -43,6 +43,14 @@ asm
str r1, [r0]
{$endif REMAP_VECTTAB}
{$if defined(FPUARM_HAS_VFP_EXTENSION)}
ldr r0, .Lcpacr
ldr r1, [r0]
orr r1, r1, #0xf00000
str r1, [r0]
dsb
isb
{$endif defined(FPUARM_HAS_VFP_EXTENSION)}
bl PASCALMAIN
b HaltProc
@ -56,10 +64,14 @@ asm
.long _data
.L_edata:
.long _edata
{$if defined(FPUARM_HAS_VFP_EXTENSION)}
.Lcpacr:
.long 0xE000ED88
{$endif defined(FPUARM_HAS_VFP_EXTENSION)}
{$ifdef REMAP_VECTTAB}
.Lvtor:
.long 0xE000ED08
.Ltext_start:
.long _text_start
{$endif REMAP_VECTTAB}
end;
end;

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;

79
tests/test/units/strutils/tboyer.pp Normal file
View File

@ -0,0 +1,79 @@
{$mode objfpc}
uses
StrUtils;
const
result1 : array of SizeInt = (1, 4, 7, 10, 13, 16);
var
a : array of SizeInt;
i : LongInt;
begin
if FindMatchesBoyerMooreCaseSensitive('abcabcabcabcabcabcab','abcab',a,false) then
begin
if Length(a)<>1 then
halt(2);
if a[0]<>result1[0] then
halt(3);
end
else
halt(1);
if FindMatchesBoyerMooreCaseSensitive('abcabcabcabcabcabcab','abcab',a,true) then
begin
if Length(a)<>Length(result1) then
halt(12);
for i:=Low(a) to High(a) do
if a[i]<>result1[i] then
halt(13);
end
else
halt(11);
if FindMatchesBoyerMooreCaseInSensitive('abcabcabcabcabcabcab','abcab',a,false) then
begin
if Length(a)<>1 then
halt(22);
if a[0]<>result1[0] then
halt(23);
end
else
halt(21);
{
apparently not working yet:
if FindMatchesBoyerMooreCaseInSensitive('abcabcabcabcabcabcab','abcab',a,true) then
begin
if Length(a)<>Length(result1) then
halt(32);
for i:=Low(a) to High(a) do
if a[i]<>result1[i] then
halt(33);
end
else
halt(31);
if FindMatchesBoyerMooreCaseInSensitive('abcabcabcAbcabcAbcab','abcaB',a,false) then
begin
if Length(a)<>1 then
halt(42);
if a[0]<>result1[0] then
halt(43);
end
else
halt(41);
if FindMatchesBoyerMooreCaseInSensitive('abcabCabcAbcabcABcab','abcaB',a,true) then
begin
if Length(a)<>Length(result1) then
halt(52);
for i:=Low(a) to High(a) do
if a[i]<>result1[i] then
halt(53);
end
else
halt(51);
}
writeln('ok');
end.

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];

2
utils/unicode/cldrparser.lpr
View File

@ -54,7 +54,7 @@ const
' <HaltOnFail> may be one of (y, Y, t, T, 1) to halt the execution on the first failing.' + sLineBreak +
' ' + sLineBreak +
' The program expects some files to be present in the <dataDir> folder : ' + sLineBreak +
' - UCA_Rules_SHORT.xml ' + sLineBreak +
' - UCA_Rules_SHORT.txt ' + sLineBreak +
' - allkeys.txt this is the file allkeys_CLDR.txt renamed to allkeys.txt' + sLineBreak +
' These files are in the core.zip file of the CLDR release files. The CLDR''version used should be synchronized the' + sLineBreak +
' version of the Unicode version used, for example for Uniocde 7 it will be CLDR 26.' + sLineBreak +

14
utils/unicode/data/readme.txt
View File

@ -1,13 +1,13 @@
This folder requires the next files to be present:
Extracted from http://www.unicode.org/Public/6.2.0/ucd/UCD.zip:
* UnicodeData.txt
Extracted from https://www.unicode.org/Public/zipped/9.0.0/UCD.zip:
* UnicodeData.txt
* HangulSyllableType.txt
* PropList.txt
Extracted from http://www.unicode.org/Public/UCA/6.2.0/CollationAuxiliary.zip:
* allkeys.txt : this file is actually the allkeys_CLDR.txt file renamed. It is the CLDR's root collation.
* UCA_Rules_SHORT.xml
#??? Extracted from http://www.unicode.org/Public/UCA/6.2.0/CollationAuxiliary.zip:
Extracted from http://www.unicode.org/Public/cldr/22/core.zip (see the "common\collation" folder):
* all the language specific xml files (de.xml, es.xml, ...)
Extracted from https://www.unicode.org/Public/cldr/30/core.zip
* allkeys.txt : this file is actually the allkeys_CLDR.txt file renamed. It is the CLDR's root collation.
* UCA_Rules_SHORT.txt
* all the language specific xml files (de.xml, es.xml, ...) (see the "common\collation" folder):

58
utils/unicode/eawparser.lpi Normal file
View File

@ -0,0 +1,58 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="eawparser"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="eawparser.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="eawparser"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

332
utils/unicode/eawparser.lpr Normal file
View File

@ -0,0 +1,332 @@
{ Parser and code generator for the EastAsianWidth.
Copyright (C) 2021 Nikolay Nikolov <nickysn@users.sourceforge.net>
This source is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2 of the License, or (at your option)
any later version.
This code is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
A copy of the GNU General Public License is available on the World Wide Web
at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
Boston, MA 02110-1335, USA.
}
program eawparser;
{$mode objfpc}{$H+}
uses
SysUtils, StrUtils;
type
TEastAsianWidth = (
eawN,
eawA,
eawF,
eawH,
eawNa,
eawW);
TRange = record
RangeLo, RangeHi: UCS4Char;
end;
TRanges = array of TRange;
var
EastAsianWidths: array [UCS4Char] of TEastAsianWidth;
EAWStats: array [TEastAsianWidth] of record
Exists: Boolean;
Handled: Boolean;
MinValue: UCS4Char;
MaxValue: UCS4Char;
Count: LongInt;
Ranges: TRanges;
end;
function ParseEastAsianWidth(S: string): TEastAsianWidth;
begin
S := Trim(S);
case S of
'N':
Result := eawN;
'A':
Result := eawA;
'F':
Result := eawF;
'H':
Result := eawH;
'Na':
Result := eawNa;
'W':
Result := eawW;
else
raise EArgumentException('Unknown east asian width: ''' + S + '''');
end;
end;
procedure ParseRange(S: string; out RangeLo, RangeHi: UCS4Char);
var
dp: SizeInt;
begin
S := Trim(S);
dp := Pos('..', S);
if dp > 0 then
begin
RangeLo := StrToInt('$' + LeftStr(S, dp - 1));
RangeHi := StrToInt('$' + Copy(S, dp + 2, Length(S) - dp + 3));
end
else
begin
RangeLo := StrToInt('$' + S);
RangeHi := RangeLo;
end;
end;
procedure ParseEastAsianWidths(const FileName: string);
var
InF: TextFile;
S: string;
SplitS: TStringArray;
LineNr: Integer = 0;
eaw: TEastAsianWidth;
RangeLo, RangeHi, R: UCS4Char;
begin
{ - All code points, assigned or unassigned, that are not listed
explicitly are given the value "N". }
for R in UCS4Char do
EastAsianWidths[R] := eawN;
{ - The unassigned code points in the following blocks default to "W":
CJK Unified Ideographs Extension A: U+3400..U+4DBF
CJK Unified Ideographs: U+4E00..U+9FFF
CJK Compatibility Ideographs: U+F900..U+FAFF }
for R := $3400 to $4DBF do
EastAsianWidths[R] := eawW;
for R := $4E00 to $9FFF do
EastAsianWidths[R] := eawW;
for R := $F900 to $FAFF do
EastAsianWidths[R] := eawW;
{ - All undesignated code points in Planes 2 and 3, whether inside or
outside of allocated blocks, default to "W":
Plane 2: U+20000..U+2FFFD
Plane 3: U+30000..U+3FFFD }
for R := $20000 to $2FFFD do
EastAsianWidths[R] := eawW;
for R := $30000 to $3FFFD do
EastAsianWidths[R] := eawW;
if not FileExists(FileName) then
begin
Writeln('File doesn''t exist: ', FileName);
Halt(1);
end;
AssignFile(InF, FileName);
Reset(InF);
while not EoF(InF) do
begin
Inc(LineNr);
Readln(InF, S);
S := Trim(S);
if Pos('#', S) > 0 then
S := LeftStr(S, Pos('#', S) - 1);
if S <> '' then
begin
SplitS := S.Split([';']);
if Length(SplitS) <> 2 then
raise Exception.Create('Invalid number of ; separators on line ' + IntToStr(LineNr));
ParseRange(SplitS[0], RangeLo, RangeHi);
eaw := ParseEastAsianWidth(SplitS[1]);
for R := RangeLo to RangeHi do
EastAsianWidths[R] := eaw;
end;
end;
CloseFile(InF);
end;
procedure CalcStatsAndRanges;
var
Ch: UCS4Char;
eaw, prev_eaw: TEastAsianWidth;
begin
FillChar(EAWStats, SizeOf(EAWStats), 0);
eaw := Low(TEastAsianWidth);
for Ch := Low(UCS4Char) to High(UCS4Char) do
begin
prev_eaw := eaw;
eaw := EastAsianWidths[Ch];
with EAWStats[eaw] do
begin
if not Exists then
begin
Exists := True;
MinValue := Ch;
MaxValue := Ch;
Count := 1;
SetLength(Ranges, 1);
Ranges[0].RangeLo := Ch;
Ranges[0].RangeHi := Ch;
end
else
begin
MaxValue := Ch;
Inc(Count);
if prev_eaw <> eaw then
begin
SetLength(Ranges, Length(Ranges) + 1);
with Ranges[High(Ranges)] do
begin
RangeLo := Ch;
RangeHi := Ch;
end;
end
else
Ranges[High(Ranges)].RangeHi := Ch;
end;
end;
end;
end;
procedure MaybeCoalesceRanges(RLo, RHi: UCS4Char);
var
eaw: TEastAsianWidth;
RI: Integer;
begin
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
if EAWStats[eaw].Exists and (not EAWStats[eaw].Handled) then
begin
for RI := 0 to High(EAWStats[eaw].Ranges) - 1 do
if (EAWStats[eaw].Ranges[RI].RangeHi = (RLo - 1)) and
(EAWStats[eaw].Ranges[RI + 1].RangeLo = (RHi + 1)) then
begin
EAWStats[eaw].Ranges[RI].RangeHi := EAWStats[eaw].Ranges[RI + 1].RangeHi;
Delete(EAWStats[eaw].Ranges, RI + 1, 1);
exit;
end;
end;
end;
function FindMinRangeCount: Integer;
var
eaw: TEastAsianWidth;
begin
Result := High(Integer);
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
if EAWStats[eaw].Exists and (not EAWStats[eaw].Handled) and (Length(EAWStats[eaw].Ranges) < Result) then
Result := Length(EAWStats[eaw].Ranges);
end;
procedure GenCode(const OutFileName: string);
const
RangeCountThreshold = 30{400};
var
eaw: TEastAsianWidth;
RI, NextRangeCount: Integer;
OutFile: TextFile;
begin
Writeln('Generating file: ', OutFileName);
AssignFile(OutFile, OutFileName);
Rewrite(OutFile);
Writeln(OutFile, '{ do not edit, this file is autogenerated by the eawparser tool }');
{ unused properties are already handled }
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
if not EAWStats[eaw].Exists then
EAWStats[eaw].Handled := True;
{ handle single codepoints first }
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
if (not EAWStats[eaw].Handled) and (EAWStats[eaw].Count = 1) then
begin
if EAWStats[eaw].MinValue <> EAWStats[eaw].MaxValue then
raise Exception.Create('Internal error');
Writeln(OutFile, 'if Ch=', EAWStats[eaw].MinValue, 'then result:=',eaw,' else');
EAWStats[eaw].Handled := True;
MaybeCoalesceRanges(EAWStats[eaw].MinValue, EAWStats[eaw].MaxValue);
end;
{ handle single range codepoints next }
while FindMinRangeCount = 1 do
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
if (not EAWStats[eaw].Handled) and (Length(EAWStats[eaw].Ranges) = 1) then
begin
Writeln(OutFile, 'if(Ch>=', EAWStats[eaw].MinValue, ')and(Ch<=', EAWStats[eaw].MaxValue, ')then result:=',eaw,' else');
EAWStats[eaw].Handled := True;
MaybeCoalesceRanges(EAWStats[eaw].MinValue, EAWStats[eaw].MaxValue);
end;
repeat
NextRangeCount := FindMinRangeCount;
if NextRangeCount <= RangeCountThreshold then
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
begin
if not EAWStats[eaw].Handled and (Length(EAWStats[eaw].Ranges) <= NextRangeCount) then
begin
EAWStats[eaw].Handled := True;
Write(OutFile, 'if');
for RI := 0 to High(EAWStats[eaw].Ranges) do
begin
if RI <> 0 then
Writeln(OutFile, 'or');
with EAWStats[eaw].Ranges[RI] do
begin
if RangeLo = RangeHi then
Write(OutFile, '(Ch=', RangeLo, ')')
else
Write(OutFile, '((Ch>=', RangeLo, ')and(Ch<=', RangeHi, '))');
MaybeCoalesceRanges(RangeLo, RangeHi);
end;
end;
Writeln(OutFile, 'then result:=',eaw,' else');
end;
end;
until NextRangeCount > RangeCountThreshold;
if NextRangeCount <> High(Integer) then
begin
//for eaw := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
// if not EAWStats[eaw].Handled then
// Writeln(eaw, ' ', EAWStats[eaw].MinValue, '..', EAWStats[eaw].MaxValue, ' ', EAWStats[eaw].Count, ' ', Length(EAWStats[eaw].Ranges), ' ', (EAWStats[eaw].MaxValue - EAWStats[eaw].MinValue + 7) div 8);
Writeln(OutFile, 'case Ch of');
for eaw := Succ(Low(TEastAsianWidth)) to High(TEastAsianWidth) do
begin
if not EAWStats[eaw].Handled then
begin
EAWStats[eaw].Handled := True;
for RI := 0 to High(EAWStats[eaw].Ranges) do
begin
if RI <> 0 then
Writeln(OutFile, ',');
with EAWStats[eaw].Ranges[RI] do
begin
if RangeLo = RangeHi then
Write(OutFile, RangeLo)
else
Write(OutFile, RangeLo, '..', RangeHi);
end;
end;
Writeln(OutFile, ':result:=', eaw, ';');
end;
end;
Writeln(OutFile, 'else result:=eawN end');
end
else
Writeln(OutFile, 'result:=eawN');
CloseFile(OutFile);
end;
begin
ParseEastAsianWidths('data/UCD/EastAsianWidth.txt');
CalcStatsAndRanges;
GenCode('eastasianwidth_code.inc');
Writeln('Done');
end.

2
utils/unicode/fpmake.pp
View File

@ -60,6 +60,8 @@ begin
T:=P.Targets.AddProgram('cldrparser.lpr');
T:=P.Targets.AddProgram('unihelper.lpr');
T:=P.Targets.AddProgram('gbpparser.lpr');
T:=P.Targets.AddProgram('eawparser.lpr');
end;
end;

58
utils/unicode/gbpparser.lpi Normal file
View File

@ -0,0 +1,58 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="gbpparser"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="gbpparser.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="gbpparser"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

379
utils/unicode/gbpparser.lpr Normal file
View File

@ -0,0 +1,379 @@
{ Parser and code generator for the GraphemeBreakProperty.
Copyright (C) 2021 Nikolay Nikolov <nickysn@users.sourceforge.net>
This source is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2 of the License, or (at your option)
any later version.
This code is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
A copy of the GNU General Public License is available on the World Wide Web
at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
Boston, MA 02110-1335, USA.
}
program gbpparser;
{$mode objfpc}{$H+}
uses
SysUtils, StrUtils;
type
TGraphemeBreakProperty = (
gbpOther,
gbpPrepend,
gbpCR,
gbpLF,
gbpControl,
gbpExtend,
gpbRegional_Indicator,
gbpSpacingMark,
gbpL,
gbpV,
gbpT,
gbpLV,
gbpLVT,
gbpE_Base,
gbpE_Modifier,
gbpZWJ,
gbpGlue_After_Zwj,
gbpE_Base_GAZ);
TRange = record
RangeLo, RangeHi: UCS4Char;
end;
TRanges = array of TRange;
var
GraphemeBreakProperties: array [UCS4Char] of TGraphemeBreakProperty;
GBPStats: array [TGraphemeBreakProperty] of record
Exists: Boolean;
Handled: Boolean;
MinValue: UCS4Char;
MaxValue: UCS4Char;
Count: LongInt;
Ranges: TRanges;
end;
function ParseGraphemeBreakProperty(S: string): TGraphemeBreakProperty;
begin
S := Trim(S);
case S of
'Prepend':
Result := gbpPrepend;
'CR':
Result := gbpCR;
'LF':
Result := gbpLF;
'Control':
Result := gbpControl;
'Extend':
Result := gbpExtend;
'Regional_Indicator':
Result := gpbRegional_Indicator;
'SpacingMark':
Result := gbpSpacingMark;
'L':
Result := gbpL;
'V':
Result := gbpV;
'T':
Result := gbpT;
'LV':
Result := gbpLV;
'LVT':
Result := gbpLVT;
'E_Base':
Result := gbpE_Base;
'E_Modifier':
Result := gbpE_Modifier;
'ZWJ':
Result := gbpZWJ;
'Glue_After_Zwj':
Result := gbpGlue_After_Zwj;
'E_Base_GAZ':
Result := gbpE_Base_GAZ;
else
raise EArgumentException('Unknown grapheme break property: ''' + S + '''');
end;
end;
procedure ParseRange(S: string; out RangeLo, RangeHi: UCS4Char);
var
dp: SizeInt;
begin
S := Trim(S);
dp := Pos('..', S);
if dp > 0 then
begin
RangeLo := StrToInt('$' + LeftStr(S, dp - 1));
RangeHi := StrToInt('$' + Copy(S, dp + 2, Length(S) - dp + 3));
end
else
begin
RangeLo := StrToInt('$' + S);
RangeHi := RangeLo;
end;
end;
procedure ParseGraphemeBreakProperties(const FileName: string);
var
InF: TextFile;
S: string;
SplitS: TStringArray;
LineNr: Integer = 0;
gbp: TGraphemeBreakProperty;
RangeLo, RangeHi, R: UCS4Char;
begin
if not FileExists(FileName) then
begin
Writeln('File doesn''t exist: ', FileName);
Halt(1);
end;
AssignFile(InF, FileName);
Reset(InF);
while not EoF(InF) do
begin
Inc(LineNr);
Readln(InF, S);
S := Trim(S);
if Pos('#', S) > 0 then
S := LeftStr(S, Pos('#', S) - 1);
if S <> '' then
begin
SplitS := S.Split([';']);
if Length(SplitS) <> 2 then
raise Exception.Create('Invalid number of ; separators on line ' + IntToStr(LineNr));
ParseRange(SplitS[0], RangeLo, RangeHi);
gbp := ParseGraphemeBreakProperty(SplitS[1]);
for R := RangeLo to RangeHi do
GraphemeBreakProperties[R] := gbp;
end;
end;
CloseFile(InF);
end;
procedure CalcStatsAndRanges;
var
Ch: UCS4Char;
gbp, prev_gbp: TGraphemeBreakProperty;
begin
FillChar(GBPStats, SizeOf(GBPStats), 0);
gbp := Low(TGraphemeBreakProperty);
for Ch := Low(UCS4Char) to High(UCS4Char) do
begin
prev_gbp := gbp;
gbp := GraphemeBreakProperties[Ch];
with GBPStats[gbp] do
begin
if not Exists then
begin
Exists := True;
MinValue := Ch;
MaxValue := Ch;
Count := 1;
SetLength(Ranges, 1);
Ranges[0].RangeLo := Ch;
Ranges[0].RangeHi := Ch;
end
else
begin
MaxValue := Ch;
Inc(Count);
if prev_gbp <> gbp then
begin
SetLength(Ranges, Length(Ranges) + 1);
with Ranges[High(Ranges)] do
begin
RangeLo := Ch;
RangeHi := Ch;
end;
end
else
Ranges[High(Ranges)].RangeHi := Ch;
end;
end;
end;
end;
procedure MaybeCoalesceRanges(RLo, RHi: UCS4Char);
var
gbp: TGraphemeBreakProperty;
RI: Integer;
begin
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
if GBPStats[gbp].Exists and (not GBPStats[gbp].Handled) then
begin
for RI := 0 to High(GBPStats[gbp].Ranges) - 1 do
if (GBPStats[gbp].Ranges[RI].RangeHi = (RLo - 1)) and
(GBPStats[gbp].Ranges[RI + 1].RangeLo = (RHi + 1)) then
begin
GBPStats[gbp].Ranges[RI].RangeHi := GBPStats[gbp].Ranges[RI + 1].RangeHi;
Delete(GBPStats[gbp].Ranges, RI + 1, 1);
exit;
end;
end;
end;
function FindMinRangeCount: Integer;
var
gbp: TGraphemeBreakProperty;
begin
Result := High(Integer);
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
if GBPStats[gbp].Exists and (not GBPStats[gbp].Handled) and (Length(GBPStats[gbp].Ranges) < Result) then
Result := Length(GBPStats[gbp].Ranges);
end;
function ApplyLV_LVTCompression: Boolean;
const
RangeLo = 44032;
RangeHi = 55203;
var
Ch: UCS4Char;
begin
Result := False;
if (GBPStats[gbpLV].MinValue <> RangeLo) or (GBPStats[gbpLV].MaxValue <> (RangeHi - 27)) or
(GBPStats[gbpLVT].MinValue <> (RangeLo + 1)) or (GBPStats[gbpLVT].MaxValue <> RangeHi) then
exit;
for Ch := RangeLo to RangeHi do
begin
if ((Ch - RangeLo) mod 28) = 0 then
begin
if GraphemeBreakProperties[Ch] <> gbpLV then
exit;
end
else
begin
if GraphemeBreakProperties[Ch] <> gbpLVT then
exit;
end;
end;
Result := True;
end;
procedure GenCode(const OutFileName: string);
const
RangeCountThreshold = 30{400};
var
gbp: TGraphemeBreakProperty;
RI, NextRangeCount: Integer;
OutFile: TextFile;
begin
Writeln('Generating file: ', OutFileName);
AssignFile(OutFile, OutFileName);
Rewrite(OutFile);
Writeln(OutFile, '{ do not edit, this file is autogenerated by the gbpparser tool }');
{ unused properties are already handled }
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
if not GBPStats[gbp].Exists then
GBPStats[gbp].Handled := True;
{ handle single codepoints first }
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
if (not GBPStats[gbp].Handled) and (GBPStats[gbp].Count = 1) then
begin
if GBPStats[gbp].MinValue <> GBPStats[gbp].MaxValue then
raise Exception.Create('Internal error');
Writeln(OutFile, 'if Ch=', GBPStats[gbp].MinValue, 'then result:=',gbp,' else');
GBPStats[gbp].Handled := True;
MaybeCoalesceRanges(GBPStats[gbp].MinValue, GBPStats[gbp].MaxValue);
end;
{ handle single range codepoints next }
while FindMinRangeCount = 1 do
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
if (not GBPStats[gbp].Handled) and (Length(GBPStats[gbp].Ranges) = 1) then
begin
Writeln(OutFile, 'if(Ch>=', GBPStats[gbp].MinValue, ')and(Ch<=', GBPStats[gbp].MaxValue, ')then result:=',gbp,' else');
GBPStats[gbp].Handled := True;
MaybeCoalesceRanges(GBPStats[gbp].MinValue, GBPStats[gbp].MaxValue);
end;
if ApplyLV_LVTCompression then
begin
Writeln(OutFile, 'if(Ch>=44032)and(Ch<=55203)then begin if((Ch-44032)mod 28)=0then result:=gbpLV else result:=gbpLVT end else');
GBPStats[gbpLV].Handled := True;
GBPStats[gbpLVT].Handled := True;
end;
repeat
NextRangeCount := FindMinRangeCount;
if NextRangeCount <= RangeCountThreshold then
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
begin
if not GBPStats[gbp].Handled and (Length(GBPStats[gbp].Ranges) <= NextRangeCount) then
begin
GBPStats[gbp].Handled := True;
Write(OutFile, 'if');
for RI := 0 to High(GBPStats[gbp].Ranges) do
begin
if RI <> 0 then
Writeln(OutFile, 'or');
with GBPStats[gbp].Ranges[RI] do
begin
if RangeLo = RangeHi then
Write(OutFile, '(Ch=', RangeLo, ')')
else
Write(OutFile, '((Ch>=', RangeLo, ')and(Ch<=', RangeHi, '))');
MaybeCoalesceRanges(RangeLo, RangeHi);
end;
end;
Writeln(OutFile, 'then result:=',gbp,' else');
end;
end;
until NextRangeCount > RangeCountThreshold;
if NextRangeCount <> High(Integer) then
begin
//for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
// if not GBPStats[gbp].Handled then
// Writeln(gbp, ' ', GBPStats[gbp].MinValue, '..', GBPStats[gbp].MaxValue, ' ', GBPStats[gbp].Count, ' ', Length(GBPStats[gbp].Ranges), ' ', (GBPStats[gbp].MaxValue - GBPStats[gbp].MinValue + 7) div 8);
Writeln(OutFile, 'case Ch of');
for gbp := Succ(Low(TGraphemeBreakProperty)) to High(TGraphemeBreakProperty) do
begin
if not GBPStats[gbp].Handled then
begin
GBPStats[gbp].Handled := True;
for RI := 0 to High(GBPStats[gbp].Ranges) do
begin
if RI <> 0 then
Writeln(OutFile, ',');
with GBPStats[gbp].Ranges[RI] do
begin
if RangeLo = RangeHi then
Write(OutFile, RangeLo)
else
Write(OutFile, RangeLo, '..', RangeHi);
end;
end;
Writeln(OutFile, ':result:=', gbp, ';');
end;
end;
Writeln(OutFile, 'else result:=gbpOther end');
end
else
Writeln(OutFile, 'result:=gbpOther');
CloseFile(OutFile);
end;
begin
FillChar(GraphemeBreakProperties, SizeOf(GraphemeBreakProperties), 0);
ParseGraphemeBreakProperties('data/UCD/auxiliary/GraphemeBreakProperty.txt');
CalcStatsAndRanges;
GenCode('graphemebreakproperty_code.inc');
Writeln('Done');
end.

16
utils/unicode/parse-collations.bat
View File

@ -1,17 +1,17 @@
cldrparser.exe de.xml -d.\data -o.\data
cldrparser.exe de -d.\data -o.\data
echo
cldrparser es.xml -d.\data -o.\data
cldrparser es -d.\data -o.\data
echo
cldrparser fr_CA.xml -d.\data -o.\data
cldrparser fr_CA -d.\data -o.\data
echo
cldrparser ja.xml -d.\data -o.\data
cldrparser ja -d.\data -o.\data
echo
cldrparser ko.xml -d.\data -o.\data
cldrparser ko -d.\data -o.\data
echo
cldrparser ru.xml -d.\data -o.\data
cldrparser ru -d.\data -o.\data
echo
cldrparser sv.xml -d.\data -o.\data
cldrparser sv -d.\data -o.\data
echo
cldrparser zh.xml -d.\data -o.\data
cldrparser zh -d.\data -o.\data
pause

16
utils/unicode/parse-collations.sh
View File

@ -1,18 +1,18 @@
#!/bin/bash
./cldrparser de.xml -d./data -o./data
./cldrparser de -d./data -o./data
echo
./cldrparser es.xml -d./data -o./data
./cldrparser es -d./data -o./data
echo
./cldrparser fr_CA.xml -d./data -o./data
./cldrparser fr_CA -d./data -o./data
echo
./cldrparser ja.xml -d./data -o./data
./cldrparser ja -d./data -o./data
echo
./cldrparser ko.xml -d./data -o./data
./cldrparser ko -d./data -o./data
echo
./cldrparser ru.xml -d./data -o./data
./cldrparser ru -d./data -o./data
echo
./cldrparser sv.xml -d./data -o./data
./cldrparser sv -d./data -o./data
echo
./cldrparser zh.xml -d./data -o./data
./cldrparser zh -d./data -o./data
read -p "Press [Enter] key to continue ..."