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

* synchronised with trunk till r41537

Browse Source 
git-svn-id: branches/debug_eh@41538 -
This commit is contained in:
Jonas Maebe 2019-03-01 16:20:22 +00:00
commit 50c82b6468
63 changed files with 1452 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -3473,6 +3473,7 @@ packages/fcl-web/src/restbridge/sqldbrestdata.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestini.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestio.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestjson.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestmodule.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestschema.pp svneol=native#text/plain
packages/fcl-web/src/restbridge/sqldbrestxml.pp svneol=native#text/plain
packages/fcl-web/src/webdata/Makefile svneol=native#text/plain
@ -7616,6 +7617,7 @@ packages/rtl-objpas/Makefile.fpc svneol=native#text/plain
packages/rtl-objpas/Makefile.fpc.fpcmake svneol=native#text/plain
packages/rtl-objpas/fpmake.pp svneol=native#text/plain
packages/rtl-objpas/src/common/varutils.pp svneol=native#text/plain
packages/rtl-objpas/src/i386/invoke.inc svneol=native#text/pascal
packages/rtl-objpas/src/inc/convutil.inc svneol=native#text/plain
packages/rtl-objpas/src/inc/convutil.pp svneol=native#text/plain
packages/rtl-objpas/src/inc/convutils.pp svneol=native#text/plain
@ -14811,6 +14813,7 @@ tests/webtbf/tw34821.pp svneol=native#text/plain
tests/webtbf/tw3488.pp svneol=native#text/plain
tests/webtbf/tw3495.pp svneol=native#text/plain
tests/webtbf/tw3502.pp svneol=native#text/plain
tests/webtbf/tw35149a.pp svneol=native#text/plain
tests/webtbf/tw3553.pp svneol=native#text/plain
tests/webtbf/tw3562.pp svneol=native#text/plain
tests/webtbf/tw3583.pp svneol=native#text/plain
@ -16542,6 +16545,7 @@ tests/webtbs/tw3504.pp svneol=native#text/plain
tests/webtbs/tw3506.pp svneol=native#text/plain
tests/webtbs/tw35139.pp svneol=native#text/plain
tests/webtbs/tw35139a.pp svneol=native#text/plain
tests/webtbs/tw35149.pp svneol=native#text/plain
tests/webtbs/tw3523.pp svneol=native#text/plain
tests/webtbs/tw3529.pp svneol=native#text/plain
tests/webtbs/tw3531.pp svneol=native#text/plain

3
compiler/Makefile
View File

@ -545,6 +545,9 @@ endif
ifeq ($(PPC_TARGET),arm)
override LOCALOPT+=-Fuarmgen
endif
ifeq ($(PPC_TARGET),armeb)
override LOCALOPT+=-Fuarmgen
endif
ifeq ($(PPC_TARGET),mipsel)
override LOCALOPT+=-Fumips
endif

5
compiler/Makefile.fpc
View File

@ -312,6 +312,11 @@ ifeq ($(PPC_TARGET),arm)
override LOCALOPT+=-Fuarmgen
endif
# ARMEB specific
ifeq ($(PPC_TARGET),armeb)
override LOCALOPT+=-Fuarmgen
endif
# mipsel specific
ifeq ($(PPC_TARGET),mipsel)
override LOCALOPT+=-Fumips

2
compiler/arm/narmld.pas
View File

@ -55,8 +55,6 @@ implementation
procedure tarmloadnode.generate_threadvar_access(gvs: tstaticvarsym);
var
paraloc1 : tcgpara;
pd: tprocdef;
href: treference;
hregister : tregister;
handled: boolean;

4
compiler/cclasses.pas
View File

@ -422,9 +422,9 @@ type
{ true if string is in the container }
function Find(const s:TCmdStr):TCmdStrListItem;
{ inserts an item }
procedure InsertItem(item:TCmdStrListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure InsertItem(item:TCmdStrListItem);
{ concats an item }
procedure ConcatItem(item:TCmdStrListItem); {$ifdef CCLASSESINLINE}inline;{$endif}
procedure ConcatItem(item:TCmdStrListItem);
property Doubles:boolean read FDoubles write FDoubles;
end;

2
compiler/hlcg2ll.pas
View File

@ -1550,7 +1550,7 @@ implementation
{$else cpu64bitalu}
{ use cg64 only for int64, not for 8 byte records; in particular,
filter out records passed in fpu/mm register}
if (l.size in [OS_64,OS_S64]) and (cgpara.Size in [OS_64,OS_S64]) and (cgpara.location^.loc=LOC_REGISTER) then
if (l.size in [OS_64,OS_S64]) and (cgpara.Size in [OS_64,OS_S64]) and (cgpara.location^.loc in [LOC_REGISTER,LOC_REFERENCE]) then
cg64.a_load64_loc_cgpara(list,l,cgpara)
else
{$endif cpu64bitalu}

1
compiler/i386/aoptcpu.pas
View File

@ -131,7 +131,6 @@ function WriteOk : Boolean;
end;
var
l : longint;
p,hp1,hp2 : tai;
hp3,hp4: tai;
v:aint;

9
compiler/i386/cgcpu.pas
View File

@ -261,10 +261,6 @@ unit cgcpu;
reference_reset_symbol(tmpref,dirref.symbol,0,sizeof(pint),[]);
tmpref.refaddr:=addr_pic;
tmpref.base:=current_procinfo.got;
{$ifdef EXTDEBUG}
if not (pi_needs_got in current_procinfo.flags) then
Comment(V_warning,'pi_needs_got not included');
{$endif EXTDEBUG}
include(current_procinfo.flags,pi_needs_got);
list.concat(taicpu.op_ref(A_PUSH,S_L,tmpref));
end
@ -549,7 +545,10 @@ unit cgcpu;
if not (target_info.system in [system_i386_darwin,system_i386_iphonesim]) then
begin
{ Use ECX as a temp register by default }
tmpreg:=NR_ECX;
if current_procinfo.got = NR_EBX then
tmpreg:=NR_EBX
else
tmpreg:=NR_ECX;
{ Allocate registers used for parameters to make sure they
never allocated during this PIC init code }
for i:=0 to current_procinfo.procdef.paras.Count - 1 do

5
compiler/i386/cpupi.pas
View File

@ -100,8 +100,11 @@ unit cpupi;
begin
if (cs_create_pic in current_settings.moduleswitches) then
begin
if pi_uses_threadvar in flags then
if (pi_uses_threadvar in flags) and (tf_section_threadvars in target_info.flags) then
begin
{ FIXME: It is better to use an imaginary register for GOT and
if EBX is needed for some reason just allocate EBX and
copy GOT into it before its usage. }
cg.getcpuregister(list,NR_EBX);
got := NR_EBX;
end

1
compiler/i386/hlcgcpu.pas
View File

@ -196,6 +196,7 @@ implementation
{ Alloc EBX }
getcpuregister(list, NR_PIC_OFFSET_REG);
list.concat(taicpu.op_reg_reg(A_MOV,S_L,current_procinfo.got,NR_PIC_OFFSET_REG));
include(current_procinfo.flags,pi_needs_got);
end;
Result:=inherited a_call_name(list, pd, s, paras, forceresdef, weak);
{ Free EBX }

4
compiler/nbas.pas
View File

@ -1093,10 +1093,6 @@ implementation
{ temps which are immutable do not need to be initialized/finalized }
if (tempinfo^.typedef.needs_inittable) and not(ti_const in tempflags) then
include(current_procinfo.flags,pi_needs_implicit_finally);
if (cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) and
is_rtti_managed_type(tempinfo^.typedef) then
include(current_procinfo.flags,pi_needs_got);
if assigned(tempinfo^.withnode) then
firstpass(tempinfo^.withnode);
if assigned(tempinfo^.tempinitcode) then

18
compiler/ncal.pas
View File

@ -1086,19 +1086,6 @@ implementation
aktcallnode.procdefinition.proccalloption) then
copy_value_by_ref_para;
{ does it need to load RTTI? }
if assigned(parasym) and (parasym.varspez=vs_out) and
(cs_create_pic in current_settings.moduleswitches) and
(
is_rtti_managed_type(left.resultdef) or
(
is_open_array(resultdef) and
is_managed_type(tarraydef(resultdef).elementdef)
)
) and
not(target_info.system in systems_garbage_collected_managed_types) then
include(current_procinfo.flags,pi_needs_got);
if assigned(fparainit) then
firstpass(fparainit);
firstpass(left);
@ -4382,11 +4369,6 @@ implementation
([cnf_member_call,cnf_inherited] * callnodeflags <> []) then
current_procinfo.ConstructorCallingConstructor:=true;
{ object check helper will load VMT -> needs GOT }
if (cs_check_object in current_settings.localswitches) and
(cs_create_pic in current_settings.moduleswitches) then
include(current_procinfo.flags,pi_needs_got);
{ Continue with checking a normal call or generate the inlined code }
if cnf_do_inline in callnodeflags then
result:=pass1_inline

3
compiler/ncgrtti.pas
View File

@ -2022,9 +2022,6 @@ implementation
begin
s:=def.rtti_mangledname(rt)+suffix;
result:=current_asmdata.RefAsmSymbol(s,AT_DATA,indirect);
if (cs_create_pic in current_settings.moduleswitches) and
assigned(current_procinfo) then
include(current_procinfo.flags,pi_needs_got);
if def.owner.moduleid<>current_module.moduleid then
current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA);
end;

4
compiler/ncgset.pas
View File

@ -827,7 +827,7 @@ implementation
{$endif}
{$endif cpuhighleveltarget}
begin
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, tcgint(t^._low),hregister, blocklabel(t^.blockid));
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, tcgint(t^._low.svalue),hregister, blocklabel(t^.blockid));
end;
{ Reset last here, because we've only checked for one value and need to compare
for the next range both the lower and upper bound }
@ -934,7 +934,7 @@ implementation
{$endif}
{$endif cpuhighleveltarget}
begin
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, tcgint(t^._low), hregister,
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, tcgint(t^._low.svalue), hregister,
elselabel);
end;
end;

6
compiler/ncnv.pas
View File

@ -3177,9 +3177,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_REGISTER;
{ Use of FPC_EMPTYCHAR label requires setting pi_needs_got flag }
if (cs_create_pic in current_settings.moduleswitches) then
include(current_procinfo.flags,pi_needs_got);
end;
@ -3604,9 +3601,6 @@ implementation
begin
first_ansistring_to_pchar:=nil;
expectloc:=LOC_REGISTER;
{ Use of FPC_EMPTYCHAR label requires setting pi_needs_got flag }
if (cs_create_pic in current_settings.moduleswitches) then
include(current_procinfo.flags,pi_needs_got);
end;

11
compiler/ncon.pas
View File

@ -465,8 +465,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_CREFERENCE;
if (cs_create_pic in current_settings.moduleswitches) then
include(current_procinfo.flags,pi_needs_got);
end;
@ -868,9 +866,6 @@ implementation
end
else
expectloc:=LOC_CREFERENCE;
if (cs_create_pic in current_settings.moduleswitches) and
(expectloc <> LOC_CONSTANT) then
include(current_procinfo.flags,pi_needs_got);
end;
@ -1160,9 +1155,6 @@ implementation
expectloc:=LOC_CONSTANT
else
expectloc:=LOC_CREFERENCE;
if (cs_create_pic in current_settings.moduleswitches) and
(expectloc <> LOC_CONSTANT) then
include(current_procinfo.flags,pi_needs_got);
end;
@ -1254,9 +1246,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_CREFERENCE;
if (cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) then
include(current_procinfo.flags,pi_needs_got);
end;

5
compiler/nflw.pas
View File

@ -2433,11 +2433,6 @@ implementation
begin
result:=nil;
include(current_procinfo.flags,pi_do_call);
{ Loads exception class VMT, therefore may need GOT
(generic code only; descendants may need to avoid this check) }
if (cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) then
include(current_procinfo.flags,pi_needs_got);
expectloc:=LOC_VOID;
if assigned(left) then
firstpass(left);

9
compiler/nld.pas
View File

@ -400,9 +400,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_REFERENCE;
if (cs_create_pic in current_settings.moduleswitches) and
not(symtableentry.typ in [paravarsym,localvarsym]) then
include(current_procinfo.flags,pi_needs_got);
case symtableentry.typ of
absolutevarsym :
@ -424,9 +421,6 @@ implementation
else
if (tabstractvarsym(symtableentry).varspez=vs_const) then
expectloc:=LOC_CREFERENCE;
if (target_info.system=system_powerpc_darwin) and
([vo_is_dll_var,vo_is_external] * tabstractvarsym(symtableentry).varoptions <> []) then
include(current_procinfo.flags,pi_needs_got);
{ call to get address of threadvar }
if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
begin
@ -1383,9 +1377,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_CREFERENCE;
if (cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) then
include(current_procinfo.flags,pi_needs_got);
end;

3
compiler/nmem.pas
View File

@ -242,9 +242,6 @@ implementation
begin
result:=nil;
expectloc:=LOC_REGISTER;
if (left.nodetype=typen) and
(cs_create_pic in current_settings.moduleswitches) then
include(current_procinfo.flags,pi_needs_got);
if left.nodetype<>typen then
begin
if (is_objc_class_or_protocol(left.resultdef) or

3
compiler/pdecvar.pas
View File

@ -1591,14 +1591,13 @@ implementation
sc : TFPObjectList;
i : longint;
hs,sorg : string;
hdef,casetype,tmpdef : tdef;
hdef,casetype : tdef;
{ maxsize contains the max. size of a variant }
{ startvarrec contains the start of the variant part of a record }
maxsize, startvarrecsize : longint;
usedalign,
maxalignment,startvarrecalign,
maxpadalign, startpadalign: shortint;
stowner : tdef;
pt : tnode;
fieldvs : tfieldvarsym;
hstaticvs : tstaticvarsym;

4
compiler/pexpr.pas
View File

@ -1409,9 +1409,7 @@ implementation
(current_procinfo.procdef.struct=structh))) then
Message(parser_e_only_class_members)
else
Message(parser_e_only_class_members_via_class_ref)
else if isobjecttype then
Message(parser_e_only_static_members_via_object_type);
Message(parser_e_only_class_members_via_class_ref);
p1:=csubscriptnode.create(sym,p1);
end;
end;

