ptconst.pas 56 KB

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