summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authornickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2>2021-03-01 13:21:24 +0000
committernickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2>2021-03-01 13:21:24 +0000
commitefc9f396e6322803ca30817ffbb7efa47f056254 (patch)
tree6b133633c9766e3ae8e62d8a5ac988637e662e23
parent7970081cf98f70ce91af964068a6b32f062d9b8f (diff)
parente7fde3b46193c6a3865103c7a7a82e600f787782 (diff)
downloadfpc-efc9f396e6322803ca30817ffbb7efa47f056254.tar.gz
* synchronized with trunk
git-svn-id: https://svn.freepascal.org/svn/fpc/branches/wasm@48846 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r--compiler/Makefile4
-rw-r--r--compiler/Makefile.fpc5
-rw-r--r--compiler/aarch64/racpugas.pas11
-rw-r--r--compiler/aasmcnst.pas4
-rw-r--r--compiler/cgexcept.pas15
-rw-r--r--compiler/cutils.pas7
-rw-r--r--compiler/dbgdwarf.pas6
-rw-r--r--compiler/defutil.pas12
-rw-r--r--compiler/i386/n386add.pas2
-rw-r--r--compiler/jvm/hlcgcpu.pas4
-rw-r--r--compiler/jvm/jvmdef.pas3
-rw-r--r--compiler/llvm/llvmpi.pas2
-rw-r--r--compiler/m68k/n68kmem.pas24
-rw-r--r--compiler/nadd.pas42
-rw-r--r--compiler/ncgflw.pas24
-rw-r--r--compiler/ncginl.pas14
-rw-r--r--compiler/ncon.pas10
-rw-r--r--compiler/ngtcon.pas26
-rw-r--r--compiler/nmat.pas14
-rw-r--r--compiler/nset.pas8
-rw-r--r--compiler/nutils.pas36
-rw-r--r--compiler/psabiehpi.pas4
-rw-r--r--compiler/pstatmnt.pas1
-rw-r--r--compiler/psub.pas2
-rw-r--r--compiler/symconst.pas4
-rw-r--r--compiler/symdef.pas18
-rw-r--r--compiler/systems/i_darwin.pas6
-rw-r--r--compiler/systems/i_linux.pas10
-rw-r--r--compiler/utils/ppuutils/ppudump.pp3
-rw-r--r--compiler/x86/aoptx86.pas359
-rw-r--r--installer/install.dat22
-rw-r--r--packages/fcl-db/src/export/fpxmlxsdexport.pp2
-rw-r--r--packages/fcl-net/src/amiga/resolve.inc22
-rw-r--r--packages/fcl-net/src/aros/resolve.inc23
-rw-r--r--packages/fcl-passrc/src/pasresolver.pp72
-rw-r--r--packages/fcl-process/src/amicommon/pipes.inc7
-rw-r--r--packages/fcl-process/src/amicommon/process.inc77
-rw-r--r--packages/fcl-process/src/pipes.pp22
-rw-r--r--packages/fpmkunit/src/fpmkunit.pp5
-rw-r--r--packages/hash/examples/sha1performancetest.pas4
-rw-r--r--packages/pastojs/src/fppas2js.pp67
-rw-r--r--packages/pastojs/tests/tcgenerics.pas16
-rw-r--r--packages/pastojs/tests/tcmodules.pas176
-rw-r--r--packages/rtl-extra/src/amiga/sockets.pp22
-rw-r--r--packages/rtl-extra/src/aros/sockets.pp38
-rw-r--r--packages/rtl-objpas/src/inc/dateutil.inc13
-rw-r--r--packages/rtl-objpas/src/inc/strutils.pp6
-rw-r--r--packages/rtl-unicode/fpmake.pp16
-rw-r--r--packages/rtl-unicode/src/inc/eastasianwidth.pp55
-rw-r--r--packages/rtl-unicode/src/inc/eastasianwidth_code.inc300
-rw-r--r--packages/rtl-unicode/src/inc/graphemebreakproperty.pp180
-rw-r--r--packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc511
-rw-r--r--packages/tplylib/fpmake.pp2
-rw-r--r--rtl/embedded/Makefile2
-rw-r--r--rtl/embedded/Makefile.fpc2
-rw-r--r--rtl/embedded/arm/cortexm4f_start.inc14
-rw-r--r--rtl/freertos/arm/cortexm4f_start.inc14
-rw-r--r--rtl/linux/arm/sighnd.inc8
-rw-r--r--rtl/objpas/math.pp54
-rw-r--r--tests/test/tandorandnot1.pp34
-rw-r--r--tests/test/tmt1.pp4
-rw-r--r--tests/test/units/strutils/tboyer.pp79
-rw-r--r--tests/utils/dotest.pp12
-rw-r--r--tests/webtbf/tw38504.pp11
-rw-r--r--tests/webtbf/tw38504b.pp11
-rw-r--r--tests/webtbs/tw28713.pp7
-rw-r--r--tests/webtbs/tw36250.pp15
-rw-r--r--tests/webtbs/tw38497.pp24
-rw-r--r--tests/webtbs/tw38527.pp15
-rw-r--r--tests/webtbs/tw8177.pp5
-rw-r--r--utils/json2pas/fpmake.pp2
-rw-r--r--utils/unicode/cldrparser.lpr2
-rw-r--r--utils/unicode/data/readme.txt14
-rw-r--r--utils/unicode/eawparser.lpi58
-rw-r--r--utils/unicode/eawparser.lpr332
-rw-r--r--utils/unicode/fpmake.pp2
-rw-r--r--utils/unicode/gbpparser.lpi58
-rw-r--r--utils/unicode/gbpparser.lpr379
-rw-r--r--utils/unicode/parse-collations.bat16
-rwxr-xr-xutils/unicode/parse-collations.sh16
80 files changed, 3103 insertions, 425 deletions
diff --git a/compiler/Makefile b/compiler/Makefile
index 59624dabdc..821f0612d5 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -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)),)
diff --git a/compiler/Makefile.fpc b/compiler/Makefile.fpc
index ef57f6404c..df64aab8fd 100644
--- a/compiler/Makefile.fpc
+++ b/compiler/Makefile.fpc
@@ -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'
diff --git a/compiler/aarch64/racpugas.pas b/compiler/aarch64/racpugas.pas
index e06047f486..de6e892245 100644
--- a/compiler/aarch64/racpugas.pas
+++ b/compiler/aarch64/racpugas.pas
@@ -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
diff --git a/compiler/aasmcnst.pas b/compiler/aasmcnst.pas
index 2845ac390a..d9d3d0ede1 100644
--- a/compiler/aasmcnst.pas
+++ b/compiler/aasmcnst.pas
@@ -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;
diff --git a/compiler/cgexcept.pas b/compiler/cgexcept.pas
index c0d421c923..4f573b75f1 100644
--- a/compiler/cgexcept.pas
+++ b/compiler/cgexcept.pas
@@ -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;
diff --git a/compiler/cutils.pas b/compiler/cutils.pas
index d8f3f4eda0..d75b3cd486 100644
--- a/compiler/cutils.pas
+++ b/compiler/cutils.pas
@@ -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
diff --git a/compiler/dbgdwarf.pas b/compiler/dbgdwarf.pas
index c7d585876e..93843d22ee 100644
--- a/compiler/dbgdwarf.pas
+++ b/compiler/dbgdwarf.pas
@@ -4540,6 +4540,12 @@ implementation
begin
case def.objecttype of
+ odt_objcclass,
+ odt_objcprotocol:
+ begin
+ inherited;
+ exit
+ end;
odt_cppclass,
odt_object:
begin
diff --git a/compiler/defutil.pas b/compiler/defutil.pas
index 139ce98d17..852d2cfa5a 100644
--- a/compiler/defutil.pas
+++ b/compiler/defutil.pas
@@ -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
diff --git a/compiler/i386/n386add.pas b/compiler/i386/n386add.pas
index 5a086d8ee7..2d4747bef6 100644
--- a/compiler/i386/n386add.pas
+++ b/compiler/i386/n386add.pas
@@ -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;
diff --git a/compiler/jvm/hlcgcpu.pas b/compiler/jvm/hlcgcpu.pas
index 7bf73b2e04..956e404d56 100644
--- a/compiler/jvm/hlcgcpu.pas
+++ b/compiler/jvm/hlcgcpu.pas
@@ -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);
diff --git a/compiler/jvm/jvmdef.pas b/compiler/jvm/jvmdef.pas
index 658f76ed91..4a9e6b585c 100644
--- a/compiler/jvm/jvmdef.pas
+++ b/compiler/jvm/jvmdef.pas
@@ -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:
diff --git a/compiler/llvm/llvmpi.pas b/compiler/llvm/llvmpi.pas
index df69ca1818..0ed17ed583 100644
--- a/compiler/llvm/llvmpi.pas
+++ b/compiler/llvm/llvmpi.pas
@@ -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;
diff --git a/compiler/m68k/n68kmem.pas b/compiler/m68k/n68kmem.pas
index adb22b5046..7461965ac6 100644
--- a/compiler/m68k/n68kmem.pas
+++ b/compiler/m68k/n68kmem.pas
@@ -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 }
diff --git a/compiler/nadd.pas b/compiler/nadd.pas
index 6c49f126e9..063c81b793 100644
--- a/compiler/nadd.pas
+++ b/compiler/nadd.pas
@@ -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
diff --git a/compiler/ncgflw.pas b/compiler/ncgflw.pas
index a9e2261f01..55250c6089 100644
--- a/compiler/ncgflw.pas
+++ b/compiler/ncgflw.pas
@@ -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
diff --git a/compiler/ncginl.pas b/compiler/ncginl.pas
index b91cc6a6ac..e19eaa35d9 100644
--- a/compiler/ncginl.pas
+++ b/compiler/ncginl.pas
@@ -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);
diff --git a/compiler/ncon.pas b/compiler/ncon.pas
index 048624d664..007c75f423 100644
--- a/compiler/ncon.pas
+++ b/compiler/ncon.pas
@@ -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;
diff --git a/compiler/ngtcon.pas b/compiler/ngtcon.pas
index f08ec07c21..930ca5fa38 100644
--- a/compiler/ngtcon.pas
+++ b/compiler/ngtcon.pas
@@ -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;
diff --git a/compiler/nmat.pas b/compiler/nmat.pas
index d39fa67393..e7becb20dd 100644
--- a/compiler/nmat.pas
+++ b/compiler/nmat.pas
@@ -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
diff --git a/compiler/nset.pas b/compiler/nset.pas
index 3f38ac8a5d..afb3362b27 100644
--- a/compiler/nset.pas
+++ b/compiler/nset.pas
@@ -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
diff --git a/compiler/nutils.pas b/compiler/nutils.pas
index 98691eaa54..be76d4cf71 100644
--- a/compiler/nutils.pas
+++ b/compiler/nutils.pas
@@ -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.
diff --git a/compiler/psabiehpi.pas b/compiler/psabiehpi.pas
index c53a073314..65f7795fec 100644
--- a/compiler/psabiehpi.pas
+++ b/compiler/psabiehpi.pas
@@ -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;
diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas
index c0a50b2c6b..b75d876906 100644
--- a/compiler/pstatmnt.pas
+++ b/compiler/pstatmnt.pas
@@ -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
diff --git a/compiler/psub.pas b/compiler/psub.pas
index 25e7102955..1ad610972d 100644
--- a/compiler/psub.pas
+++ b/compiler/psub.pas
@@ -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;
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 8d017c20d5..a59e28173a 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -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;
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index da190640ad..fca90803bf 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -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
diff --git a/compiler/systems/i_darwin.pas b/compiler/systems/i_darwin.pas
index 998941cbd2..3bb6731774 100644
--- a/compiler/systems/i_darwin.pas
+++ b/compiler/systems/i_darwin.pas
@@ -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
diff --git a/compiler/systems/i_linux.pas b/compiler/systems/i_linux.pas
index eb8e31c729..a6e3e4f00b 100644
--- a/compiler/systems/i_linux.pas
+++ b/compiler/systems/i_linux.pas
@@ -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';
diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp
index 448fca3a87..bbea4bde1e 100644
--- a/compiler/utils/ppuutils/ppudump.pp
+++ b/compiler/utils/ppuutils/ppudump.pp
@@ -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;
diff --git a/compiler/x86/aoptx86.pas b/compiler/x86/aoptx86.pas
index 83fc2deb84..646f27d526 100644
--- a/compiler/x86/aoptx86.pas
+++ b/compiler/x86/aoptx86.pas
@@ -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
- 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
+
+ { 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
- 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;
+ 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;
- 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);
+
+ TransferUsedRegs(TmpUsedRegs);
+ UpdateUsedRegs(TmpUsedRegs, next);
+ UpdateUsedRegs(TmpUsedRegs, tai(hp1.next));
- { JAE/JNB will always branch (use 'condition_in', since C_AE <> C_NB normally) }
- if condition_in(C_AE, JumpC) then
- Unconditional := True
+ 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
- begin
- if SetC = C_NONE then
- InternalError(2018061402);
+ RemoveInstruction(hp1);
- taicpu(hp2).SetCondition(SetC);
- end;
+ 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;
- if not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp2, TmpUsedRegs) then
+ 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
- RemoveCurrentp(p, hp2);
- Result := True;
+ 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;
-
- 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);
diff --git a/installer/install.dat b/installer/install.dat
index ac27e4ef9d..485eaa8029 100644
--- a/installer/install.dat
+++ b/installer/install.dat
@@ -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
#
diff --git a/packages/fcl-db/src/export/fpxmlxsdexport.pp b/packages/fcl-db/src/export/fpxmlxsdexport.pp
index 84822d92ea..e5551d1436 100644
--- a/packages/fcl-db/src/export/fpxmlxsdexport.pp
+++ b/packages/fcl-db/src/export/fpxmlxsdexport.pp
@@ -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
diff --git a/packages/fcl-net/src/amiga/resolve.inc b/packages/fcl-net/src/amiga/resolve.inc
index 5674ab180e..0e67c9b750 100644
--- a/packages/fcl-net/src/amiga/resolve.inc
+++ b/packages/fcl-net/src/amiga/resolve.inc
@@ -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;
diff --git a/packages/fcl-net/src/aros/resolve.inc b/packages/fcl-net/src/aros/resolve.inc
index e303907086..c0be8b00d4 100644
--- a/packages/fcl-net/src/aros/resolve.inc
+++ b/packages/fcl-net/src/aros/resolve.inc
@@ -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;
diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp
index 54f9110705..331baee4c2 100644
--- a/packages/fcl-passrc/src/pasresolver.pp
+++ b/packages/fcl-passrc/src/pasresolver.pp
@@ -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;
diff --git a/packages/fcl-process/src/amicommon/pipes.inc b/packages/fcl-process/src/amicommon/pipes.inc
index 5f6838c51f..da8de7ec51 100644
--- a/packages/fcl-process/src/amicommon/pipes.inc
+++ b/packages/fcl-process/src/amicommon/pipes.inc
@@ -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;
diff --git a/packages/fcl-process/src/amicommon/process.inc b/packages/fcl-process/src/amicommon/process.inc
index b9c92058a6..2abf94fd4a 100644
--- a/packages/fcl-process/src/amicommon/process.inc
+++ b/packages/fcl-process/src/amicommon/process.inc
@@ -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
diff --git a/packages/fcl-process/src/pipes.pp b/packages/fcl-process/src/pipes.pp
index 86c661993c..9aebd8d177 100644
--- a/packages/fcl-process/src/pipes.pp
+++ b/packages/fcl-process/src/pipes.pp
@@ -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;
diff --git a/packages/fpmkunit/src/fpmkunit.pp b/packages/fpmkunit/src/fpmkunit.pp
index 7cb98f2fcf..0384fcb689 100644
--- a/packages/fpmkunit/src/fpmkunit.pp
+++ b/packages/fpmkunit/src/fpmkunit.pp
@@ -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
diff --git a/packages/hash/examples/sha1performancetest.pas b/packages/hash/examples/sha1performancetest.pas
index 5bd0b0d463..59f4cfc7c4 100644
--- a/packages/hash/examples/sha1performancetest.pas
+++ b/packages/hash/examples/sha1performancetest.pas
@@ -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.
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index f60b74be61..2865296ddc 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -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;
diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas
index 8e7dd8b6ec..e7a2f72f13 100644
--- a/packages/pastojs/tests/tcgenerics.pas
+++ b/packages/pastojs/tests/tcgenerics.pas
@@ -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 () {',
diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas
index ca46edd38b..1092da987a 100644
--- a/packages/pastojs/tests/tcmodules.pas
+++ b/packages/pastojs/tests/tcmodules.pas
@@ -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"]);',
diff --git a/packages/rtl-extra/src/amiga/sockets.pp b/packages/rtl-extra/src/amiga/sockets.pp
index 50065d03f7..340770cdfa 100644
--- a/packages/rtl-extra/src/amiga/sockets.pp
+++ b/packages/rtl-extra/src/amiga/sockets.pp
@@ -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;
diff --git a/packages/rtl-extra/src/aros/sockets.pp b/packages/rtl-extra/src/aros/sockets.pp
index d90fa78315..c98aec42f9 100644
--- a/packages/rtl-extra/src/aros/sockets.pp
+++ b/packages/rtl-extra/src/aros/sockets.pp
@@ -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;
diff --git a/packages/rtl-objpas/src/inc/dateutil.inc b/packages/rtl-objpas/src/inc/dateutil.inc
index 5ea6b1a51f..d3f8c243dc 100644
--- a/packages/rtl-objpas/src/inc/dateutil.inc
+++ b/packages/rtl-objpas/src/inc/dateutil.inc
@@ -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;
diff --git a/packages/rtl-objpas/src/inc/strutils.pp b/packages/rtl-objpas/src/inc/strutils.pp
index a84075f9b7..8233c1ecce 100644
--- a/packages/rtl-objpas/src/inc/strutils.pp
+++ b/packages/rtl-objpas/src/inc/strutils.pp
@@ -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;
diff --git a/packages/rtl-unicode/fpmake.pp b/packages/rtl-unicode/fpmake.pp
index 3290665914..914aaa2694 100644
--- a/packages/rtl-unicode/fpmake.pp
+++ b/packages/rtl-unicode/fpmake.pp
@@ -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;
diff --git a/packages/rtl-unicode/src/inc/eastasianwidth.pp b/packages/rtl-unicode/src/inc/eastasianwidth.pp
new file mode 100644
index 0000000000..6eeefb98cc
--- /dev/null
+++ b/packages/rtl-unicode/src/inc/eastasianwidth.pp
@@ -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.
diff --git a/packages/rtl-unicode/src/inc/eastasianwidth_code.inc b/packages/rtl-unicode/src/inc/eastasianwidth_code.inc
new file mode 100644
index 0000000000..66551c8c1c
--- /dev/null
+++ b/packages/rtl-unicode/src/inc/eastasianwidth_code.inc
@@ -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
diff --git a/packages/rtl-unicode/src/inc/graphemebreakproperty.pp b/packages/rtl-unicode/src/inc/graphemebreakproperty.pp
new file mode 100644
index 0000000000..f097f74db2
--- /dev/null
+++ b/packages/rtl-unicode/src/inc/graphemebreakproperty.pp
@@ -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.
diff --git a/packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc b/packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc
new file mode 100644
index 0000000000..4be3cabe06
--- /dev/null
+++ b/packages/rtl-unicode/src/inc/graphemebreakproperty_code.inc
@@ -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
diff --git a/packages/tplylib/fpmake.pp b/packages/tplylib/fpmake.pp
index 1756b0e391..b7b6c65010 100644
--- a/packages/tplylib/fpmake.pp
+++ b/packages/tplylib/fpmake.pp
@@ -13,7 +13,7 @@ begin
{$endif ALLPACKAGES}
P:=AddPackage('tplylib');
- P.ShortName:='tplylib';
+ P.ShortName:='tpll';
{$ifdef ALLPACKAGES}
P.Directory:=ADirectory;
{$endif ALLPACKAGES}
diff --git a/rtl/embedded/Makefile b/rtl/embedded/Makefile
index eed7058295..d4d5c1c88b 100644
--- a/rtl/embedded/Makefile
+++ b/rtl/embedded/Makefile
@@ -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)
diff --git a/rtl/embedded/Makefile.fpc b/rtl/embedded/Makefile.fpc
index ff89dc336c..8817d786bd 100644
--- a/rtl/embedded/Makefile.fpc
+++ b/rtl/embedded/Makefile.fpc
@@ -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)
diff --git a/rtl/embedded/arm/cortexm4f_start.inc b/rtl/embedded/arm/cortexm4f_start.inc
index 82202b1565..62017d9834 100644
--- a/rtl/embedded/arm/cortexm4f_start.inc
+++ b/rtl/embedded/arm/cortexm4f_start.inc
@@ -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; \ No newline at end of file
+end;
diff --git a/rtl/freertos/arm/cortexm4f_start.inc b/rtl/freertos/arm/cortexm4f_start.inc
index 82202b1565..62017d9834 100644
--- a/rtl/freertos/arm/cortexm4f_start.inc
+++ b/rtl/freertos/arm/cortexm4f_start.inc
@@ -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; \ No newline at end of file
+end;
diff --git a/rtl/linux/arm/sighnd.inc b/rtl/linux/arm/sighnd.inc
index 08fc516dc6..8cce5c9e3b 100644
--- a/rtl/linux/arm/sighnd.inc
+++ b/rtl/linux/arm/sighnd.inc
@@ -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);
diff --git a/rtl/objpas/math.pp b/rtl/objpas/math.pp
index e6f3b511aa..2ee7fd4069 100644
--- a/rtl/objpas/math.pp
+++ b/rtl/objpas/math.pp
@@ -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];
diff --git a/tests/test/tandorandnot1.pp b/tests/test/tandorandnot1.pp
new file mode 100644
index 0000000000..aff04507ea
--- /dev/null
+++ b/tests/test/tandorandnot1.pp
@@ -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.
diff --git a/tests/test/tmt1.pp b/tests/test/tmt1.pp
index b2992963ed..c4a50d5217 100644
--- a/tests/test/tmt1.pp
+++ b/tests/test/tmt1.pp
@@ -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;
diff --git a/tests/test/units/strutils/tboyer.pp b/tests/test/units/strutils/tboyer.pp
new file mode 100644
index 0000000000..7eb6fda835
--- /dev/null
+++ b/tests/test/units/strutils/tboyer.pp
@@ -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.
diff --git a/tests/utils/dotest.pp b/tests/utils/dotest.pp
index 9aa88073f0..fd248b97d0 100644
--- a/tests/utils/dotest.pp
+++ b/tests/utils/dotest.pp
@@ -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
diff --git a/tests/webtbf/tw38504.pp b/tests/webtbf/tw38504.pp
new file mode 100644
index 0000000000..6eb43cac70
--- /dev/null
+++ b/tests/webtbf/tw38504.pp
@@ -0,0 +1,11 @@
+{ %fail }
+Var
+ MyVar : char;
+
+Procedure MyProc;
+Begin
+ MyVar := ''; (* <-- two single-quotes *)
+End;
+
+Begin
+End.
diff --git a/tests/webtbf/tw38504b.pp b/tests/webtbf/tw38504b.pp
new file mode 100644
index 0000000000..211f763d03
--- /dev/null
+++ b/tests/webtbf/tw38504b.pp
@@ -0,0 +1,11 @@
+{ %fail }
+Var
+ MyVar : char;
+
+Procedure MyProc;
+Begin
+ MyVar := char('');
+End;
+
+Begin
+End.
diff --git a/tests/webtbs/tw28713.pp b/tests/webtbs/tw28713.pp
index e0879f1cc3..d27b8bb138 100644
--- a/tests/webtbs/tw28713.pp
+++ b/tests/webtbs/tw28713.pp
@@ -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
diff --git a/tests/webtbs/tw36250.pp b/tests/webtbs/tw36250.pp
new file mode 100644
index 0000000000..569294da6f
--- /dev/null
+++ b/tests/webtbs/tw36250.pp
@@ -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.
diff --git a/tests/webtbs/tw38497.pp b/tests/webtbs/tw38497.pp
new file mode 100644
index 0000000000..4c8c5ebcb9
--- /dev/null
+++ b/tests/webtbs/tw38497.pp
@@ -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.
diff --git a/tests/webtbs/tw38527.pp b/tests/webtbs/tw38527.pp
new file mode 100644
index 0000000000..4f50d92bc8
--- /dev/null
+++ b/tests/webtbs/tw38527.pp
@@ -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.
diff --git a/tests/webtbs/tw8177.pp b/tests/webtbs/tw8177.pp
index 4b410fabf4..c2e7e05eec 100644
--- a/tests/webtbs/tw8177.pp
+++ b/tests/webtbs/tw8177.pp
@@ -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}
diff --git a/utils/json2pas/fpmake.pp b/utils/json2pas/fpmake.pp
index 6ac5f4b30e..f57c9dab0d 100644
--- a/utils/json2pas/fpmake.pp
+++ b/utils/json2pas/fpmake.pp
@@ -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];
diff --git a/utils/unicode/cldrparser.lpr b/utils/unicode/cldrparser.lpr
index 0bb0e7de95..770fbbd2f2 100644
--- a/utils/unicode/cldrparser.lpr
+++ b/utils/unicode/cldrparser.lpr
@@ -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 +
diff --git a/utils/unicode/data/readme.txt b/utils/unicode/data/readme.txt
index 239aa6fc28..1513349112 100644
--- a/utils/unicode/data/readme.txt
+++ b/utils/unicode/data/readme.txt
@@ -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, ...) \ No newline at end of file
+ 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):
diff --git a/utils/unicode/eawparser.lpi b/utils/unicode/eawparser.lpi
new file mode 100644
index 0000000000..f7b6a46841
--- /dev/null
+++ b/utils/unicode/eawparser.lpi
@@ -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>
diff --git a/utils/unicode/eawparser.lpr b/utils/unicode/eawparser.lpr
new file mode 100644
index 0000000000..b178b78ab8
--- /dev/null
+++ b/utils/unicode/eawparser.lpr
@@ -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.
+
diff --git a/utils/unicode/fpmake.pp b/utils/unicode/fpmake.pp
index 56e696e672..ed826dc7b8 100644
--- a/utils/unicode/fpmake.pp
+++ b/utils/unicode/fpmake.pp
@@ -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;
diff --git a/utils/unicode/gbpparser.lpi b/utils/unicode/gbpparser.lpi
new file mode 100644
index 0000000000..940fae4e66
--- /dev/null
+++ b/utils/unicode/gbpparser.lpi
@@ -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>
diff --git a/utils/unicode/gbpparser.lpr b/utils/unicode/gbpparser.lpr
new file mode 100644
index 0000000000..1d47fa4479
--- /dev/null
+++ b/utils/unicode/gbpparser.lpr
@@ -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.
+
diff --git a/utils/unicode/parse-collations.bat b/utils/unicode/parse-collations.bat
index d3d2e1a14a..0553e8ed14 100644
--- a/utils/unicode/parse-collations.bat
+++ b/utils/unicode/parse-collations.bat
@@ -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 \ No newline at end of file
diff --git a/utils/unicode/parse-collations.sh b/utils/unicode/parse-collations.sh
index 891319eb8d..c96b68416b 100755
--- a/utils/unicode/parse-collations.sh
+++ b/utils/unicode/parse-collations.sh
@@ -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 ..." \ No newline at end of file