mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 11:29:18 +02:00
a26bc50ca6
new ShortString->(Some)String precedence: ShortString, UTF8String, AnsiString, AnsiString(CodePage) and RawByteString, UnicodeString, WideString and other string types new AnsiString->(Some)String precedence: RawByteString, UTF8String, AnsiString, AnsiString(CodePage), UnicodeString, WideString, ShortString and other string types The new logic makes UTF8String more preferrable than other AnsiString types, AnsiString more preferrable than other AnsiStrings(codepage) and also makes UnicodeString more preferrable than WideString. git-svn-id: trunk@21057 -
1582 lines
62 KiB
ObjectPascal
1582 lines
62 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2002 by Florian Klaempfl
|
|
|
|
Reads typed constants
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit ptconst;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses symtype,symsym,aasmdata;
|
|
|
|
procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils,
|
|
globtype,systems,tokens,verbose,constexp,
|
|
cclasses,cutils,globals,widestr,scanner,
|
|
symconst,symbase,symdef,symtable,
|
|
aasmbase,aasmtai,aasmcpu,defutil,defcmp,
|
|
{ pass 1 }
|
|
node,htypechk,procinfo,
|
|
nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
|
|
{ parser specific stuff }
|
|
pbase,pexpr,pdecvar,
|
|
{ codegen }
|
|
cpuinfo,cgbase,dbgbase,
|
|
wpobase,asmutils
|
|
;
|
|
|
|
{$maxfpuregisters 0}
|
|
|
|
{*****************************************************************************
|
|
Bitpacked value helpers
|
|
*****************************************************************************}
|
|
|
|
type
|
|
tbitpackedval = record
|
|
curval, nextval: aword;
|
|
curbitoffset: smallint;
|
|
loadbitsize,packedbitsize: byte;
|
|
end;
|
|
|
|
|
|
procedure initbitpackval(out bp: tbitpackedval; packedbitsize: byte);
|
|
begin
|
|
bp.curval:=0;
|
|
bp.nextval:=0;
|
|
bp.curbitoffset:=0;
|
|
bp.packedbitsize:=packedbitsize;
|
|
bp.loadbitsize:=packedbitsloadsize(bp.packedbitsize)*8;
|
|
end;
|
|
|
|
|
|
{$push}
|
|
{$r-}
|
|
{$q-}
|
|
{ (values between quotes below refer to fields of bp; fields not }
|
|
{ mentioned are unused by this routine) }
|
|
{ bitpacks "value" as bitpacked value of bitsize "packedbitsize" into }
|
|
{ "curval", which has already been filled up to "curbitoffset", and }
|
|
{ stores the spillover if any into "nextval". It also updates }
|
|
{ curbitoffset to reflect how many bits of currval are now used (can be }
|
|
{ > AIntBits in case of spillover) }
|
|
procedure bitpackval(value: aword; var bp: tbitpackedval);
|
|
var
|
|
shiftcount: longint;
|
|
begin
|
|
if (target_info.endian=endian_big) then
|
|
begin
|
|
{ bitpacked format: left-aligned (i.e., "big endian bitness") }
|
|
bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
|
|
shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
|
|
{ carry-over to the next element? }
|
|
if (shiftcount<0) then
|
|
bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
|
|
(AIntBits+shiftcount)
|
|
end
|
|
else
|
|
begin
|
|
{ bitpacked format: right aligned (i.e., "little endian bitness") }
|
|
bp.curval:=bp.curval or (value shl bp.curbitoffset);
|
|
{ carry-over to the next element? }
|
|
if (bp.curbitoffset+bp.packedbitsize>AIntBits) then
|
|
bp.nextval:=value shr (AIntBits-bp.curbitoffset)
|
|
end;
|
|
inc(bp.curbitoffset,bp.packedbitsize);
|
|
end;
|
|
|
|
{$pop}
|
|
|
|
procedure flush_packed_value(list: tasmlist; var bp: tbitpackedval);
|
|
var
|
|
bitstowrite: longint;
|
|
writeval : byte;
|
|
begin
|
|
if (bp.curbitoffset < AIntBits) then
|
|
begin
|
|
{ forced flush -> write multiple of loadsize }
|
|
bitstowrite:=align(bp.curbitoffset,bp.loadbitsize);
|
|
bp.curbitoffset:=0;
|
|
end
|
|
else
|
|
begin
|
|
bitstowrite:=AIntBits;
|
|
dec(bp.curbitoffset,AIntBits);
|
|
end;
|
|
while (bitstowrite>=8) do
|
|
begin
|
|
if (target_info.endian=endian_little) then
|
|
begin
|
|
{ write lowest byte }
|
|
writeval:=byte(bp.curval);
|
|
bp.curval:=bp.curval shr 8;
|
|
end
|
|
else
|
|
begin
|
|
{ write highest byte }
|
|
writeval:=bp.curval shr (AIntBits-8);
|
|
bp.curval:=(bp.curval and (not($ff shl (AIntBits-8)))) shl 8;
|
|
end;
|
|
list.concat(tai_const.create_8bit(writeval));
|
|
dec(bitstowrite,8);
|
|
end;
|
|
bp.curval:=bp.nextval;
|
|
bp.nextval:=0;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
read typed const
|
|
*****************************************************************************}
|
|
|
|
type
|
|
{ context used for parsing complex types (arrays/records/objects) }
|
|
threc = record
|
|
list : tasmlist;
|
|
origsym: tstaticvarsym;
|
|
offset: asizeint;
|
|
origblock: tblock_type;
|
|
end;
|
|
|
|
{ this procedure reads typed constants }
|
|
procedure read_typed_const_data(var hr:threc;def:tdef); forward;
|
|
|
|
procedure parse_orddef(list:tasmlist;def:torddef);
|
|
var
|
|
n : tnode;
|
|
intvalue : tconstexprint;
|
|
|
|
procedure do_error;
|
|
begin
|
|
if is_constnode(n) then
|
|
IncompatibleTypes(n.resultdef, def)
|
|
else
|
|
if not(parse_generic) then
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
{ for C-style booleans, true=-1 and false=0) }
|
|
if is_cbool(def) then
|
|
inserttypeconv(n,def);
|
|
case def.ordtype of
|
|
pasbool8,
|
|
bool8bit :
|
|
begin
|
|
if is_constboolnode(n) then
|
|
list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
pasbool16,
|
|
bool16bit :
|
|
begin
|
|
if is_constboolnode(n) then
|
|
list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
pasbool32,
|
|
bool32bit :
|
|
begin
|
|
if is_constboolnode(n) then
|
|
list.concat(Tai_const.Create_32bit(longint(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
pasbool64,
|
|
bool64bit :
|
|
begin
|
|
if is_constboolnode(n) then
|
|
list.concat(Tai_const.Create_64bit(int64(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
uchar :
|
|
begin
|
|
if is_constwidecharnode(n) then
|
|
inserttypeconv(n,cchartype);
|
|
if is_constcharnode(n) or
|
|
((m_delphi in current_settings.modeswitches) and
|
|
is_constwidecharnode(n) and
|
|
(tordconstnode(n).value <= 255)) then
|
|
list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
uwidechar :
|
|
begin
|
|
if is_constcharnode(n) then
|
|
inserttypeconv(n,cwidechartype);
|
|
if is_constwidecharnode(n) then
|
|
list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)))
|
|
else
|
|
do_error;
|
|
end;
|
|
s8bit,u8bit,
|
|
u16bit,s16bit,
|
|
s32bit,u32bit,
|
|
s64bit,u64bit :
|
|
begin
|
|
if is_constintnode(n) then
|
|
begin
|
|
testrange(def,tordconstnode(n).value,false,false);
|
|
case def.size of
|
|
1 :
|
|
list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)));
|
|
2 :
|
|
list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)));
|
|
4 :
|
|
list.concat(Tai_const.Create_32bit(longint(tordconstnode(n).value.svalue)));
|
|
8 :
|
|
list.concat(Tai_const.Create_64bit(tordconstnode(n).value.svalue));
|
|
end;
|
|
end
|
|
else
|
|
do_error;
|
|
end;
|
|
scurrency:
|
|
begin
|
|
if is_constintnode(n) then
|
|
intvalue:=tordconstnode(n).value*10000
|
|
{ allow bootstrapping }
|
|
else if is_constrealnode(n) then
|
|
intvalue:=PInt64(@trealconstnode(n).value_currency)^
|
|
else
|
|
begin
|
|
intvalue:=0;
|
|
IncompatibleTypes(n.resultdef, def);
|
|
end;
|
|
list.concat(Tai_const.Create_64bit(intvalue));
|
|
end;
|
|
else
|
|
internalerror(200611052);
|
|
end;
|
|
n.free;
|
|
end;
|
|
|
|
procedure parse_floatdef(list:tasmlist;def:tfloatdef);
|
|
var
|
|
n : tnode;
|
|
value : bestreal;
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
if is_constrealnode(n) then
|
|
value:=trealconstnode(n).value_real
|
|
else if is_constintnode(n) then
|
|
value:=tordconstnode(n).value
|
|
else if is_constnode(n) then
|
|
IncompatibleTypes(n.resultdef, def)
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
|
|
case def.floattype of
|
|
s32real :
|
|
list.concat(Tai_real_32bit.Create(ts32real(value)));
|
|
s64real :
|
|
{$ifdef ARM}
|
|
if is_double_hilo_swapped then
|
|
list.concat(Tai_real_64bit.Create_hiloswapped(ts64real(value)))
|
|
else
|
|
{$endif ARM}
|
|
list.concat(Tai_real_64bit.Create(ts64real(value)));
|
|
s80real :
|
|
list.concat(Tai_real_80bit.Create(value,s80floattype.size));
|
|
sc80real :
|
|
list.concat(Tai_real_80bit.Create(value,sc80floattype.size));
|
|
s64comp :
|
|
{ the round is necessary for native compilers where comp isn't a float }
|
|
list.concat(Tai_comp_64bit.Create(round(value)));
|
|
s64currency:
|
|
list.concat(Tai_comp_64bit.Create(round(value*10000)));
|
|
s128real:
|
|
list.concat(Tai_real_128bit.Create(value));
|
|
else
|
|
internalerror(200611053);
|
|
end;
|
|
n.free;
|
|
end;
|
|
|
|
procedure parse_classrefdef(list:tasmlist;def:tclassrefdef);
|
|
var
|
|
n : tnode;
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
case n.nodetype of
|
|
loadvmtaddrn:
|
|
begin
|
|
if not Tobjectdef(tclassrefdef(n.resultdef).pointeddef).is_related(tobjectdef(def.pointeddef)) then
|
|
IncompatibleTypes(n.resultdef, def);
|
|
list.concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(n.resultdef).pointeddef).vmt_mangledname)));
|
|
{ update wpo info }
|
|
if not assigned(current_procinfo) or
|
|
(po_inline in current_procinfo.procdef.procoptions) or
|
|
wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
|
|
tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type;
|
|
end;
|
|
niln:
|
|
list.concat(Tai_const.Create_sym(nil));
|
|
else if is_constnode(n) then
|
|
IncompatibleTypes(n.resultdef, def)
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
n.free;
|
|
end;
|
|
|
|
procedure parse_pointerdef(list:tasmlist;def:tpointerdef);
|
|
var
|
|
hp,p : tnode;
|
|
srsym : tsym;
|
|
pd : tprocdef;
|
|
ca : pchar;
|
|
pw : pcompilerwidestring;
|
|
i,len : longint;
|
|
base,
|
|
offset : aint;
|
|
v : Tconstexprint;
|
|
ll : tasmlabel;
|
|
varalign : shortint;
|
|
begin
|
|
p:=comp_expr(true,false);
|
|
{ remove equal typecasts for pointer/nil addresses }
|
|
if (p.nodetype=typeconvn) then
|
|
with Ttypeconvnode(p) do
|
|
if (left.nodetype in [addrn,niln]) and equal_defs(def,p.resultdef) then
|
|
begin
|
|
hp:=left;
|
|
left:=nil;
|
|
p.free;
|
|
p:=hp;
|
|
end;
|
|
{ allows horrible ofs(typeof(TButton)^) code !! }
|
|
if (p.nodetype=addrn) then
|
|
with Taddrnode(p) do
|
|
if left.nodetype=derefn then
|
|
begin
|
|
hp:=tderefnode(left).left;
|
|
tderefnode(left).left:=nil;
|
|
p.free;
|
|
p:=hp;
|
|
end;
|
|
{ const pointer ? }
|
|
if (p.nodetype = pointerconstn) then
|
|
begin
|
|
{$if sizeof(TConstPtrUInt)=8}
|
|
list.concat(Tai_const.Create_64bit(int64(tpointerconstnode(p).value)));
|
|
{$else}
|
|
{$if sizeof(TConstPtrUInt)=4}
|
|
list.concat(Tai_const.Create_32bit(longint(tpointerconstnode(p).value)));
|
|
{$else}
|
|
internalerror(200404122);
|
|
{$endif} {$endif}
|
|
end
|
|
{ nil pointer ? }
|
|
else if p.nodetype=niln then
|
|
list.concat(Tai_const.Create_sym(nil))
|
|
{ maybe pchar ? }
|
|
else
|
|
if is_char(def.pointeddef) and
|
|
(p.nodetype<>addrn) then
|
|
begin
|
|
current_asmdata.getdatalabel(ll);
|
|
list.concat(Tai_const.Create_sym(ll));
|
|
if p.nodetype=stringconstn then
|
|
varalign:=size_2_align(tstringconstnode(p).len)
|
|
else
|
|
varalign:=0;
|
|
varalign:=const_align(varalign);
|
|
new_section(current_asmdata.asmlists[al_const], sec_rodata, ll.name, varalign);
|
|
current_asmdata.asmlists[al_const].concat(Tai_label.Create(ll));
|
|
if p.nodetype=stringconstn then
|
|
begin
|
|
len:=tstringconstnode(p).len;
|
|
{ For tp7 the maximum lentgh can be 255 }
|
|
if (m_tp7 in current_settings.modeswitches) and
|
|
(len>255) then
|
|
len:=255;
|
|
getmem(ca,len+2);
|
|
move(tstringconstnode(p).value_str^,ca^,len+1);
|
|
current_asmdata.asmlists[al_const].concat(Tai_string.Create_pchar(ca,len+1));
|
|
end
|
|
else
|
|
if is_constcharnode(p) then
|
|
current_asmdata.asmlists[al_const].concat(Tai_string.Create(char(byte(tordconstnode(p).value.svalue))+#0))
|
|
else
|
|
IncompatibleTypes(p.resultdef, def);
|
|
end
|
|
{ maybe pwidechar ? }
|
|
else
|
|
if is_widechar(def.pointeddef) and
|
|
(p.nodetype<>addrn) then
|
|
begin
|
|
current_asmdata.getdatalabel(ll);
|
|
list.concat(Tai_const.Create_sym(ll));
|
|
current_asmdata.asmlists[al_typedconsts].concat(tai_align.create(const_align(sizeof(pint))));
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(ll));
|
|
if (p.nodetype in [stringconstn,ordconstn]) then
|
|
begin
|
|
{ convert to unicodestring stringconstn }
|
|
inserttypeconv(p,cunicodestringtype);
|
|
if (p.nodetype=stringconstn) and
|
|
(tstringconstnode(p).cst_type in [cst_widestring,cst_unicodestring]) then
|
|
begin
|
|
pw:=pcompilerwidestring(tstringconstnode(p).value_str);
|
|
for i:=0 to tstringconstnode(p).len-1 do
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(pw^.data[i]));
|
|
{ ending #0 }
|
|
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(0))
|
|
end;
|
|
end
|
|
else
|
|
IncompatibleTypes(p.resultdef, def);
|
|
end
|
|
else
|
|
if (p.nodetype=addrn) or
|
|
is_proc2procvar_load(p,pd) then
|
|
begin
|
|
{ insert typeconv }
|
|
inserttypeconv(p,def);
|
|
hp:=p;
|
|
while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
|
|
hp:=tunarynode(hp).left;
|
|
if (hp.nodetype=loadn) then
|
|
begin
|
|
hp:=p;
|
|
offset:=0;
|
|
while assigned(hp) and (hp.nodetype<>loadn) do
|
|
begin
|
|
case hp.nodetype of
|
|
vecn :
|
|
begin
|
|
case tvecnode(hp).left.resultdef.typ of
|
|
stringdef :
|
|
begin
|
|
{ this seems OK for shortstring and ansistrings PM }
|
|
{ it is wrong for widestrings !! }
|
|
len:=1;
|
|
base:=0;
|
|
end;
|
|
arraydef :
|
|
begin
|
|
if not is_packed_array(tvecnode(hp).left.resultdef) then
|
|
begin
|
|
len:=tarraydef(tvecnode(hp).left.resultdef).elesize;
|
|
base:=tarraydef(tvecnode(hp).left.resultdef).lowrange;
|
|
end
|
|
else
|
|
begin
|
|
Message(parser_e_packed_dynamic_open_array);
|
|
len:=1;
|
|
base:=0;
|
|
end;
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
if is_constintnode(tvecnode(hp).right) then
|
|
begin
|
|
{Prevent overflow.}
|
|
v:=get_ordinal_value(tvecnode(hp).right)-base;
|
|
if (v<int64(low(offset))) or (v>int64(high(offset))) then
|
|
message3(type_e_range_check_error_bounds,tostr(v),tostr(low(offset)),tostr(high(offset)));
|
|
if high(offset)-offset div len>v then
|
|
inc(offset,len*v.svalue)
|
|
else
|
|
message3(type_e_range_check_error_bounds,tostr(v),'0',tostr(high(offset)-offset div len))
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
subscriptn :
|
|
inc(offset,tsubscriptnode(hp).vs.fieldoffset);
|
|
typeconvn :
|
|
begin
|
|
if not(ttypeconvnode(hp).convtype in [tc_equal,tc_proc_2_procvar]) then
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
addrn :
|
|
;
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
hp:=tunarynode(hp).left;
|
|
end;
|
|
srsym:=tloadnode(hp).symtableentry;
|
|
case srsym.typ of
|
|
procsym :
|
|
begin
|
|
pd:=tprocdef(tprocsym(srsym).ProcdefList[0]);
|
|
if Tprocsym(srsym).ProcdefList.Count>1 then
|
|
Message(parser_e_no_overloaded_procvars);
|
|
if po_abstractmethod in pd.procoptions then
|
|
Message(type_e_cant_take_address_of_abstract_method)
|
|
else
|
|
list.concat(Tai_const.Createname(pd.mangledname,offset));
|
|
end;
|
|
staticvarsym :
|
|
list.concat(Tai_const.Createname(tstaticvarsym(srsym).mangledname,offset));
|
|
labelsym :
|
|
list.concat(Tai_const.Createname(tlabelsym(srsym).mangledname,offset));
|
|
constsym :
|
|
if tconstsym(srsym).consttyp=constresourcestring then
|
|
list.concat(Tai_const.Createname(make_mangledname('RESSTR',tconstsym(srsym).owner,tconstsym(srsym).name),sizeof(pint)))
|
|
else
|
|
Message(type_e_variable_id_expected);
|
|
else
|
|
Message(type_e_variable_id_expected);
|
|
end;
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end
|
|
else
|
|
{ allow typeof(Object type)}
|
|
if (p.nodetype=inlinen) and
|
|
(tinlinenode(p).inlinenumber=in_typeof_x) then
|
|
begin
|
|
if (tinlinenode(p).left.nodetype=typen) then
|
|
begin
|
|
list.concat(Tai_const.createname(
|
|
tobjectdef(tinlinenode(p).left.resultdef).vmt_mangledname,0));
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
p.free;
|
|
end;
|
|
|
|
procedure parse_setdef(list:tasmlist;def:tsetdef);
|
|
type
|
|
setbytes = array[0..31] of byte;
|
|
Psetbytes = ^setbytes;
|
|
var
|
|
p : tnode;
|
|
i : longint;
|
|
begin
|
|
p:=comp_expr(true,false);
|
|
if p.nodetype=setconstn then
|
|
begin
|
|
{ be sure to convert to the correct result, else
|
|
it can generate smallset data instead of normalset (PFV) }
|
|
inserttypeconv(p,def);
|
|
{ we only allow const sets }
|
|
if (p.nodetype<>setconstn) or
|
|
assigned(tsetconstnode(p).left) then
|
|
Message(parser_e_illegal_expression)
|
|
else
|
|
begin
|
|
tsetconstnode(p).adjustforsetbase;
|
|
{ this writing is endian-dependant }
|
|
if source_info.endian = target_info.endian then
|
|
begin
|
|
for i:=0 to p.resultdef.size-1 do
|
|
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[i]));
|
|
end
|
|
else
|
|
begin
|
|
for i:=0 to p.resultdef.size-1 do
|
|
list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(p).value_set)^[i])));
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
p.free;
|
|
end;
|
|
|
|
procedure parse_enumdef(list:tasmlist;def:tenumdef);
|
|
var
|
|
p : tnode;
|
|
begin
|
|
p:=comp_expr(true,false);
|
|
if p.nodetype=ordconstn then
|
|
begin
|
|
if equal_defs(p.resultdef,def) or
|
|
is_subequal(p.resultdef,def) then
|
|
begin
|
|
case longint(p.resultdef.size) of
|
|
1 : list.concat(Tai_const.Create_8bit(Byte(tordconstnode(p).value.svalue)));
|
|
2 : list.concat(Tai_const.Create_16bit(Word(tordconstnode(p).value.svalue)));
|
|
4 : list.concat(Tai_const.Create_32bit(Longint(tordconstnode(p).value.svalue)));
|
|
end;
|
|
end
|
|
else
|
|
IncompatibleTypes(p.resultdef,def);
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
p.free;
|
|
end;
|
|
|
|
|
|
procedure parse_stringdef(const hr:threc;def:tstringdef);
|
|
var
|
|
n : tnode;
|
|
strlength : aint;
|
|
strval : pchar;
|
|
strch : char;
|
|
ll : tasmlabel;
|
|
ca : pchar;
|
|
winlike : boolean;
|
|
hsym : tconstsym;
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
{ load strval and strlength of the constant tree }
|
|
if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) or
|
|
((n.nodetype=typen) and is_interfacecorba(ttypenode(n).typedef)) then
|
|
begin
|
|
{ convert to the expected string type so that
|
|
for widestrings strval is a pcompilerwidestring }
|
|
inserttypeconv(n,def);
|
|
if (not codegenerror) and
|
|
(n.nodetype=stringconstn) then
|
|
begin
|
|
strlength:=tstringconstnode(n).len;
|
|
strval:=tstringconstnode(n).value_str;
|
|
end
|
|
else
|
|
begin
|
|
{ an error occurred trying to convert the result to a string }
|
|
strlength:=-1;
|
|
{ it's possible that the type conversion could not be
|
|
evaluated at compile-time }
|
|
if not codegenerror then
|
|
CGMessage(parser_e_widestring_to_ansi_compile_time);
|
|
end;
|
|
end
|
|
else if is_constcharnode(n) then
|
|
begin
|
|
{ strval:=pchar(@tordconstnode(n).value);
|
|
THIS FAIL on BIG_ENDIAN MACHINES PM }
|
|
strch:=chr(tordconstnode(n).value.svalue and $ff);
|
|
strval:=@strch;
|
|
strlength:=1
|
|
end
|
|
else if is_constresourcestringnode(n) then
|
|
begin
|
|
hsym:=tconstsym(tloadnode(n).symtableentry);
|
|
strval:=pchar(hsym.value.valueptr);
|
|
strlength:=hsym.value.len;
|
|
{ Delphi-compatible (mis)feature:
|
|
Link AnsiString constants to their initializing resourcestring,
|
|
enabling them to be (re)translated at runtime.
|
|
Wide/UnicodeString are currently rejected above (with incorrect error message).
|
|
ShortStrings cannot be handled unless another table is built for them;
|
|
considering this acceptable, because Delphi rejects them altogether.
|
|
}
|
|
if (not is_shortstring(def)) and
|
|
((hr.origsym.owner.symtablelevel<=main_program_level) or
|
|
(hr.origblock=bt_const)) then
|
|
begin
|
|
current_asmdata.ResStrInits.Concat(
|
|
TTCInitItem.Create(hr.origsym,hr.offset,
|
|
current_asmdata.RefAsmSymbol(make_mangledname('RESSTR',hsym.owner,hsym.name)))
|
|
);
|
|
Include(hr.origsym.varoptions,vo_force_finalize);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Message(parser_e_illegal_expression);
|
|
strlength:=-1;
|
|
end;
|
|
if strlength>=0 then
|
|
begin
|
|
case def.stringtype of
|
|
st_shortstring:
|
|
begin
|
|
if strlength>=def.size then
|
|
begin
|
|
message2(parser_w_string_too_long,strpas(strval),tostr(def.size-1));
|
|
strlength:=def.size-1;
|
|
end;
|
|
hr.list.concat(Tai_const.Create_8bit(strlength));
|
|
{ this can also handle longer strings }
|
|
getmem(ca,strlength+1);
|
|
move(strval^,ca^,strlength);
|
|
ca[strlength]:=#0;
|
|
hr.list.concat(Tai_string.Create_pchar(ca,strlength));
|
|
{ fillup with spaces if size is shorter }
|
|
if def.size>strlength then
|
|
begin
|
|
getmem(ca,def.size-strlength);
|
|
{ def.size contains also the leading length, so we }
|
|
{ we have to subtract one }
|
|
fillchar(ca[0],def.size-strlength-1,' ');
|
|
ca[def.size-strlength-1]:=#0;
|
|
{ this can also handle longer strings }
|
|
hr.list.concat(Tai_string.Create_pchar(ca,def.size-strlength-1));
|
|
end;
|
|
end;
|
|
st_ansistring:
|
|
begin
|
|
{ an empty ansi string is nil! }
|
|
if (strlength=0) then
|
|
ll := nil
|
|
else
|
|
ll := emit_ansistring_const(current_asmdata.asmlists[al_const],strval,strlength,def.encoding);
|
|
hr.list.concat(Tai_const.Create_sym(ll));
|
|
end;
|
|
st_unicodestring,
|
|
st_widestring:
|
|
begin
|
|
{ an empty wide/unicode string is nil! }
|
|
if (strlength=0) then
|
|
ll := nil
|
|
else
|
|
begin
|
|
winlike := (def.stringtype=st_widestring) and (tf_winlikewidestring in target_info.flags);
|
|
ll := emit_unicodestring_const(current_asmdata.asmlists[al_const],
|
|
strval,
|
|
def.encoding,
|
|
winlike);
|
|
|
|
{ Collect Windows widestrings that need initialization at startup.
|
|
Local initialized vars are excluded because they are initialized
|
|
at function entry instead. }
|
|
if winlike and ((hr.origsym.owner.symtablelevel <= main_program_level) or
|
|
(hr.origblock=bt_const)) then
|
|
begin
|
|
current_asmdata.WideInits.Concat(
|
|
TTCInitItem.Create(hr.origsym, hr.offset, ll)
|
|
);
|
|
ll := nil;
|
|
Include(hr.origsym.varoptions, vo_force_finalize);
|
|
end;
|
|
end;
|
|
hr.list.concat(Tai_const.Create_sym(ll));
|
|
end;
|
|
else
|
|
internalerror(200107081);
|
|
end;
|
|
end;
|
|
n.free;
|
|
end;
|
|
|
|
|
|
{ parse a single constant and add it to the packed const info }
|
|
{ represented by curval etc (see explanation of bitpackval for }
|
|
{ what the different parameters mean) }
|
|
function parse_single_packed_const(list: tasmlist; def: tdef; var bp: tbitpackedval): boolean;
|
|
var
|
|
n : tnode;
|
|
begin
|
|
result:=true;
|
|
n:=comp_expr(true,false);
|
|
if (n.nodetype <> ordconstn) or
|
|
(not equal_defs(n.resultdef,def) and
|
|
not is_subequal(n.resultdef,def)) then
|
|
begin
|
|
n.free;
|
|
incompatibletypes(n.resultdef,def);
|
|
consume_all_until(_SEMICOLON);
|
|
result:=false;
|
|
exit;
|
|
end;
|
|
if (Tordconstnode(n).value<qword(low(Aword))) or (Tordconstnode(n).value>qword(high(Aword))) then
|
|
message3(type_e_range_check_error_bounds,tostr(Tordconstnode(n).value),tostr(low(Aword)),tostr(high(Aword)))
|
|
else
|
|
bitpackval(Tordconstnode(n).value.uvalue,bp);
|
|
if (bp.curbitoffset>=AIntBits) then
|
|
flush_packed_value(list,bp);
|
|
n.free;
|
|
end;
|
|
|
|
|
|
{ parses a packed array constant }
|
|
procedure parse_packed_array_def(list: tasmlist; def: tarraydef);
|
|
var
|
|
i : aint;
|
|
bp : tbitpackedval;
|
|
begin
|
|
if not(def.elementdef.typ in [orddef,enumdef]) then
|
|
internalerror(2007022010);
|
|
{ begin of the array }
|
|
consume(_LKLAMMER);
|
|
initbitpackval(bp,def.elepackedbitsize);
|
|
i:=def.lowrange;
|
|
{ can't use for-loop, fails when cross-compiling from }
|
|
{ 32 to 64 bit because i is then 64 bit }
|
|
while (i<def.highrange) do
|
|
begin
|
|
{ get next item of the packed array }
|
|
if not parse_single_packed_const(list,def.elementdef,bp) then
|
|
exit;
|
|
consume(_COMMA);
|
|
inc(i);
|
|
end;
|
|
{ final item }
|
|
if not parse_single_packed_const(list,def.elementdef,bp) then
|
|
exit;
|
|
{ flush final incomplete value if necessary }
|
|
if (bp.curbitoffset <> 0) then
|
|
flush_packed_value(list,bp);
|
|
consume(_RKLAMMER);
|
|
end;
|
|
|
|
|
|
procedure parse_arraydef(hr:threc;def:tarraydef);
|
|
var
|
|
n : tnode;
|
|
i : longint;
|
|
len : asizeint;
|
|
ch : array[0..1] of char;
|
|
ca : pbyte;
|
|
int_const: tai_const;
|
|
char_size: integer;
|
|
begin
|
|
{ dynamic array nil }
|
|
if is_dynamic_array(def) then
|
|
begin
|
|
{ Only allow nil initialization }
|
|
consume(_NIL);
|
|
hr.list.concat(Tai_const.Create_sym(nil));
|
|
end
|
|
{ packed array constant }
|
|
else if is_packed_array(def) and
|
|
((def.elepackedbitsize mod 8 <> 0) or
|
|
not ispowerof2(def.elepackedbitsize div 8,i)) then
|
|
begin
|
|
parse_packed_array_def(hr.list,def);
|
|
end
|
|
{ normal array const between brackets }
|
|
else if try_to_consume(_LKLAMMER) then
|
|
begin
|
|
hr.offset:=0;
|
|
for i:=def.lowrange to def.highrange-1 do
|
|
begin
|
|
read_typed_const_data(hr,def.elementdef);
|
|
Inc(hr.offset,def.elementdef.size);
|
|
if token=_RKLAMMER then
|
|
begin
|
|
Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
|
|
consume(_RKLAMMER);
|
|
exit;
|
|
end
|
|
else
|
|
consume(_COMMA);
|
|
end;
|
|
read_typed_const_data(hr,def.elementdef);
|
|
consume(_RKLAMMER);
|
|
end
|
|
{ if array of char then we allow also a string }
|
|
else if is_anychar(def.elementdef) then
|
|
begin
|
|
char_size:=def.elementdef.size;
|
|
n:=comp_expr(true,false);
|
|
if n.nodetype=stringconstn then
|
|
begin
|
|
len:=tstringconstnode(n).len;
|
|
case char_size of
|
|
1:
|
|
begin
|
|
if (tstringconstnode(n).cst_type in [cst_unicodestring,cst_widestring]) then
|
|
inserttypeconv(n,getansistringdef);
|
|
if n.nodetype<>stringconstn then
|
|
internalerror(2010033003);
|
|
ca:=pointer(tstringconstnode(n).value_str);
|
|
end;
|
|
2:
|
|
begin
|
|
inserttypeconv(n,cunicodestringtype);
|
|
if n.nodetype<>stringconstn then
|
|
internalerror(2010033003);
|
|
ca:=pointer(pcompilerwidestring(tstringconstnode(n).value_str)^.data)
|
|
end;
|
|
else
|
|
internalerror(2010033005);
|
|
end;
|
|
{ For tp7 the maximum lentgh can be 255 }
|
|
if (m_tp7 in current_settings.modeswitches) and
|
|
(len>255) then
|
|
len:=255;
|
|
end
|
|
else if is_constcharnode(n) then
|
|
begin
|
|
case char_size of
|
|
1:
|
|
ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
|
|
2:
|
|
begin
|
|
inserttypeconv(n,cwidechartype);
|
|
if not is_constwidecharnode(n) then
|
|
internalerror(2010033001);
|
|
widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
|
|
end;
|
|
else
|
|
internalerror(2010033002);
|
|
end;
|
|
ca:=@ch;
|
|
len:=1;
|
|
end
|
|
else if is_constwidecharnode(n) and (current_settings.sourcecodepage<>CP_UTF8) then
|
|
begin
|
|
case char_size of
|
|
1:
|
|
begin
|
|
inserttypeconv(n,cchartype);
|
|
if not is_constcharnode(n) then
|
|
internalerror(2010033001);
|
|
ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
|
|
end;
|
|
2:
|
|
widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
|
|
else
|
|
internalerror(2010033002);
|
|
end;
|
|
ca:=@ch;
|
|
len:=1;
|
|
end
|
|
else
|
|
begin
|
|
Message(parser_e_illegal_expression);
|
|
len:=0;
|
|
end;
|
|
if len>(def.highrange-def.lowrange+1) then
|
|
Message(parser_e_string_larger_array);
|
|
for i:=0 to def.highrange-def.lowrange do
|
|
begin
|
|
if i<len then
|
|
begin
|
|
case char_size of
|
|
1:
|
|
int_const:=Tai_const.Create_char(char_size,pbyte(ca)^);
|
|
2:
|
|
int_const:=Tai_const.Create_char(char_size,pword(ca)^);
|
|
else
|
|
internalerror(2010033004);
|
|
end;
|
|
inc(ca, char_size);
|
|
end
|
|
else
|
|
{Fill the remaining positions with #0.}
|
|
int_const:=Tai_const.Create_char(char_size,0);
|
|
hr.list.concat(int_const)
|
|
end;
|
|
n.free;
|
|
end
|
|
else
|
|
begin
|
|
{ we want the ( }
|
|
consume(_LKLAMMER);
|
|
end;
|
|
end;
|
|
|
|
procedure parse_procvardef(list:tasmlist;def:tprocvardef);
|
|
var
|
|
tmpn,n : tnode;
|
|
pd : tprocdef;
|
|
begin
|
|
{ Procvars and pointers are no longer compatible. }
|
|
{ under tp: =nil or =var under fpc: =nil or =@var }
|
|
if try_to_consume(_NIL) then
|
|
begin
|
|
list.concat(Tai_const.Create_sym(nil));
|
|
if not def.is_addressonly then
|
|
list.concat(Tai_const.Create_sym(nil));
|
|
exit;
|
|
end;
|
|
{ you can't assign a value other than NIL to a typed constant }
|
|
{ which is a "procedure of object", because this also requires }
|
|
{ address of an object/class instance, which is not known at }
|
|
{ compile time (JM) }
|
|
if (po_methodpointer in def.procoptions) then
|
|
Message(parser_e_no_procvarobj_const);
|
|
{ parse the rest too, so we can continue with error checking }
|
|
getprocvardef:=def;
|
|
n:=comp_expr(true,false);
|
|
getprocvardef:=nil;
|
|
if codegenerror then
|
|
begin
|
|
n.free;
|
|
exit;
|
|
end;
|
|
{ let type conversion check everything needed }
|
|
inserttypeconv(n,def);
|
|
if codegenerror then
|
|
begin
|
|
n.free;
|
|
exit;
|
|
end;
|
|
{ remove typeconvs, that will normally insert a lea
|
|
instruction which is not necessary for us }
|
|
while n.nodetype=typeconvn do
|
|
begin
|
|
tmpn:=ttypeconvnode(n).left;
|
|
ttypeconvnode(n).left:=nil;
|
|
n.free;
|
|
n:=tmpn;
|
|
end;
|
|
{ remove addrn which we also don't need here }
|
|
if n.nodetype=addrn then
|
|
begin
|
|
tmpn:=taddrnode(n).left;
|
|
taddrnode(n).left:=nil;
|
|
n.free;
|
|
n:=tmpn;
|
|
end;
|
|
{ we now need to have a loadn with a procsym }
|
|
if (n.nodetype=loadn) and
|
|
(tloadnode(n).symtableentry.typ=procsym) then
|
|
begin
|
|
pd:=tloadnode(n).procdef;
|
|
list.concat(Tai_const.createname(pd.mangledname,0));
|
|
{ nested procvar typed consts can only be initialised with nil
|
|
(checked above) or with a global procedure (checked here),
|
|
because in other cases we need a valid frame pointer }
|
|
if is_nested_pd(def) then
|
|
begin
|
|
if is_nested_pd(pd) then
|
|
Message(parser_e_no_procvarnested_const);
|
|
list.concat(Tai_const.Create_sym(nil));
|
|
end
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
n.free;
|
|
end;
|
|
|
|
procedure parse_recorddef(hr:threc;def:trecorddef);
|
|
var
|
|
n : tnode;
|
|
symidx : longint;
|
|
recsym,
|
|
srsym : tsym;
|
|
hs : string;
|
|
sorg,s : TIDString;
|
|
tmpguid : tguid;
|
|
curroffset,
|
|
fillbytes : aint;
|
|
bp : tbitpackedval;
|
|
error,
|
|
is_packed: boolean;
|
|
startoffset: aint;
|
|
|
|
procedure handle_stringconstn;
|
|
var
|
|
i : longint;
|
|
begin
|
|
hs:=strpas(tstringconstnode(n).value_str);
|
|
if string2guid(hs,tmpguid) then
|
|
begin
|
|
hr.list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
|
|
hr.list.concat(Tai_const.Create_16bit(tmpguid.D2));
|
|
hr.list.concat(Tai_const.Create_16bit(tmpguid.D3));
|
|
for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
|
|
hr.list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
|
|
end
|
|
else
|
|
Message(parser_e_improper_guid_syntax);
|
|
end;
|
|
|
|
function get_next_varsym(const SymList:TFPHashObjectList; var symidx:longint):tsym;inline;
|
|
begin
|
|
while symidx<SymList.Count do
|
|
begin
|
|
result:=tsym(def.symtable.SymList[symidx]);
|
|
inc(symidx);
|
|
if result.typ=fieldvarsym then
|
|
exit;
|
|
end;
|
|
result:=nil;
|
|
end;
|
|
|
|
var
|
|
i : longint;
|
|
SymList:TFPHashObjectList;
|
|
begin
|
|
{ GUID }
|
|
if (def=rec_tguid) and (token=_ID) then
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
if n.nodetype=stringconstn then
|
|
handle_stringconstn
|
|
else
|
|
begin
|
|
inserttypeconv(n,rec_tguid);
|
|
if n.nodetype=guidconstn then
|
|
begin
|
|
tmpguid:=tguidconstnode(n).value;
|
|
hr.list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
|
|
hr.list.concat(Tai_const.Create_16bit(tmpguid.D2));
|
|
hr.list.concat(Tai_const.Create_16bit(tmpguid.D3));
|
|
for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
|
|
hr.list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
|
|
end
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
n.free;
|
|
exit;
|
|
end;
|
|
if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
inserttypeconv(n,cshortstringtype);
|
|
if n.nodetype=stringconstn then
|
|
handle_stringconstn
|
|
else
|
|
Message(parser_e_illegal_expression);
|
|
n.free;
|
|
exit;
|
|
end;
|
|
{ bitpacked record? }
|
|
is_packed:=is_packed_record_or_object(def);
|
|
if (is_packed) then
|
|
begin
|
|
{ loadbitsize = 8, bitpacked records are always padded to }
|
|
{ a multiple of a byte. packedbitsize will be set separately }
|
|
{ for each field }
|
|
initbitpackval(bp,0);
|
|
bp.loadbitsize:=8;
|
|
end;
|
|
{ normal record }
|
|
consume(_LKLAMMER);
|
|
curroffset:=0;
|
|
sorg:='';
|
|
symidx:=0;
|
|
symlist:=def.symtable.SymList;
|
|
srsym:=get_next_varsym(symlist,symidx);
|
|
recsym := nil;
|
|
startoffset:=hr.offset;
|
|
while token<>_RKLAMMER do
|
|
begin
|
|
s:=pattern;
|
|
sorg:=orgpattern;
|
|
consume(_ID);
|
|
consume(_COLON);
|
|
error := false;
|
|
recsym := tsym(def.symtable.Find(s));
|
|
if not assigned(recsym) then
|
|
begin
|
|
Message1(sym_e_illegal_field,sorg);
|
|
error := true;
|
|
end;
|
|
if (not error) and
|
|
(not assigned(srsym) or
|
|
(s <> srsym.name)) then
|
|
{ possible variant record (JM) }
|
|
begin
|
|
{ All parts of a variant start at the same offset }
|
|
{ Also allow jumping from one variant part to another, }
|
|
{ as long as the offsets match }
|
|
if (assigned(srsym) and
|
|
(tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
|
|
{ srsym is not assigned after parsing w2 in the }
|
|
{ typed const in the next example: }
|
|
{ type tr = record case byte of }
|
|
{ 1: (l1,l2: dword); }
|
|
{ 2: (w1,w2: word); }
|
|
{ end; }
|
|
{ const r: tr = (w1:1;w2:1;l2:5); }
|
|
(tfieldvarsym(recsym).fieldoffset = curroffset) then
|
|
begin
|
|
srsym:=recsym;
|
|
{ symidx should contain the next symbol id to search }
|
|
symidx:=SymList.indexof(srsym)+1;
|
|
end
|
|
{ going backwards isn't allowed in any mode }
|
|
else if (tfieldvarsym(recsym).fieldoffset<curroffset) then
|
|
begin
|
|
Message(parser_e_invalid_record_const);
|
|
error := true;
|
|
end
|
|
{ Delphi allows you to skip fields }
|
|
else if (m_delphi in current_settings.modeswitches) then
|
|
begin
|
|
Message1(parser_w_skipped_fields_before,sorg);
|
|
srsym := recsym;
|
|
end
|
|
{ FPC and TP don't }
|
|
else
|
|
begin
|
|
Message1(parser_e_skipped_fields_before,sorg);
|
|
error := true;
|
|
end;
|
|
end;
|
|
if error then
|
|
consume_all_until(_SEMICOLON)
|
|
else
|
|
begin
|
|
{ if needed fill (alignment) }
|
|
if tfieldvarsym(srsym).fieldoffset>curroffset then
|
|
begin
|
|
if not(is_packed) then
|
|
fillbytes:=tfieldvarsym(srsym).fieldoffset-curroffset
|
|
else
|
|
begin
|
|
flush_packed_value(hr.list,bp);
|
|
{ curoffset is now aligned to the next byte }
|
|
curroffset:=align(curroffset,8);
|
|
{ offsets are in bits in this case }
|
|
fillbytes:=(tfieldvarsym(srsym).fieldoffset-curroffset) div 8;
|
|
end;
|
|
for i:=1 to fillbytes do
|
|
hr.list.concat(Tai_const.Create_8bit(0))
|
|
end;
|
|
|
|
{ new position }
|
|
curroffset:=tfieldvarsym(srsym).fieldoffset;
|
|
if not(is_packed) then
|
|
inc(curroffset,tfieldvarsym(srsym).vardef.size)
|
|
else
|
|
inc(curroffset,tfieldvarsym(srsym).vardef.packedbitsize);
|
|
|
|
{ read the data }
|
|
if not(is_packed) or
|
|
{ only orddefs and enumdefs are bitpacked, as in gcc/gpc }
|
|
not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
|
|
begin
|
|
if is_packed then
|
|
begin
|
|
flush_packed_value(hr.list,bp);
|
|
curroffset:=align(curroffset,8);
|
|
end;
|
|
hr.offset:=startoffset+tfieldvarsym(srsym).fieldoffset;
|
|
read_typed_const_data(hr,tfieldvarsym(srsym).vardef);
|
|
end
|
|
else
|
|
begin
|
|
bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
|
|
parse_single_packed_const(hr.list,tfieldvarsym(srsym).vardef,bp);
|
|
end;
|
|
|
|
{ keep previous field for checking whether whole }
|
|
{ record was initialized (JM) }
|
|
recsym := srsym;
|
|
{ goto next field }
|
|
srsym:=get_next_varsym(SymList,symidx);
|
|
if token=_SEMICOLON then
|
|
consume(_SEMICOLON)
|
|
else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
|
|
consume(_COMMA)
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
{ are there any fields left, but don't complain if there only
|
|
come other variant parts after the last initialized field }
|
|
if assigned(srsym) and
|
|
(
|
|
(recsym=nil) or
|
|
(tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
|
|
) then
|
|
Message1(parser_w_skipped_fields_after,sorg);
|
|
|
|
if not(is_packed) then
|
|
fillbytes:=def.size-curroffset
|
|
else
|
|
begin
|
|
flush_packed_value(hr.list,bp);
|
|
curroffset:=align(curroffset,8);
|
|
fillbytes:=def.size-(curroffset div 8);
|
|
end;
|
|
for i:=1 to fillbytes do
|
|
hr.list.concat(Tai_const.Create_8bit(0));
|
|
|
|
consume(_RKLAMMER);
|
|
end;
|
|
|
|
{ note: hr is passed by value }
|
|
procedure parse_objectdef(hr:threc;def:tobjectdef);
|
|
var
|
|
n : tnode;
|
|
i : longint;
|
|
obj : tobjectdef;
|
|
srsym : tsym;
|
|
st : tsymtable;
|
|
curroffset : aint;
|
|
s,sorg : TIDString;
|
|
vmtwritten : boolean;
|
|
startoffset:aint;
|
|
begin
|
|
{ no support for packed object }
|
|
if is_packed_record_or_object(def) then
|
|
begin
|
|
Message(type_e_no_const_packed_record);
|
|
exit;
|
|
end;
|
|
|
|
{ only allow nil for implicit pointer object types }
|
|
if is_implicit_pointer_object_type(def) then
|
|
begin
|
|
n:=comp_expr(true,false);
|
|
if n.nodetype<>niln then
|
|
begin
|
|
Message(parser_e_type_const_not_possible);
|
|
consume_all_until(_SEMICOLON);
|
|
end
|
|
else
|
|
hr.list.concat(Tai_const.Create_sym(nil));
|
|
n.free;
|
|
exit;
|
|
end;
|
|
|
|
{ for objects we allow it only if it doesn't contain a vmt }
|
|
if (oo_has_vmt in def.objectoptions) and
|
|
(m_fpc in current_settings.modeswitches) then
|
|
begin
|
|
Message(parser_e_type_object_constants);
|
|
exit;
|
|
end;
|
|
|
|
consume(_LKLAMMER);
|
|
startoffset:=hr.offset;
|
|
curroffset:=0;
|
|
vmtwritten:=false;
|
|
while token<>_RKLAMMER do
|
|
begin
|
|
s:=pattern;
|
|
sorg:=orgpattern;
|
|
consume(_ID);
|
|
consume(_COLON);
|
|
srsym:=nil;
|
|
obj:=tobjectdef(def);
|
|
st:=obj.symtable;
|
|
while (srsym=nil) and assigned(st) do
|
|
begin
|
|
srsym:=tsym(st.Find(s));
|
|
if assigned(obj) then
|
|
obj:=obj.childof;
|
|
if assigned(obj) then
|
|
st:=obj.symtable
|
|
else
|
|
st:=nil;
|
|
end;
|
|
|
|
if (srsym=nil) or
|
|
(srsym.typ<>fieldvarsym) then
|
|
begin
|
|
if (srsym=nil) then
|
|
Message1(sym_e_id_not_found,sorg)
|
|
else
|
|
Message1(sym_e_illegal_field,sorg);
|
|
consume_all_until(_RKLAMMER);
|
|
break;
|
|
end
|
|
else
|
|
with tfieldvarsym(srsym) do
|
|
begin
|
|
{ check position }
|
|
if fieldoffset<curroffset then
|
|
message(parser_e_invalid_record_const);
|
|
|
|
{ check in VMT needs to be added for TP mode }
|
|
if not(vmtwritten) and
|
|
not(m_fpc in current_settings.modeswitches) and
|
|
(oo_has_vmt in def.objectoptions) and
|
|
(def.vmt_offset<fieldoffset) then
|
|
begin
|
|
for i:=1 to def.vmt_offset-curroffset do
|
|
hr.list.concat(tai_const.create_8bit(0));
|
|
hr.list.concat(tai_const.createname(def.vmt_mangledname,0));
|
|
{ this is more general }
|
|
curroffset:=def.vmt_offset + sizeof(pint);
|
|
vmtwritten:=true;
|
|
end;
|
|
|
|
{ if needed fill }
|
|
if fieldoffset>curroffset then
|
|
for i:=1 to fieldoffset-curroffset do
|
|
hr.list.concat(Tai_const.Create_8bit(0));
|
|
|
|
{ new position }
|
|
curroffset:=fieldoffset+vardef.size;
|
|
|
|
{ read the data }
|
|
hr.offset:=startoffset+fieldoffset;
|
|
read_typed_const_data(hr,vardef);
|
|
|
|
if not try_to_consume(_SEMICOLON) then
|
|
break;
|
|
end;
|
|
end;
|
|
if not(m_fpc in current_settings.modeswitches) and
|
|
(oo_has_vmt in def.objectoptions) and
|
|
(def.vmt_offset>=curroffset) then
|
|
begin
|
|
for i:=1 to def.vmt_offset-curroffset do
|
|
hr.list.concat(tai_const.create_8bit(0));
|
|
hr.list.concat(tai_const.createname(def.vmt_mangledname,0));
|
|
{ this is more general }
|
|
curroffset:=def.vmt_offset + sizeof(pint);
|
|
end;
|
|
for i:=1 to def.size-curroffset do
|
|
hr.list.concat(Tai_const.Create_8bit(0));
|
|
consume(_RKLAMMER);
|
|
end;
|
|
|
|
procedure read_typed_const_data(var hr:threc;def:tdef);
|
|
var
|
|
old_block_type : tblock_type;
|
|
begin
|
|
old_block_type:=block_type;
|
|
block_type:=bt_const;
|
|
case def.typ of
|
|
orddef :
|
|
parse_orddef(hr.list,torddef(def));
|
|
floatdef :
|
|
parse_floatdef(hr.list,tfloatdef(def));
|
|
classrefdef :
|
|
parse_classrefdef(hr.list,tclassrefdef(def));
|
|
pointerdef :
|
|
parse_pointerdef(hr.list,tpointerdef(def));
|
|
setdef :
|
|
parse_setdef(hr.list,tsetdef(def));
|
|
enumdef :
|
|
parse_enumdef(hr.list,tenumdef(def));
|
|
stringdef :
|
|
parse_stringdef(hr,tstringdef(def));
|
|
arraydef :
|
|
parse_arraydef(hr,tarraydef(def));
|
|
procvardef:
|
|
parse_procvardef(hr.list,tprocvardef(def));
|
|
recorddef:
|
|
parse_recorddef(hr,trecorddef(def));
|
|
objectdef:
|
|
parse_objectdef(hr,tobjectdef(def));
|
|
errordef:
|
|
begin
|
|
{ try to consume something useful }
|
|
if token=_LKLAMMER then
|
|
consume_all_until(_RKLAMMER)
|
|
else
|
|
consume_all_until(_SEMICOLON);
|
|
end;
|
|
else
|
|
Message(parser_e_type_const_not_possible);
|
|
end;
|
|
block_type:=old_block_type;
|
|
end;
|
|
|
|
{$maxfpuregisters default}
|
|
|
|
procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
|
|
var
|
|
storefilepos : tfileposinfo;
|
|
cursectype : TAsmSectionType;
|
|
hrec : threc;
|
|
section : ansistring;
|
|
begin
|
|
{ mark the staticvarsym as typedconst }
|
|
include(sym.varoptions,vo_is_typed_const);
|
|
{ The variable has a value assigned }
|
|
sym.varstate:=vs_initialised;
|
|
{ the variable can't be placed in a register }
|
|
sym.varregable:=vr_none;
|
|
|
|
{ generate data for typed const }
|
|
storefilepos:=current_filepos;
|
|
current_filepos:=sym.fileinfo;
|
|
if sym.varspez=vs_const then
|
|
cursectype:=sec_rodata
|
|
else
|
|
cursectype:=sec_data;
|
|
maybe_new_object_file(list);
|
|
hrec.list:=tasmlist.create;
|
|
hrec.origsym:=sym;
|
|
hrec.offset:=0;
|
|
hrec.origblock:=block_type;
|
|
read_typed_const_data(hrec,sym.vardef);
|
|
|
|
{ Parse hints }
|
|
try_consume_hintdirective(sym.symoptions,sym.deprecatedmsg);
|
|
|
|
consume(_SEMICOLON);
|
|
|
|
{ parse public/external/export/... }
|
|
if not in_structure and
|
|
(
|
|
(
|
|
(token = _ID) and
|
|
(idtoken in [_EXPORT,_EXTERNAL,_WEAKEXTERNAL,_PUBLIC,_CVAR]) and
|
|
(m_cvar_support in current_settings.modeswitches)
|
|
) or
|
|
(
|
|
(m_mac in current_settings.modeswitches) and
|
|
(
|
|
(cs_external_var in current_settings.localswitches) or
|
|
(cs_externally_visible in current_settings.localswitches)
|
|
)
|
|
)
|
|
) then
|
|
read_public_and_external(sym);
|
|
|
|
{ try to parse a section directive }
|
|
if not in_structure and (target_info.system in systems_allow_section) and
|
|
(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) and
|
|
(idtoken=_SECTION) then
|
|
begin
|
|
try_consume_sectiondirective(section);
|
|
if section<>'' then
|
|
begin
|
|
if (sym.varoptions *[vo_is_external,vo_is_weak_external])<>[] then
|
|
Message(parser_e_externals_no_section);
|
|
if sym.typ<>staticvarsym then
|
|
Message(parser_e_section_no_locals);
|
|
tstaticvarsym(sym).section:=section;
|
|
include(sym.varoptions, vo_has_section);
|
|
end;
|
|
end;
|
|
|
|
{ only now add items based on the symbolname, because it may }
|
|
{ have been modified by the directives parsed above }
|
|
if vo_has_section in sym.varoptions then
|
|
new_section(list,sec_user,sym.section,const_align(sym.vardef.alignment))
|
|
else
|
|
new_section(list,cursectype,lower(sym.mangledname),const_align(sym.vardef.alignment));
|
|
if (sym.owner.symtabletype=globalsymtable) or
|
|
create_smartlink or
|
|
(assigned(current_procinfo) and
|
|
(po_inline in current_procinfo.procdef.procoptions)) or
|
|
DLLSource then
|
|
begin
|
|
{ see same code in ncgutil.insertbssdata }
|
|
if (target_dbg.id=dbg_stabx) and
|
|
(cs_debuginfo in current_settings.moduleswitches) and
|
|
not assigned(current_asmdata.GetAsmSymbol(sym.name)) then
|
|
begin
|
|
list.concat(tai_symbol.Create(current_asmdata.DefineAsmSymbol(sym.name,AB_LOCAL,AT_DATA),0));
|
|
list.concat(tai_directive.Create(asd_reference,sym.name));
|
|
end;
|
|
list.concat(Tai_symbol.Createname_global(sym.mangledname,AT_DATA,0))
|
|
end
|
|
else
|
|
list.concat(Tai_symbol.Createname(sym.mangledname,AT_DATA,0));
|
|
|
|
{ add the parsed value }
|
|
list.concatlist(hrec.list);
|
|
hrec.list.free;
|
|
list.concat(tai_symbol_end.Createname(sym.mangledname));
|
|
current_filepos:=storefilepos;
|
|
end;
|
|
|
|
end.
|