pdecvar.pas 56 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Parses variable declarations. Used for var statement and record
  4. definitions
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pdecvar;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. symsym,symdef;
  23. type
  24. tvar_dec_option=(vd_record,vd_object,vd_threadvar);
  25. tvar_dec_options=set of tvar_dec_option;
  26. function read_property_dec(aclass:tobjectdef):tpropertysym;
  27. procedure read_var_decls(options:Tvar_dec_options);
  28. procedure read_record_fields(options:Tvar_dec_options);
  29. implementation
  30. uses
  31. { common }
  32. cutils,cclasses,
  33. { global }
  34. globtype,globals,tokens,verbose,
  35. systems,
  36. { symtable }
  37. symconst,symbase,symtype,symtable,defutil,defcmp,
  38. fmodule,
  39. { pass 1 }
  40. node,pass_1,aasmdata,
  41. nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,
  42. { codegen }
  43. ncgutil,
  44. { parser }
  45. scanner,
  46. pbase,pexpr,ptype,ptconst,pdecsub,
  47. { link }
  48. import
  49. ;
  50. function read_property_dec(aclass:tobjectdef):tpropertysym;
  51. { convert a node tree to symlist and return the last
  52. symbol }
  53. function parse_symlist(pl:tsymlist;var def:tdef):boolean;
  54. var
  55. idx : longint;
  56. sym : tsym;
  57. srsymtable : tsymtable;
  58. st : tsymtable;
  59. p : tnode;
  60. begin
  61. result:=true;
  62. def:=nil;
  63. if token=_ID then
  64. begin
  65. if assigned(aclass) then
  66. sym:=search_class_member(aclass,pattern)
  67. else
  68. searchsym(pattern,sym,srsymtable);
  69. if assigned(sym) then
  70. begin
  71. case sym.typ of
  72. fieldvarsym :
  73. begin
  74. if not(sp_private in current_object_option) then
  75. addsymref(sym);
  76. pl.addsym(sl_load,sym);
  77. def:=tfieldvarsym(sym).vartype.def;
  78. end;
  79. procsym :
  80. begin
  81. if not(sp_private in current_object_option) then
  82. addsymref(sym);
  83. pl.addsym(sl_call,sym);
  84. end;
  85. else
  86. begin
  87. Message1(parser_e_illegal_field_or_method,orgpattern);
  88. result:=false;
  89. end;
  90. end;
  91. end
  92. else
  93. begin
  94. Message1(parser_e_illegal_field_or_method,orgpattern);
  95. result:=false;
  96. end;
  97. consume(_ID);
  98. repeat
  99. case token of
  100. _ID,
  101. _SEMICOLON :
  102. begin
  103. break;
  104. end;
  105. _POINT :
  106. begin
  107. consume(_POINT);
  108. if assigned(def) then
  109. begin
  110. st:=def.getsymtable(gs_record);
  111. if assigned(st) then
  112. begin
  113. sym:=tsym(st.search(pattern));
  114. if assigned(sym) then
  115. begin
  116. pl.addsym(sl_subscript,sym);
  117. case sym.typ of
  118. fieldvarsym :
  119. def:=tfieldvarsym(sym).vartype.def;
  120. else
  121. begin
  122. Message1(sym_e_illegal_field,orgpattern);
  123. result:=false;
  124. end;
  125. end;
  126. end
  127. else
  128. begin
  129. Message1(sym_e_illegal_field,orgpattern);
  130. result:=false;
  131. end;
  132. end
  133. else
  134. begin
  135. Message(parser_e_invalid_qualifier);
  136. result:=false;
  137. end;
  138. end
  139. else
  140. begin
  141. Message(parser_e_invalid_qualifier);
  142. result:=false;
  143. end;
  144. consume(_ID);
  145. end;
  146. _LECKKLAMMER :
  147. begin
  148. consume(_LECKKLAMMER);
  149. repeat
  150. if def.deftype=arraydef then
  151. begin
  152. idx:=0;
  153. p:=comp_expr(true);
  154. if (not codegenerror) then
  155. begin
  156. if (p.nodetype=ordconstn) then
  157. begin
  158. if compare_defs(p.resulttype.def,tarraydef(def).rangetype.def,nothingn)>=te_equal then
  159. idx:=tordconstnode(p).value
  160. else
  161. IncompatibleTypes(p.resulttype.def,tarraydef(def).rangetype.def);
  162. end
  163. else
  164. Message(type_e_ordinal_expr_expected)
  165. end;
  166. p.free;
  167. pl.addconst(sl_vec,idx,p.resulttype);
  168. def:=tarraydef(def).elementtype.def;
  169. end
  170. else
  171. begin
  172. Message(parser_e_invalid_qualifier);
  173. result:=false;
  174. end;
  175. until not try_to_consume(_COMMA);
  176. consume(_RECKKLAMMER);
  177. end;
  178. else
  179. begin
  180. Message(parser_e_ill_property_access_sym);
  181. result:=false;
  182. break;
  183. end;
  184. end;
  185. until false;
  186. end
  187. else
  188. begin
  189. Message(parser_e_ill_property_access_sym);
  190. result:=false;
  191. end;
  192. end;
  193. var
  194. sym : tsym;
  195. p : tpropertysym;
  196. overriden : tsym;
  197. varspez : tvarspez;
  198. tt : ttype;
  199. arraytype : ttype;
  200. def : tdef;
  201. pt : tnode;
  202. sc : TFPObjectList;
  203. paranr : word;
  204. i : longint;
  205. intfidx: longint;
  206. hreadparavs,
  207. hparavs : tparavarsym;
  208. storedprocdef,
  209. readprocdef,
  210. writeprocdef : tprocvardef;
  211. begin
  212. { Generate temp procvardefs to search for matching read/write
  213. procedures. the readprocdef will store all definitions }
  214. paranr:=0;
  215. readprocdef:=tprocvardef.create(normal_function_level);
  216. writeprocdef:=tprocvardef.create(normal_function_level);
  217. storedprocdef:=tprocvardef.create(normal_function_level);
  218. { make it method pointers }
  219. if assigned(aclass) then
  220. begin
  221. include(readprocdef.procoptions,po_methodpointer);
  222. include(writeprocdef.procoptions,po_methodpointer);
  223. include(storedprocdef.procoptions,po_methodpointer);
  224. end;
  225. { method for stored must return boolean }
  226. storedprocdef.rettype:=booltype;
  227. if token<>_ID then
  228. begin
  229. consume(_ID);
  230. consume(_SEMICOLON);
  231. exit;
  232. end;
  233. { Generate propertysym and insert in symtablestack }
  234. p:=tpropertysym.create(orgpattern);
  235. symtablestack.top.insert(p);
  236. consume(_ID);
  237. { property parameters ? }
  238. if try_to_consume(_LECKKLAMMER) then
  239. begin
  240. if (sp_published in current_object_option) and
  241. not (m_delphi in aktmodeswitches) then
  242. Message(parser_e_cant_publish_that_property);
  243. { create a list of the parameters }
  244. symtablestack.push(readprocdef.parast);
  245. sc:=TFPObjectList.create(false);
  246. inc(testcurobject);
  247. repeat
  248. if try_to_consume(_VAR) then
  249. varspez:=vs_var
  250. else if try_to_consume(_CONST) then
  251. varspez:=vs_const
  252. else if (m_out in aktmodeswitches) and try_to_consume(_OUT) then
  253. varspez:=vs_out
  254. else
  255. varspez:=vs_value;
  256. sc.clear;
  257. repeat
  258. inc(paranr);
  259. hreadparavs:=tparavarsym.create(orgpattern,10*paranr,varspez,generrortype,[]);
  260. readprocdef.parast.insert(hreadparavs);
  261. sc.add(hreadparavs);
  262. consume(_ID);
  263. until not try_to_consume(_COMMA);
  264. if try_to_consume(_COLON) then
  265. begin
  266. if try_to_consume(_ARRAY) then
  267. begin
  268. consume(_OF);
  269. { define range and type of range }
  270. tt.setdef(tarraydef.create(0,-1,s32inttype));
  271. { define field type }
  272. single_type(arraytype,false);
  273. tarraydef(tt.def).setelementtype(arraytype);
  274. end
  275. else
  276. single_type(tt,false);
  277. end
  278. else
  279. tt:=cformaltype;
  280. for i:=0 to sc.count-1 do
  281. begin
  282. hreadparavs:=tparavarsym(sc[i]);
  283. hreadparavs.vartype:=tt;
  284. { also update the writeprocdef }
  285. hparavs:=tparavarsym.create(hreadparavs.realname,hreadparavs.paranr,vs_value,tt,[]);
  286. writeprocdef.parast.insert(hparavs);
  287. end;
  288. until not try_to_consume(_SEMICOLON);
  289. sc.free;
  290. dec(testcurobject);
  291. symtablestack.pop(readprocdef.parast);
  292. consume(_RECKKLAMMER);
  293. { the parser need to know if a property has parameters, the
  294. index parameter doesn't count (PFV) }
  295. if paranr>0 then
  296. include(p.propoptions,ppo_hasparameters);
  297. end;
  298. { overriden property ? }
  299. { force property interface
  300. there is a property parameter
  301. a global property }
  302. if (token=_COLON) or (paranr>0) or (aclass=nil) then
  303. begin
  304. consume(_COLON);
  305. single_type(p.proptype,false);
  306. if (idtoken=_INDEX) then
  307. begin
  308. consume(_INDEX);
  309. pt:=comp_expr(true);
  310. { Only allow enum and integer indexes. Convert all integer
  311. values to s32int to be compatible with delphi, because the
  312. procedure matching requires equal parameters }
  313. if is_constnode(pt) and
  314. is_ordinal(pt.resulttype.def)
  315. {$ifndef cpu64bit}
  316. and (not is_64bitint(pt.resulttype.def))
  317. {$endif cpu64bit}
  318. then
  319. begin
  320. if is_integer(pt.resulttype.def) then
  321. inserttypeconv_internal(pt,s32inttype);
  322. p.index:=tordconstnode(pt).value;
  323. end
  324. else
  325. begin
  326. Message(parser_e_invalid_property_index_value);
  327. p.index:=0;
  328. end;
  329. p.indextype:=pt.resulttype;
  330. include(p.propoptions,ppo_indexed);
  331. { concat a longint to the para templates }
  332. inc(paranr);
  333. hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indextype,[]);
  334. readprocdef.parast.insert(hparavs);
  335. hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indextype,[]);
  336. writeprocdef.parast.insert(hparavs);
  337. hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indextype,[]);
  338. storedprocdef.parast.insert(hparavs);
  339. pt.free;
  340. end;
  341. end
  342. else
  343. begin
  344. { do an property override }
  345. overriden:=search_class_member(aclass.childof,p.name);
  346. if assigned(overriden) and (overriden.typ=propertysym) and not(is_dispinterface(aclass)) then
  347. begin
  348. p.dooverride(tpropertysym(overriden));
  349. end
  350. else
  351. begin
  352. p.proptype:=generrortype;
  353. message(parser_e_no_property_found_to_override);
  354. end;
  355. end;
  356. if ((sp_published in current_object_option) or is_dispinterface(aclass)) and
  357. not(p.proptype.def.is_publishable) then
  358. Message(parser_e_cant_publish_that_property);
  359. if not(is_dispinterface(aclass)) then
  360. begin
  361. if try_to_consume(_READ) then
  362. begin
  363. p.readaccess.clear;
  364. if parse_symlist(p.readaccess,def) then
  365. begin
  366. sym:=p.readaccess.firstsym^.sym;
  367. case sym.typ of
  368. procsym :
  369. begin
  370. { read is function returning the type of the property }
  371. readprocdef.rettype:=p.proptype;
  372. { Insert hidden parameters }
  373. handle_calling_convention(readprocdef);
  374. { search procdefs matching readprocdef }
  375. { we ignore hidden stuff here because the property access symbol might have
  376. non default calling conventions which might change the hidden stuff;
  377. see tw3216.pp (FK) }
  378. p.readaccess.procdef:=Tprocsym(sym).search_procdef_bypara(readprocdef.paras,p.proptype.def,[cpo_allowdefaults,cpo_ignorehidden]);
  379. if not assigned(p.readaccess.procdef) then
  380. Message(parser_e_ill_property_access_sym);
  381. end;
  382. fieldvarsym :
  383. begin
  384. if not assigned(def) then
  385. internalerror(200310071);
  386. if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
  387. begin
  388. { property parameters are allowed if this is
  389. an indexed property, because the index is then
  390. the parameter.
  391. Note: In the help of Kylix it is written
  392. that it isn't allowed, but the compiler accepts it (PFV) }
  393. if (ppo_hasparameters in p.propoptions) then
  394. Message(parser_e_ill_property_access_sym);
  395. end
  396. else
  397. IncompatibleTypes(def,p.proptype.def);
  398. end;
  399. else
  400. Message(parser_e_ill_property_access_sym);
  401. end;
  402. end;
  403. end;
  404. if try_to_consume(_WRITE) then
  405. begin
  406. p.writeaccess.clear;
  407. if parse_symlist(p.writeaccess,def) then
  408. begin
  409. sym:=p.writeaccess.firstsym^.sym;
  410. case sym.typ of
  411. procsym :
  412. begin
  413. { write is a procedure with an extra value parameter
  414. of the of the property }
  415. writeprocdef.rettype:=voidtype;
  416. inc(paranr);
  417. hparavs:=tparavarsym.create('$value',10*paranr,vs_value,p.proptype,[]);
  418. writeprocdef.parast.insert(hparavs);
  419. { Insert hidden parameters }
  420. handle_calling_convention(writeprocdef);
  421. { search procdefs matching writeprocdef }
  422. p.writeaccess.procdef:=Tprocsym(sym).search_procdef_bypara(writeprocdef.paras,writeprocdef.rettype.def,[cpo_allowdefaults]);
  423. if not assigned(p.writeaccess.procdef) then
  424. Message(parser_e_ill_property_access_sym);
  425. end;
  426. fieldvarsym :
  427. begin
  428. if not assigned(def) then
  429. internalerror(200310072);
  430. if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
  431. begin
  432. { property parameters are allowed if this is
  433. an indexed property, because the index is then
  434. the parameter.
  435. Note: In the help of Kylix it is written
  436. that it isn't allowed, but the compiler accepts it (PFV) }
  437. if (ppo_hasparameters in p.propoptions) then
  438. Message(parser_e_ill_property_access_sym);
  439. end
  440. else
  441. IncompatibleTypes(def,p.proptype.def);
  442. end;
  443. else
  444. Message(parser_e_ill_property_access_sym);
  445. end;
  446. end;
  447. end;
  448. end
  449. else
  450. begin
  451. if try_to_consume(_READONLY) then
  452. begin
  453. end
  454. else if try_to_consume(_WRITEONLY) then
  455. begin
  456. end;
  457. if try_to_consume(_DISPID) then
  458. begin
  459. pt:=comp_expr(true);
  460. if is_constintnode(pt) then
  461. // tprocdef(pd).extnumber:=tordconstnode(pt).value
  462. else
  463. Message(parser_e_dispid_must_be_ord_const);
  464. pt.free;
  465. end;
  466. end;
  467. if assigned(aclass) and not(is_dispinterface(aclass)) then
  468. begin
  469. { ppo_stored might be not set by an overridden property }
  470. if not(ppo_is_override in p.propoptions) then
  471. include(p.propoptions,ppo_stored);
  472. if try_to_consume(_STORED) then
  473. begin
  474. include(p.propoptions,ppo_stored);
  475. p.storedaccess.clear;
  476. case token of
  477. _ID:
  478. begin
  479. { in the case that idtoken=_DEFAULT }
  480. { we have to do nothing except }
  481. { setting ppo_stored, it's the same }
  482. { as stored true }
  483. if idtoken<>_DEFAULT then
  484. begin
  485. if parse_symlist(p.storedaccess,def) then
  486. begin
  487. sym:=p.storedaccess.firstsym^.sym;
  488. case sym.typ of
  489. procsym :
  490. begin
  491. { Insert hidden parameters }
  492. handle_calling_convention(storedprocdef);
  493. p.storedaccess.procdef:=Tprocsym(sym).search_procdef_bypara(storedprocdef.paras,storedprocdef.rettype.def,[cpo_allowdefaults,cpo_ignorehidden]);
  494. if not assigned(p.storedaccess.procdef) then
  495. message(parser_e_ill_property_storage_sym);
  496. end;
  497. fieldvarsym :
  498. begin
  499. if not assigned(def) then
  500. internalerror(200310073);
  501. if (ppo_hasparameters in p.propoptions) or
  502. not(is_boolean(def)) then
  503. Message(parser_e_stored_property_must_be_boolean);
  504. end;
  505. else
  506. Message(parser_e_ill_property_access_sym);
  507. end;
  508. end;
  509. end;
  510. end;
  511. _FALSE:
  512. begin
  513. consume(_FALSE);
  514. exclude(p.propoptions,ppo_stored);
  515. end;
  516. _TRUE:
  517. begin
  518. p.default:=longint($80000000);
  519. consume(_TRUE);
  520. end;
  521. end;
  522. end;
  523. end;
  524. if try_to_consume(_DEFAULT) then
  525. begin
  526. if not(is_ordinal(p.proptype.def) or
  527. {$ifndef cpu64bit}
  528. is_64bitint(p.proptype.def) or
  529. {$endif cpu64bit}
  530. is_class(p.proptype.def) or
  531. is_single(p.proptype.def) or
  532. (p.proptype.def.deftype in [classrefdef,pointerdef]) or
  533. ((p.proptype.def.deftype=setdef) and
  534. (tsetdef(p.proptype.def).settype=smallset))) or
  535. ((p.proptype.def.deftype=arraydef) and
  536. (ppo_indexed in p.propoptions)) or
  537. (ppo_hasparameters in p.propoptions) then
  538. begin
  539. Message(parser_e_property_cant_have_a_default_value);
  540. { Error recovery }
  541. pt:=comp_expr(true);
  542. pt.free;
  543. end
  544. else
  545. begin
  546. { Get the result of the default, the firstpass is
  547. needed to support values like -1 }
  548. pt:=comp_expr(true);
  549. if (p.proptype.def.deftype=setdef) and
  550. (pt.nodetype=arrayconstructorn) then
  551. begin
  552. arrayconstructor_to_set(pt);
  553. do_resulttypepass(pt);
  554. end;
  555. inserttypeconv(pt,p.proptype);
  556. if not(is_constnode(pt)) then
  557. Message(parser_e_property_default_value_must_const);
  558. { Set default value }
  559. case pt.nodetype of
  560. setconstn :
  561. p.default:=plongint(tsetconstnode(pt).value_set)^;
  562. ordconstn :
  563. p.default:=longint(tordconstnode(pt).value);
  564. niln :
  565. p.default:=0;
  566. realconstn:
  567. p.default:=longint(single(trealconstnode(pt).value_real));
  568. end;
  569. pt.free;
  570. end;
  571. end
  572. else if try_to_consume(_NODEFAULT) then
  573. begin
  574. p.default:=longint($80000000);
  575. end;
  576. { Parse possible "implements" keyword }
  577. if try_to_consume(_IMPLEMENTS) then
  578. begin
  579. consume(_ID);
  580. {$message warn unlocalized string}
  581. if not is_interface(p.proptype.def) then
  582. begin
  583. writeln('Implements property must have interface type');
  584. Message1(sym_e_illegal_field, pattern);
  585. end;
  586. if pattern <> p.proptype.def.mangledparaname() then
  587. begin
  588. writeln('Implements-property must implement interface of correct type');
  589. Message1(sym_e_illegal_field, pattern);
  590. end;
  591. intfidx := 0;
  592. with aclass.implementedinterfaces do
  593. begin
  594. for i := 1 to count do
  595. if interfaces(i).objname^ = pattern then
  596. begin
  597. intfidx := i;
  598. break;
  599. end;
  600. if intfidx > 0 then
  601. begin
  602. interfaces(intfidx).iitype := etFieldValue;
  603. interfaces(intfidx).iioffset := tfieldvarsym(p.readaccess.firstsym^.sym).fieldoffset;
  604. end else
  605. begin
  606. writeln('Implements-property used on unimplemented interface');
  607. Message1(sym_e_illegal_field, pattern);
  608. end;
  609. end;
  610. end;
  611. { remove temporary procvardefs }
  612. readprocdef.free;
  613. writeprocdef.free;
  614. result:=p;
  615. end;
  616. function maybe_parse_proc_directives(const tt:ttype):boolean;
  617. var
  618. newtype : ttypesym;
  619. begin
  620. result:=false;
  621. { Process procvar directives before = and ; }
  622. if (tt.def.deftype=procvardef) and
  623. (tt.def.typesym=nil) and
  624. check_proc_directive(true) then
  625. begin
  626. newtype:=ttypesym.create('unnamed',tt);
  627. parse_var_proc_directives(tsym(newtype));
  628. newtype.restype.def:=nil;
  629. tt.def.typesym:=nil;
  630. newtype.free;
  631. result:=true;
  632. end;
  633. end;
  634. const
  635. variantrecordlevel : longint = 0;
  636. procedure read_var_decls(options:Tvar_dec_options);
  637. procedure read_default_value(sc : TFPObjectList;tt : ttype;is_threadvar : boolean);
  638. var
  639. vs : tabstractnormalvarsym;
  640. tcsym : ttypedconstsym;
  641. begin
  642. vs:=tabstractnormalvarsym(sc[0]);
  643. if sc.count>1 then
  644. Message(parser_e_initialized_only_one_var);
  645. if is_threadvar then
  646. Message(parser_e_initialized_not_for_threadvar);
  647. if symtablestack.top.symtabletype=localsymtable then
  648. begin
  649. consume(_EQUAL);
  650. tcsym:=ttypedconstsym.createtype('$default'+vs.realname,tt,false);
  651. include(tcsym.symoptions,sp_internal);
  652. vs.defaultconstsym:=tcsym;
  653. symtablestack.top.insert(tcsym);
  654. readtypedconst(current_asmdata.asmlists[al_typedconsts],tt,tcsym,false);
  655. { The variable has a value assigned }
  656. vs.varstate:=vs_initialised;
  657. end
  658. else
  659. begin
  660. tcsym:=ttypedconstsym.createtype(vs.realname,tt,true);
  661. tcsym.fileinfo:=vs.fileinfo;
  662. symtablestack.top.replace(vs,tcsym);
  663. vs.free;
  664. consume(_EQUAL);
  665. readtypedconst(current_asmdata.asmlists[al_typedconsts],tt,tcsym,true);
  666. end;
  667. end;
  668. var
  669. sc : TFPObjectList;
  670. i : longint;
  671. old_block_type : tblock_type;
  672. symdone : boolean;
  673. { to handle absolute }
  674. abssym : tabsolutevarsym;
  675. { c var }
  676. is_dll,
  677. hasdefaultvalue,
  678. is_gpc_name,is_cdecl,
  679. extern_var,export_var : boolean;
  680. old_current_object_option : tsymoptions;
  681. hs,sorg,C_name,dll_name : string;
  682. tt : ttype;
  683. hp,pt : tnode;
  684. vs : tabstractvarsym;
  685. hintsymoptions : tsymoptions;
  686. semicolonatend,semicoloneaten: boolean;
  687. begin
  688. old_current_object_option:=current_object_option;
  689. { all variables are public if not in a object declaration }
  690. current_object_option:=[sp_public];
  691. old_block_type:=block_type;
  692. block_type:=bt_type;
  693. is_gpc_name:=false;
  694. { Force an expected ID error message }
  695. if not (token in [_ID,_CASE,_END]) then
  696. consume(_ID);
  697. { read vars }
  698. sc:=TFPObjectList.create(false);
  699. while (token=_ID) do
  700. begin
  701. sorg:=orgpattern;
  702. semicoloneaten:=false;
  703. hasdefaultvalue:=false;
  704. symdone:=false;
  705. sc.clear;
  706. repeat
  707. if (token = _ID) then
  708. begin
  709. case symtablestack.top.symtabletype of
  710. localsymtable :
  711. vs:=tlocalvarsym.create(orgpattern,vs_value,generrortype,[]);
  712. staticsymtable,
  713. globalsymtable :
  714. vs:=tglobalvarsym.create(orgpattern,vs_value,generrortype,[]);
  715. else
  716. internalerror(200411064);
  717. end;
  718. sc.add(vs);
  719. symtablestack.top.insert(vs);
  720. end;
  721. consume(_ID);
  722. until not try_to_consume(_COMMA);
  723. consume(_COLON);
  724. if (m_gpc in aktmodeswitches) and
  725. (token=_ID) and
  726. (orgpattern='__asmname__') then
  727. begin
  728. consume(_ID);
  729. C_name:=get_stringconst;
  730. Is_gpc_name:=true;
  731. end;
  732. { this is needed for Delphi mode at least
  733. but should be OK for all modes !! (PM) }
  734. ignore_equal:=true;
  735. read_anon_type(tt,false);
  736. ignore_equal:=false;
  737. { Process procvar directives }
  738. if maybe_parse_proc_directives(tt) then
  739. semicoloneaten:=true;
  740. if is_gpc_name then
  741. begin
  742. vs:=tabstractvarsym(sc[0]);
  743. if sc.count>1 then
  744. Message(parser_e_absolute_only_one_var);
  745. vs.vartype:=tt;
  746. if vs.typ=globalvarsym then
  747. begin
  748. tglobalvarsym(vs).set_mangledname(target_info.Cprefix+sorg);
  749. include(vs.varoptions,vo_is_C_var);
  750. include(vs.varoptions,vo_is_external);
  751. end
  752. else
  753. Message(parser_e_no_local_var_external);
  754. symdone:=true;
  755. end;
  756. { check for absolute }
  757. if not symdone and
  758. try_to_consume(_ABSOLUTE) then
  759. begin
  760. abssym:=nil;
  761. { only allowed for one var }
  762. vs:=tabstractvarsym(sc[0]);
  763. if sc.count>1 then
  764. Message(parser_e_absolute_only_one_var);
  765. { parse the rest }
  766. pt:=expr;
  767. { check allowed absolute types }
  768. if (pt.nodetype=stringconstn) or
  769. (is_constcharnode(pt)) then
  770. begin
  771. abssym:=tabsolutevarsym.create(vs.realname,tt);
  772. abssym.fileinfo:=vs.fileinfo;
  773. if pt.nodetype=stringconstn then
  774. hs:=strpas(tstringconstnode(pt).value_str)
  775. else
  776. hs:=chr(tordconstnode(pt).value);
  777. consume(token);
  778. abssym.abstyp:=toasm;
  779. abssym.asmname:=stringdup(hs);
  780. { replace the varsym }
  781. symtablestack.top.replace(vs,abssym);
  782. vs.free;
  783. end
  784. { address }
  785. else if is_constintnode(pt) and
  786. ((target_info.system in [system_i386_go32v2,system_i386_watcom,
  787. system_i386_wdosx,system_i386_win32,
  788. system_arm_wince,system_i386_wince,
  789. system_arm_gba]) or
  790. (m_objfpc in aktmodeswitches) or
  791. (m_delphi in aktmodeswitches)) then
  792. begin
  793. abssym:=tabsolutevarsym.create(vs.realname,tt);
  794. abssym.fileinfo:=vs.fileinfo;
  795. abssym.abstyp:=toaddr;
  796. abssym.addroffset:=tordconstnode(pt).value;
  797. {$ifdef i386}
  798. abssym.absseg:=false;
  799. if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
  800. try_to_consume(_COLON) then
  801. begin
  802. pt.free;
  803. pt:=expr;
  804. if is_constintnode(pt) then
  805. begin
  806. abssym.addroffset:=abssym.addroffset shl 4+tordconstnode(pt).value;
  807. abssym.absseg:=true;
  808. end
  809. else
  810. Message(type_e_ordinal_expr_expected);
  811. end;
  812. {$endif i386}
  813. symtablestack.top.replace(vs,abssym);
  814. vs.free;
  815. end
  816. { variable }
  817. else
  818. begin
  819. { remove subscriptn before checking for loadn }
  820. hp:=pt;
  821. while (hp.nodetype in [subscriptn,typeconvn,vecn]) do
  822. hp:=tunarynode(hp).left;
  823. if (hp.nodetype=loadn) then
  824. begin
  825. { we should check the result type of loadn }
  826. if not (tloadnode(hp).symtableentry.typ in [fieldvarsym,globalvarsym,localvarsym,
  827. paravarsym,typedconstsym]) then
  828. Message(parser_e_absolute_only_to_var_or_const);
  829. abssym:=tabsolutevarsym.create(vs.realname,tt);
  830. abssym.fileinfo:=vs.fileinfo;
  831. abssym.abstyp:=tovar;
  832. abssym.ref:=node_to_symlist(pt);
  833. symtablestack.top.replace(vs,abssym);
  834. vs.free;
  835. end
  836. else
  837. Message(parser_e_absolute_only_to_var_or_const);
  838. end;
  839. if assigned(abssym) then
  840. begin
  841. { try to consume the hint directives with absolute symbols }
  842. hintsymoptions:=[];
  843. try_consume_hintdirective(hintsymoptions);
  844. abssym.symoptions := abssym.symoptions + hintsymoptions;
  845. end;
  846. pt.free;
  847. symdone:=true;
  848. end;
  849. { try to parse the hint directives }
  850. hintsymoptions:=[];
  851. try_consume_hintdirective(hintsymoptions);
  852. { Handling of Delphi typed const = initialized vars }
  853. if (token=_EQUAL) and
  854. not(m_tp7 in aktmodeswitches) and
  855. (symtablestack.top.symtabletype<>parasymtable) then
  856. begin
  857. { Add calling convention for procvar }
  858. if (tt.def.deftype=procvardef) and
  859. (tt.def.typesym=nil) then
  860. handle_calling_convention(tprocvardef(tt.def));
  861. read_default_value(sc,tt,vd_threadvar in options);
  862. consume(_SEMICOLON);
  863. { for locals we've created typedconstsym with a different name }
  864. if symtablestack.top.symtabletype<>localsymtable then
  865. symdone:=true;
  866. hasdefaultvalue:=true;
  867. end
  868. else
  869. begin
  870. if not(semicoloneaten) then
  871. consume(_SEMICOLON);
  872. end;
  873. { Support calling convention for procvars after semicolon }
  874. if not(hasdefaultvalue) and
  875. (tt.def.deftype=procvardef) and
  876. (tt.def.typesym=nil) then
  877. begin
  878. { Parse procvar directives after ; }
  879. maybe_parse_proc_directives(tt);
  880. { Add calling convention for procvar }
  881. handle_calling_convention(tprocvardef(tt.def));
  882. { Handling of Delphi typed const = initialized vars }
  883. if (token=_EQUAL) and
  884. not(m_tp7 in aktmodeswitches) and
  885. (symtablestack.top.symtabletype<>parasymtable) then
  886. begin
  887. read_default_value(sc,tt,vd_threadvar in options);
  888. consume(_SEMICOLON);
  889. symdone:=true;
  890. hasdefaultvalue:=true;
  891. end;
  892. end;
  893. { Check for EXTERNAL etc directives or, in macpas, if cs_external_var is set}
  894. if not symdone then
  895. begin
  896. if (
  897. (token=_ID) and
  898. (m_cvar_support in aktmodeswitches) and
  899. (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR])
  900. ) or
  901. (
  902. (m_mac in aktmodeswitches) and
  903. ((cs_external_var in aktlocalswitches) or (cs_externally_visible in aktlocalswitches))
  904. ) then
  905. begin
  906. { only allowed for one var }
  907. vs:=tabstractvarsym(sc[0]);
  908. if sc.count>1 then
  909. Message(parser_e_absolute_only_one_var);
  910. { set type of the var }
  911. vs.vartype:=tt;
  912. vs.symoptions := vs.symoptions + hintsymoptions;
  913. { defaults }
  914. is_dll:=false;
  915. is_cdecl:=false;
  916. extern_var:=false;
  917. export_var:=false;
  918. C_name:=sorg;
  919. semicolonatend:= false;
  920. { cdecl }
  921. if try_to_consume(_CVAR) then
  922. begin
  923. consume(_SEMICOLON);
  924. is_cdecl:=true;
  925. C_name:=target_info.Cprefix+sorg;
  926. end;
  927. { external }
  928. if try_to_consume(_EXTERNAL) then
  929. begin
  930. extern_var:=true;
  931. semicolonatend:= true;
  932. end;
  933. { macpas specific handling due to some switches}
  934. if (m_mac in aktmodeswitches) then
  935. begin
  936. if (cs_external_var in aktlocalswitches) then
  937. begin {The effect of this is the same as if cvar; external; has been given as directives.}
  938. is_cdecl:=true;
  939. C_name:=target_info.Cprefix+sorg;
  940. extern_var:=true;
  941. end
  942. else if (cs_externally_visible in aktlocalswitches) then
  943. begin {The effect of this is the same as if cvar has been given as directives.}
  944. is_cdecl:=true;
  945. C_name:=target_info.Cprefix+sorg;
  946. end;
  947. vs.varregable := vr_none;
  948. end;
  949. { export }
  950. if idtoken in [_EXPORT,_PUBLIC] then
  951. begin
  952. consume(_ID);
  953. if extern_var then
  954. Message(parser_e_not_external_and_export)
  955. else
  956. begin
  957. export_var:=true;
  958. semicolonatend:= true;
  959. end;
  960. end;
  961. { external and export need a name after when no cdecl is used }
  962. if not is_cdecl then
  963. begin
  964. { dll name ? }
  965. if (extern_var) and (idtoken<>_NAME) then
  966. begin
  967. is_dll:=true;
  968. dll_name:=AddExtension(get_stringconst,target_info.sharedlibext);
  969. end;
  970. if try_to_consume(_NAME) then
  971. C_name:=get_stringconst
  972. else
  973. C_name:=sorg;
  974. end;
  975. { consume the ; when export or external is used }
  976. if semicolonatend then
  977. consume(_SEMICOLON);
  978. { set some vars options }
  979. if is_dll then
  980. begin
  981. { Windows uses an indirect reference using import tables }
  982. if target_info.system in system_all_windows then
  983. include(vs.varoptions,vo_is_dll_var);
  984. end
  985. else
  986. include(vs.varoptions,vo_is_C_var);
  987. if (is_dll) and
  988. (target_info.system in [system_powerpc_darwin,system_i386_darwin]) then
  989. C_Name := target_info.Cprefix+C_Name;
  990. if export_var then
  991. begin
  992. inc(vs.refs);
  993. include(vs.varoptions,vo_is_exported);
  994. end;
  995. if extern_var then
  996. include(vs.varoptions,vo_is_external);
  997. if vs.typ=globalvarsym then
  998. begin
  999. tglobalvarsym(vs).set_mangledname(C_Name);
  1000. { insert in the al_globals when it is not external }
  1001. if (not extern_var) then
  1002. insertbssdata(tglobalvarsym(vs));
  1003. { now we can insert it in the import lib if its a dll, or
  1004. add it to the externals }
  1005. if extern_var then
  1006. begin
  1007. vs.varregable := vr_none;
  1008. if is_dll then
  1009. current_module.AddExternalImport(dll_name,C_Name,0,true)
  1010. else
  1011. if tf_has_dllscanner in target_info.flags then
  1012. current_module.dllscannerinputlist.Add(vs.mangledname,vs);
  1013. end;
  1014. end
  1015. else
  1016. Message(parser_e_no_local_var_external);
  1017. symdone:=true;
  1018. end;
  1019. end;
  1020. { insert it in the symtable, if not done yet }
  1021. if not symdone then
  1022. begin
  1023. for i:=0 to sc.count-1 do
  1024. begin
  1025. vs:=tabstractvarsym(sc[i]);
  1026. vs.vartype:=tt;
  1027. { insert any additional hint directives }
  1028. vs.symoptions := vs.symoptions + hintsymoptions;
  1029. if vd_threadvar in options then
  1030. include(vs.varoptions,vo_is_thread_var);
  1031. { static data fields are inserted in the globalsymtable }
  1032. if vs.typ=globalvarsym then
  1033. insertbssdata(tglobalvarsym(vs));
  1034. end;
  1035. end;
  1036. end;
  1037. block_type:=old_block_type;
  1038. current_object_option:=old_current_object_option;
  1039. { free the list }
  1040. sc.free;
  1041. end;
  1042. procedure read_record_fields(options:Tvar_dec_options);
  1043. var
  1044. sc : TFPObjectList;
  1045. i : longint;
  1046. old_block_type : tblock_type;
  1047. old_current_object_option : tsymoptions;
  1048. hs,sorg : string;
  1049. tt,casetype : ttype;
  1050. { maxsize contains the max. size of a variant }
  1051. { startvarrec contains the start of the variant part of a record }
  1052. maxsize, startvarrecsize : longint;
  1053. usedalign,
  1054. maxalignment,startvarrecalign,
  1055. maxpadalign, startpadalign: shortint;
  1056. pt : tnode;
  1057. fieldvs : tfieldvarsym;
  1058. hstaticvs : tglobalvarsym;
  1059. vs : tabstractvarsym;
  1060. srsym : tsym;
  1061. srsymtable : tsymtable;
  1062. recst : tabstractrecordsymtable;
  1063. unionsymtable : trecordsymtable;
  1064. offset : longint;
  1065. uniondef : trecorddef;
  1066. unionsym : tfieldvarsym;
  1067. uniontype : ttype;
  1068. hintsymoptions : tsymoptions;
  1069. semicoloneaten: boolean;
  1070. {$ifdef powerpc}
  1071. tempdef: tdef;
  1072. is_first_field: boolean;
  1073. {$endif powerpc}
  1074. begin
  1075. recst:=tabstractrecordsymtable(symtablestack.top);
  1076. {$ifdef powerpc}
  1077. is_first_field := true;
  1078. {$endif powerpc}
  1079. old_current_object_option:=current_object_option;
  1080. { all variables are public if not in a object declaration }
  1081. if not(vd_object in options) then
  1082. current_object_option:=[sp_public];
  1083. old_block_type:=block_type;
  1084. block_type:=bt_type;
  1085. { Force an expected ID error message }
  1086. if not (token in [_ID,_CASE,_END]) then
  1087. consume(_ID);
  1088. { read vars }
  1089. sc:=TFPObjectList.create(false);
  1090. while (token=_ID) and
  1091. not((vd_object in options) and
  1092. (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT])) do
  1093. begin
  1094. sorg:=orgpattern;
  1095. semicoloneaten:=false;
  1096. sc.clear;
  1097. repeat
  1098. if try_to_consume(_ID) then
  1099. begin
  1100. vs:=tfieldvarsym.create(orgpattern,vs_value,generrortype,[]);
  1101. sc.add(vs);
  1102. recst.insert(vs);
  1103. end;
  1104. until not try_to_consume(_COMMA);
  1105. consume(_COLON);
  1106. { Don't search in the recordsymtable for types }
  1107. if ([df_generic,df_specialization]*tdef(recst.defowner).defoptions=[]) then
  1108. symtablestack.pop(recst);
  1109. ignore_equal:=true;
  1110. read_anon_type(tt,false);
  1111. ignore_equal:=false;
  1112. if ([df_generic,df_specialization]*tdef(recst.defowner).defoptions=[]) then
  1113. symtablestack.push(recst);
  1114. { Process procvar directives }
  1115. if maybe_parse_proc_directives(tt) then
  1116. semicoloneaten:=true;
  1117. {$ifdef powerpc}
  1118. { from gcc/gcc/config/rs6000/rs6000.h:
  1119. /* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
  1120. /* Return the alignment of a struct based on the Macintosh PowerPC
  1121. alignment rules. In general the alignment of a struct is
  1122. determined by the greatest alignment of its elements. However, the
  1123. PowerPC rules cause the alignment of a struct to peg at word
  1124. alignment except when the first field has greater than word
  1125. (32-bit) alignment, in which case the alignment is determined by
  1126. the alignment of the first field. */
  1127. }
  1128. if (target_info.system in [system_powerpc_darwin, system_powerpc_macos]) and
  1129. is_first_field and
  1130. (symtablestack.top.symtabletype = recordsymtable) and
  1131. (trecordsymtable(symtablestack.top).usefieldalignment = -1) then
  1132. begin
  1133. tempdef := tt.def;
  1134. while tempdef.deftype = arraydef do
  1135. tempdef := tarraydef(tempdef).elementtype.def;
  1136. if tempdef.deftype <> recorddef then
  1137. maxpadalign := tempdef.alignment
  1138. else
  1139. maxpadalign := trecorddef(tempdef).padalignment;
  1140. if (maxpadalign > 4) and
  1141. (maxpadalign > trecordsymtable(symtablestack.top).padalignment) then
  1142. trecordsymtable(symtablestack.top).padalignment := maxpadalign;
  1143. is_first_field := false;
  1144. end;
  1145. {$endif powerpc}
  1146. { types that use init/final are not allowed in variant parts, but
  1147. classes are allowed }
  1148. if (variantrecordlevel>0) and
  1149. (tt.def.needs_inittable and not is_class(tt.def)) then
  1150. Message(parser_e_cant_use_inittable_here);
  1151. { try to parse the hint directives }
  1152. hintsymoptions:=[];
  1153. try_consume_hintdirective(hintsymoptions);
  1154. { Records and objects can't have default values }
  1155. { for a record there doesn't need to be a ; before the END or ) }
  1156. if not(token in [_END,_RKLAMMER]) and
  1157. not(semicoloneaten) then
  1158. consume(_SEMICOLON);
  1159. { Parse procvar directives after ; }
  1160. maybe_parse_proc_directives(tt);
  1161. { Add calling convention for procvar }
  1162. if (tt.def.deftype=procvardef) and
  1163. (tt.def.typesym=nil) then
  1164. handle_calling_convention(tprocvardef(tt.def));
  1165. { Check for STATIC directive }
  1166. if (vd_object in options) and
  1167. (cs_static_keyword in aktmoduleswitches) and
  1168. (try_to_consume(_STATIC)) then
  1169. begin
  1170. include(current_object_option,sp_static);
  1171. consume(_SEMICOLON);
  1172. end;
  1173. if (sp_published in current_object_option) and
  1174. not(is_class(tt.def)) then
  1175. begin
  1176. Message(parser_e_cant_publish_that);
  1177. exclude(current_object_option,sp_published);
  1178. { recover by changing access type to public }
  1179. for i:=0 to sc.count-1 do
  1180. begin
  1181. fieldvs:=tfieldvarsym(sc[i]);
  1182. exclude(fieldvs.symoptions,sp_published);
  1183. include(fieldvs.symoptions,sp_public);
  1184. end;
  1185. end
  1186. else
  1187. if (sp_published in current_object_option) and
  1188. not(oo_can_have_published in tobjectdef(tt.def).objectoptions) then
  1189. begin
  1190. Message(parser_e_only_publishable_classes_can__be_published);
  1191. exclude(current_object_option,sp_published);
  1192. end;
  1193. { update variable options }
  1194. for i:=0 to sc.count-1 do
  1195. begin
  1196. fieldvs:=tfieldvarsym(sc[i]);
  1197. fieldvs.vartype:=tt;
  1198. { insert any additional hint directives }
  1199. fieldvs.symoptions := fieldvs.symoptions + hintsymoptions;
  1200. if (sp_static in current_object_option) then
  1201. include(fieldvs.symoptions,sp_static);
  1202. { static data fields are inserted in the globalsymtable }
  1203. if (sp_static in current_object_option) then
  1204. begin
  1205. hstaticvs:=tglobalvarsym.create('$'+lower(symtablestack.top.name^)+'_'+fieldvs.name,vs_value,tt,[]);
  1206. recst.defowner.owner.insert(hstaticvs);
  1207. insertbssdata(hstaticvs);
  1208. end
  1209. else
  1210. recst.addfield(fieldvs);
  1211. end;
  1212. { restore current_object_option, it can be changed for
  1213. publishing or static }
  1214. current_object_option:=old_current_object_option;
  1215. end;
  1216. { Check for Case }
  1217. if (vd_record in options) and
  1218. try_to_consume(_CASE) then
  1219. begin
  1220. maxsize:=0;
  1221. maxalignment:=0;
  1222. maxpadalign:=0;
  1223. { including a field declaration? }
  1224. fieldvs:=nil;
  1225. sorg:=orgpattern;
  1226. hs:=pattern;
  1227. searchsym(hs,srsym,srsymtable);
  1228. if not(assigned(srsym) and (srsym.typ in [typesym,unitsym])) then
  1229. begin
  1230. consume(_ID);
  1231. consume(_COLON);
  1232. fieldvs:=tfieldvarsym.create(sorg,vs_value,generrortype,[]);
  1233. symtablestack.top.insert(fieldvs);
  1234. end;
  1235. read_anon_type(casetype,true);
  1236. if assigned(fieldvs) then
  1237. begin
  1238. fieldvs.vartype:=casetype;
  1239. recst.addfield(fieldvs);
  1240. end;
  1241. if not(is_ordinal(casetype.def))
  1242. {$ifndef cpu64bit}
  1243. or is_64bitint(casetype.def)
  1244. {$endif cpu64bit}
  1245. then
  1246. Message(type_e_ordinal_expr_expected);
  1247. consume(_OF);
  1248. UnionSymtable:=trecordsymtable.create(aktpackrecords);
  1249. UnionDef:=trecorddef.create(unionsymtable);
  1250. uniondef.isunion:=true;
  1251. startvarrecsize:=UnionSymtable.datasize;
  1252. { align the bitpacking to the next byte }
  1253. UnionSymtable.datasize:=startvarrecsize;
  1254. startvarrecalign:=UnionSymtable.fieldalignment;
  1255. startpadalign:=Unionsymtable.padalignment;
  1256. symtablestack.push(UnionSymtable);
  1257. repeat
  1258. repeat
  1259. pt:=comp_expr(true);
  1260. if not(pt.nodetype=ordconstn) then
  1261. Message(parser_e_illegal_expression);
  1262. pt.free;
  1263. if token=_COMMA then
  1264. consume(_COMMA)
  1265. else
  1266. break;
  1267. until false;
  1268. consume(_COLON);
  1269. { read the vars }
  1270. consume(_LKLAMMER);
  1271. inc(variantrecordlevel);
  1272. if token<>_RKLAMMER then
  1273. read_record_fields([vd_record]);
  1274. dec(variantrecordlevel);
  1275. consume(_RKLAMMER);
  1276. { calculates maximal variant size }
  1277. maxsize:=max(maxsize,unionsymtable.datasize);
  1278. maxalignment:=max(maxalignment,unionsymtable.fieldalignment);
  1279. maxpadalign:=max(maxpadalign,unionsymtable.padalignment);
  1280. { the items of the next variant are overlayed }
  1281. unionsymtable.datasize:=startvarrecsize;
  1282. unionsymtable.fieldalignment:=startvarrecalign;
  1283. unionsymtable.padalignment:=startpadalign;
  1284. if (token<>_END) and (token<>_RKLAMMER) then
  1285. consume(_SEMICOLON)
  1286. else
  1287. break;
  1288. until (token=_END) or (token=_RKLAMMER);
  1289. symtablestack.pop(UnionSymtable);
  1290. { at last set the record size to that of the biggest variant }
  1291. unionsymtable.datasize:=maxsize;
  1292. unionsymtable.fieldalignment:=maxalignment;
  1293. uniontype.def:=uniondef;
  1294. uniontype.sym:=nil;
  1295. UnionSym:=tfieldvarsym.create('$case',vs_value,uniontype,[]);
  1296. unionsymtable.addalignmentpadding;
  1297. {$ifdef powerpc}
  1298. { parent inherits the alignment padding if the variant is the first "field" of the parent record/variant }
  1299. if (target_info.system in [system_powerpc_darwin, system_powerpc_macos]) and
  1300. is_first_field and
  1301. (recst.usefieldalignment = -1) and
  1302. (maxpadalign > recst.padalignment) then
  1303. recst.padalignment:=maxpadalign;
  1304. {$endif powerpc}
  1305. { Align the offset where the union symtable is added }
  1306. if (recst.usefieldalignment=-1) then
  1307. usedalign:=used_align(unionsymtable.recordalignment,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
  1308. else
  1309. usedalign:=used_align(unionsymtable.recordalignment,aktalignment.recordalignmin,aktalignment.recordalignmax);
  1310. offset:=align(recst.datasize,usedalign);
  1311. recst.datasize:=offset+unionsymtable.datasize;
  1312. if unionsymtable.recordalignment>recst.fieldalignment then
  1313. recst.fieldalignment:=unionsymtable.recordalignment;
  1314. trecordsymtable(recst).insertunionst(Unionsymtable,offset);
  1315. unionsym.free;
  1316. uniondef.free;
  1317. end;
  1318. block_type:=old_block_type;
  1319. current_object_option:=old_current_object_option;
  1320. { free the list }
  1321. sc.free;
  1322. {$ifdef powerpc}
  1323. is_first_field := false;
  1324. {$endif powerpc}
  1325. end;
  1326. end.