pdecvar.pas 68 KB

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