ngtcon.pas 84 KB

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