4
compiler/powerpc/cpupara.pas
View File

@ -650,8 +650,6 @@ unit cpupara;
result:=create_paraloc_info_intern(p,side,varargspara,curintreg,curfloatreg,curmmreg,cur_stack_offset,true)
else
internalerror(2019021921);
if curfloatreg<>firstfloatreg then
include(varargspara.varargsinfo,va_uses_float_reg);
end;
{ varargs routines have to reserve at least 32 bytes for the AIX abi }
if (target_info.abi in [abi_powerpc_aix,abi_powerpc_darwin]) and
@ -660,6 +658,8 @@ unit cpupara;
end
else
internalerror(2019021710);
if curfloatreg<>firstfloatreg then
include(varargspara.varargsinfo,va_uses_float_reg);
create_funcretloc_info(p,side);
end;

4
compiler/powerpc64/cpupara.pas
View File

@ -767,8 +767,6 @@ begin
curfloatreg, curmmreg, cur_stack_offset, true)
else
internalerror(2019021920);
if curfloatreg <> firstfloatreg then
include(varargspara.varargsinfo, va_uses_float_reg);
end;
{ varargs routines have to reserve at least 64 bytes for the PPC64 ABI }
if (result < 64) then
@ -776,6 +774,8 @@ begin
end
else
internalerror(2019021911);
if curfloatreg <> firstfloatreg then
include(varargspara.varargsinfo, va_uses_float_reg);
create_funcretloc_info(p, side);
end;

9
compiler/psub.pas
View File

@ -299,11 +299,6 @@ implementation
include(current_procinfo.flags,pi_needs_implicit_finally);
include(current_procinfo.flags,pi_do_call);
end;
if (tparavarsym(p).varspez in [vs_value,vs_out]) and
(cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) and
is_rtti_managed_type(tparavarsym(p).vardef) then
include(current_procinfo.flags,pi_needs_got);
end;
end;
@ -318,10 +313,6 @@ implementation
begin
include(current_procinfo.flags,pi_needs_implicit_finally);
include(current_procinfo.flags,pi_do_call);
if is_rtti_managed_type(tlocalvarsym(p).vardef) and
(cs_create_pic in current_settings.moduleswitches) and
(tf_pic_uses_got in target_info.flags) then
include(current_procinfo.flags,pi_needs_got);
end;
end;

5
compiler/rgobj.pas
View File

@ -1474,8 +1474,9 @@ unit rgobj;
adj : psuperregisterworklist;
maxlength,p,i :word;
minweight: longint;
dist,
maxdist: Double;
{$ifdef SPILLING_NEW}
dist: Double;
{$endif}
begin
{$ifdef SPILLING_NEW}
{ This new approach for selecting the next spill candidate takes care of the weight of a register:

30
compiler/systems/i_linux.pas
View File

@ -508,13 +508,13 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 4;
constalignmax : 8;
constalignmax : 16;
varalignmin : 4;
varalignmax : 8;
varalignmax : 16;
localalignmin : 4;
localalignmax : 8;
recordalignmin : 0;
recordalignmax : 8;
recordalignmax : 16;
maxCrecordalign : 8
);
first_parm_offset : 92;
@ -654,13 +654,13 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 0;
constalignmax : 8;
constalignmax : 16;
varalignmin : 0;
varalignmax : 8;
varalignmax : 16;
localalignmin : 4;
localalignmax : 8;
recordalignmin : 0;
recordalignmax : 8;
recordalignmax : 16;
maxCrecordalign : 8
);
first_parm_offset : 8;
@ -727,13 +727,13 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 0;
constalignmax : 8;
constalignmax : 16;
varalignmin : 0;
varalignmax : 8;
varalignmax : 16;
localalignmin : 4;
localalignmax : 8;
recordalignmin : 0;
recordalignmax : 8;
recordalignmax : 16;
maxCrecordalign : 8
);
first_parm_offset : 8;
@ -797,13 +797,13 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 0;
constalignmax : 4;
constalignmax : 16;
varalignmin : 0;
varalignmax : 4;
varalignmax : 16;
localalignmin : 4;
localalignmax : 8;
recordalignmin : 0;
recordalignmax : 4;
recordalignmax : 16;
maxCrecordalign : 4
);
first_parm_offset : 8;
@ -865,13 +865,13 @@ unit i_linux;
coalescealign : 0;
coalescealignskipmax: 0;
constalignmin : 0;
constalignmax : 4;
constalignmax : 16;
varalignmin : 0;
varalignmax : 4;
varalignmax : 16;
localalignmin : 4;
localalignmax : 4;
recordalignmin : 0;
recordalignmax : 4;
recordalignmax : 16;
maxCrecordalign : 4
);
first_parm_offset : 8;

5
compiler/x86/cgx86.pas
View File

@ -902,10 +902,7 @@ unit cgx86;
{ darwin's assembler doesn't want @PLT after call symbols }
not(target_info.system in [system_x86_64_darwin,system_i386_iphonesim,system_x86_64_iphonesim]) then
begin
{$ifdef i386}
include(current_procinfo.flags,pi_needs_got);
{$endif i386}
r.refaddr:=addr_pic
r.refaddr:=addr_pic;
end
else
r.refaddr:=addr_full;

1
compiler/x86/nx86ld.pas
View File

@ -102,6 +102,7 @@ implementation
begin
if not(cs_create_pic in current_settings.moduleswitches) then
Internalerror(2018110701);
include(current_procinfo.flags,pi_needs_got);
reference_reset(href,0,[]);
location.reference.index:=current_procinfo.got;
location.reference.scalefactor:=1;

1
compiler/x86/nx86set.pas
View File

@ -176,6 +176,7 @@ implementation
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,jumpreg);
cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR,current_procinfo.got,jumpreg);
emit_reg(A_JMP,S_NO,jumpreg);
include(current_procinfo.flags,pi_needs_got);
end
else
emit_ref(A_JMP,S_NO,href);

4
packages/fcl-js/tests/testjs.lpr
View File

@ -12,10 +12,6 @@ uses
var
Application: TTestRunner;
{$IFDEF WINDOWS}{$R testjs.rc}{$ENDIF}
{$R *.res}
begin
DefaultFormat:=fplain;
DefaultRunAllTests:=True;

16
packages/fcl-json/src/fpjson.pp
View File

@ -2496,7 +2496,7 @@ begin
vtChar : Result:=CreateJSON(VChar);
vtExtended : Result:=CreateJSON(VExtended^);
vtString : Result:=CreateJSON(vString^);
vtAnsiString : Result:=CreateJSON(AnsiString(vAnsiString));
vtAnsiString : Result:=CreateJSON(UTF8Decode(StrPas(VPChar)));
vtPChar : Result:=CreateJSON(StrPas(VPChar));
vtPointer : If (VPointer<>Nil) then
TJSONData.DoError(SErrPointerNotNil,[SourceType])
@ -3153,7 +3153,7 @@ constructor TJSONObject.Create(const Elements: array of {$ifdef pas2js}jsvalue{$
Var
I : integer;
AName : String;
AName : TJSONUnicodeStringType;
J : TJSONData;
begin
@ -3171,10 +3171,10 @@ begin
{$else}
With Elements[i] do
Case VType of
vtChar : AName:=VChar;
vtString : AName:=vString^;
vtAnsiString : AName:=(AnsiString(vAnsiString));
vtPChar : AName:=StrPas(VPChar);
vtChar : AName:=TJSONUnicodeStringType(VChar);
vtString : AName:=TJSONUnicodeStringType(vString^);
vtAnsiString : AName:=UTF8Decode(StrPas(VPChar));
vtPChar : AName:=TJSONUnicodeStringType(StrPas(VPChar));
else
DoError(SErrNameMustBeString,[I+1]);
end;
@ -3183,7 +3183,11 @@ begin
DoError(SErrNameMustBeString,[I+1]);
Inc(I);
J:=VarRecToJSON(Elements[i],'Object');
{$IFDEF FPC_HAS_CPSTRING}
Add(UTF8Encode(AName),J);
{$ELSE}
Add(AName,J);
{$ENDIF}
Inc(I);
end;
end;

53
packages/fcl-json/src/jsonconf.pp
View File

@ -90,13 +90,21 @@ type
Procedure EnumValues(Const APath : UnicodeString; List : TStrings);
function GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString; overload;
function GetValue(const APath: RawByteString; const ADefault: RawByteString): UnicodeString; overload;
function GetValue(const APath: UnicodeString; ADefault: Integer): Integer; overload;
function GetValue(const APath: RawByteString; ADefault: Integer): Integer; overload;
function GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload;
function GetValue(const APath: RawByteString; ADefault: Int64): Int64; overload;
function GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload;
function GetValue(const APath: RawByteString; ADefault: Boolean): Boolean; overload;
function GetValue(const APath: UnicodeString; ADefault: Double): Double; overload;
function GetValue(const APath: RawByteString; ADefault: Double): Double; overload;
Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: String) : Boolean; overload;
Function GetValue(const APath: RawByteString; AValue: TStrings; Const ADefault: String) : Boolean; overload;
Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: TStrings): Boolean; overload;
procedure SetValue(const APath: UnicodeString; const AValue: UnicodeString); overload;
procedure SetValue(const APath: RawByteString; const AValue: RawByteString); overload;
procedure SetValue(const APath: UnicodeString; AValue: Integer); overload;
procedure SetValue(const APath: UnicodeString; AValue: Int64); overload;
procedure SetValue(const APath: UnicodeString; AValue: Boolean); overload;
@ -289,6 +297,12 @@ begin
end;
function TJSONConfig.GetValue(const APath: RawByteString; const ADefault: RawByteString): UnicodeString;
begin
Result:=GetValue(UTF8Decode(aPath),UTF8Decode(ADefault));
end;
function TJSONConfig.GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString;
var
@ -302,6 +316,12 @@ begin
Result:=ADefault;
end;
function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Integer): Integer;
begin
Result:=GetValue(UTF8Decode(aPath),ADefault);
end;
function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Integer): Integer;
var
El : TJSONData;
@ -316,6 +336,12 @@ begin
Result:=StrToIntDef(El.AsString,ADefault);
end;
function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Int64): Int64;
begin
Result:=GetValue(UTF8Decode(aPath),ADefault);
end;
function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Int64): Int64;
var
El : TJSONData;
@ -330,6 +356,12 @@ begin
Result:=StrToInt64Def(El.AsString,ADefault);
end;
function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Boolean): Boolean;
begin
Result:=GetValue(UTF8Decode(aPath),ADefault);
end;
function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean;
var
@ -345,6 +377,12 @@ begin
Result:=StrToBoolDef(El.AsString,ADefault);
end;
function TJSONConfig.GetValue(const APath: RawByteString; ADefault: Double): Double;
begin
Result:=GetValue(UTF8Decode(aPath),ADefault);
end;
function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Double): Double;
var
@ -360,6 +398,14 @@ begin
Result:=StrToFloatDef(El.AsString,ADefault);
end;
function TJSONConfig.GetValue(const APath: RawByteString; AValue: TStrings;
const ADefault: String): Boolean;
begin
Result:=GetValue(UTF8Decode(aPath),AValue, ADefault);
end;
function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
const ADefault: String): Boolean;
var
@ -418,6 +464,13 @@ begin
FModified:=True;
end;
procedure TJSONConfig.SetValue(const APath: RawByteString;
const AValue: RawByteString);
begin
SetValue(UTF8Decode(APath),UTF8Decode(AValue));
end;
procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString);
begin
if AValue = DefValue then

4
packages/fcl-json/src/jsonreader.pp
View File

@ -36,7 +36,7 @@ Type
procedure DoError(const Msg: String);
Procedure DoParse(AtCurrent,AllowEOF: Boolean);
function GetNextToken: TJSONToken;
function CurrentTokenString: String;
function CurrentTokenString: RawByteString;
function CurrentToken: TJSONToken; inline;
Procedure KeyValue(Const AKey : TJSONStringType); virtual; abstract;
@ -203,7 +203,7 @@ begin
Result:=FScanner.CurToken;
end;
function TBaseJSONReader.CurrentTokenString: String;
function TBaseJSONReader.CurrentTokenString: RawByteString;
begin
If CurrentToken in [tkString,tkIdentifier,tkNumber,tkComment] then

8
packages/fcl-json/src/jsonscanner.pp
View File

@ -28,7 +28,7 @@ uses SysUtils, Classes;
resourcestring
SErrInvalidCharacter = 'Invalid character at line %d, pos %d: ''%s''';
SUnterminatedComment = 'Unterminated comment at line %d, pos %d: ''%s''';
SErrOpenString = 'string exceeds end of line';
SErrOpenString = 'string exceeds end of line %d';
type
@ -331,7 +331,7 @@ begin
u1:=u2;
end
end;
#0 : Error(SErrOpenString);
#0 : Error(SErrOpenString,[FCurRow]);
else
Error(SErrInvalidCharacter, [CurRow,CurColumn,FTokenStr[0]]);
end;
@ -355,11 +355,11 @@ begin
else
MaybeAppendUnicode;
if FTokenStr[0] = #0 then
Error(SErrOpenString);
Error(SErrOpenString,[FCurRow]);
Inc(FTokenStr);
end;
if FTokenStr[0] = #0 then
Error(SErrOpenString);
Error(SErrOpenString,[FCurRow]);
MaybeAppendUnicode;
SectionLength := FTokenStr - TokenStart;
SetLength(FCurTokenString, OldLength + SectionLength);

29
packages/fcl-json/tests/jsonconftest.pp
View File

