pdecvar.pas 58 KB

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