ptconst.pas 59 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Reads typed constants
  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 ptconst;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses symtype,symsym,aasmdata;
  21. procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
  22. implementation
  23. uses
  24. SysUtils,
  25. globtype,systems,tokens,verbose,constexp,
  26. cutils,globals,widestr,scanner,
  27. symconst,symbase,symdef,symtable,
  28. aasmbase,aasmtai,aasmcpu,defutil,defcmp,
  29. { pass 1 }
  30. node,htypechk,procinfo,
  31. nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
  32. { parser specific stuff }
  33. pbase,pexpr,pdecvar,
  34. { codegen }
  35. cpuinfo,cgbase,dbgbase,
  36. wpobase,asmutils
  37. ;
  38. {$maxfpuregisters 0}
  39. {*****************************************************************************
  40. Bitpacked value helpers
  41. *****************************************************************************}
  42. type
  43. tbitpackedval = record
  44. curval, nextval: aword;
  45. curbitoffset: smallint;
  46. loadbitsize,packedbitsize: byte;
  47. end;
  48. procedure initbitpackval(out bp: tbitpackedval; packedbitsize: byte);
  49. begin
  50. bp.curval:=0;
  51. bp.nextval:=0;
  52. bp.curbitoffset:=0;
  53. bp.packedbitsize:=packedbitsize;
  54. bp.loadbitsize:=packedbitsloadsize(bp.packedbitsize)*8;
  55. end;
  56. {$ifopt r+}
  57. {$define rangeon}
  58. {$r-}
  59. {$endif}
  60. {$ifopt q+}
  61. {$define overflowon}
  62. {$q-}
  63. {$endif}
  64. { (values between quotes below refer to fields of bp; fields not }
  65. { mentioned are unused by this routine) }
  66. { bitpacks "value" as bitpacked value of bitsize "packedbitsize" into }
  67. { "curval", which has already been filled up to "curbitoffset", and }
  68. { stores the spillover if any into "nextval". It also updates }
  69. { curbitoffset to reflect how many bits of currval are now used (can be }
  70. { > AIntBits in case of spillover) }
  71. procedure bitpackval(value: aword; var bp: tbitpackedval);
  72. var
  73. shiftcount: longint;
  74. begin
  75. if (target_info.endian=endian_big) then
  76. begin
  77. { bitpacked format: left-aligned (i.e., "big endian bitness") }
  78. bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
  79. shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
  80. { carry-over to the next element? }
  81. if (shiftcount<0) then
  82. bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
  83. (AIntBits+shiftcount)
  84. end
  85. else
  86. begin
  87. { bitpacked format: right aligned (i.e., "little endian bitness") }
  88. bp.curval:=bp.curval or (value shl bp.curbitoffset);
  89. { carry-over to the next element? }
  90. if (bp.curbitoffset+bp.packedbitsize>AIntBits) then
  91. bp.nextval:=value shr (AIntBits-bp.curbitoffset)
  92. end;
  93. inc(bp.curbitoffset,bp.packedbitsize);
  94. end;
  95. {$ifdef rangeon}
  96. {$r+}
  97. {$undef rangeon}
  98. {$endif}
  99. {$ifdef overflowon}
  100. {$q+}
  101. {$undef overflowon}
  102. {$endif}
  103. procedure flush_packed_value(list: tasmlist; var bp: tbitpackedval);
  104. var
  105. bitstowrite: longint;
  106. writeval : byte;
  107. begin
  108. if (bp.curbitoffset < AIntBits) then
  109. begin
  110. { forced flush -> write multiple of loadsize }
  111. bitstowrite:=align(bp.curbitoffset,bp.loadbitsize);
  112. bp.curbitoffset:=0;
  113. end
  114. else
  115. begin
  116. bitstowrite:=AIntBits;
  117. dec(bp.curbitoffset,AIntBits);
  118. end;
  119. while (bitstowrite>=8) do
  120. begin
  121. if (target_info.endian=endian_little) then
  122. begin
  123. { write lowest byte }
  124. writeval:=byte(bp.curval);
  125. bp.curval:=bp.curval shr 8;
  126. end
  127. else
  128. begin
  129. { write highest byte }
  130. writeval:=bp.curval shr (AIntBits-8);
  131. bp.curval:=(bp.curval and (not($ff shl (AIntBits-8)))) shl 8;
  132. end;
  133. list.concat(tai_const.create_8bit(writeval));
  134. dec(bitstowrite,8);
  135. end;
  136. bp.curval:=bp.nextval;
  137. bp.nextval:=0;
  138. end;
  139. {*****************************************************************************
  140. read typed const
  141. *****************************************************************************}
  142. type
  143. { context used for parsing complex types (arrays/records/objects) }
  144. threc = record
  145. list : tasmlist;
  146. origsym: tstaticvarsym;
  147. offset: asizeint;
  148. origblock: tblock_type;
  149. end;
  150. { this procedure reads typed constants }
  151. procedure read_typed_const_data(var hr:threc;def:tdef); forward;
  152. procedure parse_orddef(list:tasmlist;def:torddef);
  153. var
  154. n : tnode;
  155. intvalue : tconstexprint;
  156. procedure do_error;
  157. begin
  158. if is_constnode(n) then
  159. IncompatibleTypes(n.resultdef, def)
  160. else
  161. Message(parser_e_illegal_expression);
  162. end;
  163. begin
  164. n:=comp_expr(true,false);
  165. { for C-style booleans, true=-1 and false=0) }
  166. if is_cbool(def) then
  167. inserttypeconv(n,def);
  168. case def.ordtype of
  169. pasbool8,
  170. bool8bit :
  171. begin
  172. if is_constboolnode(n) then
  173. list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)))
  174. else
  175. do_error;
  176. end;
  177. pasbool16,
  178. bool16bit :
  179. begin
  180. if is_constboolnode(n) then
  181. list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)))
  182. else
  183. do_error;
  184. end;
  185. pasbool32,
  186. bool32bit :
  187. begin
  188. if is_constboolnode(n) then
  189. list.concat(Tai_const.Create_32bit(longint(tordconstnode(n).value.svalue)))
  190. else
  191. do_error;
  192. end;
  193. pasbool64,
  194. bool64bit :
  195. begin
  196. if is_constboolnode(n) then
  197. list.concat(Tai_const.Create_64bit(int64(tordconstnode(n).value.svalue)))
  198. else
  199. do_error;
  200. end;
  201. uchar :
  202. begin
  203. if is_constwidecharnode(n) then
  204. inserttypeconv(n,cchartype);
  205. if is_constcharnode(n) or
  206. ((m_delphi in current_settings.modeswitches) and
  207. is_constwidecharnode(n) and
  208. (tordconstnode(n).value <= 255)) then
  209. list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)))
  210. else
  211. do_error;
  212. end;
  213. uwidechar :
  214. begin
  215. if is_constcharnode(n) then
  216. inserttypeconv(n,cwidechartype);
  217. if is_constwidecharnode(n) then
  218. list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)))
  219. else
  220. do_error;
  221. end;
  222. s8bit,u8bit,
  223. u16bit,s16bit,
  224. s32bit,u32bit,
  225. s64bit,u64bit :
  226. begin
  227. if is_constintnode(n) then
  228. begin
  229. testrange(def,tordconstnode(n).value,false,false);
  230. case def.size of
  231. 1 :
  232. list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value.svalue)));
  233. 2 :
  234. list.concat(Tai_const.Create_16bit(word(tordconstnode(n).value.svalue)));
  235. 4 :
  236. list.concat(Tai_const.Create_32bit(longint(tordconstnode(n).value.svalue)));
  237. 8 :
  238. list.concat(Tai_const.Create_64bit(tordconstnode(n).value.svalue));
  239. end;
  240. end
  241. else
  242. do_error;
  243. end;
  244. scurrency:
  245. begin
  246. if is_constintnode(n) then
  247. intvalue := tordconstnode(n).value
  248. { allow bootstrapping }
  249. else if is_constrealnode(n) then
  250. intvalue:=PInt64(@trealconstnode(n).value_currency)^
  251. else
  252. begin
  253. intvalue:=0;
  254. IncompatibleTypes(n.resultdef, def);
  255. end;
  256. list.concat(Tai_const.Create_64bit(intvalue));
  257. end;
  258. else
  259. internalerror(200611052);
  260. end;
  261. n.free;
  262. end;
  263. procedure parse_floatdef(list:tasmlist;def:tfloatdef);
  264. var
  265. n : tnode;
  266. value : bestreal;
  267. begin
  268. n:=comp_expr(true,false);
  269. if is_constrealnode(n) then
  270. value:=trealconstnode(n).value_real
  271. else if is_constintnode(n) then
  272. value:=tordconstnode(n).value
  273. else if is_constnode(n) then
  274. IncompatibleTypes(n.resultdef, def)
  275. else
  276. Message(parser_e_illegal_expression);
  277. case def.floattype of
  278. s32real :
  279. list.concat(Tai_real_32bit.Create(ts32real(value)));
  280. s64real :
  281. {$ifdef ARM}
  282. if is_double_hilo_swapped then
  283. list.concat(Tai_real_64bit.Create_hiloswapped(ts64real(value)))
  284. else
  285. {$endif ARM}
  286. list.concat(Tai_real_64bit.Create(ts64real(value)));
  287. s80real :
  288. list.concat(Tai_real_80bit.Create(value,s80floattype.size));
  289. sc80real :
  290. list.concat(Tai_real_80bit.Create(value,sc80floattype.size));
  291. s64comp :
  292. { the round is necessary for native compilers where comp isn't a float }
  293. list.concat(Tai_comp_64bit.Create(round(value)));
  294. s64currency:
  295. list.concat(Tai_comp_64bit.Create(round(value*10000)));
  296. s128real:
  297. list.concat(Tai_real_128bit.Create(value));
  298. else
  299. internalerror(200611053);
  300. end;
  301. n.free;
  302. end;
  303. procedure parse_classrefdef(list:tasmlist;def:tclassrefdef);
  304. var
  305. n : tnode;
  306. begin
  307. n:=comp_expr(true,false);
  308. case n.nodetype of
  309. loadvmtaddrn:
  310. begin
  311. if not Tobjectdef(tclassrefdef(n.resultdef).pointeddef).is_related(tobjectdef(def.pointeddef)) then
  312. IncompatibleTypes(n.resultdef, def);
  313. list.concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(n.resultdef).pointeddef).vmt_mangledname)));
  314. { update wpo info }
  315. if not assigned(current_procinfo) or
  316. (po_inline in current_procinfo.procdef.procoptions) or
  317. wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
  318. tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type;
  319. end;
  320. niln:
  321. list.concat(Tai_const.Create_sym(nil));
  322. else if is_constnode(n) then
  323. IncompatibleTypes(n.resultdef, def)
  324. else
  325. Message(parser_e_illegal_expression);
  326. end;
  327. n.free;
  328. end;
  329. procedure parse_pointerdef(list:tasmlist;def:tpointerdef);
  330. var
  331. hp,p : tnode;
  332. srsym : tsym;
  333. pd : tprocdef;
  334. ca : pchar;
  335. pw : pcompilerwidestring;
  336. i,len : longint;
  337. base,
  338. offset : aint;
  339. v : Tconstexprint;
  340. ll : tasmlabel;
  341. varalign : shortint;
  342. begin
  343. p:=comp_expr(true,false);
  344. { remove equal typecasts for pointer/nil addresses }
  345. if (p.nodetype=typeconvn) then
  346. with Ttypeconvnode(p) do
  347. if (left.nodetype in [addrn,niln]) and equal_defs(def,p.resultdef) then
  348. begin
  349. hp:=left;
  350. left:=nil;
  351. p.free;
  352. p:=hp;
  353. end;
  354. { allows horrible ofs(typeof(TButton)^) code !! }
  355. if (p.nodetype=addrn) then
  356. with Taddrnode(p) do
  357. if left.nodetype=derefn then
  358. begin
  359. hp:=tderefnode(left).left;
  360. tderefnode(left).left:=nil;
  361. p.free;
  362. p:=hp;
  363. end;
  364. { const pointer ? }
  365. if (p.nodetype = pointerconstn) then
  366. begin
  367. {$if sizeof(TConstPtrUInt)=8}
  368. list.concat(Tai_const.Create_64bit(int64(tpointerconstnode(p).value)));
  369. {$else}
  370. {$if sizeof(TConstPtrUInt)=4}
  371. list.concat(Tai_const.Create_32bit(longint(tpointerconstnode(p).value)));
  372. {$else}
  373. internalerror(200404122);
  374. {$endif} {$endif}
  375. end
  376. { nil pointer ? }
  377. else if p.nodetype=niln then
  378. list.concat(Tai_const.Create_sym(nil))
  379. { maybe pchar ? }
  380. else
  381. if is_char(def.pointeddef) and
  382. (p.nodetype<>addrn) then
  383. begin
  384. current_asmdata.getdatalabel(ll);
  385. list.concat(Tai_const.Create_sym(ll));
  386. if p.nodetype=stringconstn then
  387. varalign:=size_2_align(tstringconstnode(p).len)
  388. else
  389. varalign:=0;
  390. varalign:=const_align(varalign);
  391. new_section(current_asmdata.asmlists[al_const], sec_rodata, ll.name, varalign);
  392. current_asmdata.asmlists[al_const].concat(Tai_label.Create(ll));
  393. if p.nodetype=stringconstn then
  394. begin
  395. len:=tstringconstnode(p).len;
  396. { For tp7 the maximum lentgh can be 255 }
  397. if (m_tp7 in current_settings.modeswitches) and
  398. (len>255) then
  399. len:=255;
  400. getmem(ca,len+2);
  401. move(tstringconstnode(p).value_str^,ca^,len+1);
  402. current_asmdata.asmlists[al_const].concat(Tai_string.Create_pchar(ca,len+1));
  403. end
  404. else
  405. if is_constcharnode(p) then
  406. current_asmdata.asmlists[al_const].concat(Tai_string.Create(char(byte(tordconstnode(p).value.svalue))+#0))
  407. else
  408. IncompatibleTypes(p.resultdef, def);
  409. end
  410. { maybe pwidechar ? }
  411. else
  412. if is_widechar(def.pointeddef) and
  413. (p.nodetype<>addrn) then
  414. begin
  415. current_asmdata.getdatalabel(ll);
  416. list.concat(Tai_const.Create_sym(ll));
  417. current_asmdata.asmlists[al_typedconsts].concat(tai_align.create(const_align(sizeof(pint))));
  418. current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(ll));
  419. if (p.nodetype in [stringconstn,ordconstn]) then
  420. begin
  421. { convert to widestring stringconstn }
  422. inserttypeconv(p,cwidestringtype);
  423. if (p.nodetype=stringconstn) and
  424. (tstringconstnode(p).cst_type in [cst_widestring,cst_unicodestring]) then
  425. begin
  426. pw:=pcompilerwidestring(tstringconstnode(p).value_str);
  427. for i:=0 to tstringconstnode(p).len-1 do
  428. current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(pw^.data[i]));
  429. { ending #0 }
  430. current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(0))
  431. end;
  432. end
  433. else
  434. IncompatibleTypes(p.resultdef, def);
  435. end
  436. else
  437. if (p.nodetype=addrn) or
  438. is_proc2procvar_load(p,pd) then
  439. begin
  440. { insert typeconv }
  441. inserttypeconv(p,def);
  442. hp:=p;
  443. while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
  444. hp:=tunarynode(hp).left;
  445. if (hp.nodetype=loadn) then
  446. begin
  447. hp:=p;
  448. offset:=0;
  449. while assigned(hp) and (hp.nodetype<>loadn) do
  450. begin
  451. case hp.nodetype of
  452. vecn :
  453. begin
  454. case tvecnode(hp).left.resultdef.typ of
  455. stringdef :
  456. begin
  457. { this seems OK for shortstring and ansistrings PM }
  458. { it is wrong for widestrings !! }
  459. len:=1;
  460. base:=0;
  461. end;
  462. arraydef :
  463. begin
  464. if not is_packed_array(tvecnode(hp).left.resultdef) then
  465. begin
  466. len:=tarraydef(tvecnode(hp).left.resultdef).elesize;
  467. base:=tarraydef(tvecnode(hp).left.resultdef).lowrange;
  468. end
  469. else
  470. begin
  471. Message(parser_e_packed_dynamic_open_array);
  472. len:=1;
  473. base:=0;
  474. end;
  475. end
  476. else
  477. Message(parser_e_illegal_expression);
  478. end;
  479. if is_constintnode(tvecnode(hp).right) then
  480. begin
  481. {Prevent overflow.}
  482. v:=get_ordinal_value(tvecnode(hp).right)-base;
  483. if (v<int64(low(offset))) or (v>int64(high(offset))) then
  484. message(parser_e_range_check_error);
  485. if high(offset)-offset div len>v then
  486. inc(offset,len*v.svalue)
  487. else
  488. message(parser_e_range_check_error);
  489. end
  490. else
  491. Message(parser_e_illegal_expression);
  492. end;
  493. subscriptn :
  494. inc(offset,tsubscriptnode(hp).vs.fieldoffset);
  495. typeconvn :
  496. begin
  497. if not(ttypeconvnode(hp).convtype in [tc_equal,tc_proc_2_procvar]) then
  498. Message(parser_e_illegal_expression);
  499. end;
  500. addrn :
  501. ;
  502. else
  503. Message(parser_e_illegal_expression);
  504. end;
  505. hp:=tunarynode(hp).left;
  506. end;
  507. srsym:=tloadnode(hp).symtableentry;
  508. case srsym.typ of
  509. procsym :
  510. begin
  511. pd:=tprocdef(tprocsym(srsym).ProcdefList[0]);
  512. if Tprocsym(srsym).ProcdefList.Count>1 then
  513. Message(parser_e_no_overloaded_procvars);
  514. if po_abstractmethod in pd.procoptions then
  515. Message(type_e_cant_take_address_of_abstract_method)
  516. else
  517. list.concat(Tai_const.Createname(pd.mangledname,offset));
  518. end;
  519. staticvarsym :
  520. list.concat(Tai_const.Createname(tstaticvarsym(srsym).mangledname,offset));
  521. labelsym :
  522. list.concat(Tai_const.Createname(tlabelsym(srsym).mangledname,offset));
  523. constsym :
  524. if tconstsym(srsym).consttyp=constresourcestring then
  525. list.concat(Tai_const.Createname(make_mangledname('RESSTR',tconstsym(srsym).owner,tconstsym(srsym).name),sizeof(pint)))
  526. else
  527. Message(type_e_variable_id_expected);
  528. else
  529. Message(type_e_variable_id_expected);
  530. end;
  531. end
  532. else
  533. Message(parser_e_illegal_expression);
  534. end
  535. else
  536. { allow typeof(Object type)}
  537. if (p.nodetype=inlinen) and
  538. (tinlinenode(p).inlinenumber=in_typeof_x) then
  539. begin
  540. if (tinlinenode(p).left.nodetype=typen) then
  541. begin
  542. list.concat(Tai_const.createname(
  543. tobjectdef(tinlinenode(p).left.resultdef).vmt_mangledname,0));
  544. end
  545. else
  546. Message(parser_e_illegal_expression);
  547. end
  548. else
  549. Message(parser_e_illegal_expression);
  550. p.free;
  551. end;
  552. procedure parse_setdef(list:tasmlist;def:tsetdef);
  553. type
  554. setbytes = array[0..31] of byte;
  555. Psetbytes = ^setbytes;
  556. var
  557. p : tnode;
  558. i : longint;
  559. begin
  560. p:=comp_expr(true,false);
  561. if p.nodetype=setconstn then
  562. begin
  563. { be sure to convert to the correct result, else
  564. it can generate smallset data instead of normalset (PFV) }
  565. inserttypeconv(p,def);
  566. { we only allow const sets }
  567. if (p.nodetype<>setconstn) or
  568. assigned(tsetconstnode(p).left) then
  569. Message(parser_e_illegal_expression)
  570. else
  571. begin
  572. tsetconstnode(p).adjustforsetbase;
  573. { this writing is endian-dependant }
  574. if source_info.endian = target_info.endian then
  575. begin
  576. for i:=0 to p.resultdef.size-1 do
  577. list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[i]));
  578. end
  579. else
  580. begin
  581. for i:=0 to p.resultdef.size-1 do
  582. list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(p).value_set)^[i])));
  583. end;
  584. end;
  585. end
  586. else
  587. Message(parser_e_illegal_expression);
  588. p.free;
  589. end;
  590. procedure parse_enumdef(list:tasmlist;def:tenumdef);
  591. var
  592. p : tnode;
  593. begin
  594. p:=comp_expr(true,false);
  595. if p.nodetype=ordconstn then
  596. begin
  597. if equal_defs(p.resultdef,def) or
  598. is_subequal(p.resultdef,def) then
  599. begin
  600. case longint(p.resultdef.size) of
  601. 1 : list.concat(Tai_const.Create_8bit(Byte(tordconstnode(p).value.svalue)));
  602. 2 : list.concat(Tai_const.Create_16bit(Word(tordconstnode(p).value.svalue)));
  603. 4 : list.concat(Tai_const.Create_32bit(Longint(tordconstnode(p).value.svalue)));
  604. end;
  605. end
  606. else
  607. IncompatibleTypes(p.resultdef,def);
  608. end
  609. else
  610. Message(parser_e_illegal_expression);
  611. p.free;
  612. end;
  613. procedure parse_stringdef(const hr:threc;def:tstringdef);
  614. var
  615. n : tnode;
  616. strlength : aint;
  617. strval : pchar;
  618. strch : char;
  619. ll : tasmlabel;
  620. ca : pchar;
  621. winlike : boolean;
  622. hsym : tconstsym;
  623. begin
  624. n:=comp_expr(true,false);
  625. { load strval and strlength of the constant tree }
  626. if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) or
  627. ((n.nodetype=typen) and is_interfacecorba(ttypenode(n).typedef)) then
  628. begin
  629. { convert to the expected string type so that
  630. for widestrings strval is a pcompilerwidestring }
  631. inserttypeconv(n,def);
  632. if (not codegenerror) and
  633. (n.nodetype=stringconstn) then
  634. begin
  635. strlength:=tstringconstnode(n).len;
  636. strval:=tstringconstnode(n).value_str;
  637. end
  638. else
  639. begin
  640. { an error occurred trying to convert the result to a string }
  641. strlength:=-1;
  642. { it's possible that the type conversion could not be
  643. evaluated at compile-time }
  644. if not codegenerror then
  645. CGMessage(parser_e_widestring_to_ansi_compile_time);
  646. end;
  647. end
  648. else if is_constcharnode(n) then
  649. begin
  650. { strval:=pchar(@tordconstnode(n).value);
  651. THIS FAIL on BIG_ENDIAN MACHINES PM }
  652. strch:=chr(tordconstnode(n).value.svalue and $ff);
  653. strval:=@strch;
  654. strlength:=1
  655. end
  656. else if is_constresourcestringnode(n) then
  657. begin
  658. hsym:=tconstsym(tloadnode(n).symtableentry);
  659. strval:=pchar(hsym.value.valueptr);
  660. strlength:=hsym.value.len;
  661. { Delphi-compatible (mis)feature:
  662. Link AnsiString constants to their initializing resourcestring,
  663. enabling them to be (re)translated at runtime.
  664. Wide/UnicodeString are currently rejected above (with incorrect error message).
  665. ShortStrings cannot be handled unless another table is built for them;
  666. considering this acceptable, because Delphi rejects them altogether.
  667. }
  668. if (not is_shortstring(def)) and
  669. ((hr.origsym.owner.symtablelevel<=main_program_level) or
  670. (hr.origblock=bt_const)) then
  671. begin
  672. current_asmdata.ResStrInits.Concat(
  673. TTCInitItem.Create(hr.origsym,hr.offset,
  674. current_asmdata.RefAsmSymbol(make_mangledname('RESSTR',hsym.owner,hsym.name)))
  675. );
  676. Include(hr.origsym.varoptions,vo_force_finalize);
  677. end;
  678. end
  679. else
  680. begin
  681. Message(parser_e_illegal_expression);
  682. strlength:=-1;
  683. end;
  684. if strlength>=0 then
  685. begin
  686. case def.stringtype of
  687. st_shortstring:
  688. begin
  689. if strlength>=def.size then
  690. begin
  691. message2(parser_w_string_too_long,strpas(strval),tostr(def.size-1));
  692. strlength:=def.size-1;
  693. end;
  694. hr.list.concat(Tai_const.Create_8bit(strlength));
  695. { this can also handle longer strings }
  696. getmem(ca,strlength+1);
  697. move(strval^,ca^,strlength);
  698. ca[strlength]:=#0;
  699. hr.list.concat(Tai_string.Create_pchar(ca,strlength));
  700. { fillup with spaces if size is shorter }
  701. if def.size>strlength then
  702. begin
  703. getmem(ca,def.size-strlength);
  704. { def.size contains also the leading length, so we }
  705. { we have to subtract one }
  706. fillchar(ca[0],def.size-strlength-1,' ');
  707. ca[def.size-strlength-1]:=#0;
  708. { this can also handle longer strings }
  709. hr.list.concat(Tai_string.Create_pchar(ca,def.size-strlength-1));
  710. end;
  711. end;
  712. st_ansistring:
  713. begin
  714. { an empty ansi string is nil! }
  715. if (strlength=0) then
  716. ll := nil
  717. else
  718. ll := emit_ansistring_const(current_asmdata.asmlists[al_const],strval,strlength);
  719. hr.list.concat(Tai_const.Create_sym(ll));
  720. end;
  721. st_unicodestring,
  722. st_widestring:
  723. begin
  724. { an empty wide/unicode string is nil! }
  725. if (strlength=0) then
  726. ll := nil
  727. else
  728. begin
  729. winlike := (def.stringtype=st_widestring) and (tf_winlikewidestring in target_info.flags);
  730. ll := emit_unicodestring_const(current_asmdata.asmlists[al_const],
  731. strval,
  732. winlike);
  733. { Collect Windows widestrings that need initialization at startup.
  734. Local initialized vars are excluded because they are initialized
  735. at function entry instead. }
  736. if winlike and ((hr.origsym.owner.symtablelevel <= main_program_level) or
  737. (hr.origblock=bt_const)) then
  738. begin
  739. current_asmdata.WideInits.Concat(
  740. TTCInitItem.Create(hr.origsym, hr.offset, ll)
  741. );
  742. ll := nil;
  743. Include(hr.origsym.varoptions, vo_force_finalize);
  744. end;
  745. end;
  746. hr.list.concat(Tai_const.Create_sym(ll));
  747. end;
  748. else
  749. internalerror(200107081);
  750. end;
  751. end;
  752. n.free;
  753. end;
  754. { parse a single constant and add it to the packed const info }
  755. { represented by curval etc (see explanation of bitpackval for }
  756. { what the different parameters mean) }
  757. function parse_single_packed_const(list: tasmlist; def: tdef; var bp: tbitpackedval): boolean;
  758. var
  759. n : tnode;
  760. begin
  761. result:=true;
  762. n:=comp_expr(true,false);
  763. if (n.nodetype <> ordconstn) or
  764. (not equal_defs(n.resultdef,def) and
  765. not is_subequal(n.resultdef,def)) then
  766. begin
  767. n.free;
  768. incompatibletypes(n.resultdef,def);
  769. consume_all_until(_SEMICOLON);
  770. result:=false;
  771. exit;
  772. end;
  773. if (Tordconstnode(n).value<qword(low(Aword))) or (Tordconstnode(n).value>qword(high(Aword))) then
  774. message(parser_e_range_check_error)
  775. else
  776. bitpackval(Tordconstnode(n).value.uvalue,bp);
  777. if (bp.curbitoffset>=AIntBits) then
  778. flush_packed_value(list,bp);
  779. n.free;
  780. end;
  781. { parses a packed array constant }
  782. procedure parse_packed_array_def(list: tasmlist; def: tarraydef);
  783. var
  784. i : aint;
  785. bp : tbitpackedval;
  786. begin
  787. if not(def.elementdef.typ in [orddef,enumdef]) then
  788. internalerror(2007022010);
  789. { begin of the array }
  790. consume(_LKLAMMER);
  791. initbitpackval(bp,def.elepackedbitsize);
  792. i:=def.lowrange;
  793. { can't use for-loop, fails when cross-compiling from }
  794. { 32 to 64 bit because i is then 64 bit }
  795. while (i<def.highrange) do
  796. begin
  797. { get next item of the packed array }
  798. if not parse_single_packed_const(list,def.elementdef,bp) then
  799. exit;
  800. consume(_COMMA);
  801. inc(i);
  802. end;
  803. { final item }
  804. if not parse_single_packed_const(list,def.elementdef,bp) then
  805. exit;
  806. { flush final incomplete value if necessary }
  807. if (bp.curbitoffset <> 0) then
  808. flush_packed_value(list,bp);
  809. consume(_RKLAMMER);
  810. end;
  811. procedure parse_arraydef(hr:threc;def:tarraydef);
  812. var
  813. n : tnode;
  814. i : longint;
  815. len : asizeint;
  816. ch : array[0..1] of char;
  817. ca : pbyte;
  818. int_const: tai_const;
  819. char_size: integer;
  820. begin
  821. { dynamic array nil }
  822. if is_dynamic_array(def) then
  823. begin
  824. { Only allow nil initialization }
  825. consume(_NIL);
  826. hr.list.concat(Tai_const.Create_sym(nil));
  827. end
  828. { packed array constant }
  829. else if is_packed_array(def) and
  830. ((def.elepackedbitsize mod 8 <> 0) or
  831. not ispowerof2(def.elepackedbitsize div 8,i)) then
  832. begin
  833. parse_packed_array_def(hr.list,def);
  834. end
  835. { normal array const between brackets }
  836. else if try_to_consume(_LKLAMMER) then
  837. begin
  838. hr.offset:=0;
  839. for i:=def.lowrange to def.highrange-1 do
  840. begin
  841. read_typed_const_data(hr,def.elementdef);
  842. Inc(hr.offset,def.elementdef.size);
  843. if token=_RKLAMMER then
  844. begin
  845. Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
  846. consume(_RKLAMMER);
  847. exit;
  848. end
  849. else
  850. consume(_COMMA);
  851. end;
  852. read_typed_const_data(hr,def.elementdef);
  853. consume(_RKLAMMER);
  854. end
  855. { if array of char then we allow also a string }
  856. else if is_anychar(def.elementdef) then
  857. begin
  858. char_size:=def.elementdef.size;
  859. n:=comp_expr(true,false);
  860. if n.nodetype=stringconstn then
  861. begin
  862. len:=tstringconstnode(n).len;
  863. case char_size of
  864. 1:
  865. ca:=pointer(tstringconstnode(n).value_str);
  866. 2:
  867. begin
  868. inserttypeconv(n,cwidestringtype);
  869. if n.nodetype<>stringconstn then
  870. internalerror(2010033003);
  871. ca:=pointer(pcompilerwidestring(tstringconstnode(n).value_str)^.data)
  872. end;
  873. else
  874. internalerror(2010033005);
  875. end;
  876. { For tp7 the maximum lentgh can be 255 }
  877. if (m_tp7 in current_settings.modeswitches) and
  878. (len>255) then
  879. len:=255;
  880. end
  881. else if is_constcharnode(n) then
  882. begin
  883. case char_size of
  884. 1:
  885. ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
  886. 2:
  887. begin
  888. inserttypeconv(n,cwidechartype);
  889. if not is_constwidecharnode(n) then
  890. internalerror(2010033001);
  891. widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
  892. end;
  893. else
  894. internalerror(2010033002);
  895. end;
  896. ca:=@ch;
  897. len:=1;
  898. end
  899. else
  900. begin
  901. Message(parser_e_illegal_expression);
  902. len:=0;
  903. end;
  904. if len>(def.highrange-def.lowrange+1) then
  905. Message(parser_e_string_larger_array);
  906. for i:=0 to def.highrange-def.lowrange do
  907. begin
  908. if i<len then
  909. begin
  910. case char_size of
  911. 1:
  912. int_const:=Tai_const.Create_char(char_size,pbyte(ca)^);
  913. 2:
  914. int_const:=Tai_const.Create_char(char_size,pword(ca)^);
  915. else
  916. internalerror(2010033004);
  917. end;
  918. inc(ca, char_size);
  919. end
  920. else
  921. {Fill the remaining positions with #0.}
  922. int_const:=Tai_const.Create_char(char_size,0);
  923. hr.list.concat(int_const)
  924. end;
  925. n.free;
  926. end
  927. else
  928. begin
  929. { we want the ( }
  930. consume(_LKLAMMER);
  931. end;
  932. end;
  933. procedure parse_procvardef(list:tasmlist;def:tprocvardef);
  934. var
  935. tmpn,n : tnode;
  936. pd : tprocdef;
  937. begin
  938. { Procvars and pointers are no longer compatible. }
  939. { under tp: =nil or =var under fpc: =nil or =@var }
  940. if try_to_consume(_NIL) then
  941. begin
  942. list.concat(Tai_const.Create_sym(nil));
  943. if not def.is_addressonly then
  944. list.concat(Tai_const.Create_sym(nil));
  945. exit;
  946. end;
  947. { you can't assign a value other than NIL to a typed constant }
  948. { which is a "procedure of object", because this also requires }
  949. { address of an object/class instance, which is not known at }
  950. { compile time (JM) }
  951. if (po_methodpointer in def.procoptions) then
  952. Message(parser_e_no_procvarobj_const);
  953. { parse the rest too, so we can continue with error checking }
  954. getprocvardef:=def;
  955. n:=comp_expr(true,false);
  956. getprocvardef:=nil;
  957. if codegenerror then
  958. begin
  959. n.free;
  960. exit;
  961. end;
  962. { let type conversion check everything needed }
  963. inserttypeconv(n,def);
  964. if codegenerror then
  965. begin
  966. n.free;
  967. exit;
  968. end;
  969. { remove typeconvs, that will normally insert a lea
  970. instruction which is not necessary for us }
  971. while n.nodetype=typeconvn do
  972. begin
  973. tmpn:=ttypeconvnode(n).left;
  974. ttypeconvnode(n).left:=nil;
  975. n.free;
  976. n:=tmpn;
  977. end;
  978. { remove addrn which we also don't need here }
  979. if n.nodetype=addrn then
  980. begin
  981. tmpn:=taddrnode(n).left;
  982. taddrnode(n).left:=nil;
  983. n.free;
  984. n:=tmpn;
  985. end;
  986. { we now need to have a loadn with a procsym }
  987. if (n.nodetype=loadn) and
  988. (tloadnode(n).symtableentry.typ=procsym) then
  989. begin
  990. pd:=tloadnode(n).procdef;
  991. list.concat(Tai_const.createname(pd.mangledname,0));
  992. { nested procvar typed consts can only be initialised with nil
  993. (checked above) or with a global procedure (checked here),
  994. because in other cases we need a valid frame pointer }
  995. if is_nested_pd(def) then
  996. begin
  997. if is_nested_pd(pd) then
  998. Message(parser_e_no_procvarnested_const);
  999. list.concat(Tai_const.Create_sym(nil));
  1000. end
  1001. end
  1002. else
  1003. Message(parser_e_illegal_expression);
  1004. n.free;
  1005. end;
  1006. procedure parse_recorddef(hr:threc;def:trecorddef);
  1007. var
  1008. n : tnode;
  1009. symidx : longint;
  1010. recsym,
  1011. srsym : tsym;
  1012. hs : string;
  1013. sorg,s : TIDString;
  1014. tmpguid : tguid;
  1015. curroffset,
  1016. fillbytes : aint;
  1017. bp : tbitpackedval;
  1018. error,
  1019. is_packed: boolean;
  1020. startoffset: aint;
  1021. procedure handle_stringconstn;
  1022. var
  1023. i : longint;
  1024. begin
  1025. hs:=strpas(tstringconstnode(n).value_str);
  1026. if string2guid(hs,tmpguid) then
  1027. begin
  1028. hr.list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
  1029. hr.list.concat(Tai_const.Create_16bit(tmpguid.D2));
  1030. hr.list.concat(Tai_const.Create_16bit(tmpguid.D3));
  1031. for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
  1032. hr.list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
  1033. end
  1034. else
  1035. Message(parser_e_improper_guid_syntax);
  1036. end;
  1037. var
  1038. i : longint;
  1039. begin
  1040. { GUID }
  1041. if (def=rec_tguid) and (token=_ID) then
  1042. begin
  1043. n:=comp_expr(true,false);
  1044. if n.nodetype=stringconstn then
  1045. handle_stringconstn
  1046. else
  1047. begin
  1048. inserttypeconv(n,rec_tguid);
  1049. if n.nodetype=guidconstn then
  1050. begin
  1051. tmpguid:=tguidconstnode(n).value;
  1052. hr.list.concat(Tai_const.Create_32bit(longint(tmpguid.D1)));
  1053. hr.list.concat(Tai_const.Create_16bit(tmpguid.D2));
  1054. hr.list.concat(Tai_const.Create_16bit(tmpguid.D3));
  1055. for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
  1056. hr.list.concat(Tai_const.Create_8bit(tmpguid.D4[i]));
  1057. end
  1058. else
  1059. Message(parser_e_illegal_expression);
  1060. end;
  1061. n.free;
  1062. exit;
  1063. end;
  1064. if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
  1065. begin
  1066. n:=comp_expr(true,false);
  1067. inserttypeconv(n,cshortstringtype);
  1068. if n.nodetype=stringconstn then
  1069. handle_stringconstn
  1070. else
  1071. Message(parser_e_illegal_expression);
  1072. n.free;
  1073. exit;
  1074. end;
  1075. { bitpacked record? }
  1076. is_packed:=is_packed_record_or_object(def);
  1077. if (is_packed) then
  1078. begin
  1079. { loadbitsize = 8, bitpacked records are always padded to }
  1080. { a multiple of a byte. packedbitsize will be set separately }
  1081. { for each field }
  1082. initbitpackval(bp,0);
  1083. bp.loadbitsize:=8;
  1084. end;
  1085. { normal record }
  1086. consume(_LKLAMMER);
  1087. curroffset:=0;
  1088. symidx:=0;
  1089. sorg:='';
  1090. srsym:=tsym(def.symtable.SymList[symidx]);
  1091. recsym := nil;
  1092. startoffset:=hr.offset;
  1093. while token<>_RKLAMMER do
  1094. begin
  1095. s:=pattern;
  1096. sorg:=orgpattern;
  1097. consume(_ID);
  1098. consume(_COLON);
  1099. error := false;
  1100. recsym := tsym(def.symtable.Find(s));
  1101. if not assigned(recsym) then
  1102. begin
  1103. Message1(sym_e_illegal_field,sorg);
  1104. error := true;
  1105. end;
  1106. if (not error) and
  1107. (not assigned(srsym) or
  1108. (s <> srsym.name)) then
  1109. { possible variant record (JM) }
  1110. begin
  1111. { All parts of a variant start at the same offset }
  1112. { Also allow jumping from one variant part to another, }
  1113. { as long as the offsets match }
  1114. if (assigned(srsym) and
  1115. (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
  1116. { srsym is not assigned after parsing w2 in the }
  1117. { typed const in the next example: }
  1118. { type tr = record case byte of }
  1119. { 1: (l1,l2: dword); }
  1120. { 2: (w1,w2: word); }
  1121. { end; }
  1122. { const r: tr = (w1:1;w2:1;l2:5); }
  1123. (tfieldvarsym(recsym).fieldoffset = curroffset) then
  1124. begin
  1125. srsym := recsym;
  1126. symidx := def.symtable.SymList.indexof(srsym)
  1127. end
  1128. { going backwards isn't allowed in any mode }
  1129. else if (tfieldvarsym(recsym).fieldoffset<curroffset) then
  1130. begin
  1131. Message(parser_e_invalid_record_const);
  1132. error := true;
  1133. end
  1134. { Delphi allows you to skip fields }
  1135. else if (m_delphi in current_settings.modeswitches) then
  1136. begin
  1137. Message1(parser_w_skipped_fields_before,sorg);
  1138. srsym := recsym;
  1139. end
  1140. { FPC and TP don't }
  1141. else
  1142. begin
  1143. Message1(parser_e_skipped_fields_before,sorg);
  1144. error := true;
  1145. end;
  1146. end;
  1147. if error then
  1148. consume_all_until(_SEMICOLON)
  1149. else
  1150. begin
  1151. { if needed fill (alignment) }
  1152. if tfieldvarsym(srsym).fieldoffset>curroffset then
  1153. begin
  1154. if not(is_packed) then
  1155. fillbytes:=tfieldvarsym(srsym).fieldoffset-curroffset
  1156. else
  1157. begin
  1158. flush_packed_value(hr.list,bp);
  1159. { curoffset is now aligned to the next byte }
  1160. curroffset:=align(curroffset,8);
  1161. { offsets are in bits in this case }
  1162. fillbytes:=(tfieldvarsym(srsym).fieldoffset-curroffset) div 8;
  1163. end;
  1164. for i:=1 to fillbytes do
  1165. hr.list.concat(Tai_const.Create_8bit(0))
  1166. end;
  1167. { new position }
  1168. curroffset:=tfieldvarsym(srsym).fieldoffset;
  1169. if not(is_packed) then
  1170. inc(curroffset,tfieldvarsym(srsym).vardef.size)
  1171. else
  1172. inc(curroffset,tfieldvarsym(srsym).vardef.packedbitsize);
  1173. { read the data }
  1174. if not(is_packed) or
  1175. { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
  1176. not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
  1177. begin
  1178. if is_packed then
  1179. begin
  1180. flush_packed_value(hr.list,bp);
  1181. curroffset:=align(curroffset,8);
  1182. end;
  1183. hr.offset:=startoffset+tfieldvarsym(srsym).fieldoffset;
  1184. read_typed_const_data(hr,tfieldvarsym(srsym).vardef);
  1185. end
  1186. else
  1187. begin
  1188. bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
  1189. parse_single_packed_const(hr.list,tfieldvarsym(srsym).vardef,bp);
  1190. end;
  1191. { keep previous field for checking whether whole }
  1192. { record was initialized (JM) }
  1193. recsym := srsym;
  1194. { goto next field }
  1195. inc(symidx);
  1196. if symidx<def.symtable.SymList.Count then
  1197. srsym:=tsym(def.symtable.SymList[symidx])
  1198. else
  1199. srsym:=nil;
  1200. if token=_SEMICOLON then
  1201. consume(_SEMICOLON)
  1202. else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
  1203. consume(_COMMA)
  1204. else
  1205. break;
  1206. end;
  1207. end;
  1208. { are there any fields left, but don't complain if there only
  1209. come other variant parts after the last initialized field }
  1210. if assigned(srsym) and
  1211. (
  1212. (recsym=nil) or
  1213. (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
  1214. ) then
  1215. Message1(parser_w_skipped_fields_after,sorg);
  1216. if not(is_packed) then
  1217. fillbytes:=def.size-curroffset
  1218. else
  1219. begin
  1220. flush_packed_value(hr.list,bp);
  1221. curroffset:=align(curroffset,8);
  1222. fillbytes:=def.size-(curroffset div 8);
  1223. end;
  1224. for i:=1 to fillbytes do
  1225. hr.list.concat(Tai_const.Create_8bit(0));
  1226. consume(_RKLAMMER);
  1227. end;
  1228. { note: hr is passed by value }
  1229. procedure parse_objectdef(hr:threc;def:tobjectdef);
  1230. var
  1231. n : tnode;
  1232. i : longint;
  1233. obj : tobjectdef;
  1234. srsym : tsym;
  1235. st : tsymtable;
  1236. curroffset : aint;
  1237. s,sorg : TIDString;
  1238. vmtwritten : boolean;
  1239. startoffset:aint;
  1240. begin
  1241. { no support for packed object }
  1242. if is_packed_record_or_object(def) then
  1243. begin
  1244. Message(type_e_no_const_packed_record);
  1245. exit;
  1246. end;
  1247. { only allow nil for implicit pointer object types }
  1248. if is_implicit_pointer_object_type(def) then
  1249. begin
  1250. n:=comp_expr(true,false);
  1251. if n.nodetype<>niln then
  1252. begin
  1253. Message(parser_e_type_const_not_possible);
  1254. consume_all_until(_SEMICOLON);
  1255. end
  1256. else
  1257. hr.list.concat(Tai_const.Create_sym(nil));
  1258. n.free;
  1259. exit;
  1260. end;
  1261. { for objects we allow it only if it doesn't contain a vmt }
  1262. if (oo_has_vmt in def.objectoptions) and
  1263. (m_fpc in current_settings.modeswitches) then
  1264. begin
  1265. Message(parser_e_type_object_constants);
  1266. exit;
  1267. end;
  1268. consume(_LKLAMMER);
  1269. startoffset:=hr.offset;
  1270. curroffset:=0;
  1271. vmtwritten:=false;
  1272. while token<>_RKLAMMER do
  1273. begin
  1274. s:=pattern;
  1275. sorg:=orgpattern;
  1276. consume(_ID);
  1277. consume(_COLON);
  1278. srsym:=nil;
  1279. obj:=tobjectdef(def);
  1280. st:=obj.symtable;
  1281. while (srsym=nil) and assigned(st) do
  1282. begin
  1283. srsym:=tsym(st.Find(s));
  1284. if assigned(obj) then
  1285. obj:=obj.childof;
  1286. if assigned(obj) then
  1287. st:=obj.symtable
  1288. else
  1289. st:=nil;
  1290. end;
  1291. if (srsym=nil) or
  1292. (srsym.typ<>fieldvarsym) then
  1293. begin
  1294. if (srsym=nil) then
  1295. Message1(sym_e_id_not_found,sorg)
  1296. else
  1297. Message1(sym_e_illegal_field,sorg);
  1298. consume_all_until(_RKLAMMER);
  1299. break;
  1300. end
  1301. else
  1302. with tfieldvarsym(srsym) do
  1303. begin
  1304. { check position }
  1305. if fieldoffset<curroffset then
  1306. message(parser_e_invalid_record_const);
  1307. { check in VMT needs to be added for TP mode }
  1308. if not(vmtwritten) and
  1309. not(m_fpc in current_settings.modeswitches) and
  1310. (oo_has_vmt in def.objectoptions) and
  1311. (def.vmt_offset<fieldoffset) then
  1312. begin
  1313. for i:=1 to def.vmt_offset-curroffset do
  1314. hr.list.concat(tai_const.create_8bit(0));
  1315. hr.list.concat(tai_const.createname(def.vmt_mangledname,0));
  1316. { this is more general }
  1317. curroffset:=def.vmt_offset + sizeof(pint);
  1318. vmtwritten:=true;
  1319. end;
  1320. { if needed fill }
  1321. if fieldoffset>curroffset then
  1322. for i:=1 to fieldoffset-curroffset do
  1323. hr.list.concat(Tai_const.Create_8bit(0));
  1324. { new position }
  1325. curroffset:=fieldoffset+vardef.size;
  1326. { read the data }
  1327. hr.offset:=startoffset+fieldoffset;
  1328. read_typed_const_data(hr,vardef);
  1329. if not try_to_consume(_SEMICOLON) then
  1330. break;
  1331. end;
  1332. end;
  1333. if not(m_fpc in current_settings.modeswitches) and
  1334. (oo_has_vmt in def.objectoptions) and
  1335. (def.vmt_offset>=curroffset) then
  1336. begin
  1337. for i:=1 to def.vmt_offset-curroffset do
  1338. hr.list.concat(tai_const.create_8bit(0));
  1339. hr.list.concat(tai_const.createname(def.vmt_mangledname,0));
  1340. { this is more general }
  1341. curroffset:=def.vmt_offset + sizeof(pint);
  1342. end;
  1343. for i:=1 to def.size-curroffset do
  1344. hr.list.concat(Tai_const.Create_8bit(0));
  1345. consume(_RKLAMMER);
  1346. end;
  1347. procedure read_typed_const_data(var hr:threc;def:tdef);
  1348. var
  1349. old_block_type : tblock_type;
  1350. begin
  1351. old_block_type:=block_type;
  1352. block_type:=bt_const;
  1353. case def.typ of
  1354. orddef :
  1355. parse_orddef(hr.list,torddef(def));
  1356. floatdef :
  1357. parse_floatdef(hr.list,tfloatdef(def));
  1358. classrefdef :
  1359. parse_classrefdef(hr.list,tclassrefdef(def));
  1360. pointerdef :
  1361. parse_pointerdef(hr.list,tpointerdef(def));
  1362. setdef :
  1363. parse_setdef(hr.list,tsetdef(def));
  1364. enumdef :
  1365. parse_enumdef(hr.list,tenumdef(def));
  1366. stringdef :
  1367. parse_stringdef(hr,tstringdef(def));
  1368. arraydef :
  1369. parse_arraydef(hr,tarraydef(def));
  1370. procvardef:
  1371. parse_procvardef(hr.list,tprocvardef(def));
  1372. recorddef:
  1373. parse_recorddef(hr,trecorddef(def));
  1374. objectdef:
  1375. parse_objectdef(hr,tobjectdef(def));
  1376. errordef:
  1377. begin
  1378. { try to consume something useful }
  1379. if token=_LKLAMMER then
  1380. consume_all_until(_RKLAMMER)
  1381. else
  1382. consume_all_until(_SEMICOLON);
  1383. end;
  1384. else
  1385. Message(parser_e_type_const_not_possible);
  1386. end;
  1387. block_type:=old_block_type;
  1388. end;
  1389. {$maxfpuregisters default}
  1390. procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
  1391. var
  1392. storefilepos : tfileposinfo;
  1393. cursectype : TAsmSectionType;
  1394. hrec : threc;
  1395. section : ansistring;
  1396. begin
  1397. { mark the staticvarsym as typedconst }
  1398. include(sym.varoptions,vo_is_typed_const);
  1399. { The variable has a value assigned }
  1400. sym.varstate:=vs_initialised;
  1401. { the variable can't be placed in a register }
  1402. sym.varregable:=vr_none;
  1403. { generate data for typed const }
  1404. storefilepos:=current_filepos;
  1405. current_filepos:=sym.fileinfo;
  1406. if sym.varspez=vs_const then
  1407. cursectype:=sec_rodata
  1408. else
  1409. cursectype:=sec_data;
  1410. maybe_new_object_file(list);
  1411. hrec.list:=tasmlist.create;
  1412. hrec.origsym:=sym;
  1413. hrec.offset:=0;
  1414. hrec.origblock:=block_type;
  1415. read_typed_const_data(hrec,sym.vardef);
  1416. { Parse hints }
  1417. try_consume_hintdirective(sym.symoptions,sym.deprecatedmsg);
  1418. consume(_SEMICOLON);
  1419. { parse public/external/export/... }
  1420. if not in_structure and
  1421. (
  1422. (
  1423. (token = _ID) and
  1424. (idtoken in [_EXPORT,_EXTERNAL,_WEAKEXTERNAL,_PUBLIC,_CVAR]) and
  1425. (m_cvar_support in current_settings.modeswitches)
  1426. ) or
  1427. (
  1428. (m_mac in current_settings.modeswitches) and
  1429. (
  1430. (cs_external_var in current_settings.localswitches) or
  1431. (cs_externally_visible in current_settings.localswitches)
  1432. )
  1433. )
  1434. ) then
  1435. read_public_and_external(sym);
  1436. { try to parse a section directive }
  1437. if not in_structure and (target_info.system in systems_allow_section) and
  1438. (symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) and
  1439. (idtoken=_SECTION) then
  1440. begin
  1441. try_consume_sectiondirective(section);
  1442. if section<>'' then
  1443. begin
  1444. if (sym.varoptions *[vo_is_external,vo_is_weak_external])<>[] then
  1445. Message(parser_e_externals_no_section);
  1446. if sym.typ<>staticvarsym then
  1447. Message(parser_e_section_no_locals);
  1448. tstaticvarsym(sym).section:=section;
  1449. include(sym.varoptions, vo_has_section);
  1450. end;
  1451. end;
  1452. { only now add items based on the symbolname, because it may }
  1453. { have been modified by the directives parsed above }
  1454. if vo_has_section in sym.varoptions then
  1455. new_section(list,sec_user,sym.section,const_align(sym.vardef.alignment))
  1456. else
  1457. new_section(list,cursectype,lower(sym.mangledname),const_align(sym.vardef.alignment));
  1458. if (sym.owner.symtabletype=globalsymtable) or
  1459. create_smartlink or
  1460. (assigned(current_procinfo) and
  1461. (po_inline in current_procinfo.procdef.procoptions)) or
  1462. DLLSource then
  1463. list.concat(Tai_symbol.Createname_global(sym.mangledname,AT_DATA,0))
  1464. else
  1465. list.concat(Tai_symbol.Createname(sym.mangledname,AT_DATA,0));
  1466. { add the parsed value }
  1467. list.concatlist(hrec.list);
  1468. hrec.list.free;
  1469. list.concat(tai_symbol_end.Createname(sym.mangledname));
  1470. current_filepos:=storefilepos;
  1471. end;
  1472. end.