summaryrefslogtreecommitdiff
path: root/closures/compiler/ptconst.pas
diff options
context:
space:
mode:
Diffstat (limited to 'closures/compiler/ptconst.pas')
-rw-r--r--closures/compiler/ptconst.pas1570
1 files changed, 1570 insertions, 0 deletions
diff --git a/closures/compiler/ptconst.pas b/closures/compiler/ptconst.pas
new file mode 100644
index 0000000000..51d0126472
--- /dev/null
+++ b/closures/compiler/ptconst.pas
@@ -0,0 +1,1570 @@
+{
+ 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
+ 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
+ { 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 widestring stringconstn }
+ inserttypeconv(p,cwidestringtype);
+ 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
+ message(parser_e_range_check_error);
+ if high(offset)-offset div len>v then
+ inc(offset,len*v.svalue)
+ else
+ message(parser_e_range_check_error);
+ 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
+ message(parser_e_range_check_error)
+ 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,cwidestringtype);
+ 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
+ list.concat(Tai_symbol.Createname_global(sym.mangledname,AT_DATA,0))
+ 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.
View Lorry Controller Status