pdecvar.pas 60 KB

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