@ -27,6 +27,7 @@ type
procedure TestKey;
procedure TestStrings;
procedure TestUnicodeStrings;
procedure TestUnicodeStrings2;
end;
implementation
@ -352,6 +353,34 @@ begin
end;
end;
procedure TTestJSONConfig.TestUnicodeStrings2;
Const
utf8str = 'Größe ÄÜÖ ㎰ す 가';
utf8path = 'Größe/す가';
Var
Co : TJSONCOnfig;
begin
Co:=CreateConf('test.json');
try
Co.SetValue('/проверка',utf8str);
Co.SetValue(utf8path,'something');
Co.Flush;
finally
co.Free;
end;
Co:=CreateConf('test.json');
try
AssertEquals('UTF8 string read/Write',utf8str,utf8encode(Co.GetValue('/проверка','')));
AssertEquals('UTF8 path read/Write','something',Co.GetValue(utf8path,'something'));
finally
DeleteConf(Co,True);
end;
end;
initialization

3
packages/fcl-json/tests/testjsonconf.lpi
View File

@ -14,9 +14,6 @@
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>

4
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -181,7 +181,7 @@ const
nDerivedXMustExtendASubClassY = 3115;
nDefaultPropertyNotAllowedInHelperForX = 3116;
nHelpersCannotBeUsedAsTypes = 3117;
nBitWiseOperationsAre32Bit = 3118;
// free 3118
nImplictConversionUnicodeToAnsi = 3119;
nWrongTypeXInArrayConstructor = 3120;
nUnknownCustomAttributeX = 3121;
@ -315,7 +315,7 @@ resourcestring
sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s';
sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types';
sBitWiseOperationsAre32Bit = 'Bitwise operations are 32-bit';
// was 3118
sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"';
sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor';
sUnknownCustomAttributeX = 'Unknown custom attribute "%s"';

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

@ -9205,7 +9205,8 @@ begin
end
else if LTypeEl.ClassType=TPasEnumType then
begin
if LeftResolved.IdentEl is TPasEnumType then
if (LeftResolved.IdentEl is TPasType)
and (ResolveAliasType(TPasType(LeftResolved.IdentEl)).ClassType=TPasEnumType) then
begin
// e.g. TShiftState.ssAlt
DotScope:=PushEnumDotScope(TPasEnumType(LTypeEl));
@ -16283,23 +16284,25 @@ begin
if (TypeEl.ClassType=TPasClassType)
and (TPasClassType(TypeEl).HelperForType<>nil) then
TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType) as TPasType;
if (TypeEl.ClassType=TPasClassType) and
TPasClassType(TypeEl).IsAbstract then
LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl);
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
begin
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
if (TypeEl.ClassType=TPasClassType) and TPasClassType(TypeEl).IsAbstract then
LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl)
else
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
end;
end;
end;
end;
@ -17094,7 +17097,7 @@ begin
Scope.Add(HelperScope);
HelperScope:=HelperScope.AncestorScope;
end;
if not (msMultipleScopeHelpers in CurrentParser.CurrentModeswitches) then
if not (msMultiHelpers in CurrentParser.CurrentModeswitches) then
break;
end;
end;

14
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -1475,6 +1475,7 @@ var
ModScope: TPasModuleScope;
Access: TResolvedRefAccess;
SubEl: TPasElement;
ParamsExpr: TParamsExpr;
begin
if El=nil then exit;
// Note: expression itself is not marked, but it can reference identifiers
@ -1527,7 +1528,8 @@ begin
case BuiltInProc.BuiltIn of
bfExit:
begin
if El.Parent is TParamsExpr then
ParamsExpr:=Resolver.GetParamsOfNameExpr(El);
if ParamsExpr<>nil then
begin
Params:=(El.Parent as TParamsExpr).Params;
if length(Params)=1 then
@ -1546,7 +1548,10 @@ begin
end;
bfTypeInfo:
begin
Params:=(El.Parent as TParamsExpr).Params;
ParamsExpr:=Resolver.GetParamsOfNameExpr(El);
if ParamsExpr=nil then
RaiseNotSupported(20190225150136,El);
Params:=ParamsExpr.Params;
if length(Params)<>1 then
RaiseNotSupported(20180226144217,El.Parent);
Resolver.ComputeElement(Params[0],ParamResolved,[rcNoImplicitProc]);
@ -1773,6 +1778,9 @@ begin
{$IFDEF VerbosePasAnalyzer}
writeln('TPasAnalyzer.UseProcedure ',GetElModName(Proc));
{$ENDIF}
if Proc.Parent is TPasMembersType then
UseClassOrRecType(TPasMembersType(Proc.Parent),paumElement);
UseScopeReferences(ProcScope.References);
UseProcedureType(Proc.ProcType);
@ -2006,7 +2014,7 @@ begin
RaiseInconsistency(20170414152143,IntToStr(ord(Mode)));
end;
{$IFDEF VerbosePasAnalyzer}
writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
writeln('TPasAnalyzer.UseClassOrRecType ',GetElModName(El),' ',Mode,' First=',FirstTime);
{$ENDIF}
aClass:=nil;
ClassScope:=nil;

8
packages/fcl-passrc/src/pparser.pp
View File

@ -3909,7 +3909,7 @@ begin
NextToken;
if not (CurToken in [tkChar,tkString,tkIdentifier]) then
ParseExcTokenError(TokenInfos[tkString]);
Result.ExportName:=DoParseExpression(Parent);
Result.ExportName:=DoParseExpression(Result);
Result.IsConst:=true; // external const is readonly
end
else if CurToken=tkSemicolon then
@ -4326,7 +4326,7 @@ begin
UngetToken;
exit;
end;
Include(varMods,ExtMod);
Include(VarMods,ExtMod);
Result:=Result+';'+CurTokenText;
NextToken;
@ -4444,14 +4444,14 @@ begin
NextToken;
If Curtoken<>tkSemicolon then
UnGetToken;
VarEl:=TPasVariable(VarList[0]);
VarEl:=TPasVariable(VarList[OldListCount]);
AllowedVarMods:=[];
if ExternalStruct then
AllowedVarMods:=[vmExternal]
else
AllowedVarMods:=[vmCVar,vmExternal,vmPublic,vmExport];
Mods:=GetVariableModifiers(VarEl,VarMods,aLibName,aExpName,AllowedVarMods);
if (mods='') and (CurToken<>tkSemicolon) then
if (Mods='') and (CurToken<>tkSemicolon) then
NextToken;
end
else

8
packages/fcl-passrc/src/pscanner.pp
View File

@ -294,7 +294,7 @@ type
msExternalClass, { Allow external class definitions }
msPrefixedAttributes, { Allow attributes, disable proc modifier [] }
msOmitRTTI, { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch }
msMultipleScopeHelpers { off=only one helper per type, on=all }
msMultiHelpers { off=only one helper per type, on=all }
);
TModeSwitches = Set of TModeSwitch;
@ -1038,7 +1038,7 @@ const
'EXTERNALCLASS',
'PREFIXEDATTRIBUTES',
'OMITRTTI',
'MULTIPLESCOPEHELPERS'
'MULTIHELPERS'
);
LetterSwitchNames: array['A'..'Z'] of string=(
@ -3271,10 +3271,8 @@ begin
DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[Identifier]);
exit;
end;
end;
if Number>=0 then
SetWarnMsgState(Number,State);
end;
end;
procedure TPascalScanner.HandleDefine(Param: String);

