diff options
| author | nickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2021-03-01 13:21:24 +0000 |
|---|---|---|
| committer | nickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2021-03-01 13:21:24 +0000 |
| commit | efc9f396e6322803ca30817ffbb7efa47f056254 (patch) | |
| tree | 6b133633c9766e3ae8e62d8a5ac988637e662e23 | |
| parent | 7970081cf98f70ce91af964068a6b32f062d9b8f (diff) | |
| parent | e7fde3b46193c6a3865103c7a7a82e600f787782 (diff) | |
| download | fpc-efc9f396e6322803ca30817ffbb7efa47f056254.tar.gz | |
* synchronized with trunk
git-svn-id: https://svn.freepascal.org/svn/fpc/branches/wasm@48846 3ad0048d-3df7-0310-abae-a5850022a9f2
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 |
