pdecvar.pas 61 KB

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