169
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -609,6 +609,7 @@ type
Procedure TestClass_UntypedParam_TypeCast;
Procedure TestClass_Sealed;
Procedure TestClass_SealedDescendFail;
Procedure TestClass_Abstract;
Procedure TestClass_AbstractCreateFail;
Procedure TestClass_VarExternal;
Procedure TestClass_WarnOverrideLowerVisibility;
@ -913,7 +914,7 @@ type
Procedure TestClassHelper_ReintroduceHides_CallFail;
Procedure TestClassHelper_DefaultProperty;
Procedure TestClassHelper_DefaultClassProperty;
Procedure TestClassHelper_MultipleScopeHelpers;
Procedure TestClassHelper_MultiHelpers;
Procedure TestRecordHelper;
Procedure TestRecordHelper_ForByteFail;
Procedure TestRecordHelper_ClassNonStaticFail;
@ -929,6 +930,7 @@ type
Procedure TestTypeHelper_Enumerator;
Procedure TestTypeHelper_String;
Procedure TestTypeHelper_Boolean;
Procedure TestTypeHelper_Double;
Procedure TestTypeHelper_Constructor_NewInstance;
Procedure TestTypeHelper_InterfaceFail;
@ -3681,25 +3683,30 @@ end;
procedure TTestResolver.TestEnums;
begin
StartProgram(false);
Add('type {#TFlag}TFlag = ({#Red}Red, {#Green}Green, {#Blue}Blue);');
Add('var');
Add(' {#f}{=TFlag}f: TFlag;');
Add(' {#v}{=TFlag}v: TFlag = Green;');
Add(' {#i}i: longint;');
Add('begin');
Add(' {@f}f:={@Red}Red;');
Add(' {@f}f:={@v}v;');
Add(' if {@f}f={@Red}Red then ;');
Add(' if {@f}f={@v}v then ;');
Add(' if {@f}f>{@v}v then ;');
Add(' if {@f}f<{@v}v then ;');
Add(' if {@f}f>={@v}v then ;');
Add(' if {@f}f<={@v}v then ;');
Add(' if {@f}f<>{@v}v then ;');
Add(' if ord({@f}f)<>ord({@Red}Red) then ;');
Add(' {@f}f:={@TFlag}TFlag.{@Red}Red;');
Add(' {@f}f:={@TFlag}TFlag({@i}i);');
Add(' {@i}i:=longint({@f}f);');
Add([
'type',
' {#TFlag}TFlag = ({#Red}Red, {#Green}Green, {#Blue}Blue);',
' {#TAlias}TAlias = TFlag;',
'var',
' {#f}{=TFlag}f: TFlag;',
' {#v}{=TFlag}v: TFlag = Green;',
' {#i}i: longint;',
'begin',
' {@f}f:={@Red}Red;',
' {@f}f:={@v}v;',
' if {@f}f={@Red}Red then ;',
' if {@f}f={@v}v then ;',
' if {@f}f>{@v}v then ;',
' if {@f}f<{@v}v then ;',
' if {@f}f>={@v}v then ;',
' if {@f}f<={@v}v then ;',
' if {@f}f<>{@v}v then ;',
' if ord({@f}f)<>ord({@Red}Red) then ;',
' {@f}f:={@TFlag}TFlag.{@Red}Red;',
' {@f}f:={@TFlag}TFlag({@i}i);',
' {@i}i:=longint({@f}f);',
' {@f}f:={@TAlias}TAlias.{@Green}Green;',
'']);
ParseProgram;
end;
@ -9703,40 +9710,42 @@ end;
procedure TTestResolver.TestClassCallInherited;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;');
Add(' procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;');
Add(' end;');
Add(' {#A}TClassA = class');
Add(' procedure {#A_ProcA}ProcA({#i1}vI: longint); override;');
Add(' procedure {#A_ProcB}ProcB(vJ: longint); override;');
Add(' procedure {#A_ProcC}ProcC; virtual;');
Add(' end;');
Add('procedure TObject.ProcA(vi: longint);');
Add('begin');
Add(' inherited; // ignore, do not raise error');
Add('end;');
Add('procedure TObject.ProcB(vj: longint);');
Add('begin');
Add('end;');
Add('procedure TClassA.ProcA(vi: longint);');
Add('begin');
Add(' {@A_ProcA}ProcA({@i1}vI);');
Add(' {@TOBJ_ProcA}inherited;');
Add(' inherited {@TOBJ_ProcA}ProcA({@i1}vI);');
Add(' {@A_ProcB}ProcB({@i1}vI);');
Add(' inherited {@TOBJ_ProcB}ProcB({@i1}vI);');
Add('end;');
Add('procedure TClassA.ProcB(vJ: longint);');
Add('begin');
Add('end;');
Add('procedure TClassA.ProcC;');
Add('begin');
Add(' inherited; // ignore, do not raise error');
Add('end;');
Add('begin');
Add([
'type',
' TObject = class',
' procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;',
' procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;',
' end;',
' {#A}TClassA = class',
' procedure {#A_ProcA}ProcA({#i1}vI: longint); override;',
' procedure {#A_ProcB}ProcB(vJ: longint); override;',
' procedure {#A_ProcC}ProcC; virtual;',
' end;',
'procedure TObject.ProcA(vi: longint);',
'begin',
' inherited; // ignore, do not raise error',
'end;',
'procedure TObject.ProcB(vj: longint);',
'begin',
'end;',
'procedure TClassA.ProcA(vi: longint);',
'begin',
' {@A_ProcA}ProcA({@i1}vI);',
' {@TOBJ_ProcA}inherited;',
' inherited {@TOBJ_ProcA}ProcA({@i1}vI);',
' {@A_ProcB}ProcB({@i1}vI);',
' inherited {@TOBJ_ProcB}ProcB({@i1}vI);',
'end;',
'procedure TClassA.ProcB(vJ: longint);',
'begin',
'end;',
'procedure TClassA.ProcC;',
'begin',
' inherited; // ignore, do not raise error',
'end;',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestClassCallInheritedNoParamsAbstractFail;
@ -10836,6 +10845,32 @@ begin
nCannotCreateADescendantOfTheSealedXY);
end;
procedure TTestResolver.TestClass_Abstract;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' constructor Create;',
' end;',
' TNop = class abstract(TObject)',
' end;',
' TBird = class(TNop)',
' constructor Create(w: word);',
' end;',
'constructor TObject.Create;',
'begin',
'end;',
'constructor TBird.Create(w: word);',
'begin',
' inherited Create;',
'end;',
'begin',
' TBird.Create;']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestClass_AbstractCreateFail;
begin
StartProgram(false);
@ -16963,11 +16998,11 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClassHelper_MultipleScopeHelpers;
procedure TTestResolver.TestClassHelper_MultiHelpers;
begin
StartProgram(false);
Add([
'{$modeswitch multiplescopehelpers}',
'{$modeswitch multihelpers}',
'type',
' TObject = class',
' end;',
@ -17454,6 +17489,30 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestTypeHelper_Double;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' Float = type double;',
' THelper = type helper for float',
' const NPI = 3.141592;',
' function ToStr: String;',
' end;',
'function THelper.ToStr: String;',
'begin',
'end;',
'var',
' a,b: Float;',
' s: string;',
'begin',
' s:=(a * b.NPI).ToStr;',
' s:=(a * float.NPI).ToStr;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestTypeHelper_Constructor_NewInstance;
var
aMarker: PSrcMarker;

46
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -168,6 +168,7 @@ type
procedure TestWP_ClassHelper_ClassConstrucor_Used;
procedure TestWP_Attributes;
procedure TestWP_Attributes_ForwardClass;
procedure TestWP_Attributes_Params;
// scope references
procedure TestSR_Proc_UnitVar;
@ -2265,6 +2266,13 @@ end;
procedure TTestUseAnalyzer.TestWP_UnitInitialization;
begin
AddModuleWithIntfImplSrc('unit2.pp',
LinesToStr([
'var i: longint;',
'']),
LinesToStr([
'']));
AddModuleWithIntfImplSrc('unit1.pp',
LinesToStr([
'uses unit2;',
@ -2273,13 +2281,6 @@ begin
'initialization',
'i:=2;']));
AddModuleWithIntfImplSrc('unit2.pp',
LinesToStr([
'var i: longint;',
'']),
LinesToStr([
'']));
StartProgram(true);
Add('uses unit1;');
Add('begin');
@ -3204,6 +3205,37 @@ begin
AnalyzeWholeProgram;
end;
procedure TTestUseAnalyzer.TestWP_Attributes_Params;
begin
StartProgram(false);
Add([
'{$modeswitch prefixedattributes}',
'type',
' TObject = class',
' constructor {#TObject_Create_notused}Create;',
' destructor {#TObject_Destroy_used}Destroy; virtual;',
' end;',
' {#TCustomAttribute_used}TCustomAttribute = class',
' end;',
' {#BigAttribute_used}BigAttribute = class(TCustomAttribute)',
' constructor {#Big_A_used}Create(Id: word = 3); overload;',
' destructor {#Big_B_used}Destroy; override;',
' end;',
'constructor TObject.Create; begin end;',
'destructor TObject.Destroy; begin end;',
'constructor BigAttribute.Create(Id: word); begin end;',
'destructor BigAttribute.Destroy; begin end;',
'var',
' [Big(3)]',
' o: TObject;',
' a: TCustomAttribute;',
'begin',
' if typeinfo(o)=nil then ;',
' a.Destroy;',
'']);
AnalyzeWholeProgram;
end;
procedure TTestUseAnalyzer.TestSR_Proc_UnitVar;
begin
StartUnit(false);

6
packages/fcl-web/fpmake.pp
View File

@ -373,6 +373,12 @@ begin
AddUnit('sqldbrestschema');
AddUnit('sqldbrestconst');
end;
T:=P.Targets.AddUnit('sqldbrestmodule.pp');
With T.Dependencies do
begin
AddUnit('sqldbrestbridge');
AddUnit('sqldbrestconst');
end;
{$ifndef ALLPACKAGES}
Run;

1
packages/fcl-web/src/restbridge/sqldbrestconst.pp
View File

@ -44,6 +44,7 @@ Resourcestring
SErrMissingDocumentRoot = 'Missing document root';
SErrInvalidCDSMissingElement = 'Invalid CDS Data packet: missing %s element';
SErrNoResourceDataFound = 'Failed to find resource data in input';
SErrNoRESTDispatcher = 'No REST bridge dispatcher assigned to handle request!';
Const
DefaultAuthenticationRealm = 'REST API Server';

85
packages/fcl-web/src/restbridge/sqldbrestio.pp
View File

@ -85,6 +85,7 @@ Type
private
FValues : Array[TRestStringProperty] of UTF8String;
function GetRestPropName(AIndex: Integer): UTF8String;
function IsRestStringStored(AIndex: Integer): Boolean;
procedure SetRestPropName(AIndex: Integer; AValue: UTF8String);
Public
Class Function GetDefaultString(aString : TRestStringProperty) :UTF8String;
@ -93,43 +94,43 @@ Type
Procedure Assign(aSource : TPersistent); override;
Published
// Indexes here MUST match TRestProperty
Property RESTDateFormat : UTF8String Index ord(rpDateFormat) Read GetRestPropName Write SetRestPropName;
Property RESTDateTimeFormat : UTF8String Index ord(rpDateTimeFormat) Read GetRestPropName Write SetRestPropName;
Property RESTTimeFormat : UTF8String Index ord(rpTimeFormat) Read GetRestPropName Write SetRestPropName;
Property DataProperty : UTF8String Index ord(rpDataRoot) Read GetRestPropName Write SetRestPropName;
Property MetaDataRoot : UTF8String Index ord(rpMetaDataRoot) Read GetRestPropName Write SetRestPropName;
Property ErrorProperty : UTF8String Index ord(rpErrorRoot) Read GetRestPropName Write SetRestPropName;
Property FieldNameProperty : UTF8String Index ord(rpFieldNameProp) Read GetRestPropName Write SetRestPropName;
Property FieldTypeProperty : UTF8String Index ord(rpFieldTypeProp) Read GetRestPropName Write SetRestPropName;
Property DateFormatProperty : UTF8String Index ord(rpFieldDateFormatProp) Read GetRestPropName Write SetRestPropName;
Property MaxLenProperty : UTF8String Index ord(rpFieldMaxLenProp) Read GetRestPropName Write SetRestPropName;
Property HumanReadableParam : UTF8String Index ord(rpHumanReadable) Read GetRestPropName Write SetRestPropName;
Property FieldListParam : UTF8String Index ord(rpFieldList) Read GetRestPropName Write SetRestPropName;
Property ExcludeFieldListParam : UTF8String Index ord(rpExcludeFieldList) Read GetRestPropName Write SetRestPropName;
Property ConnectionParam : UTF8String Index Ord(rpConnection) Read GetRestPropName Write SetRestPropName;
Property ResourceParam : UTF8String Index ord(rpResource) Read GetRestPropName Write SetRestPropName;
Property IncludeMetadataParam : UTF8String Index ord(rpIncludeMetadata) Read GetRestPropName Write SetRestPropName;
Property SparseParam : UTF8String Index Ord(rpSparse) Read GetRestPropName Write SetRestPropName;
Property RowName : UTF8String Index Ord(rpRowName) Read GetRestPropName Write SetRestPropName;
Property MetadataFields : UTF8String Index Ord(rpMetadataFields) Read GetRestPropName Write SetRestPropName;
Property MetadataField : UTF8String Index Ord(rpMetadataField) Read GetRestPropName Write SetRestPropName;
Property ErrorCode : UTF8String Index ord(rpErrorCode) Read GetRestPropName Write SetRestPropName;
Property ErrorMessage : UTF8String Index ord(rpErrorMessage) Read GetRestPropName Write SetRestPropName;
Property FilterParamEqual : UTF8String Index ord(rpFilterEqual) Read GetRestPropName Write SetRestPropName;
Property FilterParamLessThan : UTF8String Index ord(rpFilterLessThan) Read GetRestPropName Write SetRestPropName;
Property FilterParamGreaterThan : UTF8String Index ord(rpFilterGreaterThan) Read GetRestPropName Write SetRestPropName;
Property FilterParamLessThanEqual : UTF8String Index ord(rpFilterLessThanEqual) Read GetRestPropName Write SetRestPropName;
Property FilterParamGreaterThanEqual : UTF8String Index ord(rpFilterGreaterThanEqual) Read GetRestPropName Write SetRestPropName;
Property FilterParamIsNull : UTF8String Index ord(rpFilterIsNull) Read GetRestPropName Write SetRestPropName;
Property LimitParam : UTF8string Index ord(rpLimit) Read GetRestPropName Write SetRestPropName;
Property OffsetParam : UTF8string Index ord(rpOffset) Read GetRestPropName Write SetRestPropName;
Property SortParam : UTF8string Index ord(rpOrderBy) Read GetRestPropName Write SetRestPropName;
Property MetadataResourceName : UTF8string Index ord(rpMetadataResourceName) Read GetRestPropName Write SetRestPropName;
Property InputFormatParam : UTF8string Index ord(rpInputFormat) Read GetRestPropName Write SetRestPropName;
Property OutputFormatParam : UTF8string Index ord(rpOutputFormat) Read GetRestPropName Write SetRestPropName;
Property CustomViewResourceName : UTF8string Index ord(rpCustomViewResourceName) Read GetRestPropName Write SetRestPropName;
Property CustomViewSQLParam : UTF8string Index ord(rpCustomViewSQLParam) Read GetRestPropName Write SetRestPropName;
Property XMLDocumentRoot : UTF8string Index ord(rpXMLDocumentRoot) Read GetRestPropName Write SetRestPropName;
Property RESTDateFormat : UTF8String Index ord(rpDateFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property RESTDateTimeFormat : UTF8String Index ord(rpDateTimeFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property RESTTimeFormat : UTF8String Index ord(rpTimeFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property DataProperty : UTF8String Index ord(rpDataRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property MetaDataRoot : UTF8String Index ord(rpMetaDataRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ErrorProperty : UTF8String Index ord(rpErrorRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FieldNameProperty : UTF8String Index ord(rpFieldNameProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FieldTypeProperty : UTF8String Index ord(rpFieldTypeProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property DateFormatProperty : UTF8String Index ord(rpFieldDateFormatProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property MaxLenProperty : UTF8String Index ord(rpFieldMaxLenProp) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property HumanReadableParam : UTF8String Index ord(rpHumanReadable) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FieldListParam : UTF8String Index ord(rpFieldList) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ExcludeFieldListParam : UTF8String Index ord(rpExcludeFieldList) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ConnectionParam : UTF8String Index Ord(rpConnection) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ResourceParam : UTF8String Index ord(rpResource) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property IncludeMetadataParam : UTF8String Index ord(rpIncludeMetadata) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property SparseParam : UTF8String Index Ord(rpSparse) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property RowName : UTF8String Index Ord(rpRowName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property MetadataFields : UTF8String Index Ord(rpMetadataFields) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property MetadataField : UTF8String Index Ord(rpMetadataField) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ErrorCode : UTF8String Index ord(rpErrorCode) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property ErrorMessage : UTF8String Index ord(rpErrorMessage) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamEqual : UTF8String Index ord(rpFilterEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamLessThan : UTF8String Index ord(rpFilterLessThan) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamGreaterThan : UTF8String Index ord(rpFilterGreaterThan) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamLessThanEqual : UTF8String Index ord(rpFilterLessThanEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamGreaterThanEqual : UTF8String Index ord(rpFilterGreaterThanEqual) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property FilterParamIsNull : UTF8String Index ord(rpFilterIsNull) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property LimitParam : UTF8string Index ord(rpLimit) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property OffsetParam : UTF8string Index ord(rpOffset) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property SortParam : UTF8string Index ord(rpOrderBy) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property MetadataResourceName : UTF8string Index ord(rpMetadataResourceName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property InputFormatParam : UTF8string Index ord(rpInputFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property OutputFormatParam : UTF8string Index ord(rpOutputFormat) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property CustomViewResourceName : UTF8string Index ord(rpCustomViewResourceName) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property CustomViewSQLParam : UTF8string Index ord(rpCustomViewSQLParam) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
Property XMLDocumentRoot : UTF8string Index ord(rpXMLDocumentRoot) Read GetRestPropName Write SetRestPropName Stored IsRestStringStored;
end;
{ TRestStreamer }
@ -491,6 +492,16 @@ begin
Result:=DefaultPropertyNames[TRestStringProperty(AIndex)]
end;
function TRestStringsConfig.IsRestStringStored(AIndex: Integer): Boolean;
Var
V : UTF8String;
begin
V:=FValues[TRestStringProperty(AIndex)];
Result:=(V<>'') and (V<>DefaultPropertyNames[TRestStringProperty(AIndex)]);
end;
procedure TRestStringsConfig.SetRestPropName(AIndex: Integer; AValue: UTF8String);
begin
FValues[TRestStringProperty(AIndex)]:=aValue;

78
packages/fcl-web/src/restbridge/sqldbrestmodule.pp Normal file
View File

@ -0,0 +1,78 @@
unit sqldbrestmodule;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, httpdefs, fphttp, sqldbrestbridge;
Type
{ TSQLDBRestModule }
TSQLDBRestModule = Class (TSessionHTTPModule)
private
FDispatcher: TSQLDBRestDispatcher;
procedure SetDispatcher(AValue: TSQLDBRestDispatcher);
Protected
Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Function FindDispatcher : TSQLDBRestDispatcher; virtual;
Public
constructor Create(AOwner: TComponent); override;
Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override;
Published
Property Dispatcher : TSQLDBRestDispatcher Read FDispatcher Write SetDispatcher;
Property Kind;
end;
implementation
uses sqldbrestconst;
{ TSQLDBRestModule }
procedure TSQLDBRestModule.SetDispatcher(AValue: TSQLDBRestDispatcher);
begin
if FDispatcher=AValue then Exit;
if Assigned(Dispatcher) then
FDispatcher.RemoveFreeNotification(Self);
FDispatcher:=AValue;
if Assigned(Dispatcher) then
FDispatcher.FreeNotification(Self);
end;
procedure TSQLDBRestModule.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation=opRemove then
if AComponent=FDispatcher then
FDispatcher:=Nil;
end;
function TSQLDBRestModule.FindDispatcher: TSQLDBRestDispatcher;
begin
Result:=Dispatcher;
end;
constructor TSQLDBRestModule.Create(AOwner: TComponent);
begin
Kind:=wkOneShot;
inherited Create(AOwner);
end;
procedure TSQLDBRestModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
Var
Disp : TSQLDBRestDispatcher;
begin
Disp:=FindDispatcher;
If assigned(Disp) then
Disp.HandleRequest(aRequest,aResponse)
else
Raise EHTTP.Create(SErrNoRESTDispatcher);
end;
end.

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

@ -520,6 +520,7 @@ const
nCantCallExtBracketAccessor = 4025;
nJSNewNotSupported = 4026;
nHelperClassMethodForExtClassMustBeStatic = 4027;
nBitWiseOperationIs32Bit = 4028;
// resourcestring patterns of messages
resourcestring
sPasElementNotSupported = 'Pascal element not supported: %s';
@ -549,6 +550,7 @@ resourcestring
sCantCallExtBracketAccessor = 'cannot call external bracket accessor, use a property instead';
sJSNewNotSupported = 'Pascal class does not support the "new" constructor';
sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static';
sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit';
const
ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@ -566,6 +568,9 @@ type
pbifnArray_Static_Clone,
pbifnAs,
pbifnAsExt,
pbifnBitwiseNativeIntAnd,
pbifnBitwiseNativeIntOr,
pbifnBitwiseNativeIntXor,
pbifnCheckMethodCall,
pbifnCheckVersion,
pbifnClassInstanceFree,
@ -725,6 +730,9 @@ const
'$clone',
'as', // rtl.as
'asExt', // rtl.asExt
'and', // pbifnBitwiseNativeIntAnd,
'or', // pbifnBitwiseNativeIntOr,
'xor', // pbifnBitwiseNativeIntXor,
'checkMethodCall',
'checkVersion',
'$destroy',
@ -1167,7 +1175,7 @@ const
msArrayOperators,
msPrefixedAttributes,
msOmitRTTI,
msMultipleScopeHelpers];
msMultiHelpers];
msAllPas2jsBoolSwitchesReadOnly = [
bsLongStrings
@ -1436,6 +1444,7 @@ type
ScannerModeSwitches: TModeSwitches;
constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); virtual;
function GetRootModule: TPasModule;
function GetRootContext: TConvertContext;
function GetNonDotContext: TConvertContext;
function GetFunctionContext: TFunctionContext;
function GetLocalName(El: TPasElement): string; virtual;
@ -1456,6 +1465,9 @@ type
TRootContext = Class(TConvertContext)
public
ResourceStrings: TJSVarDeclaration;
GlobalClassMethods: TArrayOfPasProcedure;
procedure AddGlobalClassMethod(p: TPasProcedure);
destructor Destroy; override;
end;
{ TFCLocalIdentifier }
@ -1622,12 +1634,11 @@ type
{$ENDIF}
private
FGlobals: TPasToJSConverterGlobals;
FGlobalClassMethods: TArrayOfPasProcedure;
FOnIsElementUsed: TPas2JSIsElementUsedEvent;
FOnIsTypeInfoUsed: TPas2JSIsElementUsedEvent;
FOptions: TPasToJsConverterOptions;
FReservedWords: TJSReservedWordList; // sorted with CompareStr
Procedure AddGlobalClassMethod(P: TPasProcedure);
Procedure AddGlobalClassMethod(aContext: TConvertContext; P: TPasProcedure);
Function CreatePrimitiveDotExpr(Path: string; PosEl: TPasElement): TJSElement;
Function CreateSubDeclJSNameExpr(El: TPasElement; JSName: string;
AContext: TConvertContext; PosEl: TPasElement): TJSElement;
@ -1874,7 +1885,7 @@ type
Function ConvertRepeatStatement(El: TPasImplRepeatUntil; AContext: TConvertContext): TJSElement; virtual;
Function ConvertForStatement(El: TPasImplForLoop; AContext: TConvertContext): TJSElement; virtual;
Function ConvertFinalizationSection(El: TFinalizationSection; AContext: TConvertContext): TJSElement; virtual;
Function ConvertInitializationSection(El: TInitializationSection; AContext: TConvertContext): TJSElement; virtual;
Function ConvertInitializationSection(El: TPasModule; AContext: TConvertContext): TJSElement; virtual;
Function ConvertSimpleStatement(El: TPasImplSimple; AContext: TConvertContext): TJSElement; virtual;
Function ConvertWithStatement(El: TPasImplWithDo; AContext: TConvertContext): TJSElement; virtual;
Function ConvertTryStatement(El: TPasImplTry; AContext: TConvertContext ): TJSElement; virtual;
@ -2128,6 +2139,23 @@ begin
Result:='['+Result+']';
end;
{ TRootContext }
procedure TRootContext.AddGlobalClassMethod(p: TPasProcedure);
begin
{$IF defined(fpc) and (FPC_FULLVERSION<30101)}
SetLength(GlobalClassMethods,length(GlobalClassMethods)+1);
GlobalClassMethods[length(GlobalClassMethods)-1]:=P;
{$ELSE}
Insert(P,GlobalClassMethods,length(GlobalClassMethods));
{$ENDIF}
end;
destructor TRootContext.Destroy;
begin
inherited Destroy;
end;
{ TPasToJSConverterGlobals }
constructor TPasToJSConverterGlobals.Create(TheOwner: TObject);
@ -5831,6 +5859,13 @@ begin
Result:=nil;
end;
function TConvertContext.GetRootContext: TConvertContext;
begin
Result:=Self;
while Result.Parent<>nil do
Result:=Result.Parent;
end;
function TConvertContext.GetNonDotContext: TConvertContext;
begin
Result:=Self;
@ -6005,14 +6040,15 @@ begin
Result:=FGlobals.BuiltInNames[bin];
end;
procedure TPasToJSConverter.AddGlobalClassMethod(P: TPasProcedure);
procedure TPasToJSConverter.AddGlobalClassMethod(aContext: TConvertContext;
P: TPasProcedure);
var
RootContext: TConvertContext;
begin
{$IF defined(fpc) and (FPC_FULLVERSION<30101)}
SetLength(FGlobalClassMethods,length(FGlobalClassMethods)+1);
FGlobalClassMethods[length(FGlobalClassMethods)-1]:=P;
{$ELSE}
Insert(P,FGlobalClassMethods,length(FGlobalClassMethods));
{$ENDIF}
RootContext:=aContext.GetRootContext;
if not (RootContext is TRootContext) then
DoError(20190226232141,RootContext.ClassName);
TRootContext(RootContext).AddGlobalClassMethod(P);
end;
procedure TPasToJSConverter.AddToSourceElements(Src: TJSSourceElements;
@ -6650,6 +6686,7 @@ var
ModeSwitches: TModeSwitches;
aResolver: TPas2JSResolver;
LeftTypeEl, RightTypeEl: TPasType;
OldAccess: TCtxAccess;
begin
Result:=Nil;
aResolver:=AContext.Resolver;
@ -6668,14 +6705,8 @@ begin
end;
end;
if AContext.Access<>caRead then
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertBinaryExpression OpCode=',El.OpCode,' AContext.Access=',AContext.Access);
{$ENDIF}
DoError(20170209152633,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El);
end;
OldAccess:=AContext.Access;
AContext.Access:=caRead;
Call:=nil;
A:=ConvertExpression(El.left,AContext);
B:=nil;
@ -6784,9 +6815,7 @@ begin
Result:=Call;
exit;
end;
eopAnd,
eopOr,
eopXor:
eopAnd:
begin
if aResolver<>nil then
begin
@ -6795,26 +6824,74 @@ begin
if UseBitwiseOp
and (LeftResolved.BaseType in [btIntDouble,btUIntDouble])
and (RightResolved.BaseType in [btIntDouble,btUIntDouble]) then
aResolver.LogMsg(20190124233439,mtWarning,nBitWiseOperationsAre32Bit,
sBitWiseOperationsAre32Bit,[],El);
begin
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntAnd)]);
Call.AddArg(A);
Call.AddArg(B);
Result:=Call;
exit;
end;
end
else
UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber)
or (GetExpressionValueType(El.right,AContext)=jstNumber);
if UseBitwiseOp then
Case El.OpCode of
eopAnd : C:=TJSBitwiseAndExpression;
eopOr : C:=TJSBitwiseOrExpression;
eopXor : C:=TJSBitwiseXOrExpression;
C:=TJSBitwiseAndExpression
else
C:=TJSLogicalAndExpression;
end;
eopOr:
begin
if aResolver<>nil then
begin
UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger)
or (RightResolved.BaseType in btAllJSInteger));
if UseBitwiseOp
and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble])
or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then
begin
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntOr)]);
Call.AddArg(A);
Call.AddArg(B);
Result:=Call;
exit;
end;
end
else
Case El.OpCode of
eopAnd : C:=TJSLogicalAndExpression;
eopOr : C:=TJSLogicalOrExpression;
eopXor : C:=TJSBitwiseXOrExpression;
else
DoError(20161024191234,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,['logical XOR'],El);
end;
UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber)
or (GetExpressionValueType(El.right,AContext)=jstNumber);
if UseBitwiseOp then
C:=TJSBitwiseOrExpression
else
C:=TJSLogicalOrExpression;
end;
eopXor:
begin
if aResolver<>nil then
begin
UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger)
or (RightResolved.BaseType in btAllJSInteger));
if UseBitwiseOp
and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble])
or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then
begin
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntXor)]);
Call.AddArg(A);
Call.AddArg(B);
Result:=Call;
exit;
end;
end
else
UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber)
or (GetExpressionValueType(El.right,AContext)=jstNumber);
if UseBitwiseOp then
C:=TJSBitwiseXOrExpression
else
C:=TJSBitwiseXOrExpression;
end;
eopPower:
begin
@ -6823,7 +6900,7 @@ begin
Call.AddArg(A);
Call.AddArg(B);
Result:=Call;
end
end;
else
if C=nil then
DoError(20161024191244,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El);
@ -6835,11 +6912,17 @@ begin
R.B:=B; B:=nil;
Result:=R;
if El.OpCode=eopDiv then
case El.OpCode of
eopDiv:
begin
// convert "a div b" to "Math.floor(a/b)"
Result:=CreateMathFloor(El,Result);
end;
eopShl,eopShr:
if (aResolver<>nil) and (LeftResolved.BaseType in [btIntDouble,btUIntDouble]) then
aResolver.LogMsg(20190228220225,mtWarning,nBitWiseOperationIs32Bit,
sBitWiseOperationIs32Bit,[],El);
end;
if (bsOverflowChecks in AContext.ScannerBoolSwitches) and (aResolver<>nil) then
case El.OpCode of
@ -6854,6 +6937,7 @@ begin
end;
end;
finally
AContext.Access:=OldAccess;
if Result=nil then
begin
A.Free;
@ -12945,7 +13029,7 @@ begin
else if (C=TPasClassConstructor)
or (C=TPasClassDestructor) then
begin
AddGlobalClassMethod(TPasProcedure(P));
AddGlobalClassMethod(AContext,TPasProcedure(P));
continue;
end;
NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
@ -14079,11 +14163,12 @@ begin
end;
end;
function TPasToJSConverter.ConvertInitializationSection(
El: TInitializationSection; AContext: TConvertContext): TJSElement;
function TPasToJSConverter.ConvertInitializationSection(El: TPasModule;
AContext: TConvertContext): TJSElement;
var
FDS: TJSFunctionDeclarationStatement;
FuncContext: TFunctionContext;
PosEl: TPasElement;
function CreateBody: TJSFunctionBody;
var
@ -14093,12 +14178,12 @@ var
Result:=FuncDef.Body;
if Result=nil then
begin
Result:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
Result:=TJSFunctionBody(CreateElement(TJSFunctionBody,PosEl));
FuncDef.Body:=Result;
Result.A:=TJSSourceElements(CreateElement(TJSSourceElements, El));
Result.A:=TJSSourceElements(CreateElement(TJSSourceElements, PosEl));
end;
if FuncContext=nil then
FuncContext:=TFunctionContext.Create(El,Result,AContext);
FuncContext:=TFunctionContext.Create(PosEl,Result,AContext);
end;
var
@ -14109,65 +14194,80 @@ var
Scope: TPas2JSInitialFinalizationScope;
Line, Col: integer;
Lit: TJSLiteral;
Section: TInitializationSection;
RootContext: TRootContext;
begin
// create: '$mod.$init=function(){}'
Result:=nil;
Scope:=TPas2JSInitialFinalizationScope(El.CustomData);
IsMain:=(El.Parent<>nil) and (El.Parent is TPasProgram);
Section:=El.InitializationSection;
if Section<>nil then
begin
PosEl:=Section;
Scope:=TPas2JSInitialFinalizationScope(Section.CustomData);
end
else
begin
PosEl:=El;
Scope:=nil;
end;
IsMain:=(El is TPasProgram);
if IsMain then
FunName:=GetBIName(pbifnProgramMain)
else
FunName:=GetBIName(pbifnUnitInit);
NeedRTLCheckVersion:=IsMain and (coRTLVersionCheckMain in Options);
RootContext:=AContext.GetRootContext as TRootContext;
FuncContext:=nil;
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
try
// $mod.$init =
AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnModule),FunName]);
// = function(){...}
FDS:=CreateFunctionSt(El,false);
FDS:=CreateFunctionSt(PosEl,false);
AssignSt.Expr:=FDS;
Body:=FDS.AFunction.Body;
// first convert main/initialization statements
if Scope.JS<>'' then
begin
S:=TrimRight(Scope.JS);
if S<>'' then
if Section<>nil then
if Scope.JS<>'' then
begin
S:=TrimRight(Scope.JS);
if S<>'' then
begin
Body:=CreateBody;
// use precompiled JS
TPasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
Lit:=TJSLiteral.Create(Line,Col,El.SourceFilename);
Lit.Value.CustomValue:=StrToJSString(S);
Body.A:=Lit;
end;
end
else if Section.Elements.Count>0 then
begin
Body:=CreateBody;
// use precompiled JS
TPasResolver.UnmangleSourceLineNumber(El.Parent.SourceLinenumber,Line,Col);
Lit:=TJSLiteral.Create(Line,Col,El.Parent.SourceFilename);
Lit.Value.CustomValue:=StrToJSString(S);
Body.A:=Lit;
end;
end
else if El.Elements.Count>0 then
begin
Body:=CreateBody;
// Note: although the rtl sets 'this' as the module, the function can
// simply refer to $mod, so no need to set ThisPas here
Body.A:=ConvertImplBlockElements(El,FuncContext,false);
FuncContext.BodySt:=Body.A;
// Note: although the rtl sets 'this' as the module, the function can
// simply refer to $mod, so no need to set ThisPas here
Body.A:=ConvertImplBlockElements(Section,FuncContext,false);
FuncContext.BodySt:=Body.A;
AddInterfaceReleases(FuncContext,El);
Body.A:=FuncContext.BodySt;
AddInterfaceReleases(FuncContext,PosEl);
Body.A:=FuncContext.BodySt;
// store precompiled JS
if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
begin
Scope.JS:=TrimRight(CreatePrecompiledJS(Body.A));
if Scope.JS='' then
Scope.JS:=' '; // store the information, that there is an empty initialization section
end;
end
else if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
Scope.JS:=' '; // store the information, that there is an empty initialization section
// store precompiled JS
if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
begin
Scope.JS:=TrimRight(CreatePrecompiledJS(Body.A));
if Scope.JS='' then
Scope.JS:=' '; // store the information, that there is an empty initialization section
end;
end
else if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
Scope.JS:=' '; // store the information, that there is an empty initialization section
if length(FGlobalClassMethods)>0 then
if length(RootContext.GlobalClassMethods)>0 then
begin
// prepend class constructors (which one depends on WPO)
Body:=CreateBody;
@ -14588,10 +14688,14 @@ end;
procedure TPasToJSConverter.CreateInitSection(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext);
var
RootContext: TRootContext;
begin
RootContext:=AContext.GetRootContext as TRootContext;
// add initialization section
if Assigned(El.InitializationSection) then
AddToSourceElements(Src,ConvertInitializationSection(El.InitializationSection,AContext));
if Assigned(El.InitializationSection)
or (length(RootContext.GlobalClassMethods)>0) then
AddToSourceElements(Src,ConvertInitializationSection(El,AContext));
// finalization: not supported
if Assigned(El.FinalizationSection) then
raise Exception.Create('TPasToJSConverter.ConvertInitializationSection: finalization section is not supported');
@ -15636,13 +15740,15 @@ var
St: TJSElement;
Call: TJSCallExpression;
Bracket: TJSUnaryBracketsExpression;
RootContext: TRootContext;
begin
RootContext:=TRootContext(FuncContext.GetRootContext);
First:=nil;
Last:=nil;
try
for i:=0 to length(FGlobalClassMethods)-1 do
for i:=0 to length(RootContext.GlobalClassMethods)-1 do
begin
Proc:=FGlobalClassMethods[i];
Proc:=RootContext.GlobalClassMethods[i];
St:=ConvertProcedure(Proc,FuncContext);
// create direct call ( function(){} )();
Bracket:=TJSUnaryBracketsExpression(CreateElement(TJSUnaryBracketsExpression,PosEl));
@ -18090,7 +18196,7 @@ begin
// append args
ProcType:=Proc.ProcType;
if Expr.Parent is TParamsExpr then
if (Expr.Parent is TParamsExpr) and (TParamsExpr(Expr.Parent).Value=Expr) then
ParamsExpr:=TParamsExpr(Expr.Parent)
else
ParamsExpr:=nil;
@ -18232,7 +18338,7 @@ begin
else if (El.ClassType=TPasImplBeginBlock) then
Result:=ConvertBeginEndStatement(TPasImplBeginBlock(El),AContext,true)
else if (El.ClassType=TInitializationSection) then
Result:=ConvertInitializationSection(TInitializationSection(El),AContext)
Result:=ConvertInitializationSection(TPasModule(El.Parent),AContext)
else if (El.ClassType=TFinalizationSection) then
Result:=ConvertFinalizationSection(TFinalizationSection(El),AContext)
else if (El.ClassType=TPasImplTry) then
@ -21242,7 +21348,7 @@ begin
begin
// pass set with argDefault -> create reference rtl.refSet(right)
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcedureCallArg create reference of SET variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
writeln('TPasToJSConverter.CreateProcCallArg create reference of SET variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
{$ENDIF}
Result:=CreateReferencedSet(El,Result);
end;
@ -21320,7 +21426,7 @@ begin
begin
// pass record with argDefault -> "TGuid.$clone(RightRecord)"
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcedureCallArg clone RECORD TGuid variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
writeln('TPasToJSConverter.CreateProcCallArg clone RECORD TGuid variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
{$ENDIF}
Result:=CreateRecordCallClone(El,TPasRecordType(ArgTypeEl),Result,AContext);
end;
@ -21389,7 +21495,7 @@ begin
begin
// pass record with argDefault -> "RightRecord.$clone(RightRecord)"
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcedureCallArg clone RECORD variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
writeln('TPasToJSConverter.CreateProcCallArg clone RECORD variable Right={',GetResolverResultDbg(ExprResolved),'} AssignContext.RightResolved.IdentEl=',GetObjName(ExprResolved.IdentEl));
{$ENDIF}
Result:=CreateRecordCallClone(El,TPasRecordType(ExprTypeEl),Result,AContext);
end;
@ -21500,6 +21606,7 @@ begin
ParamContext.Arg:=TargetArg;
ParamContext.Expr:=El;
ParamContext.ResolvedExpr:=ResolvedEl;
writeln('AAA1 TPasToJSConverter.CreateProcCallArgRef ',GetObjName(El));
FullGetter:=ConvertExpression(El,ParamContext);
// FullGetter is now a full JS expression to retrieve the value.
if ParamContext.ReusingReference then
@ -21513,7 +21620,7 @@ begin
// ParamContext.Getter is the last part of the FullGetter
// FullSetter is created from FullGetter by replacing the Getter with the Setter
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcedureCallArg VAR FullGetter=',GetObjName(FullGetter),' Setter=',GetObjName(ParamContext.Setter),' ',GetResolverResultDbg(ResolvedEl));
writeln('TPasToJSConverter.CreateProcCallArgRef VAR El=',GetObjName(El),' FullGetter=',GetObjName(FullGetter),' Setter=',GetObjName(ParamContext.Setter),' ',GetResolverResultDbg(ResolvedEl));
{$ENDIF}
// create "{p:path,get:function(){return this.p.Getter},set:function(v){this.p.Setter(v);}}"
@ -21657,12 +21764,23 @@ begin
end
else
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcedureCallArg FullGetter=',GetObjName(FullGetter),' Setter=',GetObjName(ParamContext.Setter));
{$ENDIF}
RaiseNotSupported(El,AContext,20170213230336);
// getter is the result of an operation
// create "p:FullGetter"
AddVar(TempRefParamName,FullGetter);
FullGetter:=nil;
// GetExpr "this.a"
GetExpr:=CreatePrimitiveDotExpr('this.'+TempRefParamName,El);
// SetExpr "raise EPropReadOnly"
SetExpr:=CreateRaisePropReadOnly(El);
end;
{$IFDEF VerbosePas2JS}
//writeln('TPasToJSConverter.CreateProcCallArgRef GetExpr=',GetObjName(GetExpr),' SetExpr=',GetObjName(SetExpr),' SetterArgName=',SetterArgName);
{$ENDIF}
if (SetExpr.ClassType=TJSPrimaryExpressionIdent)
or (SetExpr.ClassType=TJSDotMemberExpression)
or (SetExpr.ClassType=TJSBracketMemberExpression) then
@ -21717,6 +21835,10 @@ begin
else
RaiseInconsistency(20170213225940,El);
{$IFDEF VerbosePas2JS}
//writeln('TPasToJSConverter.CreateProcCallArgRef created full SetExpr=',GetObjName(SetExpr),' SetterArgName=',SetterArgName);
{$ENDIF}
// add p:GetPathExpr
AddVar(TempRefGetPathName,GetPathExpr);
@ -22231,7 +22353,7 @@ begin
begin
if (C=TPasClassConstructor)
or (C=TPasClassDestructor) then
AddGlobalClassMethod(TPasProcedure(P))
AddGlobalClassMethod(AContext,TPasProcedure(P))
else
begin
Methods.Add(P);

39
packages/pastojs/src/pas2jscompiler.pp
View File

@ -387,6 +387,7 @@ type
function ReadContinue: boolean; // true=finished
function ReaderState: TPas2jsReaderState;
procedure CreateJS;
procedure EmitModuleHints;
function GetPasFirstSection: TPasSection;
function GetPasImplSection: TPasSection;
function GetPasMainUsesClause: TPasUsesClause;
@ -1479,13 +1480,6 @@ procedure TPas2jsCompilerFile.CreateJS;
begin
//writeln('TPas2jsCompilerFile.CreateJS START ',UnitFilename,' JS=',GetObjName(FJSModule));
try
// show hints only for units that are actually converted
if (PCUSupport=nil) or not PCUSupport.HasReader then
begin
//writeln('TPas2jsCompilerFile.CreateJS ',UnitFilename);
UseAnalyzer.EmitModuleHints(PasModule);
end;
// convert
CreateConverter;
Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
@ -1505,6 +1499,27 @@ begin
//writeln('TPas2jsCompilerFile.CreateJS END ',UnitFilename,' JS=',GetObjName(FJSModule));
end;
procedure TPas2jsCompilerFile.EmitModuleHints;
begin
try
// show hints only for units with sources
if (PCUSupport=nil) or not PCUSupport.HasReader then
begin
//writeln('TPas2jsCompilerFile.EmitModuleHints ',UnitFilename);
UseAnalyzer.EmitModuleHints(PasModule);
end;
except
on E: ECompilerTerminate do
raise;
on E: Exception do
HandleException(E);
{$IFDEF pas2js}
else
HandleJSException('[20190226183324] TPas2jsCompilerFile.EmitModuleHints File="'+UnitFilename+'"',
JSExceptValue);
{$ENDIF}
end;
end;
function TPas2jsCompilerFile.GetPasFirstSection: TPasSection;
var
@ -1971,11 +1986,17 @@ procedure TPas2jsCompiler.CreateJavaScript(aFile: TPas2jsCompilerFile;
begin
//writeln('TPas2jsCompiler.CreateJavaScript ',aFile.UnitFilename,' JS=',GetObjName(aFile.JSModule),' Need=',aFile.NeedBuild);
if (aFile.JSModule<>nil) or (not aFile.NeedBuild) then exit;
if aFile.JSModule<>nil then exit; // already created
// check each file only once
if Checked.ContainsItem(aFile) then exit;
Checked.Add(aFile);
// emit module hints
aFile.EmitModuleHints;
if not aFile.NeedBuild then exit;
Log.LogMsg(nCompilingFile,[FullFormatPath(aFile.UnitFilename)],'',0,0,
not (coShowLineNumbers in Options));
@ -4307,7 +4328,7 @@ begin
if FHasShownLogo then exit;
FHasShownLogo:=true;
WriteVersionLine;
Log.LogPlain('Copyright (c) 2018 Free Pascal team.');
Log.LogPlain('Copyright (c) 2019 Free Pascal team.');
if coShowInfos in Options then
WriteEncoding;
end;

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

@ -172,7 +172,7 @@ const
'ExternalClass',
'PrefixedAttributes',
'OmitRTTI',
'MultipleScopeHelpers'
'MultiHelpers'
); // Dont forget to update ModeSwitchToInt !
PCUDefaultBoolSwitches: TBoolSwitches = [
@ -1047,6 +1047,9 @@ type
var
PrecompileFormats: TPas2JSPrecompileFormats = nil;
PCUFormat: TPas2JSPrecompileFormat = nil;
procedure RegisterPCUFormat;
function ComparePointer(Data1, Data2: Pointer): integer;
function ComparePCUSrcFiles(File1, File2: Pointer): integer;
@ -1073,6 +1076,12 @@ function dbgmem(p: PChar; Cnt: integer): string; overload;
implementation
procedure RegisterPCUFormat;
begin
if PCUFormat=nil then
PCUFormat:=PrecompileFormats.Add('pcu','all used pcu must match exactly',TPCUReader,TPCUWriter);
end;
function ComparePointer(Data1, Data2: Pointer): integer;
begin
if Data1>Data2 then Result:=-1
@ -1394,7 +1403,7 @@ begin
// msIgnoreInterfaces: Result:=46;
// msIgnoreAttributes: Result:=47;
msOmitRTTI: Result:=48;
msMultipleScopeHelpers: Result:=49;
msMultiHelpers: Result:=49;
end;
end;
@ -4954,6 +4963,8 @@ begin
begin
s:=Names[i];
Found:=false;
if (FileVersion<5) and (SameText(s,'multiplescopehelpers')) then
s:=PCUModeSwitchNames[msMultiHelpers];
for f in TModeSwitch do
if s=PCUModeSwitchNames[f] then
begin
@ -7924,6 +7935,8 @@ end;
procedure TPas2JSPrecompileFormats.Clear;
begin
if (PCUFormat<>nil) and (FItems.IndexOf(PCUFormat)>=0) then
PCUFormat:=nil;
FItems.Clear;
end;
@ -7995,7 +8008,6 @@ end;
initialization
PrecompileFormats:=TPas2JSPrecompileFormats.Create;
PrecompileFormats.Add('pcu','all used pcu must match exactly',TPCUReader,TPCUWriter);
finalization
PrecompileFormats.Free;
PrecompileFormats:=nil;

18
packages/pastojs/src/pas2jspcucompiler.pp
View File

@ -402,11 +402,19 @@ Var
begin
if PrecompileFormats.Count>0 then
begin
writeHelpLine(' -JU<x>: Create precompiled units in format x.');
for i:=0 to PrecompileFormats.Count-1 do
with PrecompileFormats[i] do
writeHelpLine(' -JU'+Ext+': '+Description);
writeHelpLine(' -JU-: Disable prior -JU<x> option. Do not create precompiled units.');
if PrecompileFormats.Count>1 then
begin
writeHelpLine(' -JU<x>: Create precompiled units in format x.');
for i:=0 to PrecompileFormats.Count-1 do
with PrecompileFormats[i] do
writeHelpLine(' -JU'+Ext+': '+Description);
writeHelpLine(' -JU-: Disable prior -JU<x> option. Do not create precompiled units.');
end else
begin
with PrecompileFormats[0] do
writeHelpLine(' -JU'+Ext+': Create precompiled units using '+Description);
writeHelpLine(' -JU- : Disable prior -JU<x> option. Do not create precompiled units.');
end;
end;
end;

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

@ -1646,6 +1646,7 @@ begin
' s = ''abc'';', // string lit
' c: char = s[1];', // array params
' a: array[1..2] of longint = (3,4);', // anonymous array, range, array values
' PI: Double; external name ''Math.PI'';',
'resourcestring',
' rs = ''rs'';',
'implementation']);
@ -1745,11 +1746,13 @@ procedure TTestPrecompile.TestPC_Record;
begin
StartUnit(false);
Add([
'{$ModeSwitch externalclass}',
'interface',
'type',
' TRec = record',
' i: longint;',
' s: string;',
' b: boolean external name ''ext'';',
' end;',
' P = pointer;', // alias type to built-in type
' TArrOfRec = array of TRec;',
@ -2359,5 +2362,6 @@ end;
Initialization
RegisterTests([TTestPrecompile]);
RegisterPCUFormat;
end.

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

@ -263,7 +263,7 @@ type
Procedure TestInteger;
Procedure TestIntegerRange;
Procedure TestIntegerTypecasts;
Procedure TestBitwiseAndNativeIntWarn;
Procedure TestBitwiseShlNativeIntWarn;
Procedure TestCurrency;
Procedure TestForBoolDo;
Procedure TestForIntDo;
@ -473,7 +473,8 @@ type
Procedure TestAdvRecord_SubClass;
Procedure TestAdvRecord_SubInterfaceFail;
Procedure TestAdvRecord_Constructor;
Procedure TestAdvRecord_ClassConstructor;
Procedure TestAdvRecord_ClassConstructor_Program;
Procedure TestAdvRecord_ClassConstructor_Unit;
// classes
Procedure TestClass_TObjectDefaultConstructor;
@ -675,6 +676,7 @@ type
Procedure TestTypeHelper_ClassMethod;
Procedure TestTypeHelper_Constructor;
Procedure TestTypeHelper_Word;
Procedure TestTypeHelper_Double;
Procedure TestTypeHelper_StringChar;
Procedure TestTypeHelper_Array;
Procedure TestTypeHelper_EnumType;
@ -3079,24 +3081,36 @@ end;
procedure TTestModule.TestBitwiseOperators;
begin
StartProgram(false);
Add('var');
Add(' vA,vB,vC:longint;');
Add('begin');
Add(' va:=vb and vc;');
Add(' va:=vb or vc;');
Add(' va:=vb xor vc;');
Add(' va:=vb shl vc;');
Add(' va:=vb shr vc;');
Add(' va:=3 and vc;');
Add(' va:=(vb and vc) or (va and vb);');
Add(' va:=not vb;');
Add([
'var',
' vA,vB,vC:longint;',
' X,Y,Z: nativeint;',
'begin',
' va:=vb and vc;',
' va:=vb or vc;',
' va:=vb xor vc;',
' va:=vb shl vc;',
' va:=vb shr vc;',
' va:=3 and vc;',
' va:=(vb and vc) or (va and vb);',
' va:=not vb;',
' X:=Y and Z;',
' X:=Y and va;',
' X:=Y or Z;',
' X:=Y or va;',
' X:=Y xor Z;',
' X:=Y xor va;',
'']);
ConvertProgram;
CheckSource('TestBitwiseOperators',
LinesToStr([ // statements
'this.vA = 0;',
'this.vB = 0;',
'this.vC = 0;'
]),
'this.vC = 0;',
'this.X = 0;',
'this.Y = 0;',
'this.Z = 0;',
'']),
LinesToStr([ // this.$main
'$mod.vA = $mod.vB & $mod.vC;',
'$mod.vA = $mod.vB | $mod.vC;',
@ -3105,8 +3119,14 @@ begin
'$mod.vA = $mod.vB >>> $mod.vC;',
'$mod.vA = 3 & $mod.vC;',
'$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
'$mod.vA = ~$mod.vB;'
]));
'$mod.vA = ~$mod.vB;',
'$mod.X = rtl.and($mod.Y, $mod.Z);',
'$mod.X = $mod.Y & $mod.vA;',
'$mod.X = rtl.or($mod.Y, $mod.Z);',
'$mod.X = rtl.or($mod.Y, $mod.vA);',
'$mod.X = rtl.xor($mod.Y, $mod.Z);',
'$mod.X = rtl.xor($mod.Y, $mod.vA);',
'']));
end;
procedure TTestModule.TestPrgProcVar;
@ -6413,25 +6433,24 @@ begin
'']));
end;
procedure TTestModule.TestBitwiseAndNativeIntWarn;
procedure TTestModule.TestBitwiseShlNativeIntWarn;
begin
StartProgram(false);
Add([
'var',
' i,j: nativeint;',
' i: nativeint;',
'begin',
' i:=i and j;',
' i:=i shl 3;',
'']);
ConvertProgram;
CheckSource('TestBitwiseAndNativeIntWarn',
CheckSource('TestBitwiseShlNativeIntWarn',
LinesToStr([
'this.i = 0;',
'this.j = 0;',
'']),
LinesToStr([
'$mod.i = $mod.i & $mod.j;',
'$mod.i = $mod.i << 3;',
'']));
CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit);
CheckHint(mtWarning,nBitWiseOperationIs32Bit,sBitWiseOperationIs32Bit);
end;
procedure TTestModule.TestCurrency;
@ -11140,7 +11159,7 @@ begin
'']));
end;
procedure TTestModule.TestAdvRecord_ClassConstructor;
procedure TTestModule.TestAdvRecord_ClassConstructor_Program;
begin
StartProgram(false);
Add([
@ -11168,7 +11187,7 @@ begin
' r.x:=10;',
'']);
ConvertProgram;
CheckSource('TestAdvRecord_ClassConstructor',
CheckSource('TestAdvRecord_ClassConstructor_Program',
LinesToStr([ // statements
'rtl.recNewT($mod, "TPoint", function () {',
' this.x = 0;',
@ -11196,6 +11215,62 @@ begin
'']));
end;
procedure TTestModule.TestAdvRecord_ClassConstructor_Unit;
begin
StartUnit(false);
Add([
'interface',
'{$modeswitch AdvancedRecords}',
'type',
' TPoint = record',
' class var x: longint;',
' class procedure Fly; static;',
' class constructor Init;',
' end;',
'implementation',
'var count: word;',
'class procedure Tpoint.Fly;',
'begin',
'end;',
'class constructor tpoint.init;',
'begin',
' count:=count+1;',
' x:=3;',
' tpoint.x:=4;',
' fly;',
' tpoint.fly;',
'end;',
'']);
ConvertUnit;
CheckSource('TestAdvRecord_ClassConstructor_Unit',
LinesToStr([ // statements
'var $impl = $mod.$impl;',
'rtl.recNewT($mod, "TPoint", function () {',
' this.x = 0;',
' this.$eq = function (b) {',
' return true;',
' };',
' this.$assign = function (s) {',
' return this;',
' };',
' this.Fly = function () {',
' };',
'}, true);',
'']),
LinesToStr([ // $mod.$init
'(function () {',
' $impl.count = $impl.count + 1;',
' $mod.TPoint.x = 3;',
' $mod.TPoint.x = 4;',
' $mod.TPoint.Fly();',
' $mod.TPoint.Fly();',
'})();',
'']),
LinesToStr([ // $mod.$main
'$impl.count = 0;',
'']));
end;
procedure TTestModule.TestClass_TObjectDefaultConstructor;
begin
StartProgram(false);
@ -22819,6 +22894,84 @@ begin
'']));
end;
procedure TTestModule.TestTypeHelper_Double;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' Float = type double;',
' THelper = type helper for double',
' const NPI = 3.141592;',
' function ToStr: String;',
' end;',
'function THelper.ToStr: String;',
'begin',
'end;',
'procedure DoIt(s: string);',
'begin',
'end;',
'var f: Float;',
'begin',
' DoIt(f.toStr);',
' DoIt(f.toStr());',
' (f*f).toStr;',
' DoIt((f*f).toStr);',
'']);
ConvertProgram;
CheckSource('TestTypeHelper_Double',
LinesToStr([ // statements
'rtl.createHelper($mod, "THelper", null, function () {',
' this.NPI = 3.141592;',
' this.ToStr = function () {',
' var Result = "";',
' return Result;',
' };',
'});',
'this.DoIt = function (s) {',
'};',
'this.f = 0.0;',
'']),
LinesToStr([ // $mod.$main
'$mod.DoIt($mod.THelper.ToStr.call({',
' p: $mod,',
' get: function () {',
' return this.p.f;',
' },',
' set: function (v) {',
' this.p.f = v;',
' }',
'}));',
'$mod.DoIt($mod.THelper.ToStr.call({',
' p: $mod,',
' get: function () {',
' return this.p.f;',
' },',
' set: function (v) {',
' this.p.f = v;',
' }',
'}));',
'$mod.THelper.ToStr.call({',
' a: $mod.f * $mod.f,',
' get: function () {',
' return this.a;',
' },',
' set: function (v) {',
' rtl.raiseE("EPropReadOnly");',
' }',
'});',
'$mod.DoIt($mod.THelper.ToStr.call({',
' a: $mod.f * $mod.f,',
' get: function () {',
' return this.a;',
' },',
' set: function (v) {',
' rtl.raiseE("EPropReadOnly");',
' }',
'}));',
'']));
end;
procedure TTestModule.TestTypeHelper_StringChar;
begin
StartProgram(false);

