123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136 |
- {
- Copyright (c) 1998-2011 by Florian Klaempfl, Jonas Maebe
- Generates code/nodes for typed constant declarations
- 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 ngtcon;
- {$i fpcdefs.inc}
- interface
- uses
- globtype,
- aasmdata,
- node,nbas,
- symtype, symbase, symdef,symsym;
- type
- ttypedconstbuilder = class
- protected
- current_old_block_type : tblock_type;
- tcsym: tstaticvarsym;
- { this procedure reads typed constants }
- procedure read_typed_const_data(def:tdef);
- procedure parse_orddef(def: torddef);
- procedure parse_floatdef(def: tfloatdef);
- procedure parse_classrefdef(def: tclassrefdef);
- procedure parse_pointerdef(def: tpointerdef);
- procedure parse_setdef(def: tsetdef);
- procedure parse_enumdef(def: tenumdef);
- procedure parse_stringdef(def: tstringdef);
- procedure parse_arraydef(def:tarraydef);virtual;abstract;
- procedure parse_procvardef(def:tprocvardef);virtual;abstract;
- procedure parse_recorddef(def:trecorddef);virtual;abstract;
- procedure parse_objectdef(def:tobjectdef);virtual;abstract;
- procedure tc_emit_orddef(def: torddef; var node: tnode);virtual;abstract;
- procedure tc_emit_floatdef(def: tfloatdef; var node: tnode);virtual;abstract;
- procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);virtual;abstract;
- procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);virtual;abstract;
- procedure tc_emit_setdef(def: tsetdef; var node: tnode);virtual;abstract;
- procedure tc_emit_enumdef(def: tenumdef; var node: tnode);virtual;abstract;
- procedure tc_emit_stringdef(def: tstringdef; var node: tnode);virtual;abstract;
- public
- constructor create(sym: tstaticvarsym);
- end;
- ttypedconstbuilderclass = class of ttypedconstbuilder;
- { should be changed into nested type of tasmlisttypedconstbuilder when
- possible }
- tbitpackedval = record
- curval, nextval: aword;
- curbitoffset: smallint;
- loadbitsize,packedbitsize: byte;
- end;
- tasmlisttypedconstbuilder = class(ttypedconstbuilder)
- private
- curoffset: asizeint;
- function parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
- protected
- list: tasmlist;
- datalist: tasmlist;
- procedure parse_packed_array_def(def: tarraydef);
- procedure parse_arraydef(def:tarraydef);override;
- procedure parse_procvardef(def:tprocvardef);override;
- procedure parse_recorddef(def:trecorddef);override;
- procedure parse_objectdef(def:tobjectdef);override;
- procedure tc_emit_orddef(def: torddef; var node: tnode);override;
- procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
- procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
- procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
- procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
- procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
- procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
- public
- constructor create(sym: tstaticvarsym);virtual;
- procedure parse_into_asmlist(out res, data: tasmlist);
- end;
- tasmlisttypedconstbuilderclass = class of tasmlisttypedconstbuilder;
- tnodetreetypedconstbuilder = class(ttypedconstbuilder)
- protected
- resultblock: tblocknode;
- statmnt: tstatementnode;
- { when parsing a record, the base nade becomes a loadnode of the record,
- etc. }
- basenode: tnode;
- procedure parse_arraydef(def:tarraydef);override;
- procedure parse_procvardef(def:tprocvardef);override;
- procedure parse_recorddef(def:trecorddef);override;
- procedure parse_objectdef(def:tobjectdef);override;
- procedure tc_emit_orddef(def: torddef; var node: tnode);override;
- procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
- procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
- procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
- procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
- procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
- procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
- public
- constructor create(sym: tstaticvarsym; previnit: tnode);virtual;
- destructor destroy;override;
- function parse_into_nodetree: tnode;
- end;
- tnodetreetypedconstbuilderclass = class of tnodetreetypedconstbuilder;
- var
- ctypedconstbuilder: ttypedconstbuilderclass;
- implementation
- uses
- SysUtils,
- cclasses,systems,tokens,verbose,constexp,
- cutils,globals,widestr,scanner,
- symconst,symtable,
- aasmbase,aasmtai,aasmcpu,defutil,defcmp,
- { pass 1 }
- 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}
- function get_next_varsym(def: tabstractrecorddef; 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;
- {*****************************************************************************
- read typed const
- *****************************************************************************}
- procedure ttypedconstbuilder.parse_orddef(def:torddef);
- var
- n : tnode;
- begin
- n:=comp_expr(true,false);
- { for C-style booleans, true=-1 and false=0) }
- if is_cbool(def) then
- inserttypeconv(n,def);
- tc_emit_orddef(def,n);
- n.free;
- end;
- procedure ttypedconstbuilder.parse_floatdef(def:tfloatdef);
- var
- n : tnode;
- begin
- n:=comp_expr(true,false);
- tc_emit_floatdef(def,n);
- n.free;
- end;
- procedure ttypedconstbuilder.parse_classrefdef(def:tclassrefdef);
- var
- n : tnode;
- begin
- n:=comp_expr(true,false);
- case n.nodetype of
- loadvmtaddrn:
- begin
- { 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;
- end;
- tc_emit_classrefdef(def,n);
- n.free;
- end;
- procedure ttypedconstbuilder.parse_pointerdef(def:tpointerdef);
- var
- p: tnode;
- begin
- p:=comp_expr(true,false);
- tc_emit_pointerdef(def,p);
- p.free;
- end;
- procedure ttypedconstbuilder.parse_setdef(def:tsetdef);
- var
- p : tnode;
- begin
- p:=comp_expr(true,false);
- tc_emit_setdef(def,p);
- p.free;
- end;
- procedure ttypedconstbuilder.parse_enumdef(def:tenumdef);
- var
- p : tnode;
- begin
- p:=comp_expr(true,false);
- tc_emit_enumdef(def,p);
- p.free;
- end;
- procedure ttypedconstbuilder.parse_stringdef(def:tstringdef);
- var
- n : tnode;
- begin
- n:=comp_expr(true,false);
- tc_emit_stringdef(def,n);
- n.free;
- end;
- { ttypedconstbuilder }
- procedure ttypedconstbuilder.read_typed_const_data(def:tdef);
- var
- prev_old_block_type,
- old_block_type: tblock_type;
- begin
- old_block_type:=block_type;
- prev_old_block_type:=current_old_block_type;
- current_old_block_type:=old_block_type;
- block_type:=bt_const;
- case def.typ of
- orddef :
- parse_orddef(torddef(def));
- floatdef :
- parse_floatdef(tfloatdef(def));
- classrefdef :
- parse_classrefdef(tclassrefdef(def));
- pointerdef :
- parse_pointerdef(tpointerdef(def));
- setdef :
- parse_setdef(tsetdef(def));
- enumdef :
- parse_enumdef(tenumdef(def));
- stringdef :
- parse_stringdef(tstringdef(def));
- arraydef :
- parse_arraydef(tarraydef(def));
- procvardef:
- parse_procvardef(tprocvardef(def));
- recorddef:
- parse_recorddef(trecorddef(def));
- objectdef:
- parse_objectdef(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;
- current_old_block_type:=prev_old_block_type;
- end;
- constructor ttypedconstbuilder.create(sym: tstaticvarsym);
- begin
- tcsym:=sym;
- end;
- {*****************************************************************************
- Bitpacked value helpers
- *****************************************************************************}
- 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;
- { parses a packed array constant }
- procedure tasmlisttypedconstbuilder.parse_packed_array_def(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(def.elementdef,bp) then
- exit;
- consume(_COMMA);
- inc(i);
- end;
- { final item }
- if not parse_single_packed_const(def.elementdef,bp) then
- exit;
- { flush final incomplete value if necessary }
- if (bp.curbitoffset <> 0) then
- flush_packed_value(list,bp);
- consume(_RKLAMMER);
- end;
- constructor tasmlisttypedconstbuilder.create(sym: tstaticvarsym);
- begin
- inherited;
- list:=tasmlist.create;
- datalist:=tasmlist.create;
- curoffset:=0;
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
- var
- strlength : aint;
- strval : pchar;
- strch : char;
- ll : tasmlabofs;
- ca : pchar;
- winlike : boolean;
- hsym : tconstsym;
- begin
- strval:='';
- { load strval and strlength of the constant tree }
- if (node.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(node) or
- ((node.nodetype=typen) and is_interfacecorba(ttypenode(node).typedef)) then
- begin
- { convert to the expected string type so that
- for widestrings strval is a pcompilerwidestring }
- inserttypeconv(node,def);
- if (not codegenerror) and
- (node.nodetype=stringconstn) then
- begin
- strlength:=tstringconstnode(node).len;
- strval:=tstringconstnode(node).value_str;
- { the def may have changed from e.g. RawByteString to
- AnsiString(CP_ACP) }
- if node.resultdef.typ=stringdef then
- def:=tstringdef(node.resultdef)
- else
- internalerror(2014010501);
- 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(node) then
- begin
- { strval:=pchar(@tordconstnode(node).value);
- THIS FAIL on BIG_ENDIAN MACHINES PM }
- strch:=chr(tordconstnode(node).value.svalue and $ff);
- strval:=@strch;
- strlength:=1
- end
- else if is_constresourcestringnode(node) then
- begin
- hsym:=tconstsym(tloadnode(node).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
- ((tcsym.owner.symtablelevel<=main_program_level) or
- (current_old_block_type=bt_const)) then
- begin
- current_asmdata.ResStrInits.Concat(
- TTCInitItem.Create(tcsym,curoffset,
- current_asmdata.RefAsmSymbol(make_mangledname('RESSTR',hsym.owner,hsym.name),AT_DATA))
- );
- Include(tcsym.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;
- list.concat(Tai_const.Create_8bit(strlength));
- { this can also handle longer strings }
- getmem(ca,strlength+1);
- move(strval^,ca^,strlength);
- ca[strlength]:=#0;
- 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 }
- 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
- begin
- ll.lab:=nil;
- ll.ofs:=0;
- end
- else
- ll:=emit_ansistring_const(datalist,strval,strlength,def.encoding);
- list.concat(Tai_const.Create_sym_offset(ll.lab,ll.ofs));
- end;
- st_unicodestring,
- st_widestring:
- begin
- { an empty wide/unicode string is nil! }
- if (strlength=0) then
- begin
- ll.lab:=nil;
- ll.ofs:=0;
- end
- else
- begin
- winlike:=(def.stringtype=st_widestring) and (tf_winlikewidestring in target_info.flags);
- ll:=emit_unicodestring_const(datalist,
- 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
- ((tcsym.owner.symtablelevel<=main_program_level) or
- (current_old_block_type=bt_const)) then
- begin
- if ll.ofs<>0 then
- internalerror(2012051704);
- current_asmdata.WideInits.Concat(
- TTCInitItem.Create(tcsym,curoffset,ll.lab)
- );
- ll.lab:=nil;
- ll.ofs:=0;
- Include(tcsym.varoptions,vo_force_finalize);
- end;
- end;
- list.concat(Tai_const.Create_sym_offset(ll.lab,ll.ofs));
- end;
- else
- internalerror(200107081);
- end;
- end;
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
- var
- intvalue: tconstexprint;
- procedure do_error;
- begin
- if is_constnode(node) then
- IncompatibleTypes(node.resultdef, def)
- else if not(parse_generic) then
- Message(parser_e_illegal_expression);
- end;
- begin
- case def.ordtype of
- pasbool8,
- bool8bit :
- begin
- if is_constboolnode(node) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)))
- end
- else
- do_error;
- end;
- pasbool16,
- bool16bit :
- begin
- if is_constboolnode(node) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)))
- end
- else
- do_error;
- end;
- pasbool32,
- bool32bit :
- begin
- if is_constboolnode(node) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- list.concat(Tai_const.Create_32bit(longint(tordconstnode(node).value.svalue)))
- end
- else
- do_error;
- end;
- pasbool64,
- bool64bit :
- begin
- if is_constboolnode(node) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- list.concat(Tai_const.Create_64bit(int64(tordconstnode(node).value.svalue)))
- end
- else
- do_error;
- end;
- uchar :
- begin
- if is_constwidecharnode(node) then
- inserttypeconv(node,cansichartype);
- if is_constcharnode(node) or
- ((m_delphi in current_settings.modeswitches) and
- is_constwidecharnode(node) and
- (tordconstnode(node).value <= 255)) then
- list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)))
- else
- do_error;
- end;
- uwidechar :
- begin
- if is_constcharnode(node) then
- inserttypeconv(node,cwidechartype);
- if is_constwidecharnode(node) then
- list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)))
- else
- do_error;
- end;
- s8bit,u8bit,
- u16bit,s16bit,
- s32bit,u32bit,
- s64bit,u64bit :
- begin
- if is_constintnode(node) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- case def.size of
- 1 :
- list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)));
- 2 :
- list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)));
- 4 :
- list.concat(Tai_const.Create_32bit(longint(tordconstnode(node).value.svalue)));
- 8 :
- list.concat(Tai_const.Create_64bit(tordconstnode(node).value.svalue));
- end;
- end
- else
- do_error;
- end;
- scurrency:
- begin
- if is_constintnode(node) then
- intvalue:=tordconstnode(node).value*10000
- { allow bootstrapping }
- else if is_constrealnode(node) then
- intvalue:=PInt64(@trealconstnode(node).value_currency)^
- else
- begin
- intvalue:=0;
- IncompatibleTypes(node.resultdef, def);
- end;
- list.concat(Tai_const.Create_64bit(intvalue));
- end;
- else
- internalerror(200611052);
- end;
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
- var
- value : bestreal;
- begin
- value:=0.0;
- if is_constrealnode(node) then
- value:=trealconstnode(node).value_real
- else if is_constintnode(node) then
- value:=tordconstnode(node).value
- else if is_constnode(node) then
- IncompatibleTypes(node.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;
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
- begin
- case node.nodetype of
- loadvmtaddrn:
- begin
- if not def_is_related(tobjectdef(tclassrefdef(node.resultdef).pointeddef),tobjectdef(def.pointeddef)) then
- IncompatibleTypes(node.resultdef, def);
- list.concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(node.resultdef).pointeddef).vmt_mangledname,AT_DATA)));
- end;
- niln:
- list.concat(Tai_const.Create_sym(nil));
- else if is_constnode(node) then
- IncompatibleTypes(node.resultdef, def)
- else
- Message(parser_e_illegal_expression);
- end;
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
- var
- hp : tnode;
- srsym : tsym;
- pd : tprocdef;
- ca : pchar;
- pw : pcompilerwidestring;
- i,len : longint;
- base,
- offset : aint;
- v : Tconstexprint;
- ll : tasmlabel;
- varalign : shortint;
- begin
- { remove equal typecasts for pointer/nil addresses }
- if (node.nodetype=typeconvn) then
- with Ttypeconvnode(node) do
- if (left.nodetype in [addrn,niln]) and equal_defs(def,node.resultdef) then
- begin
- hp:=left;
- left:=nil;
- node.free;
- node:=hp;
- end;
- { allows horrible ofs(typeof(TButton)^) code !! }
- if (node.nodetype=addrn) then
- with Taddrnode(node) do
- if left.nodetype=derefn then
- begin
- hp:=tderefnode(left).left;
- tderefnode(left).left:=nil;
- node.free;
- node:=hp;
- end;
- { const pointer ? }
- if (node.nodetype = pointerconstn) then
- begin
- {$if sizeof(TConstPtrUInt)=8}
- list.concat(Tai_const.Create_64bit(int64(tpointerconstnode(node).value)));
- {$else}
- {$if sizeof(TConstPtrUInt)=4}
- list.concat(Tai_const.Create_32bit(longint(tpointerconstnode(node).value)));
- {$else}
- internalerror(200404122);
- {$endif} {$endif}
- end
- { nil pointer ? }
- else if node.nodetype=niln then
- list.concat(Tai_const.Create_sym(nil))
- { maybe pchar ? }
- else
- if is_char(def.pointeddef) and
- (node.nodetype<>addrn) then
- begin
- current_asmdata.getdatalabel(ll);
- list.concat(Tai_const.Create_sym(ll));
- if node.nodetype=stringconstn then
- varalign:=size_2_align(tstringconstnode(node).len)
- else
- varalign:=0;
- varalign:=const_align(varalign);
- new_section(datalist, sec_rodata, ll.name, varalign);
- datalist.concat(Tai_label.Create(ll));
- if node.nodetype=stringconstn then
- begin
- len:=tstringconstnode(node).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(node).value_str^,ca^,len+1);
- datalist.concat(Tai_string.Create_pchar(ca,len+1));
- end
- else
- if is_constcharnode(node) then
- datalist.concat(Tai_string.Create(char(byte(tordconstnode(node).value.svalue))+#0))
- else
- IncompatibleTypes(node.resultdef, def);
- end
- { maybe pwidechar ? }
- else
- if is_widechar(def.pointeddef) and
- (node.nodetype<>addrn) then
- begin
- current_asmdata.getdatalabel(ll);
- list.concat(Tai_const.Create_sym(ll));
- new_section(datalist,sec_rodata_norel,ll.name,const_align(sizeof(pint)));
- datalist.concat(Tai_label.Create(ll));
- if (node.nodetype in [stringconstn,ordconstn]) then
- begin
- { convert to unicodestring stringconstn }
- inserttypeconv(node,cunicodestringtype);
- if (node.nodetype=stringconstn) and
- (tstringconstnode(node).cst_type in [cst_widestring,cst_unicodestring]) then
- begin
- pw:=pcompilerwidestring(tstringconstnode(node).value_str);
- for i:=0 to tstringconstnode(node).len-1 do
- datalist.concat(Tai_const.Create_16bit(pw^.data[i]));
- { ending #0 }
- datalist.concat(Tai_const.Create_16bit(0))
- end;
- end
- else
- IncompatibleTypes(node.resultdef, def);
- end
- else
- if (node.nodetype=addrn) or
- is_proc2procvar_load(node,pd) then
- begin
- { insert typeconv }
- inserttypeconv(node,def);
- hp:=node;
- while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
- hp:=tunarynode(hp).left;
- if (hp.nodetype=loadn) then
- begin
- hp:=node;
- offset:=0;
- while assigned(hp) and (hp.nodetype<>loadn) do
- begin
- case hp.nodetype of
- vecn :
- begin
- len:=1;
- base:=0;
- case tvecnode(hp).left.resultdef.typ of
- stringdef :
- ;
- 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
- Message(parser_e_packed_dynamic_open_array);
- 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),AT_DATA,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 (node.nodetype=inlinen) and
- (tinlinenode(node).inlinenumber=in_typeof_x) then
- begin
- if (tinlinenode(node).left.nodetype=typen) then
- begin
- list.concat(Tai_const.createname(
- tobjectdef(tinlinenode(node).left.resultdef).vmt_mangledname,AT_DATA,0));
- end
- else
- Message(parser_e_illegal_expression);
- end
- else
- Message(parser_e_illegal_expression);
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
- type
- setbytes = array[0..31] of byte;
- Psetbytes = ^setbytes;
- var
- i: longint;
- begin
- if node.nodetype=setconstn then
- begin
- { be sure to convert to the correct result, else
- it can generate smallset data instead of normalset (PFV) }
- inserttypeconv(node,def);
- { we only allow const sets }
- if (node.nodetype<>setconstn) or
- assigned(tsetconstnode(node).left) then
- Message(parser_e_illegal_expression)
- else
- begin
- tsetconstnode(node).adjustforsetbase;
- { this writing is endian-dependant }
- if source_info.endian = target_info.endian then
- begin
- for i:=0 to node.resultdef.size-1 do
- list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(node).value_set)^[i]));
- end
- else
- begin
- for i:=0 to node.resultdef.size-1 do
- list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(node).value_set)^[i])));
- end;
- end;
- end
- else
- Message(parser_e_illegal_expression);
- end;
- procedure tasmlisttypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
- begin
- if node.nodetype=ordconstn then
- begin
- if equal_defs(node.resultdef,def) or
- is_subequal(node.resultdef,def) then
- begin
- testrange(def,tordconstnode(node).value,false,false);
- case longint(node.resultdef.size) of
- 1 : list.concat(Tai_const.Create_8bit(Byte(tordconstnode(node).value.svalue)));
- 2 : list.concat(Tai_const.Create_16bit(Word(tordconstnode(node).value.svalue)));
- 4 : list.concat(Tai_const.Create_32bit(Longint(tordconstnode(node).value.svalue)));
- end;
- end
- else
- IncompatibleTypes(node.resultdef,def);
- end
- else
- Message(parser_e_illegal_expression);
- 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 tasmlisttypedconstbuilder.parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
- var
- node: tnode;
- begin
- result:=true;
- node:=comp_expr(true,false);
- if (node.nodetype <> ordconstn) or
- (not equal_defs(node.resultdef,def) and
- not is_subequal(node.resultdef,def)) then
- begin
- incompatibletypes(node.resultdef,def);
- node.free;
- consume_all_until(_SEMICOLON);
- result:=false;
- exit;
- end;
- if (Tordconstnode(node).value<qword(low(Aword))) or (Tordconstnode(node).value>qword(high(Aword))) then
- message3(type_e_range_check_error_bounds,tostr(Tordconstnode(node).value),tostr(low(Aword)),tostr(high(Aword)))
- else
- bitpackval(Tordconstnode(node).value.uvalue,bp);
- if (bp.curbitoffset>=AIntBits) then
- flush_packed_value(list,bp);
- node.free;
- end;
- procedure tasmlisttypedconstbuilder.parse_arraydef(def:tarraydef);
- var
- n : tnode;
- i : longint;
- len : asizeint;
- ch : array[0..1] of char;
- ca : pbyte;
- int_const: tai_const;
- char_size: integer;
- oldoffset: asizeint;
- dummy : byte;
- begin
- { dynamic array nil }
- if is_dynamic_array(def) then
- begin
- { Only allow nil initialization }
- consume(_NIL);
- 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(def);
- end
- { normal array const between brackets }
- else if try_to_consume(_LKLAMMER) then
- begin
- oldoffset:=curoffset;
- curoffset:=0;
- { in case of a generic subroutine, it might be we cannot
- determine the size yet }
- if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
- begin
- while true do
- begin
- read_typed_const_data(def.elementdef);
- if token=_RKLAMMER then
- begin
- consume(_RKLAMMER);
- break;
- end
- else
- consume(_COMMA);
- end;
- end
- else
- begin
- for i:=def.lowrange to def.highrange-1 do
- begin
- read_typed_const_data(def.elementdef);
- Inc(curoffset,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(def.elementdef);
- consume(_RKLAMMER);
- end;
- curoffset:=oldoffset;
- 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,cansichartype);
- 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;
- { avoid crash later on }
- dummy:=0;
- ca:=@dummy;
- 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);
- list.concat(int_const)
- end;
- n.free;
- end
- else
- begin
- { we want the ( }
- consume(_LKLAMMER);
- end;
- end;
- procedure tasmlisttypedconstbuilder.parse_procvardef(def:tprocvardef);
- var
- tmpn,n : tnode;
- pd : tprocdef;
- havepd,
- haveblock: boolean;
- 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;
- pd:=nil;
- { we now need to have a loadn with a procsym }
- havepd:=
- (n.nodetype=loadn) and
- (tloadnode(n).symtableentry.typ=procsym);
- { or a staticvarsym representing a block }
- haveblock:=
- (n.nodetype=loadn) and
- (tloadnode(n).symtableentry.typ=staticvarsym) and
- (sp_internal in tloadnode(n).symtableentry.symoptions);
- if havepd or
- haveblock then
- begin
- if havepd then
- begin
- pd:=tloadnode(n).procdef;
- list.concat(Tai_const.createname(pd.mangledname,0));
- end
- else
- begin
- list.concat(Tai_const.Createname(tstaticvarsym(tloadnode(n).symtableentry).mangledname,0));
- end;
- { 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 haveblock or
- is_nested_pd(pd) then
- Message(parser_e_no_procvarnested_const);
- list.concat(Tai_const.Create_sym(nil));
- end
- end
- else if n.nodetype=pointerconstn then
- list.concat(Tai_const.Create_pint(tpointerconstnode(n).value))
- else
- Message(parser_e_illegal_expression);
- n.free;
- end;
- procedure tasmlisttypedconstbuilder.parse_recorddef(def:trecorddef);
- var
- n : tnode;
- symidx : longint;
- recsym,
- srsym : tsym;
- hs : string;
- sorg,s : TIDString;
- tmpguid : tguid;
- recoffset,
- 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
- list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
- list.concat(Tai_const.Create_16bit(tmpguid.D2));
- list.concat(Tai_const.Create_16bit(tmpguid.D3));
- for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
- list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
- end
- else
- Message(parser_e_improper_guid_syntax);
- 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;
- list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
- list.concat(Tai_const.Create_16bit(tmpguid.D2));
- list.concat(Tai_const.Create_16bit(tmpguid.D3));
- for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
- 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);
- recoffset:=0;
- sorg:='';
- symidx:=0;
- symlist:=def.symtable.SymList;
- srsym:=get_next_varsym(def,symlist,symidx);
- recsym := nil;
- startoffset:=curoffset;
- 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 = recoffset) 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<recoffset) 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>recoffset then
- begin
- if not(is_packed) then
- fillbytes:=tfieldvarsym(srsym).fieldoffset-recoffset
- else
- begin
- flush_packed_value(list,bp);
- { curoffset is now aligned to the next byte }
- recoffset:=align(recoffset,8);
- { offsets are in bits in this case }
- fillbytes:=(tfieldvarsym(srsym).fieldoffset-recoffset) div 8;
- end;
- for i:=1 to fillbytes do
- list.concat(Tai_const.Create_8bit(0))
- end;
- { new position }
- recoffset:=tfieldvarsym(srsym).fieldoffset;
- if not(is_packed) then
- inc(recoffset,tfieldvarsym(srsym).vardef.size)
- else
- inc(recoffset,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(list,bp);
- recoffset:=align(recoffset,8);
- end;
- curoffset:=startoffset+tfieldvarsym(srsym).fieldoffset;
- read_typed_const_data(tfieldvarsym(srsym).vardef);
- end
- else
- begin
- bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
- parse_single_packed_const(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(def,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;
- curoffset:=startoffset;
- { 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-recoffset
- else
- begin
- flush_packed_value(list,bp);
- recoffset:=align(recoffset,8);
- fillbytes:=def.size-(recoffset div 8);
- end;
- for i:=1 to fillbytes do
- list.concat(Tai_const.Create_8bit(0));
- consume(_RKLAMMER);
- end;
- procedure tasmlisttypedconstbuilder.parse_objectdef(def:tobjectdef);
- var
- n : tnode;
- i : longint;
- obj : tobjectdef;
- srsym : tsym;
- st : tsymtable;
- objoffset : 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
- 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:=curoffset;
- objoffset:=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<objoffset 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-objoffset do
- list.concat(tai_const.create_8bit(0));
- list.concat(tai_const.createname(def.vmt_mangledname,AT_DATA,0));
- { this is more general }
- objoffset:=def.vmt_offset + sizeof(pint);
- vmtwritten:=true;
- end;
- { if needed fill }
- if fieldoffset>objoffset then
- for i:=1 to fieldoffset-objoffset do
- list.concat(Tai_const.Create_8bit(0));
- { new position }
- objoffset:=fieldoffset+vardef.size;
- { read the data }
- curoffset:=startoffset+fieldoffset;
- read_typed_const_data(vardef);
- if not try_to_consume(_SEMICOLON) then
- break;
- end;
- end;
- curoffset:=startoffset;
- if not(m_fpc in current_settings.modeswitches) and
- (oo_has_vmt in def.objectoptions) and
- (def.vmt_offset>=objoffset) then
- begin
- for i:=1 to def.vmt_offset-objoffset do
- list.concat(tai_const.create_8bit(0));
- list.concat(tai_const.createname(def.vmt_mangledname,AT_DATA,0));
- { this is more general }
- objoffset:=def.vmt_offset + sizeof(pint);
- end;
- for i:=1 to def.size-objoffset do
- list.concat(Tai_const.Create_8bit(0));
- consume(_RKLAMMER);
- end;
- procedure tasmlisttypedconstbuilder.parse_into_asmlist(out res,data: tasmlist);
- begin
- read_typed_const_data(tcsym.vardef);
- res:=list;
- data:=datalist;
- end;
- { tnodetreetypedconstbuilder }
- procedure tnodetreetypedconstbuilder.parse_arraydef(def: tarraydef);
- var
- n : tnode;
- i : longint;
- orgbase: tnode;
- begin
- { dynamic array nil }
- if is_dynamic_array(def) then
- begin
- { Only allow nil initialization }
- consume(_NIL);
- addstatement(statmnt,cassignmentnode.create_internal(basenode,cnilnode.create));
- basenode:=nil;
- end
- { array const between brackets }
- else if try_to_consume(_LKLAMMER) then
- begin
- orgbase:=basenode;
- for i:=def.lowrange to def.highrange-1 do
- begin
- basenode:=cvecnode.create(orgbase.getcopy,ctypeconvnode.create_explicit(genintconstnode(i),tarraydef(def).rangedef));
- read_typed_const_data(def.elementdef);
- if token=_RKLAMMER then
- begin
- Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
- consume(_RKLAMMER);
- exit;
- end
- else
- consume(_COMMA);
- end;
- basenode:=cvecnode.create(orgbase,ctypeconvnode.create_explicit(genintconstnode(def.highrange),tarraydef(def).rangedef));
- read_typed_const_data(def.elementdef);
- consume(_RKLAMMER);
- end
- { if array of char then we allow also a string }
- else if is_anychar(def.elementdef) then
- begin
- n:=comp_expr(true,false);
- addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
- basenode:=nil;
- end
- else
- begin
- { we want the ( }
- consume(_LKLAMMER);
- end;
- end;
- procedure tnodetreetypedconstbuilder.parse_procvardef(def: tprocvardef);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,comp_expr(true,false)));
- basenode:=nil;
- end;
- procedure tnodetreetypedconstbuilder.parse_recorddef(def: trecorddef);
- var
- n,n2 : tnode;
- SymList:TFPHashObjectList;
- orgbasenode : tnode;
- symidx : longint;
- recsym,
- srsym : tsym;
- sorg,s : TIDString;
- recoffset : aint;
- error,
- is_packed: boolean;
- procedure handle_stringconstn;
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
- basenode:=nil;
- n:=nil;
- end;
- 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
- n2:=cstringconstnode.createstr(guid2string(tguidconstnode(n).value));
- n.free;
- n:=n2;
- handle_stringconstn;
- 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);
- { normal record }
- consume(_LKLAMMER);
- recoffset:=0;
- sorg:='';
- symidx:=0;
- symlist:=def.symtable.SymList;
- srsym:=get_next_varsym(def,symlist,symidx);
- recsym := nil;
- orgbasenode:=basenode;
- basenode:=nil;
- 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 = recoffset) 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<recoffset) 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
- { skipping fill bytes happens automatically, since we only
- initialize the defined fields }
- { new position }
- recoffset:=tfieldvarsym(srsym).fieldoffset;
- if not(is_packed) then
- inc(recoffset,tfieldvarsym(srsym).vardef.size)
- else
- inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
- { read the data }
- if is_packed and
- { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
- not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
- recoffset:=align(recoffset,8);
- basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
- read_typed_const_data(tfieldvarsym(srsym).vardef);
- { keep previous field for checking whether whole }
- { record was initialized (JM) }
- recsym := srsym;
- { goto next field }
- srsym:=get_next_varsym(def,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);
- orgbasenode.free;
- basenode:=nil;
- consume(_RKLAMMER);
- end;
- procedure tnodetreetypedconstbuilder.parse_objectdef(def: tobjectdef);
- var
- n,
- orgbasenode : tnode;
- obj : tobjectdef;
- srsym : tsym;
- st : tsymtable;
- objoffset : aint;
- s,sorg : TIDString;
- 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
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
- n:=nil;
- basenode:=nil;
- end;
- 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);
- objoffset:=0;
- orgbasenode:=basenode;
- basenode:=nil;
- 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<objoffset then
- message(parser_e_invalid_record_const);
- { new position }
- objoffset:=fieldoffset+vardef.size;
- { read the data }
- basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
- read_typed_const_data(vardef);
- if not try_to_consume(_SEMICOLON) then
- break;
- end;
- end;
- consume(_RKLAMMER);
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- procedure tnodetreetypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
- begin
- addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
- basenode:=nil;
- node:=nil;
- end;
- constructor tnodetreetypedconstbuilder.create(sym: tstaticvarsym; previnit: tnode);
- begin
- inherited create(sym);
- basenode:=cloadnode.create(sym,sym.owner);
- resultblock:=internalstatements(statmnt);
- if assigned(previnit) then
- addstatement(statmnt,previnit);
- end;
- destructor tnodetreetypedconstbuilder.destroy;
- begin
- freeandnil(basenode);
- freeandnil(resultblock);
- inherited destroy;
- end;
- function tnodetreetypedconstbuilder.parse_into_nodetree: tnode;
- begin
- read_typed_const_data(tcsym.vardef);
- result:=self.resultblock;
- self.resultblock:=nil;
- end;
- begin
- { default to asmlist version, best for most targets }
- ctypedconstbuilder:=tasmlisttypedconstbuilder;
- end.
|