ngtcon.pas 77 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136
  1. {
  2. Copyright (c) 1998-2011 by Florian Klaempfl, Jonas Maebe
  3. Generates code/nodes for typed constant declarations
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ngtcon;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. globtype,
  22. aasmdata,
  23. node,nbas,
  24. symtype, symbase, symdef,symsym;
  25. type
  26. ttypedconstbuilder = class
  27. protected
  28. current_old_block_type : tblock_type;
  29. tcsym: tstaticvarsym;
  30. { this procedure reads typed constants }
  31. procedure read_typed_const_data(def:tdef);
  32. procedure parse_orddef(def: torddef);
  33. procedure parse_floatdef(def: tfloatdef);
  34. procedure parse_classrefdef(def: tclassrefdef);
  35. procedure parse_pointerdef(def: tpointerdef);
  36. procedure parse_setdef(def: tsetdef);
  37. procedure parse_enumdef(def: tenumdef);
  38. procedure parse_stringdef(def: tstringdef);
  39. procedure parse_arraydef(def:tarraydef);virtual;abstract;
  40. procedure parse_procvardef(def:tprocvardef);virtual;abstract;
  41. procedure parse_recorddef(def:trecorddef);virtual;abstract;
  42. procedure parse_objectdef(def:tobjectdef);virtual;abstract;
  43. procedure tc_emit_orddef(def: torddef; var node: tnode);virtual;abstract;
  44. procedure tc_emit_floatdef(def: tfloatdef; var node: tnode);virtual;abstract;
  45. procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);virtual;abstract;
  46. procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);virtual;abstract;
  47. procedure tc_emit_setdef(def: tsetdef; var node: tnode);virtual;abstract;
  48. procedure tc_emit_enumdef(def: tenumdef; var node: tnode);virtual;abstract;
  49. procedure tc_emit_stringdef(def: tstringdef; var node: tnode);virtual;abstract;
  50. public
  51. constructor create(sym: tstaticvarsym);
  52. end;
  53. ttypedconstbuilderclass = class of ttypedconstbuilder;
  54. { should be changed into nested type of tasmlisttypedconstbuilder when
  55. possible }
  56. tbitpackedval = record
  57. curval, nextval: aword;
  58. curbitoffset: smallint;
  59. loadbitsize,packedbitsize: byte;
  60. end;
  61. tasmlisttypedconstbuilder = class(ttypedconstbuilder)
  62. private
  63. curoffset: asizeint;
  64. function parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
  65. protected
  66. list: tasmlist;
  67. datalist: tasmlist;
  68. procedure parse_packed_array_def(def: tarraydef);
  69. procedure parse_arraydef(def:tarraydef);override;
  70. procedure parse_procvardef(def:tprocvardef);override;
  71. procedure parse_recorddef(def:trecorddef);override;
  72. procedure parse_objectdef(def:tobjectdef);override;
  73. procedure tc_emit_orddef(def: torddef; var node: tnode);override;
  74. procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
  75. procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
  76. procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
  77. procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
  78. procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
  79. procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
  80. public
  81. constructor create(sym: tstaticvarsym);virtual;
  82. procedure parse_into_asmlist(out res, data: tasmlist);
  83. end;
  84. tasmlisttypedconstbuilderclass = class of tasmlisttypedconstbuilder;
  85. tnodetreetypedconstbuilder = class(ttypedconstbuilder)
  86. protected
  87. resultblock: tblocknode;
  88. statmnt: tstatementnode;
  89. { when parsing a record, the base nade becomes a loadnode of the record,
  90. etc. }
  91. basenode: tnode;
  92. procedure parse_arraydef(def:tarraydef);override;
  93. procedure parse_procvardef(def:tprocvardef);override;
  94. procedure parse_recorddef(def:trecorddef);override;
  95. procedure parse_objectdef(def:tobjectdef);override;
  96. procedure tc_emit_orddef(def: torddef; var node: tnode);override;
  97. procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
  98. procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
  99. procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
  100. procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
  101. procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
  102. procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
  103. public
  104. constructor create(sym: tstaticvarsym; previnit: tnode);virtual;
  105. destructor destroy;override;
  106. function parse_into_nodetree: tnode;
  107. end;
  108. tnodetreetypedconstbuilderclass = class of tnodetreetypedconstbuilder;
  109. var
  110. ctypedconstbuilder: ttypedconstbuilderclass;
  111. implementation
  112. uses
  113. SysUtils,
  114. cclasses,systems,tokens,verbose,constexp,
  115. cutils,globals,widestr,scanner,
  116. symconst,symtable,
  117. aasmbase,aasmtai,aasmcpu,defutil,defcmp,
  118. { pass 1 }
  119. htypechk,procinfo,
  120. nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
  121. { parser specific stuff }
  122. pbase,pexpr,pdecvar,
  123. { codegen }
  124. cpuinfo,cgbase,dbgbase,
  125. wpobase,asmutils
  126. ;
  127. {$maxfpuregisters 0}
  128. function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectList; var symidx:longint):tsym;inline;
  129. begin
  130. while symidx<SymList.Count do
  131. begin
  132. result:=tsym(def.symtable.SymList[symidx]);
  133. inc(symidx);
  134. if result.typ=fieldvarsym then
  135. exit;
  136. end;
  137. result:=nil;
  138. end;
  139. {*****************************************************************************
  140. read typed const
  141. *****************************************************************************}
  142. procedure ttypedconstbuilder.parse_orddef(def:torddef);
  143. var
  144. n : tnode;
  145. begin
  146. n:=comp_expr(true,false);
  147. { for C-style booleans, true=-1 and false=0) }
  148. if is_cbool(def) then
  149. inserttypeconv(n,def);
  150. tc_emit_orddef(def,n);
  151. n.free;
  152. end;
  153. procedure ttypedconstbuilder.parse_floatdef(def:tfloatdef);
  154. var
  155. n : tnode;
  156. begin
  157. n:=comp_expr(true,false);
  158. tc_emit_floatdef(def,n);
  159. n.free;
  160. end;
  161. procedure ttypedconstbuilder.parse_classrefdef(def:tclassrefdef);
  162. var
  163. n : tnode;
  164. begin
  165. n:=comp_expr(true,false);
  166. case n.nodetype of
  167. loadvmtaddrn:
  168. begin
  169. { update wpo info }
  170. if not assigned(current_procinfo) or
  171. (po_inline in current_procinfo.procdef.procoptions) or
  172. wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
  173. tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type;
  174. end;
  175. end;
  176. tc_emit_classrefdef(def,n);
  177. n.free;
  178. end;
  179. procedure ttypedconstbuilder.parse_pointerdef(def:tpointerdef);
  180. var
  181. p: tnode;
  182. begin
  183. p:=comp_expr(true,false);
  184. tc_emit_pointerdef(def,p);
  185. p.free;
  186. end;
  187. procedure ttypedconstbuilder.parse_setdef(def:tsetdef);
  188. var
  189. p : tnode;
  190. begin
  191. p:=comp_expr(true,false);
  192. tc_emit_setdef(def,p);
  193. p.free;
  194. end;
  195. procedure ttypedconstbuilder.parse_enumdef(def:tenumdef);
  196. var
  197. p : tnode;
  198. begin
  199. p:=comp_expr(true,false);
  200. tc_emit_enumdef(def,p);
  201. p.free;
  202. end;
  203. procedure ttypedconstbuilder.parse_stringdef(def:tstringdef);
  204. var
  205. n : tnode;
  206. begin
  207. n:=comp_expr(true,false);
  208. tc_emit_stringdef(def,n);
  209. n.free;
  210. end;
  211. { ttypedconstbuilder }
  212. procedure ttypedconstbuilder.read_typed_const_data(def:tdef);
  213. var
  214. prev_old_block_type,
  215. old_block_type: tblock_type;
  216. begin
  217. old_block_type:=block_type;
  218. prev_old_block_type:=current_old_block_type;
  219. current_old_block_type:=old_block_type;
  220. block_type:=bt_const;
  221. case def.typ of
  222. orddef :
  223. parse_orddef(torddef(def));
  224. floatdef :
  225. parse_floatdef(tfloatdef(def));
  226. classrefdef :
  227. parse_classrefdef(tclassrefdef(def));
  228. pointerdef :
  229. parse_pointerdef(tpointerdef(def));
  230. setdef :
  231. parse_setdef(tsetdef(def));
  232. enumdef :
  233. parse_enumdef(tenumdef(def));
  234. stringdef :
  235. parse_stringdef(tstringdef(def));
  236. arraydef :
  237. parse_arraydef(tarraydef(def));
  238. procvardef:
  239. parse_procvardef(tprocvardef(def));
  240. recorddef:
  241. parse_recorddef(trecorddef(def));
  242. objectdef:
  243. parse_objectdef(tobjectdef(def));
  244. errordef:
  245. begin
  246. { try to consume something useful }
  247. if token=_LKLAMMER then
  248. consume_all_until(_RKLAMMER)
  249. else
  250. consume_all_until(_SEMICOLON);
  251. end;
  252. else
  253. Message(parser_e_type_const_not_possible);
  254. end;
  255. block_type:=old_block_type;
  256. current_old_block_type:=prev_old_block_type;
  257. end;
  258. constructor ttypedconstbuilder.create(sym: tstaticvarsym);
  259. begin
  260. tcsym:=sym;
  261. end;
  262. {*****************************************************************************
  263. Bitpacked value helpers
  264. *****************************************************************************}
  265. procedure initbitpackval(out bp: tbitpackedval; packedbitsize: byte);
  266. begin
  267. bp.curval:=0;
  268. bp.nextval:=0;
  269. bp.curbitoffset:=0;
  270. bp.packedbitsize:=packedbitsize;
  271. bp.loadbitsize:=packedbitsloadsize(bp.packedbitsize)*8;
  272. end;
  273. {$push}
  274. {$r-}
  275. {$q-}
  276. { (values between quotes below refer to fields of bp; fields not }
  277. { mentioned are unused by this routine) }
  278. { bitpacks "value" as bitpacked value of bitsize "packedbitsize" into }
  279. { "curval", which has already been filled up to "curbitoffset", and }
  280. { stores the spillover if any into "nextval". It also updates }
  281. { curbitoffset to reflect how many bits of currval are now used (can be }
  282. { > AIntBits in case of spillover) }
  283. procedure bitpackval(value: aword; var bp: tbitpackedval);
  284. var
  285. shiftcount: longint;
  286. begin
  287. if (target_info.endian=endian_big) then
  288. begin
  289. { bitpacked format: left-aligned (i.e., "big endian bitness") }
  290. bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
  291. shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
  292. { carry-over to the next element? }
  293. if (shiftcount<0) then
  294. bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
  295. (AIntBits+shiftcount)
  296. end
  297. else
  298. begin
  299. { bitpacked format: right aligned (i.e., "little endian bitness") }
  300. bp.curval:=bp.curval or (value shl bp.curbitoffset);
  301. { carry-over to the next element? }
  302. if (bp.curbitoffset+bp.packedbitsize>AIntBits) then
  303. bp.nextval:=value shr (AIntBits-bp.curbitoffset)
  304. end;
  305. inc(bp.curbitoffset,bp.packedbitsize);
  306. end;
  307. {$pop}
  308. procedure flush_packed_value(list: tasmlist; var bp: tbitpackedval);
  309. var
  310. bitstowrite: longint;
  311. writeval : byte;
  312. begin
  313. if (bp.curbitoffset < AIntBits) then
  314. begin
  315. { forced flush -> write multiple of loadsize }
  316. bitstowrite:=align(bp.curbitoffset,bp.loadbitsize);
  317. bp.curbitoffset:=0;
  318. end
  319. else
  320. begin
  321. bitstowrite:=AIntBits;
  322. dec(bp.curbitoffset,AIntBits);
  323. end;
  324. while (bitstowrite>=8) do
  325. begin
  326. if (target_info.endian=endian_little) then
  327. begin
  328. { write lowest byte }
  329. writeval:=byte(bp.curval);
  330. bp.curval:=bp.curval shr 8;
  331. end
  332. else
  333. begin
  334. { write highest byte }
  335. writeval:=bp.curval shr (AIntBits-8);
  336. bp.curval:=(bp.curval and (not($ff shl (AIntBits-8)))) shl 8;
  337. end;
  338. list.concat(tai_const.create_8bit(writeval));
  339. dec(bitstowrite,8);
  340. end;
  341. bp.curval:=bp.nextval;
  342. bp.nextval:=0;
  343. end;
  344. { parses a packed array constant }
  345. procedure tasmlisttypedconstbuilder.parse_packed_array_def(def: tarraydef);
  346. var
  347. i : aint;
  348. bp : tbitpackedval;
  349. begin
  350. if not(def.elementdef.typ in [orddef,enumdef]) then
  351. internalerror(2007022010);
  352. { begin of the array }
  353. consume(_LKLAMMER);
  354. initbitpackval(bp,def.elepackedbitsize);
  355. i:=def.lowrange;
  356. { can't use for-loop, fails when cross-compiling from }
  357. { 32 to 64 bit because i is then 64 bit }
  358. while (i<def.highrange) do
  359. begin
  360. { get next item of the packed array }
  361. if not parse_single_packed_const(def.elementdef,bp) then
  362. exit;
  363. consume(_COMMA);
  364. inc(i);
  365. end;
  366. { final item }
  367. if not parse_single_packed_const(def.elementdef,bp) then
  368. exit;
  369. { flush final incomplete value if necessary }
  370. if (bp.curbitoffset <> 0) then
  371. flush_packed_value(list,bp);
  372. consume(_RKLAMMER);
  373. end;
  374. constructor tasmlisttypedconstbuilder.create(sym: tstaticvarsym);
  375. begin
  376. inherited;
  377. list:=tasmlist.create;
  378. datalist:=tasmlist.create;
  379. curoffset:=0;
  380. end;
  381. procedure tasmlisttypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
  382. var
  383. strlength : aint;
  384. strval : pchar;
  385. strch : char;
  386. ll : tasmlabofs;
  387. ca : pchar;
  388. winlike : boolean;
  389. hsym : tconstsym;
  390. begin
  391. strval:='';
  392. { load strval and strlength of the constant tree }
  393. if (node.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(node) or
  394. ((node.nodetype=typen) and is_interfacecorba(ttypenode(node).typedef)) then
  395. begin
  396. { convert to the expected string type so that
  397. for widestrings strval is a pcompilerwidestring }
  398. inserttypeconv(node,def);
  399. if (not codegenerror) and
  400. (node.nodetype=stringconstn) then
  401. begin
  402. strlength:=tstringconstnode(node).len;
  403. strval:=tstringconstnode(node).value_str;
  404. { the def may have changed from e.g. RawByteString to
  405. AnsiString(CP_ACP) }
  406. if node.resultdef.typ=stringdef then
  407. def:=tstringdef(node.resultdef)
  408. else
  409. internalerror(2014010501);
  410. end
  411. else
  412. begin
  413. { an error occurred trying to convert the result to a string }
  414. strlength:=-1;
  415. { it's possible that the type conversion could not be
  416. evaluated at compile-time }
  417. if not codegenerror then
  418. CGMessage(parser_e_widestring_to_ansi_compile_time);
  419. end;
  420. end
  421. else if is_constcharnode(node) then
  422. begin
  423. { strval:=pchar(@tordconstnode(node).value);
  424. THIS FAIL on BIG_ENDIAN MACHINES PM }
  425. strch:=chr(tordconstnode(node).value.svalue and $ff);
  426. strval:=@strch;
  427. strlength:=1
  428. end
  429. else if is_constresourcestringnode(node) then
  430. begin
  431. hsym:=tconstsym(tloadnode(node).symtableentry);
  432. strval:=pchar(hsym.value.valueptr);
  433. strlength:=hsym.value.len;
  434. { Delphi-compatible (mis)feature:
  435. Link AnsiString constants to their initializing resourcestring,
  436. enabling them to be (re)translated at runtime.
  437. Wide/UnicodeString are currently rejected above (with incorrect error message).
  438. ShortStrings cannot be handled unless another table is built for them;
  439. considering this acceptable, because Delphi rejects them altogether.
  440. }
  441. if (not is_shortstring(def)) and
  442. ((tcsym.owner.symtablelevel<=main_program_level) or
  443. (current_old_block_type=bt_const)) then
  444. begin
  445. current_asmdata.ResStrInits.Concat(
  446. TTCInitItem.Create(tcsym,curoffset,
  447. current_asmdata.RefAsmSymbol(make_mangledname('RESSTR',hsym.owner,hsym.name),AT_DATA))
  448. );
  449. Include(tcsym.varoptions,vo_force_finalize);
  450. end;
  451. end
  452. else
  453. begin
  454. Message(parser_e_illegal_expression);
  455. strlength:=-1;
  456. end;
  457. if strlength>=0 then
  458. begin
  459. case def.stringtype of
  460. st_shortstring:
  461. begin
  462. if strlength>=def.size then
  463. begin
  464. message2(parser_w_string_too_long,strpas(strval),tostr(def.size-1));
  465. strlength:=def.size-1;
  466. end;
  467. list.concat(Tai_const.Create_8bit(strlength));
  468. { this can also handle longer strings }
  469. getmem(ca,strlength+1);
  470. move(strval^,ca^,strlength);
  471. ca[strlength]:=#0;
  472. list.concat(Tai_string.Create_pchar(ca,strlength));
  473. { fillup with spaces if size is shorter }
  474. if def.size>strlength then
  475. begin
  476. getmem(ca,def.size-strlength);
  477. { def.size contains also the leading length, so we }
  478. { we have to subtract one }
  479. fillchar(ca[0],def.size-strlength-1,' ');
  480. ca[def.size-strlength-1]:=#0;
  481. { this can also handle longer strings }
  482. list.concat(Tai_string.Create_pchar(ca,def.size-strlength-1));
  483. end;
  484. end;
  485. st_ansistring:
  486. begin
  487. { an empty ansi string is nil! }
  488. if (strlength=0) then
  489. begin
  490. ll.lab:=nil;
  491. ll.ofs:=0;
  492. end
  493. else
  494. ll:=emit_ansistring_const(datalist,strval,strlength,def.encoding);
  495. list.concat(Tai_const.Create_sym_offset(ll.lab,ll.ofs));
  496. end;
  497. st_unicodestring,
  498. st_widestring:
  499. begin
  500. { an empty wide/unicode string is nil! }
  501. if (strlength=0) then
  502. begin
  503. ll.lab:=nil;
  504. ll.ofs:=0;
  505. end
  506. else
  507. begin
  508. winlike:=(def.stringtype=st_widestring) and (tf_winlikewidestring in target_info.flags);
  509. ll:=emit_unicodestring_const(datalist,
  510. strval,
  511. def.encoding,
  512. winlike);
  513. { Collect Windows widestrings that need initialization at startup.
  514. Local initialized vars are excluded because they are initialized
  515. at function entry instead. }
  516. if winlike and
  517. ((tcsym.owner.symtablelevel<=main_program_level) or
  518. (current_old_block_type=bt_const)) then
  519. begin
  520. if ll.ofs<>0 then
  521. internalerror(2012051704);
  522. current_asmdata.WideInits.Concat(
  523. TTCInitItem.Create(tcsym,curoffset,ll.lab)
  524. );
  525. ll.lab:=nil;
  526. ll.ofs:=0;
  527. Include(tcsym.varoptions,vo_force_finalize);
  528. end;
  529. end;
  530. list.concat(Tai_const.Create_sym_offset(ll.lab,ll.ofs));
  531. end;
  532. else
  533. internalerror(200107081);
  534. end;
  535. end;
  536. end;
  537. procedure tasmlisttypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
  538. var
  539. intvalue: tconstexprint;
  540. procedure do_error;
  541. begin
  542. if is_constnode(node) then
  543. IncompatibleTypes(node.resultdef, def)
  544. else if not(parse_generic) then
  545. Message(parser_e_illegal_expression);
  546. end;
  547. begin
  548. case def.ordtype of
  549. pasbool8,
  550. bool8bit :
  551. begin
  552. if is_constboolnode(node) then
  553. begin
  554. testrange(def,tordconstnode(node).value,false,false);
  555. list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)))
  556. end
  557. else
  558. do_error;
  559. end;
  560. pasbool16,
  561. bool16bit :
  562. begin
  563. if is_constboolnode(node) then
  564. begin
  565. testrange(def,tordconstnode(node).value,false,false);
  566. list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)))
  567. end
  568. else
  569. do_error;
  570. end;
  571. pasbool32,
  572. bool32bit :
  573. begin
  574. if is_constboolnode(node) then
  575. begin
  576. testrange(def,tordconstnode(node).value,false,false);
  577. list.concat(Tai_const.Create_32bit(longint(tordconstnode(node).value.svalue)))
  578. end
  579. else
  580. do_error;
  581. end;
  582. pasbool64,
  583. bool64bit :
  584. begin
  585. if is_constboolnode(node) then
  586. begin
  587. testrange(def,tordconstnode(node).value,false,false);
  588. list.concat(Tai_const.Create_64bit(int64(tordconstnode(node).value.svalue)))
  589. end
  590. else
  591. do_error;
  592. end;
  593. uchar :
  594. begin
  595. if is_constwidecharnode(node) then
  596. inserttypeconv(node,cansichartype);
  597. if is_constcharnode(node) or
  598. ((m_delphi in current_settings.modeswitches) and
  599. is_constwidecharnode(node) and
  600. (tordconstnode(node).value <= 255)) then
  601. list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)))
  602. else
  603. do_error;
  604. end;
  605. uwidechar :
  606. begin
  607. if is_constcharnode(node) then
  608. inserttypeconv(node,cwidechartype);
  609. if is_constwidecharnode(node) then
  610. list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)))
  611. else
  612. do_error;
  613. end;
  614. s8bit,u8bit,
  615. u16bit,s16bit,
  616. s32bit,u32bit,
  617. s64bit,u64bit :
  618. begin
  619. if is_constintnode(node) then
  620. begin
  621. testrange(def,tordconstnode(node).value,false,false);
  622. case def.size of
  623. 1 :
  624. list.concat(Tai_const.Create_8bit(byte(tordconstnode(node).value.svalue)));
  625. 2 :
  626. list.concat(Tai_const.Create_16bit(word(tordconstnode(node).value.svalue)));
  627. 4 :
  628. list.concat(Tai_const.Create_32bit(longint(tordconstnode(node).value.svalue)));
  629. 8 :
  630. list.concat(Tai_const.Create_64bit(tordconstnode(node).value.svalue));
  631. end;
  632. end
  633. else
  634. do_error;
  635. end;
  636. scurrency:
  637. begin
  638. if is_constintnode(node) then
  639. intvalue:=tordconstnode(node).value*10000
  640. { allow bootstrapping }
  641. else if is_constrealnode(node) then
  642. intvalue:=PInt64(@trealconstnode(node).value_currency)^
  643. else
  644. begin
  645. intvalue:=0;
  646. IncompatibleTypes(node.resultdef, def);
  647. end;
  648. list.concat(Tai_const.Create_64bit(intvalue));
  649. end;
  650. else
  651. internalerror(200611052);
  652. end;
  653. end;
  654. procedure tasmlisttypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
  655. var
  656. value : bestreal;
  657. begin
  658. value:=0.0;
  659. if is_constrealnode(node) then
  660. value:=trealconstnode(node).value_real
  661. else if is_constintnode(node) then
  662. value:=tordconstnode(node).value
  663. else if is_constnode(node) then
  664. IncompatibleTypes(node.resultdef, def)
  665. else
  666. Message(parser_e_illegal_expression);
  667. case def.floattype of
  668. s32real :
  669. list.concat(Tai_real_32bit.Create(ts32real(value)));
  670. s64real :
  671. {$ifdef ARM}
  672. if is_double_hilo_swapped then
  673. list.concat(Tai_real_64bit.Create_hiloswapped(ts64real(value)))
  674. else
  675. {$endif ARM}
  676. list.concat(Tai_real_64bit.Create(ts64real(value)));
  677. s80real :
  678. list.concat(Tai_real_80bit.Create(value,s80floattype.size));
  679. sc80real :
  680. list.concat(Tai_real_80bit.Create(value,sc80floattype.size));
  681. s64comp :
  682. { the round is necessary for native compilers where comp isn't a float }
  683. list.concat(Tai_comp_64bit.Create(round(value)));
  684. s64currency:
  685. list.concat(Tai_comp_64bit.Create(round(value*10000)));
  686. s128real:
  687. list.concat(Tai_real_128bit.Create(value));
  688. else
  689. internalerror(200611053);
  690. end;
  691. end;
  692. procedure tasmlisttypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
  693. begin
  694. case node.nodetype of
  695. loadvmtaddrn:
  696. begin
  697. if not def_is_related(tobjectdef(tclassrefdef(node.resultdef).pointeddef),tobjectdef(def.pointeddef)) then
  698. IncompatibleTypes(node.resultdef, def);
  699. list.concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(node.resultdef).pointeddef).vmt_mangledname,AT_DATA)));
  700. end;
  701. niln:
  702. list.concat(Tai_const.Create_sym(nil));
  703. else if is_constnode(node) then
  704. IncompatibleTypes(node.resultdef, def)
  705. else
  706. Message(parser_e_illegal_expression);
  707. end;
  708. end;
  709. procedure tasmlisttypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
  710. var
  711. hp : tnode;
  712. srsym : tsym;
  713. pd : tprocdef;
  714. ca : pchar;
  715. pw : pcompilerwidestring;
  716. i,len : longint;
  717. base,
  718. offset : aint;
  719. v : Tconstexprint;
  720. ll : tasmlabel;
  721. varalign : shortint;
  722. begin
  723. { remove equal typecasts for pointer/nil addresses }
  724. if (node.nodetype=typeconvn) then
  725. with Ttypeconvnode(node) do
  726. if (left.nodetype in [addrn,niln]) and equal_defs(def,node.resultdef) then
  727. begin
  728. hp:=left;
  729. left:=nil;
  730. node.free;
  731. node:=hp;
  732. end;
  733. { allows horrible ofs(typeof(TButton)^) code !! }
  734. if (node.nodetype=addrn) then
  735. with Taddrnode(node) do
  736. if left.nodetype=derefn then
  737. begin
  738. hp:=tderefnode(left).left;
  739. tderefnode(left).left:=nil;
  740. node.free;
  741. node:=hp;
  742. end;
  743. { const pointer ? }
  744. if (node.nodetype = pointerconstn) then
  745. begin
  746. {$if sizeof(TConstPtrUInt)=8}
  747. list.concat(Tai_const.Create_64bit(int64(tpointerconstnode(node).value)));
  748. {$else}
  749. {$if sizeof(TConstPtrUInt)=4}
  750. list.concat(Tai_const.Create_32bit(longint(tpointerconstnode(node).value)));
  751. {$else}
  752. internalerror(200404122);
  753. {$endif} {$endif}
  754. end
  755. { nil pointer ? }
  756. else if node.nodetype=niln then
  757. list.concat(Tai_const.Create_sym(nil))
  758. { maybe pchar ? }
  759. else
  760. if is_char(def.pointeddef) and
  761. (node.nodetype<>addrn) then
  762. begin
  763. current_asmdata.getdatalabel(ll);
  764. list.concat(Tai_const.Create_sym(ll));
  765. if node.nodetype=stringconstn then
  766. varalign:=size_2_align(tstringconstnode(node).len)
  767. else
  768. varalign:=0;
  769. varalign:=const_align(varalign);
  770. new_section(datalist, sec_rodata, ll.name, varalign);
  771. datalist.concat(Tai_label.Create(ll));
  772. if node.nodetype=stringconstn then
  773. begin
  774. len:=tstringconstnode(node).len;
  775. { For tp7 the maximum lentgh can be 255 }
  776. if (m_tp7 in current_settings.modeswitches) and
  777. (len>255) then
  778. len:=255;
  779. getmem(ca,len+2);
  780. move(tstringconstnode(node).value_str^,ca^,len+1);
  781. datalist.concat(Tai_string.Create_pchar(ca,len+1));
  782. end
  783. else
  784. if is_constcharnode(node) then
  785. datalist.concat(Tai_string.Create(char(byte(tordconstnode(node).value.svalue))+#0))
  786. else
  787. IncompatibleTypes(node.resultdef, def);
  788. end
  789. { maybe pwidechar ? }
  790. else
  791. if is_widechar(def.pointeddef) and
  792. (node.nodetype<>addrn) then
  793. begin
  794. current_asmdata.getdatalabel(ll);
  795. list.concat(Tai_const.Create_sym(ll));
  796. new_section(datalist,sec_rodata_norel,ll.name,const_align(sizeof(pint)));
  797. datalist.concat(Tai_label.Create(ll));
  798. if (node.nodetype in [stringconstn,ordconstn]) then
  799. begin
  800. { convert to unicodestring stringconstn }
  801. inserttypeconv(node,cunicodestringtype);
  802. if (node.nodetype=stringconstn) and
  803. (tstringconstnode(node).cst_type in [cst_widestring,cst_unicodestring]) then
  804. begin
  805. pw:=pcompilerwidestring(tstringconstnode(node).value_str);
  806. for i:=0 to tstringconstnode(node).len-1 do
  807. datalist.concat(Tai_const.Create_16bit(pw^.data[i]));
  808. { ending #0 }
  809. datalist.concat(Tai_const.Create_16bit(0))
  810. end;
  811. end
  812. else
  813. IncompatibleTypes(node.resultdef, def);
  814. end
  815. else
  816. if (node.nodetype=addrn) or
  817. is_proc2procvar_load(node,pd) then
  818. begin
  819. { insert typeconv }
  820. inserttypeconv(node,def);
  821. hp:=node;
  822. while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
  823. hp:=tunarynode(hp).left;
  824. if (hp.nodetype=loadn) then
  825. begin
  826. hp:=node;
  827. offset:=0;
  828. while assigned(hp) and (hp.nodetype<>loadn) do
  829. begin
  830. case hp.nodetype of
  831. vecn :
  832. begin
  833. len:=1;
  834. base:=0;
  835. case tvecnode(hp).left.resultdef.typ of
  836. stringdef :
  837. ;
  838. arraydef :
  839. begin
  840. if not is_packed_array(tvecnode(hp).left.resultdef) then
  841. begin
  842. len:=tarraydef(tvecnode(hp).left.resultdef).elesize;
  843. base:=tarraydef(tvecnode(hp).left.resultdef).lowrange;
  844. end
  845. else
  846. Message(parser_e_packed_dynamic_open_array);
  847. end;
  848. else
  849. Message(parser_e_illegal_expression);
  850. end;
  851. if is_constintnode(tvecnode(hp).right) then
  852. begin
  853. {Prevent overflow.}
  854. v:=get_ordinal_value(tvecnode(hp).right)-base;
  855. if (v<int64(low(offset))) or (v>int64(high(offset))) then
  856. message3(type_e_range_check_error_bounds,tostr(v),tostr(low(offset)),tostr(high(offset)));
  857. if high(offset)-offset div len>v then
  858. inc(offset,len*v.svalue)
  859. else
  860. message3(type_e_range_check_error_bounds,tostr(v),'0',tostr(high(offset)-offset div len))
  861. end
  862. else
  863. Message(parser_e_illegal_expression);
  864. end;
  865. subscriptn :
  866. inc(offset,tsubscriptnode(hp).vs.fieldoffset);
  867. typeconvn :
  868. begin
  869. if not(ttypeconvnode(hp).convtype in [tc_equal,tc_proc_2_procvar]) then
  870. Message(parser_e_illegal_expression);
  871. end;
  872. addrn :
  873. ;
  874. else
  875. Message(parser_e_illegal_expression);
  876. end;
  877. hp:=tunarynode(hp).left;
  878. end;
  879. srsym:=tloadnode(hp).symtableentry;
  880. case srsym.typ of
  881. procsym :
  882. begin
  883. pd:=tprocdef(tprocsym(srsym).ProcdefList[0]);
  884. if Tprocsym(srsym).ProcdefList.Count>1 then
  885. Message(parser_e_no_overloaded_procvars);
  886. if po_abstractmethod in pd.procoptions then
  887. Message(type_e_cant_take_address_of_abstract_method)
  888. else
  889. list.concat(Tai_const.Createname(pd.mangledname,offset));
  890. end;
  891. staticvarsym :
  892. list.concat(Tai_const.Createname(tstaticvarsym(srsym).mangledname,offset));
  893. labelsym :
  894. list.concat(Tai_const.Createname(tlabelsym(srsym).mangledname,offset));
  895. constsym :
  896. if tconstsym(srsym).consttyp=constresourcestring then
  897. list.concat(Tai_const.Createname(make_mangledname('RESSTR',tconstsym(srsym).owner,tconstsym(srsym).name),AT_DATA,sizeof(pint)))
  898. else
  899. Message(type_e_variable_id_expected);
  900. else
  901. Message(type_e_variable_id_expected);
  902. end;
  903. end
  904. else
  905. Message(parser_e_illegal_expression);
  906. end
  907. else
  908. { allow typeof(Object type)}
  909. if (node.nodetype=inlinen) and
  910. (tinlinenode(node).inlinenumber=in_typeof_x) then
  911. begin
  912. if (tinlinenode(node).left.nodetype=typen) then
  913. begin
  914. list.concat(Tai_const.createname(
  915. tobjectdef(tinlinenode(node).left.resultdef).vmt_mangledname,AT_DATA,0));
  916. end
  917. else
  918. Message(parser_e_illegal_expression);
  919. end
  920. else
  921. Message(parser_e_illegal_expression);
  922. end;
  923. procedure tasmlisttypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
  924. type
  925. setbytes = array[0..31] of byte;
  926. Psetbytes = ^setbytes;
  927. var
  928. i: longint;
  929. begin
  930. if node.nodetype=setconstn then
  931. begin
  932. { be sure to convert to the correct result, else
  933. it can generate smallset data instead of normalset (PFV) }
  934. inserttypeconv(node,def);
  935. { we only allow const sets }
  936. if (node.nodetype<>setconstn) or
  937. assigned(tsetconstnode(node).left) then
  938. Message(parser_e_illegal_expression)
  939. else
  940. begin
  941. tsetconstnode(node).adjustforsetbase;
  942. { this writing is endian-dependant }
  943. if source_info.endian = target_info.endian then
  944. begin
  945. for i:=0 to node.resultdef.size-1 do
  946. list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(node).value_set)^[i]));
  947. end
  948. else
  949. begin
  950. for i:=0 to node.resultdef.size-1 do
  951. list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(node).value_set)^[i])));
  952. end;
  953. end;
  954. end
  955. else
  956. Message(parser_e_illegal_expression);
  957. end;
  958. procedure tasmlisttypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
  959. begin
  960. if node.nodetype=ordconstn then
  961. begin
  962. if equal_defs(node.resultdef,def) or
  963. is_subequal(node.resultdef,def) then
  964. begin
  965. testrange(def,tordconstnode(node).value,false,false);
  966. case longint(node.resultdef.size) of
  967. 1 : list.concat(Tai_const.Create_8bit(Byte(tordconstnode(node).value.svalue)));
  968. 2 : list.concat(Tai_const.Create_16bit(Word(tordconstnode(node).value.svalue)));
  969. 4 : list.concat(Tai_const.Create_32bit(Longint(tordconstnode(node).value.svalue)));
  970. end;
  971. end
  972. else
  973. IncompatibleTypes(node.resultdef,def);
  974. end
  975. else
  976. Message(parser_e_illegal_expression);
  977. end;
  978. { parse a single constant and add it to the packed const info }
  979. { represented by curval etc (see explanation of bitpackval for }
  980. { what the different parameters mean) }
  981. function tasmlisttypedconstbuilder.parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
  982. var
  983. node: tnode;
  984. begin
  985. result:=true;
  986. node:=comp_expr(true,false);
  987. if (node.nodetype <> ordconstn) or
  988. (not equal_defs(node.resultdef,def) and
  989. not is_subequal(node.resultdef,def)) then
  990. begin
  991. incompatibletypes(node.resultdef,def);
  992. node.free;
  993. consume_all_until(_SEMICOLON);
  994. result:=false;
  995. exit;
  996. end;
  997. if (Tordconstnode(node).value<qword(low(Aword))) or (Tordconstnode(node).value>qword(high(Aword))) then
  998. message3(type_e_range_check_error_bounds,tostr(Tordconstnode(node).value),tostr(low(Aword)),tostr(high(Aword)))
  999. else
  1000. bitpackval(Tordconstnode(node).value.uvalue,bp);
  1001. if (bp.curbitoffset>=AIntBits) then
  1002. flush_packed_value(list,bp);
  1003. node.free;
  1004. end;
  1005. procedure tasmlisttypedconstbuilder.parse_arraydef(def:tarraydef);
  1006. var
  1007. n : tnode;
  1008. i : longint;
  1009. len : asizeint;
  1010. ch : array[0..1] of char;
  1011. ca : pbyte;
  1012. int_const: tai_const;
  1013. char_size: integer;
  1014. oldoffset: asizeint;
  1015. dummy : byte;
  1016. begin
  1017. { dynamic array nil }
  1018. if is_dynamic_array(def) then
  1019. begin
  1020. { Only allow nil initialization }
  1021. consume(_NIL);
  1022. list.concat(Tai_const.Create_sym(nil));
  1023. end
  1024. { packed array constant }
  1025. else if is_packed_array(def) and
  1026. ((def.elepackedbitsize mod 8 <> 0) or
  1027. not ispowerof2(def.elepackedbitsize div 8,i)) then
  1028. begin
  1029. parse_packed_array_def(def);
  1030. end
  1031. { normal array const between brackets }
  1032. else if try_to_consume(_LKLAMMER) then
  1033. begin
  1034. oldoffset:=curoffset;
  1035. curoffset:=0;
  1036. { in case of a generic subroutine, it might be we cannot
  1037. determine the size yet }
  1038. if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
  1039. begin
  1040. while true do
  1041. begin
  1042. read_typed_const_data(def.elementdef);
  1043. if token=_RKLAMMER then
  1044. begin
  1045. consume(_RKLAMMER);
  1046. break;
  1047. end
  1048. else
  1049. consume(_COMMA);
  1050. end;
  1051. end
  1052. else
  1053. begin
  1054. for i:=def.lowrange to def.highrange-1 do
  1055. begin
  1056. read_typed_const_data(def.elementdef);
  1057. Inc(curoffset,def.elementdef.size);
  1058. if token=_RKLAMMER then
  1059. begin
  1060. Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
  1061. consume(_RKLAMMER);
  1062. exit;
  1063. end
  1064. else
  1065. consume(_COMMA);
  1066. end;
  1067. read_typed_const_data(def.elementdef);
  1068. consume(_RKLAMMER);
  1069. end;
  1070. curoffset:=oldoffset;
  1071. end
  1072. { if array of char then we allow also a string }
  1073. else if is_anychar(def.elementdef) then
  1074. begin
  1075. char_size:=def.elementdef.size;
  1076. n:=comp_expr(true,false);
  1077. if n.nodetype=stringconstn then
  1078. begin
  1079. len:=tstringconstnode(n).len;
  1080. case char_size of
  1081. 1:
  1082. begin
  1083. if (tstringconstnode(n).cst_type in [cst_unicodestring,cst_widestring]) then
  1084. inserttypeconv(n,getansistringdef);
  1085. if n.nodetype<>stringconstn then
  1086. internalerror(2010033003);
  1087. ca:=pointer(tstringconstnode(n).value_str);
  1088. end;
  1089. 2:
  1090. begin
  1091. inserttypeconv(n,cunicodestringtype);
  1092. if n.nodetype<>stringconstn then
  1093. internalerror(2010033003);
  1094. ca:=pointer(pcompilerwidestring(tstringconstnode(n).value_str)^.data)
  1095. end;
  1096. else
  1097. internalerror(2010033005);
  1098. end;
  1099. { For tp7 the maximum lentgh can be 255 }
  1100. if (m_tp7 in current_settings.modeswitches) and
  1101. (len>255) then
  1102. len:=255;
  1103. end
  1104. else if is_constcharnode(n) then
  1105. begin
  1106. case char_size of
  1107. 1:
  1108. ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
  1109. 2:
  1110. begin
  1111. inserttypeconv(n,cwidechartype);
  1112. if not is_constwidecharnode(n) then
  1113. internalerror(2010033001);
  1114. widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
  1115. end;
  1116. else
  1117. internalerror(2010033002);
  1118. end;
  1119. ca:=@ch;
  1120. len:=1;
  1121. end
  1122. else if is_constwidecharnode(n) and (current_settings.sourcecodepage<>CP_UTF8) then
  1123. begin
  1124. case char_size of
  1125. 1:
  1126. begin
  1127. inserttypeconv(n,cansichartype);
  1128. if not is_constcharnode(n) then
  1129. internalerror(2010033001);
  1130. ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
  1131. end;
  1132. 2:
  1133. widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
  1134. else
  1135. internalerror(2010033002);
  1136. end;
  1137. ca:=@ch;
  1138. len:=1;
  1139. end
  1140. else
  1141. begin
  1142. Message(parser_e_illegal_expression);
  1143. len:=0;
  1144. { avoid crash later on }
  1145. dummy:=0;
  1146. ca:=@dummy;
  1147. end;
  1148. if len>(def.highrange-def.lowrange+1) then
  1149. Message(parser_e_string_larger_array);
  1150. for i:=0 to def.highrange-def.lowrange do
  1151. begin
  1152. if i<len then
  1153. begin
  1154. case char_size of
  1155. 1:
  1156. int_const:=Tai_const.Create_char(char_size,pbyte(ca)^);
  1157. 2:
  1158. int_const:=Tai_const.Create_char(char_size,pword(ca)^);
  1159. else
  1160. internalerror(2010033004);
  1161. end;
  1162. inc(ca, char_size);
  1163. end
  1164. else
  1165. {Fill the remaining positions with #0.}
  1166. int_const:=Tai_const.Create_char(char_size,0);
  1167. list.concat(int_const)
  1168. end;
  1169. n.free;
  1170. end
  1171. else
  1172. begin
  1173. { we want the ( }
  1174. consume(_LKLAMMER);
  1175. end;
  1176. end;
  1177. procedure tasmlisttypedconstbuilder.parse_procvardef(def:tprocvardef);
  1178. var
  1179. tmpn,n : tnode;
  1180. pd : tprocdef;
  1181. havepd,
  1182. haveblock: boolean;
  1183. begin
  1184. { Procvars and pointers are no longer compatible. }
  1185. { under tp: =nil or =var under fpc: =nil or =@var }
  1186. if try_to_consume(_NIL) then
  1187. begin
  1188. list.concat(Tai_const.Create_sym(nil));
  1189. if not def.is_addressonly then
  1190. list.concat(Tai_const.Create_sym(nil));
  1191. exit;
  1192. end;
  1193. { you can't assign a value other than NIL to a typed constant }
  1194. { which is a "procedure of object", because this also requires }
  1195. { address of an object/class instance, which is not known at }
  1196. { compile time (JM) }
  1197. if (po_methodpointer in def.procoptions) then
  1198. Message(parser_e_no_procvarobj_const);
  1199. { parse the rest too, so we can continue with error checking }
  1200. getprocvardef:=def;
  1201. n:=comp_expr(true,false);
  1202. getprocvardef:=nil;
  1203. if codegenerror then
  1204. begin
  1205. n.free;
  1206. exit;
  1207. end;
  1208. { let type conversion check everything needed }
  1209. inserttypeconv(n,def);
  1210. if codegenerror then
  1211. begin
  1212. n.free;
  1213. exit;
  1214. end;
  1215. { remove typeconvs, that will normally insert a lea
  1216. instruction which is not necessary for us }
  1217. while n.nodetype=typeconvn do
  1218. begin
  1219. tmpn:=ttypeconvnode(n).left;
  1220. ttypeconvnode(n).left:=nil;
  1221. n.free;
  1222. n:=tmpn;
  1223. end;
  1224. { remove addrn which we also don't need here }
  1225. if n.nodetype=addrn then
  1226. begin
  1227. tmpn:=taddrnode(n).left;
  1228. taddrnode(n).left:=nil;
  1229. n.free;
  1230. n:=tmpn;
  1231. end;
  1232. pd:=nil;
  1233. { we now need to have a loadn with a procsym }
  1234. havepd:=
  1235. (n.nodetype=loadn) and
  1236. (tloadnode(n).symtableentry.typ=procsym);
  1237. { or a staticvarsym representing a block }
  1238. haveblock:=
  1239. (n.nodetype=loadn) and
  1240. (tloadnode(n).symtableentry.typ=staticvarsym) and
  1241. (sp_internal in tloadnode(n).symtableentry.symoptions);
  1242. if havepd or
  1243. haveblock then
  1244. begin
  1245. if havepd then
  1246. begin
  1247. pd:=tloadnode(n).procdef;
  1248. list.concat(Tai_const.createname(pd.mangledname,0));
  1249. end
  1250. else
  1251. begin
  1252. list.concat(Tai_const.Createname(tstaticvarsym(tloadnode(n).symtableentry).mangledname,0));
  1253. end;
  1254. { nested procvar typed consts can only be initialised with nil
  1255. (checked above) or with a global procedure (checked here),
  1256. because in other cases we need a valid frame pointer }
  1257. if is_nested_pd(def) then
  1258. begin
  1259. if haveblock or
  1260. is_nested_pd(pd) then
  1261. Message(parser_e_no_procvarnested_const);
  1262. list.concat(Tai_const.Create_sym(nil));
  1263. end
  1264. end
  1265. else if n.nodetype=pointerconstn then
  1266. list.concat(Tai_const.Create_pint(tpointerconstnode(n).value))
  1267. else
  1268. Message(parser_e_illegal_expression);
  1269. n.free;
  1270. end;
  1271. procedure tasmlisttypedconstbuilder.parse_recorddef(def:trecorddef);
  1272. var
  1273. n : tnode;
  1274. symidx : longint;
  1275. recsym,
  1276. srsym : tsym;
  1277. hs : string;
  1278. sorg,s : TIDString;
  1279. tmpguid : tguid;
  1280. recoffset,
  1281. fillbytes : aint;
  1282. bp : tbitpackedval;
  1283. error,
  1284. is_packed: boolean;
  1285. startoffset: aint;
  1286. procedure handle_stringconstn;
  1287. var
  1288. i : longint;
  1289. begin
  1290. hs:=strpas(tstringconstnode(n).value_str);
  1291. if string2guid(hs,tmpguid) then
  1292. begin
  1293. list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
  1294. list.concat(Tai_const.Create_16bit(tmpguid.D2));
  1295. list.concat(Tai_const.Create_16bit(tmpguid.D3));
  1296. for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
  1297. list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
  1298. end
  1299. else
  1300. Message(parser_e_improper_guid_syntax);
  1301. end;
  1302. var
  1303. i : longint;
  1304. SymList:TFPHashObjectList;
  1305. begin
  1306. { GUID }
  1307. if (def=rec_tguid) and (token=_ID) then
  1308. begin
  1309. n:=comp_expr(true,false);
  1310. if n.nodetype=stringconstn then
  1311. handle_stringconstn
  1312. else
  1313. begin
  1314. inserttypeconv(n,rec_tguid);
  1315. if n.nodetype=guidconstn then
  1316. begin
  1317. tmpguid:=tguidconstnode(n).value;
  1318. list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
  1319. list.concat(Tai_const.Create_16bit(tmpguid.D2));
  1320. list.concat(Tai_const.Create_16bit(tmpguid.D3));
  1321. for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
  1322. list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
  1323. end
  1324. else
  1325. Message(parser_e_illegal_expression);
  1326. end;
  1327. n.free;
  1328. exit;
  1329. end;
  1330. if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
  1331. begin
  1332. n:=comp_expr(true,false);
  1333. inserttypeconv(n,cshortstringtype);
  1334. if n.nodetype=stringconstn then
  1335. handle_stringconstn
  1336. else
  1337. Message(parser_e_illegal_expression);
  1338. n.free;
  1339. exit;
  1340. end;
  1341. { bitpacked record? }
  1342. is_packed:=is_packed_record_or_object(def);
  1343. if (is_packed) then
  1344. begin
  1345. { loadbitsize = 8, bitpacked records are always padded to }
  1346. { a multiple of a byte. packedbitsize will be set separately }
  1347. { for each field }
  1348. initbitpackval(bp,0);
  1349. bp.loadbitsize:=8;
  1350. end;
  1351. { normal record }
  1352. consume(_LKLAMMER);
  1353. recoffset:=0;
  1354. sorg:='';
  1355. symidx:=0;
  1356. symlist:=def.symtable.SymList;
  1357. srsym:=get_next_varsym(def,symlist,symidx);
  1358. recsym := nil;
  1359. startoffset:=curoffset;
  1360. while token<>_RKLAMMER do
  1361. begin
  1362. s:=pattern;
  1363. sorg:=orgpattern;
  1364. consume(_ID);
  1365. consume(_COLON);
  1366. error := false;
  1367. recsym := tsym(def.symtable.Find(s));
  1368. if not assigned(recsym) then
  1369. begin
  1370. Message1(sym_e_illegal_field,sorg);
  1371. error := true;
  1372. end;
  1373. if (not error) and
  1374. (not assigned(srsym) or
  1375. (s <> srsym.name)) then
  1376. { possible variant record (JM) }
  1377. begin
  1378. { All parts of a variant start at the same offset }
  1379. { Also allow jumping from one variant part to another, }
  1380. { as long as the offsets match }
  1381. if (assigned(srsym) and
  1382. (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
  1383. { srsym is not assigned after parsing w2 in the }
  1384. { typed const in the next example: }
  1385. { type tr = record case byte of }
  1386. { 1: (l1,l2: dword); }
  1387. { 2: (w1,w2: word); }
  1388. { end; }
  1389. { const r: tr = (w1:1;w2:1;l2:5); }
  1390. (tfieldvarsym(recsym).fieldoffset = recoffset) then
  1391. begin
  1392. srsym:=recsym;
  1393. { symidx should contain the next symbol id to search }
  1394. symidx:=SymList.indexof(srsym)+1;
  1395. end
  1396. { going backwards isn't allowed in any mode }
  1397. else if (tfieldvarsym(recsym).fieldoffset<recoffset) then
  1398. begin
  1399. Message(parser_e_invalid_record_const);
  1400. error := true;
  1401. end
  1402. { Delphi allows you to skip fields }
  1403. else if (m_delphi in current_settings.modeswitches) then
  1404. begin
  1405. Message1(parser_w_skipped_fields_before,sorg);
  1406. srsym := recsym;
  1407. end
  1408. { FPC and TP don't }
  1409. else
  1410. begin
  1411. Message1(parser_e_skipped_fields_before,sorg);
  1412. error := true;
  1413. end;
  1414. end;
  1415. if error then
  1416. consume_all_until(_SEMICOLON)
  1417. else
  1418. begin
  1419. { if needed fill (alignment) }
  1420. if tfieldvarsym(srsym).fieldoffset>recoffset then
  1421. begin
  1422. if not(is_packed) then
  1423. fillbytes:=tfieldvarsym(srsym).fieldoffset-recoffset
  1424. else
  1425. begin
  1426. flush_packed_value(list,bp);
  1427. { curoffset is now aligned to the next byte }
  1428. recoffset:=align(recoffset,8);
  1429. { offsets are in bits in this case }
  1430. fillbytes:=(tfieldvarsym(srsym).fieldoffset-recoffset) div 8;
  1431. end;
  1432. for i:=1 to fillbytes do
  1433. list.concat(Tai_const.Create_8bit(0))
  1434. end;
  1435. { new position }
  1436. recoffset:=tfieldvarsym(srsym).fieldoffset;
  1437. if not(is_packed) then
  1438. inc(recoffset,tfieldvarsym(srsym).vardef.size)
  1439. else
  1440. inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
  1441. { read the data }
  1442. if not(is_packed) or
  1443. { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
  1444. not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
  1445. begin
  1446. if is_packed then
  1447. begin
  1448. flush_packed_value(list,bp);
  1449. recoffset:=align(recoffset,8);
  1450. end;
  1451. curoffset:=startoffset+tfieldvarsym(srsym).fieldoffset;
  1452. read_typed_const_data(tfieldvarsym(srsym).vardef);
  1453. end
  1454. else
  1455. begin
  1456. bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
  1457. parse_single_packed_const(tfieldvarsym(srsym).vardef,bp);
  1458. end;
  1459. { keep previous field for checking whether whole }
  1460. { record was initialized (JM) }
  1461. recsym := srsym;
  1462. { goto next field }
  1463. srsym:=get_next_varsym(def,SymList,symidx);
  1464. if token=_SEMICOLON then
  1465. consume(_SEMICOLON)
  1466. else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
  1467. consume(_COMMA)
  1468. else
  1469. break;
  1470. end;
  1471. end;
  1472. curoffset:=startoffset;
  1473. { are there any fields left, but don't complain if there only
  1474. come other variant parts after the last initialized field }
  1475. if assigned(srsym) and
  1476. (
  1477. (recsym=nil) or
  1478. (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
  1479. ) then
  1480. Message1(parser_w_skipped_fields_after,sorg);
  1481. if not(is_packed) then
  1482. fillbytes:=def.size-recoffset
  1483. else
  1484. begin
  1485. flush_packed_value(list,bp);
  1486. recoffset:=align(recoffset,8);
  1487. fillbytes:=def.size-(recoffset div 8);
  1488. end;
  1489. for i:=1 to fillbytes do
  1490. list.concat(Tai_const.Create_8bit(0));
  1491. consume(_RKLAMMER);
  1492. end;
  1493. procedure tasmlisttypedconstbuilder.parse_objectdef(def:tobjectdef);
  1494. var
  1495. n : tnode;
  1496. i : longint;
  1497. obj : tobjectdef;
  1498. srsym : tsym;
  1499. st : tsymtable;
  1500. objoffset : aint;
  1501. s,sorg : TIDString;
  1502. vmtwritten : boolean;
  1503. startoffset:aint;
  1504. begin
  1505. { no support for packed object }
  1506. if is_packed_record_or_object(def) then
  1507. begin
  1508. Message(type_e_no_const_packed_record);
  1509. exit;
  1510. end;
  1511. { only allow nil for implicit pointer object types }
  1512. if is_implicit_pointer_object_type(def) then
  1513. begin
  1514. n:=comp_expr(true,false);
  1515. if n.nodetype<>niln then
  1516. begin
  1517. Message(parser_e_type_const_not_possible);
  1518. consume_all_until(_SEMICOLON);
  1519. end
  1520. else
  1521. list.concat(Tai_const.Create_sym(nil));
  1522. n.free;
  1523. exit;
  1524. end;
  1525. { for objects we allow it only if it doesn't contain a vmt }
  1526. if (oo_has_vmt in def.objectoptions) and
  1527. (m_fpc in current_settings.modeswitches) then
  1528. begin
  1529. Message(parser_e_type_object_constants);
  1530. exit;
  1531. end;
  1532. consume(_LKLAMMER);
  1533. startoffset:=curoffset;
  1534. objoffset:=0;
  1535. vmtwritten:=false;
  1536. while token<>_RKLAMMER do
  1537. begin
  1538. s:=pattern;
  1539. sorg:=orgpattern;
  1540. consume(_ID);
  1541. consume(_COLON);
  1542. srsym:=nil;
  1543. obj:=tobjectdef(def);
  1544. st:=obj.symtable;
  1545. while (srsym=nil) and assigned(st) do
  1546. begin
  1547. srsym:=tsym(st.Find(s));
  1548. if assigned(obj) then
  1549. obj:=obj.childof;
  1550. if assigned(obj) then
  1551. st:=obj.symtable
  1552. else
  1553. st:=nil;
  1554. end;
  1555. if (srsym=nil) or
  1556. (srsym.typ<>fieldvarsym) then
  1557. begin
  1558. if (srsym=nil) then
  1559. Message1(sym_e_id_not_found,sorg)
  1560. else
  1561. Message1(sym_e_illegal_field,sorg);
  1562. consume_all_until(_RKLAMMER);
  1563. break;
  1564. end
  1565. else
  1566. with tfieldvarsym(srsym) do
  1567. begin
  1568. { check position }
  1569. if fieldoffset<objoffset then
  1570. message(parser_e_invalid_record_const);
  1571. { check in VMT needs to be added for TP mode }
  1572. if not(vmtwritten) and
  1573. not(m_fpc in current_settings.modeswitches) and
  1574. (oo_has_vmt in def.objectoptions) and
  1575. (def.vmt_offset<fieldoffset) then
  1576. begin
  1577. for i:=1 to def.vmt_offset-objoffset do
  1578. list.concat(tai_const.create_8bit(0));
  1579. list.concat(tai_const.createname(def.vmt_mangledname,AT_DATA,0));
  1580. { this is more general }
  1581. objoffset:=def.vmt_offset + sizeof(pint);
  1582. vmtwritten:=true;
  1583. end;
  1584. { if needed fill }
  1585. if fieldoffset>objoffset then
  1586. for i:=1 to fieldoffset-objoffset do
  1587. list.concat(Tai_const.Create_8bit(0));
  1588. { new position }
  1589. objoffset:=fieldoffset+vardef.size;
  1590. { read the data }
  1591. curoffset:=startoffset+fieldoffset;
  1592. read_typed_const_data(vardef);
  1593. if not try_to_consume(_SEMICOLON) then
  1594. break;
  1595. end;
  1596. end;
  1597. curoffset:=startoffset;
  1598. if not(m_fpc in current_settings.modeswitches) and
  1599. (oo_has_vmt in def.objectoptions) and
  1600. (def.vmt_offset>=objoffset) then
  1601. begin
  1602. for i:=1 to def.vmt_offset-objoffset do
  1603. list.concat(tai_const.create_8bit(0));
  1604. list.concat(tai_const.createname(def.vmt_mangledname,AT_DATA,0));
  1605. { this is more general }
  1606. objoffset:=def.vmt_offset + sizeof(pint);
  1607. end;
  1608. for i:=1 to def.size-objoffset do
  1609. list.concat(Tai_const.Create_8bit(0));
  1610. consume(_RKLAMMER);
  1611. end;
  1612. procedure tasmlisttypedconstbuilder.parse_into_asmlist(out res,data: tasmlist);
  1613. begin
  1614. read_typed_const_data(tcsym.vardef);
  1615. res:=list;
  1616. data:=datalist;
  1617. end;
  1618. { tnodetreetypedconstbuilder }
  1619. procedure tnodetreetypedconstbuilder.parse_arraydef(def: tarraydef);
  1620. var
  1621. n : tnode;
  1622. i : longint;
  1623. orgbase: tnode;
  1624. begin
  1625. { dynamic array nil }
  1626. if is_dynamic_array(def) then
  1627. begin
  1628. { Only allow nil initialization }
  1629. consume(_NIL);
  1630. addstatement(statmnt,cassignmentnode.create_internal(basenode,cnilnode.create));
  1631. basenode:=nil;
  1632. end
  1633. { array const between brackets }
  1634. else if try_to_consume(_LKLAMMER) then
  1635. begin
  1636. orgbase:=basenode;
  1637. for i:=def.lowrange to def.highrange-1 do
  1638. begin
  1639. basenode:=cvecnode.create(orgbase.getcopy,ctypeconvnode.create_explicit(genintconstnode(i),tarraydef(def).rangedef));
  1640. read_typed_const_data(def.elementdef);
  1641. if token=_RKLAMMER then
  1642. begin
  1643. Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
  1644. consume(_RKLAMMER);
  1645. exit;
  1646. end
  1647. else
  1648. consume(_COMMA);
  1649. end;
  1650. basenode:=cvecnode.create(orgbase,ctypeconvnode.create_explicit(genintconstnode(def.highrange),tarraydef(def).rangedef));
  1651. read_typed_const_data(def.elementdef);
  1652. consume(_RKLAMMER);
  1653. end
  1654. { if array of char then we allow also a string }
  1655. else if is_anychar(def.elementdef) then
  1656. begin
  1657. n:=comp_expr(true,false);
  1658. addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
  1659. basenode:=nil;
  1660. end
  1661. else
  1662. begin
  1663. { we want the ( }
  1664. consume(_LKLAMMER);
  1665. end;
  1666. end;
  1667. procedure tnodetreetypedconstbuilder.parse_procvardef(def: tprocvardef);
  1668. begin
  1669. addstatement(statmnt,cassignmentnode.create_internal(basenode,comp_expr(true,false)));
  1670. basenode:=nil;
  1671. end;
  1672. procedure tnodetreetypedconstbuilder.parse_recorddef(def: trecorddef);
  1673. var
  1674. n,n2 : tnode;
  1675. SymList:TFPHashObjectList;
  1676. orgbasenode : tnode;
  1677. symidx : longint;
  1678. recsym,
  1679. srsym : tsym;
  1680. sorg,s : TIDString;
  1681. recoffset : aint;
  1682. error,
  1683. is_packed: boolean;
  1684. procedure handle_stringconstn;
  1685. begin
  1686. addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
  1687. basenode:=nil;
  1688. n:=nil;
  1689. end;
  1690. begin
  1691. { GUID }
  1692. if (def=rec_tguid) and (token=_ID) then
  1693. begin
  1694. n:=comp_expr(true,false);
  1695. if n.nodetype=stringconstn then
  1696. handle_stringconstn
  1697. else
  1698. begin
  1699. inserttypeconv(n,rec_tguid);
  1700. if n.nodetype=guidconstn then
  1701. begin
  1702. n2:=cstringconstnode.createstr(guid2string(tguidconstnode(n).value));
  1703. n.free;
  1704. n:=n2;
  1705. handle_stringconstn;
  1706. end
  1707. else
  1708. Message(parser_e_illegal_expression);
  1709. end;
  1710. n.free;
  1711. exit;
  1712. end;
  1713. if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
  1714. begin
  1715. n:=comp_expr(true,false);
  1716. inserttypeconv(n,cshortstringtype);
  1717. if n.nodetype=stringconstn then
  1718. handle_stringconstn
  1719. else
  1720. Message(parser_e_illegal_expression);
  1721. n.free;
  1722. exit;
  1723. end;
  1724. { bitpacked record? }
  1725. is_packed:=is_packed_record_or_object(def);
  1726. { normal record }
  1727. consume(_LKLAMMER);
  1728. recoffset:=0;
  1729. sorg:='';
  1730. symidx:=0;
  1731. symlist:=def.symtable.SymList;
  1732. srsym:=get_next_varsym(def,symlist,symidx);
  1733. recsym := nil;
  1734. orgbasenode:=basenode;
  1735. basenode:=nil;
  1736. while token<>_RKLAMMER do
  1737. begin
  1738. s:=pattern;
  1739. sorg:=orgpattern;
  1740. consume(_ID);
  1741. consume(_COLON);
  1742. error := false;
  1743. recsym := tsym(def.symtable.Find(s));
  1744. if not assigned(recsym) then
  1745. begin
  1746. Message1(sym_e_illegal_field,sorg);
  1747. error := true;
  1748. end;
  1749. if (not error) and
  1750. (not assigned(srsym) or
  1751. (s <> srsym.name)) then
  1752. { possible variant record (JM) }
  1753. begin
  1754. { All parts of a variant start at the same offset }
  1755. { Also allow jumping from one variant part to another, }
  1756. { as long as the offsets match }
  1757. if (assigned(srsym) and
  1758. (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
  1759. { srsym is not assigned after parsing w2 in the }
  1760. { typed const in the next example: }
  1761. { type tr = record case byte of }
  1762. { 1: (l1,l2: dword); }
  1763. { 2: (w1,w2: word); }
  1764. { end; }
  1765. { const r: tr = (w1:1;w2:1;l2:5); }
  1766. (tfieldvarsym(recsym).fieldoffset = recoffset) then
  1767. begin
  1768. srsym:=recsym;
  1769. { symidx should contain the next symbol id to search }
  1770. symidx:=SymList.indexof(srsym)+1;
  1771. end
  1772. { going backwards isn't allowed in any mode }
  1773. else if (tfieldvarsym(recsym).fieldoffset<recoffset) then
  1774. begin
  1775. Message(parser_e_invalid_record_const);
  1776. error := true;
  1777. end
  1778. { Delphi allows you to skip fields }
  1779. else if (m_delphi in current_settings.modeswitches) then
  1780. begin
  1781. Message1(parser_w_skipped_fields_before,sorg);
  1782. srsym := recsym;
  1783. end
  1784. { FPC and TP don't }
  1785. else
  1786. begin
  1787. Message1(parser_e_skipped_fields_before,sorg);
  1788. error := true;
  1789. end;
  1790. end;
  1791. if error then
  1792. consume_all_until(_SEMICOLON)
  1793. else
  1794. begin
  1795. { skipping fill bytes happens automatically, since we only
  1796. initialize the defined fields }
  1797. { new position }
  1798. recoffset:=tfieldvarsym(srsym).fieldoffset;
  1799. if not(is_packed) then
  1800. inc(recoffset,tfieldvarsym(srsym).vardef.size)
  1801. else
  1802. inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
  1803. { read the data }
  1804. if is_packed and
  1805. { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
  1806. not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
  1807. recoffset:=align(recoffset,8);
  1808. basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
  1809. read_typed_const_data(tfieldvarsym(srsym).vardef);
  1810. { keep previous field for checking whether whole }
  1811. { record was initialized (JM) }
  1812. recsym := srsym;
  1813. { goto next field }
  1814. srsym:=get_next_varsym(def,SymList,symidx);
  1815. if token=_SEMICOLON then
  1816. consume(_SEMICOLON)
  1817. else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
  1818. consume(_COMMA)
  1819. else
  1820. break;
  1821. end;
  1822. end;
  1823. { are there any fields left, but don't complain if there only
  1824. come other variant parts after the last initialized field }
  1825. if assigned(srsym) and
  1826. (
  1827. (recsym=nil) or
  1828. (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
  1829. ) then
  1830. Message1(parser_w_skipped_fields_after,sorg);
  1831. orgbasenode.free;
  1832. basenode:=nil;
  1833. consume(_RKLAMMER);
  1834. end;
  1835. procedure tnodetreetypedconstbuilder.parse_objectdef(def: tobjectdef);
  1836. var
  1837. n,
  1838. orgbasenode : tnode;
  1839. obj : tobjectdef;
  1840. srsym : tsym;
  1841. st : tsymtable;
  1842. objoffset : aint;
  1843. s,sorg : TIDString;
  1844. begin
  1845. { no support for packed object }
  1846. if is_packed_record_or_object(def) then
  1847. begin
  1848. Message(type_e_no_const_packed_record);
  1849. exit;
  1850. end;
  1851. { only allow nil for implicit pointer object types }
  1852. if is_implicit_pointer_object_type(def) then
  1853. begin
  1854. n:=comp_expr(true,false);
  1855. if n.nodetype<>niln then
  1856. begin
  1857. Message(parser_e_type_const_not_possible);
  1858. consume_all_until(_SEMICOLON);
  1859. end
  1860. else
  1861. begin
  1862. addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
  1863. n:=nil;
  1864. basenode:=nil;
  1865. end;
  1866. n.free;
  1867. exit;
  1868. end;
  1869. { for objects we allow it only if it doesn't contain a vmt }
  1870. if (oo_has_vmt in def.objectoptions) and
  1871. (m_fpc in current_settings.modeswitches) then
  1872. begin
  1873. Message(parser_e_type_object_constants);
  1874. exit;
  1875. end;
  1876. consume(_LKLAMMER);
  1877. objoffset:=0;
  1878. orgbasenode:=basenode;
  1879. basenode:=nil;
  1880. while token<>_RKLAMMER do
  1881. begin
  1882. s:=pattern;
  1883. sorg:=orgpattern;
  1884. consume(_ID);
  1885. consume(_COLON);
  1886. srsym:=nil;
  1887. obj:=tobjectdef(def);
  1888. st:=obj.symtable;
  1889. while (srsym=nil) and assigned(st) do
  1890. begin
  1891. srsym:=tsym(st.Find(s));
  1892. if assigned(obj) then
  1893. obj:=obj.childof;
  1894. if assigned(obj) then
  1895. st:=obj.symtable
  1896. else
  1897. st:=nil;
  1898. end;
  1899. if (srsym=nil) or
  1900. (srsym.typ<>fieldvarsym) then
  1901. begin
  1902. if (srsym=nil) then
  1903. Message1(sym_e_id_not_found,sorg)
  1904. else
  1905. Message1(sym_e_illegal_field,sorg);
  1906. consume_all_until(_RKLAMMER);
  1907. break;
  1908. end
  1909. else
  1910. with tfieldvarsym(srsym) do
  1911. begin
  1912. { check position }
  1913. if fieldoffset<objoffset then
  1914. message(parser_e_invalid_record_const);
  1915. { new position }
  1916. objoffset:=fieldoffset+vardef.size;
  1917. { read the data }
  1918. basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
  1919. read_typed_const_data(vardef);
  1920. if not try_to_consume(_SEMICOLON) then
  1921. break;
  1922. end;
  1923. end;
  1924. consume(_RKLAMMER);
  1925. end;
  1926. procedure tnodetreetypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
  1927. begin
  1928. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1929. basenode:=nil;
  1930. node:=nil;
  1931. end;
  1932. procedure tnodetreetypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
  1933. begin
  1934. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1935. basenode:=nil;
  1936. node:=nil;
  1937. end;
  1938. procedure tnodetreetypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
  1939. begin
  1940. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1941. basenode:=nil;
  1942. node:=nil;
  1943. end;
  1944. procedure tnodetreetypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
  1945. begin
  1946. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1947. basenode:=nil;
  1948. node:=nil;
  1949. end;
  1950. procedure tnodetreetypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
  1951. begin
  1952. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1953. basenode:=nil;
  1954. node:=nil;
  1955. end;
  1956. procedure tnodetreetypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
  1957. begin
  1958. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1959. basenode:=nil;
  1960. node:=nil;
  1961. end;
  1962. procedure tnodetreetypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
  1963. begin
  1964. addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
  1965. basenode:=nil;
  1966. node:=nil;
  1967. end;
  1968. constructor tnodetreetypedconstbuilder.create(sym: tstaticvarsym; previnit: tnode);
  1969. begin
  1970. inherited create(sym);
  1971. basenode:=cloadnode.create(sym,sym.owner);
  1972. resultblock:=internalstatements(statmnt);
  1973. if assigned(previnit) then
  1974. addstatement(statmnt,previnit);
  1975. end;
  1976. destructor tnodetreetypedconstbuilder.destroy;
  1977. begin
  1978. freeandnil(basenode);
  1979. freeandnil(resultblock);
  1980. inherited destroy;
  1981. end;
  1982. function tnodetreetypedconstbuilder.parse_into_nodetree: tnode;
  1983. begin
  1984. read_typed_const_data(tcsym.vardef);
  1985. result:=self.resultblock;
  1986. self.resultblock:=nil;
  1987. end;
  1988. begin
  1989. { default to asmlist version, best for most targets }
  1990. ctypedconstbuilder:=tasmlisttypedconstbuilder;
  1991. end.