12
packages/pastojs/tests/tcprecompile.pas
View File

@ -137,6 +137,10 @@ begin
if not CheckSrcDiff(OrigSrc,NewSrc,s) then
begin
WriteSources;
writeln('TCustomTestCLI_Precompile.CheckPrecompile OrigSrc==================');
writeln(OrigSrc);
writeln('TCustomTestCLI_Precompile.CheckPrecompile NewSrc==================');
writeln(NewSrc);
Fail('test1.js: '+s);
end;
end;
@ -392,11 +396,14 @@ begin
' constructor Create;',
' end;',
' TBird = class',
' class constructor Init;',
' class constructor InitBird;',
' end;',
''],[
'constructor TObject.Create; begin end;',
'class constructor TBird.Init; begin end;',
'class constructor TBird.InitBird;',
'begin',
' exit;',
'end;',
'']);
AddUnit('src/unit2.pp',[
'uses unit1;',
@ -598,5 +605,6 @@ end;
Initialization
RegisterTests([TTestCLI_Precompile]);
RegisterPCUFormat;
end.

445
packages/rtl-objpas/src/i386/invoke.inc Normal file
View File

@ -0,0 +1,445 @@
{%MainUnit ../inc/rtti.pp}
{
This file is part of the Free Pascal run time library.
Copyright (C) 2019 Sven Barth
member of the Free Pascal development team.
Function call manager for i386
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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.
}
{$define SYSTEM_HAS_INVOKE}
function ReturnResultInParam(aType: PTypeInfo): Boolean;
var
td: PTypeData;
begin
Result := False;
if Assigned(aType) then begin
case aType^.Kind of
tkMethod,
tkSString,
tkAString,
tkUString,
tkWString,
tkInterface,
tkDynArray:
Result := True;
tkArray: begin
td := GetTypeData(aType);
Result := not (td^.ArrayData.Size in [1, 2, 4]);
end;
tkRecord: begin
td := GetTypeData(aType);
Result := not (td^.RecSize in [1, 2, 4]);
end;
tkSet: begin
td := GetTypeData(aType);
case td^.OrdType of
otUByte:
Result := not (td^.SetSize in [1, 2, 4]);
otUWord,
otULong:
Result := False;
end;
end;
end;
end;
end;
procedure InvokeKernelRegister(aCodeAddress: CodePointer; aArgs: Pointer; aArgCount: LongInt); assembler; nostackframe;
label
nostackargs;
asm
pushl %ebp
movl %esp, %ebp
pushl %edi
pushl %esi
pushl %eax
pushl %edx
cmpl $3, %ecx
jle nostackargs
{ copy arguments to stack }
subl $3, %ecx
{ allocate count (%ecx) * 4 space on stack }
movl %ecx, %eax
shll $2, %eax
sub %eax, %esp
movl %esp, %edi
lea 12(%edx), %esi
cld
rep movsd
nostackargs:
movl 8(%edx), %ecx
movl (%edx), %eax
movl 4(%edx), %edx
call -12(%ebp)
popl %ecx
movl %eax, (%ecx)
movl %edx, 4(%ecx)
popl %ecx
popl %esi
popl %edi
movl %ebp, %esp
popl %ebp
end;
resourcestring
SErrFailedToConvertArg = 'Failed to convert argument %d of type %s';
procedure SystemInvokeRegister(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
type
PBoolean16 = ^Boolean16;
PBoolean32 = ^Boolean32;
PBoolean64 = ^Boolean64;
PByteBool = ^ByteBool;
PQWordBool = ^QWordBool;
var
regstack: array of PtrUInt;
stackargs: array of SizeInt;
argcount, regidx, stackidx, stackcnt, i: LongInt;
retinparam, isstack: Boolean;
td: PTypeData;
floatres: Extended;
procedure AddRegArg(aValue: PtrUInt);
begin
if regidx < 3 then begin
regstack[regidx] := aValue;
Inc(regidx);
end else begin
if 3 + stackidx = Length(regstack) then
SetLength(regstack, Length(regstack) * 2);
regstack[3 + stackidx] := aValue;
Inc(stackidx);
end;
end;
procedure AddStackArg(aValue: PtrUInt);
begin
if 3 + stackidx = Length(regstack) then
SetLength(regstack, Length(regstack) * 2);
regstack[3 + stackidx] := aValue;
Inc(stackidx);
end;
begin
{ for the register calling convention we always have the registers EAX, EDX, ECX
and then the stack; if a parameter does not fit into a register its moved to the
next available stack slot and the next parameter gets a chance to be in a register }
retinparam := ReturnResultInParam(aResultType);
{ we allocate at least three slots for EAX, ECX and EDX }
argcount := Length(aArgs);
if retinparam then
Inc(argcount);
if argcount < 3 then
SetLength(regstack, 3)
else
SetLength(regstack, argcount);
regidx := 0;
stackidx := 0;
SetLength(stackargs, Length(aArgs));
stackcnt := 0;
{ first pass: handle register parameters }
for i := 0 to High(aArgs) do begin
if regidx >= 3 then begin
{ all register locations already used up }
stackargs[stackcnt] := i;
Inc(stackcnt);
Continue;
end;
isstack := False;
if pfArray in aArgs[i].Info.ParamFlags then
AddRegArg(PtrUInt(aArgs[i].ValueRef))
else if aArgs[i].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
AddRegArg(PtrUInt(aArgs[i].ValueRef))
else begin
td := GetTypeData(aArgs[i].Info.ParamType);
case aArgs[i].Info.ParamType^.Kind of
tkSString,
tkMethod:
AddRegArg(PtrUInt(aArgs[i].ValueRef));
tkArray:
if td^.ArrayData.Size <= 4 then
isstack := True
else
AddRegArg(PtrUInt(aArgs[i].ValueRef));
tkRecord:
if td^.RecSize <= 4 then
isstack := True
else
AddRegArg(PtrUInt(aArgs[i].ValueRef));
tkObject,
tkWString,
tkUString,
tkAString,
tkDynArray,
tkClass,
tkClassRef,
tkInterface,
tkInterfaceRaw,
tkProcVar,
tkPointer:
AddRegArg(PPtrUInt(aArgs[i].ValueRef)^);
tkInt64,
tkQWord:
isstack := True;
tkSet: begin
case td^.OrdType of
otUByte: begin
case td^.SetSize of
0, 1:
AddRegArg(PByte(aArgs[i].ValueRef)^);
2:
AddRegArg(PWord(aArgs[i].ValueRef)^);
3:
AddRegArg(PtrUInt(aArgs[i].ValueRef));
4:
AddRegArg(PLongWord(aArgs[i].ValueRef)^);
else
AddRegArg(PtrUInt(aArgs[i].ValueRef));
end;
end;
otUWord:
AddRegArg(PWord(aArgs[i].ValueRef)^);
otULong:
AddRegArg(PLongWord(aArgs[i].ValueRef)^);
end;
end;
tkEnumeration,
tkInteger: begin
case td^.OrdType of
otSByte: AddRegArg(PShortInt(aArgs[i].ValueRef)^);
otUByte: AddRegArg(PByte(aArgs[i].ValueRef)^);
otSWord: AddRegArg(PSmallInt(aArgs[i].ValueRef)^);
otUWord: AddRegArg(PWord(aArgs[i].ValueRef)^);
otSLong: AddRegArg(PLongInt(aArgs[i].ValueRef)^);
otULong: AddRegArg(PLongWord(aArgs[i].ValueRef)^);
end;
end;
tkBool: begin
case td^.OrdType of
otUByte: AddRegArg(ShortInt(System.PBoolean(aArgs[i].ValueRef)^));
otUWord: AddRegArg(Byte(PBoolean16(aArgs[i].ValueRef)^));
otULong: AddRegArg(SmallInt(PBoolean32(aArgs[i].ValueRef)^));
otUQWord: isstack := True;
otSByte: AddRegArg(Word(PByteBool(aArgs[i].ValueRef)^));
otSWord: AddRegArg(LongInt(PWordBool(aArgs[i].ValueRef)^));
otSLong: AddRegArg(LongWord(PLongBool(aArgs[i].ValueRef)^));
otSQWord: isstack := True;
end;
end;
tkFloat:
{ all float types are passed in on stack }
isstack := True;
else
raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, aArgs[i].Info.ParamType^.Name]);
end;
end;
if isstack then begin
stackargs[stackcnt] := i;
Inc(stackcnt);
end;
end;
{ then add the result parameter reference (if any) }
if Assigned(aResultType) and retinparam then
AddRegArg(PtrUInt(aResultValue));
{ second pass: handle stack arguments from right to left }
if stackcnt > 0 then begin
for i := stackcnt - 1 downto 0 do begin
if pfArray in aArgs[stackargs[i]].Info.ParamFlags then
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef))
else if aArgs[stackargs[i]].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef))
else begin
td := GetTypeData(aArgs[stackargs[i]].Info.ParamType);
case aArgs[stackargs[i]].Info.ParamType^.Kind of
tkSString,
tkMethod:
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
tkArray:
if td^.ArrayData.Size <= 4 then
AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^)
else
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
tkRecord:
if td^.RecSize <= 4 then
AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^)
else
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
tkObject,
tkWString,
tkUString,
tkAString,
tkDynArray,
tkClass,
tkClassRef,
tkInterface,
tkInterfaceRaw,
tkProcVar,
tkPointer:
AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^);
tkInt64,
tkQWord: begin
AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[0]);
AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[1]);
end;
tkSet: begin
case td^.OrdType of
otUByte: begin
case td^.SetSize of
0, 1:
AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^);
2:
AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
3:
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
4:
AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
else
AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
end;
end;
otUWord:
AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
otULong:
AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
end;
end;
tkEnumeration,
tkInteger: begin
case td^.OrdType of
otSByte: AddStackArg(PShortInt(aArgs[stackargs[i]].ValueRef)^);
otUByte: AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^);
otSWord: AddStackArg(PSmallInt(aArgs[stackargs[i]].ValueRef)^);
otUWord: AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
otSLong: AddStackArg(PLongInt(aArgs[stackargs[i]].ValueRef)^);
otULong: AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
end;
end;
tkBool: begin
case td^.OrdType of
otUByte: AddStackArg(ShortInt(System.PBoolean(aArgs[stackargs[i]].ValueRef)^));
otUWord: AddStackArg(Byte(PBoolean16(aArgs[stackargs[i]].ValueRef)^));
otULong: AddStackArg(SmallInt(PBoolean32(aArgs[stackargs[i]].ValueRef)^));
otUQWord: AddStackArg(QWord(PBoolean64(aArgs[stackargs[i]].ValueRef)));
otSByte: AddStackArg(Word(PByteBool(aArgs[stackargs[i]].ValueRef)^));
otSWord: AddStackArg(LongInt(PWordBool(aArgs[stackargs[i]].ValueRef)^));
otSLong: AddStackArg(LongWord(PLongBool(aArgs[stackargs[i]].ValueRef)^));
otSQWord: AddStackArg(PtrUInt(PQWordBool(aArgs[stackargs[i]].ValueRef)));
end;
end;
tkFloat: begin
case td^.FloatType of
ftCurr : begin
AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[0]);
AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[1]);
end;
ftSingle : AddStackArg(PInt32(PSingle(aArgs[stackargs[i]].ValueRef))^);
ftDouble : begin
AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[0]);
AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[1]);
end;
ftExtended: begin
AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[0]);
AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[1]);
AddStackArg(PWord(PExtended(aArgs[stackargs[i]].ValueRef))[4]);
end;
ftComp : begin
AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[0]);
AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[1]);
end;
end;
end;
else
raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [stackargs[i], aArgs[stackargs[i]].Info.ParamType^.Name]);
end;
end;
end;
end;
InvokeKernelRegister(aCodeAddress, @regstack[0], 3 + stackidx);
if Assigned(aResultType) and not retinparam then begin
if aResultType^.Kind = tkFloat then begin
td := GetTypeData(aResultType);
asm
lea floatres, %eax
fstpt (%eax)
end ['eax'];
case td^.FloatType of
ftSingle:
PSingle(aResultValue)^ := floatres;
ftDouble:
PDouble(aResultValue)^ := floatres;
ftExtended:
PExtended(aResultValue)^ := floatres;
ftCurr:
PCurrency(aResultValue)^ := floatres / 10000;
ftComp:
PComp(aResultValue)^ := floatres;
end;
end else if aResultType^.Kind in [tkQWord, tkInt64] then
PQWord(aResultValue)^ := regstack[0] or (QWord(regstack[1]) shl 32)
else
PPtrUInt(aResultValue)^ := regstack[0];
end;
end;
procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
begin
case aCallConv of
ccReg:
SystemInvokeRegister(aCodeAddress, aArgs, aCallConv, aResultType, aResultValue, aFlags);
otherwise
Assert(False, 'Unsupported calling convention');
end;
end;
const
SystemFunctionCallManager: TFunctionCallManager = (
Invoke: @SystemInvoke;
CreateCallbackProc: Nil;
CreateCallbackMethod: Nil;
);
procedure InitSystemFunctionCallManager;
begin
SetFunctionCallManager([ccReg{, ccCdecl, ccPascal, ccStdCall}], SystemFunctionCallManager);
end;

