ngtcon.pas 75 KB

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