2
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -3552,7 +3552,7 @@ begin
end;}
{$ifndef InLazIDE}
{$if defined(CPUX86_64) and defined(WIN64)}
{$if defined(CPUI386) or (defined(CPUX86_64) and defined(WIN64))}
{$I invoke.inc}
{$endif}
{$endif}

2
packages/rtl-objpas/tests/testrunner.rtlobjpas.pp
View File

@ -8,6 +8,8 @@ program testrunner.rtlobjpas;
{.$define useffi}
{$if defined(CPUX64) and defined(WINDOWS)}
{$define testinvoke}
{$elseif defined(CPUI386)}
{$define testinvoke}
{$else}
{$ifdef useffi}
{$define testinvoke}

10
packages/rtl-objpas/tests/tests.rtti.util.pas
View File

@ -37,7 +37,7 @@ function GetArray(const aArg: array of SizeInt): TValue;
implementation
uses
TypInfo, SysUtils;
TypInfo, SysUtils, Math;
{$ifndef fpc}
function TValueHelper.AsUnicodeString: UnicodeString;
@ -124,10 +124,12 @@ begin
Result := False
else begin
case td1^.FloatType of
ftSingle,
ftDouble,
ftSingle:
Result := SameValue(Single(aValue1.AsExtended), Single(aValue2.AsExtended));
ftDouble:
Result := SameValue(Double(aValue1.AsExtended), Double(aValue2.AsExtended));
ftExtended:
Result := aValue1.AsExtended = aValue2.AsExtended;
Result := SameValue(aValue1.AsExtended, aValue2.AsExtended);
ftComp:
Result := aValue1.AsInt64 = aValue2.AsInt64;
ftCurr:

8
rtl/android/cwstring.pp
View File

@ -67,19 +67,19 @@ threadvar
function MaskExceptions: dword;
begin
{$ifdef cpux86_64}
{$if defined(cpux86_64) or defined(cpui386)}
Result:=GetMXCSR;
SetMXCSR(Result or %0000000010000000 {MM_MaskInvalidOp} or %0001000000000000 {MM_MaskPrecision});
{$else}
Result:=0;
{$endif cpux86_64}
{$endif}
end;
procedure UnmaskExceptions(oldmask: dword);
begin
{$ifdef cpux86_64}
{$if defined(cpux86_64) or defined(cpui386)}
SetMXCSR(oldmask);
{$endif cpux86_64}
{$endif}
end;
function OpenConverter(const name: ansistring): PUConverter;

14
tests/webtbf/tw35149a.pp Normal file
View File

@ -0,0 +1,14 @@
{ %fail }
program project1;
{$mode objfpc}
type
TestObject = object
var
TestNested: Integer;
end;
begin
writeln(TestObject.TestNested);
end.

14
tests/webtbs/tw35149.pp Normal file
View File

@ -0,0 +1,14 @@
{ %norun }
program project1;
{$mode objfpc}
type
TestObject = object
var
TestNested: Integer;
end;
begin
writeln(SizeOf(TestObject.TestNested));
end.

24
utils/pas2js/dist/rtl.js vendored
View File

@ -1065,6 +1065,30 @@ var rtl = {
return 0;
},
and: function(a,b){
var hi = 0x80000000;
var low = 0x7fffffff;
var h = (a / hi) & (b / hi);
var l = (a & low) & (b & low);
return h*hi + l;
},
or: function(a,b){
var hi = 0x80000000;
var low = 0x7fffffff;
var h = (a / hi) | (b / hi);
var l = (a & low) | (b & low);
return h*hi + l;
},
xor: function(a,b){
var hi = 0x80000000;
var low = 0x7fffffff;
var h = (a / hi) ^ (b / hi);
var l = (a & low) ^ (b & low);
return h*hi + l;
},
initRTTI: function(){
if (rtl.debug_rtti) rtl.debug('initRTTI');

2
utils/pas2js/docs/translation.html
View File

@ -1868,7 +1868,7 @@ function(){
If there are multiple helpers for the same type, the last helper in scope wins.<br>
A class with ancestors can have one active helper per ancestor type, so
multiple helpers can be active, same as FPC/Delphi.<br>
Using <b>{$modeswitch multiplescopehelpers}</b> you can activate all helpers
Using <b>{$modeswitch multihelpers}</b> you can activate all helpers
within scope.
</li>
<li>Nested helpers (e.g. <i>TDemo.TSub.THelper</i>) are elevated.