ptype.pas 63 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Does parsing types for Free Pascal
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ptype;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. globtype,cclasses,
  22. symtype,symdef,symbase;
  23. type
  24. TSingleTypeOption=(stoIsForwardDef,stoAllowTypeDef,stoParseClassParent);
  25. TSingleTypeOptions=set of TSingleTypeOption;
  26. procedure resolve_forward_types;
  27. { reads a type identifier }
  28. procedure id_type(var def : tdef;isforwarddef:boolean);
  29. { reads a string, file type or a type identifier }
  30. procedure single_type(var def:tdef;options:TSingleTypeOptions);
  31. { reads any type declaration, where the resulting type will get name as type identifier }
  32. procedure read_named_type(var def:tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  33. { reads any type declaration }
  34. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  35. { generate persistent type information like VMT, RTTI and inittables }
  36. procedure write_persistent_type_info(st:tsymtable);
  37. implementation
  38. uses
  39. { common }
  40. cutils,
  41. { global }
  42. globals,tokens,verbose,constexp,
  43. systems,
  44. { target }
  45. paramgr,procinfo,
  46. { symtable }
  47. symconst,symsym,symtable,
  48. defutil,defcmp,
  49. { modules }
  50. fmodule,
  51. { pass 1 }
  52. node,ncgrtti,nobj,
  53. nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
  54. { parser }
  55. scanner,
  56. pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl;
  57. procedure resolve_forward_types;
  58. var
  59. i: longint;
  60. hpd,
  61. def : tdef;
  62. srsym : tsym;
  63. srsymtable : TSymtable;
  64. hs : string;
  65. begin
  66. for i:=0 to current_module.checkforwarddefs.Count-1 do
  67. begin
  68. def:=tdef(current_module.checkforwarddefs[i]);
  69. case def.typ of
  70. pointerdef,
  71. classrefdef :
  72. begin
  73. { classrefdef inherits from pointerdef }
  74. hpd:=tabstractpointerdef(def).pointeddef;
  75. { still a forward def ? }
  76. if hpd.typ=forwarddef then
  77. begin
  78. { try to resolve the forward }
  79. if not assigned(tforwarddef(hpd).tosymname) then
  80. internalerror(200211201);
  81. hs:=tforwarddef(hpd).tosymname^;
  82. searchsym(upper(hs),srsym,srsymtable);
  83. { we don't need the forwarddef anymore, dispose it }
  84. hpd.free;
  85. tabstractpointerdef(def).pointeddef:=nil; { if error occurs }
  86. { was a type sym found ? }
  87. if assigned(srsym) and
  88. (srsym.typ=typesym) then
  89. begin
  90. tabstractpointerdef(def).pointeddef:=ttypesym(srsym).typedef;
  91. { avoid wrong unused warnings web bug 801 PM }
  92. inc(ttypesym(srsym).refs);
  93. { we need a class type for classrefdef }
  94. if (def.typ=classrefdef) and
  95. not(is_class(ttypesym(srsym).typedef)) and
  96. not(is_objcclass(ttypesym(srsym).typedef)) then
  97. MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename);
  98. end
  99. else
  100. begin
  101. Message1(sym_e_forward_type_not_resolved,hs);
  102. { try to recover }
  103. tabstractpointerdef(def).pointeddef:=generrordef;
  104. end;
  105. end;
  106. end;
  107. objectdef :
  108. begin
  109. { give an error as the implementation may follow in an
  110. other type block which is allowed by FPC modes }
  111. if not(m_fpc in current_settings.modeswitches) and
  112. (oo_is_forward in tobjectdef(def).objectoptions) then
  113. MessagePos1(def.typesym.fileinfo,type_e_type_is_not_completly_defined,def.typename);
  114. end;
  115. else
  116. internalerror(200811071);
  117. end;
  118. end;
  119. current_module.checkforwarddefs.clear;
  120. end;
  121. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean);
  122. var
  123. st : TSymtable;
  124. srsym : tsym;
  125. pt2 : tnode;
  126. first,
  127. err : boolean;
  128. i : longint;
  129. sym : tsym;
  130. genericdef : tstoreddef;
  131. generictype : ttypesym;
  132. generictypelist : TFPObjectList;
  133. oldsymtablestack : tsymtablestack;
  134. hmodule : tmodule;
  135. pu : tused_unit;
  136. uspecializename,
  137. specializename : string;
  138. vmtbuilder : TVMTBuilder;
  139. onlyparsepara : boolean;
  140. specializest : tsymtable;
  141. item: psymtablestackitem;
  142. begin
  143. { retrieve generic def that we are going to replace }
  144. genericdef:=tstoreddef(tt);
  145. tt:=nil;
  146. onlyparsepara:=false;
  147. if not(df_generic in genericdef.defoptions) then
  148. begin
  149. Message(parser_e_special_onlygenerics);
  150. tt:=generrordef;
  151. onlyparsepara:=true;
  152. end;
  153. { only need to record the tokens, then we don't know the type yet ... }
  154. if parse_generic then
  155. begin
  156. { ... but we have to insert a def into the symtable else the deflist
  157. of generic and specialization might not be equally sized which
  158. is later assumed }
  159. tt:=tundefineddef.create;
  160. if parse_class_parent then
  161. tt:=genericdef;
  162. onlyparsepara:=true;
  163. end;
  164. { Only parse the parameters for recovery or
  165. for recording in genericbuf }
  166. if onlyparsepara then
  167. begin
  168. consume(_LSHARPBRACKET);
  169. repeat
  170. pt2:=factor(false,true);
  171. pt2.free;
  172. until not try_to_consume(_COMMA);
  173. consume(_RSHARPBRACKET);
  174. exit;
  175. end;
  176. consume(_LSHARPBRACKET);
  177. { Parse generic parameters, for each undefineddef in the symtable of
  178. the genericdef we need to have a new def }
  179. err:=false;
  180. first:=true;
  181. generictypelist:=TFPObjectList.create(false);
  182. case genericdef.typ of
  183. procdef:
  184. st:=genericdef.GetSymtable(gs_para);
  185. objectdef,
  186. recorddef:
  187. st:=genericdef.GetSymtable(gs_record);
  188. arraydef:
  189. st:=tarraydef(genericdef).symtable;
  190. else
  191. internalerror(200511182);
  192. end;
  193. { Parse type parameters }
  194. if not assigned(genericdef.typesym) then
  195. internalerror(200710173);
  196. specializename:=genericdef.typesym.realname;
  197. for i:=0 to st.SymList.Count-1 do
  198. begin
  199. sym:=tsym(st.SymList[i]);
  200. if (sp_generic_para in sym.symoptions) then
  201. begin
  202. if not first then
  203. consume(_COMMA)
  204. else
  205. first:=false;
  206. pt2:=factor(false,true);
  207. if pt2.nodetype=typen then
  208. begin
  209. if df_generic in pt2.resultdef.defoptions then
  210. Message(parser_e_no_generics_as_params);
  211. generictype:=ttypesym.create(sym.realname,pt2.resultdef);
  212. generictypelist.add(generictype);
  213. if not assigned(pt2.resultdef.typesym) then
  214. message(type_e_generics_cannot_reference_itself)
  215. else
  216. specializename:=specializename+'$'+pt2.resultdef.typesym.realname;
  217. end
  218. else
  219. begin
  220. Message(type_e_type_id_expected);
  221. err:=true;
  222. end;
  223. pt2.free;
  224. end;
  225. end;
  226. uspecializename:=upper(specializename);
  227. { force correct error location if too much type parameters are passed }
  228. if token<>_RSHARPBRACKET then
  229. consume(_RSHARPBRACKET);
  230. { Special case if we are referencing the current defined object }
  231. if assigned(current_structdef) and
  232. (current_structdef.objname^=uspecializename) then
  233. tt:=current_structdef;
  234. { for units specializations can already be needed in the interface, therefor we
  235. will use the global symtable. Programs don't have a globalsymtable and there we
  236. use the localsymtable }
  237. if current_module.is_unit then
  238. specializest:=current_module.globalsymtable
  239. else
  240. specializest:=current_module.localsymtable;
  241. { Can we reuse an already specialized type? }
  242. if not assigned(tt) then
  243. begin
  244. srsym:=tsym(specializest.find(uspecializename));
  245. if assigned(srsym) then
  246. begin
  247. if srsym.typ<>typesym then
  248. internalerror(200710171);
  249. tt:=ttypesym(srsym).typedef;
  250. end;
  251. end;
  252. if not assigned(tt) then
  253. begin
  254. { Setup symtablestack at definition time
  255. to get types right, however this is not perfect, we should probably record
  256. the resolved symbols }
  257. oldsymtablestack:=symtablestack;
  258. symtablestack:=tsymtablestack.create;
  259. if not assigned(genericdef) then
  260. internalerror(200705151);
  261. hmodule:=find_module_from_symtable(genericdef.owner);
  262. if hmodule=nil then
  263. internalerror(200705152);
  264. pu:=tused_unit(hmodule.used_units.first);
  265. while assigned(pu) do
  266. begin
  267. if not assigned(pu.u.globalsymtable) then
  268. internalerror(200705153);
  269. symtablestack.push(pu.u.globalsymtable);
  270. pu:=tused_unit(pu.next);
  271. end;
  272. if assigned(hmodule.globalsymtable) then
  273. symtablestack.push(hmodule.globalsymtable);
  274. { hacky, but necessary to insert the newly generated class properly }
  275. item:=oldsymtablestack.stack;
  276. while assigned(item) and (item^.symtable.symtablelevel>main_program_level) do
  277. item:=item^.next;
  278. if assigned(item) and (item^.symtable<>symtablestack.top) then
  279. symtablestack.push(item^.symtable);
  280. { Reparse the original type definition }
  281. if not err then
  282. begin
  283. { First a new typesym so we can reuse this specialization and
  284. references to this specialization can be handled }
  285. srsym:=ttypesym.create(specializename,generrordef);
  286. specializest.insert(srsym);
  287. if not assigned(genericdef.generictokenbuf) then
  288. internalerror(200511171);
  289. current_scanner.startreplaytokens(genericdef.generictokenbuf);
  290. read_named_type(tt,specializename,genericdef,generictypelist,false);
  291. ttypesym(srsym).typedef:=tt;
  292. tt.typesym:=srsym;
  293. { Consume the semicolon if it is also recorded }
  294. try_to_consume(_SEMICOLON);
  295. { Build VMT indexes for classes }
  296. if (tt.typ=objectdef) then
  297. begin
  298. vmtbuilder:=TVMTBuilder.Create(tobjectdef(tt));
  299. vmtbuilder.generate_vmt;
  300. vmtbuilder.free;
  301. end;
  302. end;
  303. { Restore symtablestack }
  304. symtablestack.free;
  305. symtablestack:=oldsymtablestack;
  306. end
  307. else
  308. begin
  309. { There is comment few lines before ie 200512115
  310. saying "We are parsing the same objectdef, the def index numbers
  311. are the same". This is wrong (index numbers are not same)
  312. in case there is specialization (S2 in this case) inside
  313. specialized generic (G2 in this case) which is equal to
  314. some previous specialization (S1 in this case). In that case,
  315. new symbol is not added to currently specialized type
  316. (S in this case) for that specializations (S2 in this case),
  317. and this results in that specialization and generic definition
  318. don't have same number of elements in their object symbol tables.
  319. This patch adds undefined def to ensure that those
  320. two symbol tables will have same number of elements.
  321. }
  322. tundefineddef.create;
  323. end;
  324. generictypelist.free;
  325. consume(_RSHARPBRACKET);
  326. end;
  327. procedure id_type(var def : tdef;isforwarddef:boolean);
  328. { reads a type definition }
  329. { to a appropriating tdef, s gets the name of }
  330. { the type to allow name mangling }
  331. var
  332. is_unit_specific : boolean;
  333. pos : tfileposinfo;
  334. srsym : tsym;
  335. srsymtable : TSymtable;
  336. s,sorg : TIDString;
  337. t : ttoken;
  338. structdef : tabstractrecorddef;
  339. begin
  340. s:=pattern;
  341. sorg:=orgpattern;
  342. pos:=current_tokenpos;
  343. { use of current parsed object:
  344. - classes can be used also in classes
  345. - objects can be parameters }
  346. structdef:=current_structdef;
  347. while assigned(structdef) and (structdef.typ in [objectdef,recorddef]) do
  348. begin
  349. if (structdef.objname^=pattern) then
  350. begin
  351. consume(_ID);
  352. def:=structdef;
  353. exit;
  354. end;
  355. structdef:=tabstractrecorddef(structdef.owner.defowner);
  356. end;
  357. { Use the special searchsym_type that ignores records and parameters }
  358. searchsym_type(s,srsym,srsymtable);
  359. { handle unit specification like System.Writeln }
  360. is_unit_specific:=try_consume_unitsym(srsym,srsymtable,t);
  361. consume(t);
  362. { Types are first defined with an error def before assigning
  363. the real type so check if it's an errordef. if so then
  364. give an error. Only check for typesyms in the current symbol
  365. table as forwarddef are not resolved directly }
  366. if assigned(srsym) and
  367. (srsym.typ=typesym) and
  368. (ttypesym(srsym).typedef.typ=errordef) then
  369. begin
  370. Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
  371. def:=generrordef;
  372. exit;
  373. end;
  374. { are we parsing a possible forward def ? }
  375. if isforwarddef and
  376. not(is_unit_specific) then
  377. begin
  378. def:=tforwarddef.create(sorg,pos);
  379. exit;
  380. end;
  381. { unknown sym ? }
  382. if not assigned(srsym) then
  383. begin
  384. Message1(sym_e_id_not_found,sorg);
  385. def:=generrordef;
  386. exit;
  387. end;
  388. { type sym ? }
  389. if (srsym.typ<>typesym) then
  390. begin
  391. Message(type_e_type_id_expected);
  392. def:=generrordef;
  393. exit;
  394. end;
  395. { Give an error when referring to an errordef }
  396. if (ttypesym(srsym).typedef.typ=errordef) then
  397. begin
  398. Message(sym_e_error_in_type_def);
  399. def:=generrordef;
  400. exit;
  401. end;
  402. def:=ttypesym(srsym).typedef;
  403. end;
  404. procedure single_type(var def:tdef;options:TSingleTypeOptions);
  405. var
  406. t2 : tdef;
  407. dospecialize,
  408. again : boolean;
  409. begin
  410. dospecialize:=false;
  411. repeat
  412. again:=false;
  413. case token of
  414. _STRING:
  415. string_dec(def,stoAllowTypeDef in options);
  416. _FILE:
  417. begin
  418. consume(_FILE);
  419. if (token=_OF) then
  420. begin
  421. if not(stoAllowTypeDef in options) then
  422. Message(parser_e_no_local_para_def);
  423. consume(_OF);
  424. single_type(t2,[]);
  425. if is_managed_type(t2) then
  426. Message(parser_e_no_refcounted_typed_file);
  427. def:=tfiledef.createtyped(t2);
  428. end
  429. else
  430. def:=cfiletype;
  431. end;
  432. _ID:
  433. begin
  434. if try_to_consume(_SPECIALIZE) then
  435. begin
  436. if not(stoAllowTypeDef in options) then
  437. begin
  438. Message(parser_e_no_local_para_def);
  439. { try to recover }
  440. while token<>_SEMICOLON do
  441. consume(token);
  442. def:=generrordef;
  443. end
  444. else
  445. begin
  446. dospecialize:=true;
  447. again:=true;
  448. end;
  449. end
  450. else
  451. begin
  452. id_type(def,stoIsForwardDef in options);
  453. { handle types inside classes, e.g. TNode.TLongint }
  454. while (token=_POINT) do
  455. begin
  456. if parse_generic then
  457. begin
  458. consume(_POINT);
  459. consume(_ID);
  460. end
  461. else if is_class_or_object(def) or is_record(def) then
  462. begin
  463. symtablestack.push(tabstractrecorddef(def).symtable);
  464. consume(_POINT);
  465. id_type(t2,stoIsForwardDef in options);
  466. symtablestack.pop(tabstractrecorddef(def).symtable);
  467. def:=t2;
  468. end
  469. else
  470. break;
  471. end;
  472. end;
  473. end;
  474. else
  475. begin
  476. message(type_e_type_id_expected);
  477. def:=generrordef;
  478. end;
  479. end;
  480. until not again;
  481. if (stoAllowTypeDef in options)and(m_delphi in current_settings.modeswitches) then
  482. dospecialize:=token=_LSHARPBRACKET;
  483. if dospecialize then
  484. generate_specialization(def,stoParseClassParent in options)
  485. else
  486. begin
  487. if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
  488. begin
  489. def:=current_specializedef
  490. end
  491. else if (def=current_genericdef) then
  492. begin
  493. def:=current_genericdef
  494. end
  495. else if (df_generic in def.defoptions) then
  496. begin
  497. Message(parser_e_no_generics_as_types);
  498. def:=generrordef;
  499. end
  500. else if is_objccategory(def) then
  501. begin
  502. Message(parser_e_no_category_as_types);
  503. def:=generrordef
  504. end
  505. end;
  506. end;
  507. procedure parse_record_members;
  508. procedure maybe_parse_hint_directives(pd:tprocdef);
  509. var
  510. dummysymoptions : tsymoptions;
  511. deprecatedmsg : pshortstring;
  512. begin
  513. dummysymoptions:=[];
  514. deprecatedmsg:=nil;
  515. while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
  516. Consume(_SEMICOLON);
  517. if assigned(pd) then
  518. begin
  519. pd.symoptions:=pd.symoptions+dummysymoptions;
  520. pd.deprecatedmsg:=deprecatedmsg;
  521. end
  522. else
  523. stringdispose(deprecatedmsg);
  524. end;
  525. var
  526. pd : tprocdef;
  527. oldparse_only: boolean;
  528. member_blocktype : tblock_type;
  529. fields_allowed, is_classdef, classfields: boolean;
  530. vdoptions: tvar_dec_options;
  531. begin
  532. { empty record declaration ? }
  533. if (token=_SEMICOLON) then
  534. Exit;
  535. current_structdef.symtable.currentvisibility:=vis_public;
  536. fields_allowed:=true;
  537. is_classdef:=false;
  538. classfields:=false;
  539. member_blocktype:=bt_general;
  540. repeat
  541. case token of
  542. _TYPE :
  543. begin
  544. consume(_TYPE);
  545. member_blocktype:=bt_type;
  546. end;
  547. _VAR :
  548. begin
  549. consume(_VAR);
  550. fields_allowed:=true;
  551. member_blocktype:=bt_general;
  552. classfields:=is_classdef;
  553. is_classdef:=false;
  554. end;
  555. _CONST:
  556. begin
  557. consume(_CONST);
  558. member_blocktype:=bt_const;
  559. end;
  560. _ID, _CASE, _OPERATOR :
  561. begin
  562. case idtoken of
  563. _PRIVATE :
  564. begin
  565. consume(_PRIVATE);
  566. current_structdef.symtable.currentvisibility:=vis_private;
  567. include(current_structdef.objectoptions,oo_has_private);
  568. fields_allowed:=true;
  569. is_classdef:=false;
  570. classfields:=false;
  571. member_blocktype:=bt_general;
  572. end;
  573. _PROTECTED :
  574. begin
  575. consume(_PROTECTED);
  576. current_structdef.symtable.currentvisibility:=vis_protected;
  577. include(current_structdef.objectoptions,oo_has_protected);
  578. fields_allowed:=true;
  579. is_classdef:=false;
  580. classfields:=false;
  581. member_blocktype:=bt_general;
  582. end;
  583. _PUBLIC :
  584. begin
  585. consume(_PUBLIC);
  586. current_structdef.symtable.currentvisibility:=vis_public;
  587. fields_allowed:=true;
  588. is_classdef:=false;
  589. classfields:=false;
  590. member_blocktype:=bt_general;
  591. end;
  592. _PUBLISHED :
  593. begin
  594. Message(parser_e_no_record_published);
  595. consume(_PUBLISHED);
  596. current_structdef.symtable.currentvisibility:=vis_published;
  597. fields_allowed:=true;
  598. is_classdef:=false;
  599. classfields:=false;
  600. member_blocktype:=bt_general;
  601. end;
  602. _STRICT :
  603. begin
  604. consume(_STRICT);
  605. if token=_ID then
  606. begin
  607. case idtoken of
  608. _PRIVATE:
  609. begin
  610. consume(_PRIVATE);
  611. current_structdef.symtable.currentvisibility:=vis_strictprivate;
  612. include(current_structdef.objectoptions,oo_has_strictprivate);
  613. end;
  614. _PROTECTED:
  615. begin
  616. consume(_PROTECTED);
  617. current_structdef.symtable.currentvisibility:=vis_strictprotected;
  618. include(current_structdef.objectoptions,oo_has_strictprotected);
  619. end;
  620. else
  621. message(parser_e_protected_or_private_expected);
  622. end;
  623. end
  624. else
  625. message(parser_e_protected_or_private_expected);
  626. fields_allowed:=true;
  627. is_classdef:=false;
  628. classfields:=false;
  629. member_blocktype:=bt_general;
  630. end
  631. else
  632. if is_classdef and (idtoken=_OPERATOR) then
  633. begin
  634. oldparse_only:=parse_only;
  635. parse_only:=true;
  636. pd:=parse_proc_dec(is_classdef,current_structdef);
  637. { this is for error recovery as well as forward }
  638. { interface mappings, i.e. mapping to a method }
  639. { which isn't declared yet }
  640. if assigned(pd) then
  641. begin
  642. parse_record_proc_directives(pd);
  643. handle_calling_convention(pd);
  644. { add definition to procsym }
  645. proc_add_definition(pd);
  646. end;
  647. maybe_parse_hint_directives(pd);
  648. parse_only:=oldparse_only;
  649. fields_allowed:=false;
  650. is_classdef:=false;
  651. end
  652. else
  653. begin
  654. if member_blocktype=bt_general then
  655. begin
  656. if (not fields_allowed) then
  657. Message(parser_e_field_not_allowed_here);
  658. vdoptions:=[vd_record];
  659. if classfields then
  660. include(vdoptions,vd_class);
  661. read_record_fields(vdoptions);
  662. end
  663. else if member_blocktype=bt_type then
  664. types_dec(true)
  665. else if member_blocktype=bt_const then
  666. consts_dec(true)
  667. else
  668. internalerror(201001110);
  669. end;
  670. end;
  671. end;
  672. _PROPERTY :
  673. begin
  674. struct_property_dec(is_classdef);
  675. fields_allowed:=false;
  676. is_classdef:=false;
  677. end;
  678. _CLASS:
  679. begin
  680. is_classdef:=false;
  681. { read class method }
  682. if try_to_consume(_CLASS) then
  683. begin
  684. { class modifier is only allowed for procedures, functions, }
  685. { constructors, destructors, fields and properties }
  686. if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
  687. not((token=_ID) and (idtoken=_OPERATOR)) then
  688. Message(parser_e_procedure_or_function_expected);
  689. is_classdef:=true;
  690. end;
  691. end;
  692. _PROCEDURE,
  693. _FUNCTION:
  694. begin
  695. oldparse_only:=parse_only;
  696. parse_only:=true;
  697. pd:=parse_proc_dec(is_classdef,current_structdef);
  698. { this is for error recovery as well as forward }
  699. { interface mappings, i.e. mapping to a method }
  700. { which isn't declared yet }
  701. if assigned(pd) then
  702. begin
  703. parse_record_proc_directives(pd);
  704. { since records have no inheritance don't allow non static
  705. class methods. delphi do so. }
  706. if is_classdef and not (po_staticmethod in pd.procoptions) then
  707. MessagePos(pd.fileinfo, parser_e_class_methods_only_static_in_records);
  708. handle_calling_convention(pd);
  709. { add definition to procsym }
  710. proc_add_definition(pd);
  711. end;
  712. maybe_parse_hint_directives(pd);
  713. parse_only:=oldparse_only;
  714. fields_allowed:=false;
  715. is_classdef:=false;
  716. end;
  717. _CONSTRUCTOR :
  718. begin
  719. if not is_classdef then
  720. Message(parser_e_no_constructor_in_records);
  721. if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
  722. Message(parser_w_constructor_should_be_public);
  723. { only 1 class constructor is allowed }
  724. if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
  725. Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
  726. oldparse_only:=parse_only;
  727. parse_only:=true;
  728. if is_classdef then
  729. pd:=class_constructor_head
  730. else
  731. pd:=constructor_head;
  732. parse_record_proc_directives(pd);
  733. handle_calling_convention(pd);
  734. { add definition to procsym }
  735. proc_add_definition(pd);
  736. maybe_parse_hint_directives(pd);
  737. parse_only:=oldparse_only;
  738. fields_allowed:=false;
  739. is_classdef:=false;
  740. end;
  741. _DESTRUCTOR :
  742. begin
  743. if not is_classdef then
  744. Message(parser_e_no_destructor_in_records);
  745. { only 1 class destructor is allowed }
  746. if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
  747. Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
  748. oldparse_only:=parse_only;
  749. parse_only:=true;
  750. if is_classdef then
  751. pd:=class_destructor_head
  752. else
  753. pd:=destructor_head;
  754. parse_record_proc_directives(pd);
  755. handle_calling_convention(pd);
  756. { add definition to procsym }
  757. proc_add_definition(pd);
  758. maybe_parse_hint_directives(pd);
  759. parse_only:=oldparse_only;
  760. fields_allowed:=false;
  761. is_classdef:=false;
  762. end;
  763. _END :
  764. begin
  765. consume(_END);
  766. break;
  767. end;
  768. else
  769. consume(_ID); { Give a ident expected message, like tp7 }
  770. end;
  771. until false;
  772. end;
  773. { reads a record declaration }
  774. function record_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
  775. var
  776. old_current_structdef: tabstractrecorddef;
  777. old_current_genericdef,
  778. old_current_specializedef: tstoreddef;
  779. old_parse_generic: boolean;
  780. recst: trecordsymtable;
  781. begin
  782. old_current_structdef:=current_structdef;
  783. old_current_genericdef:=current_genericdef;
  784. old_current_specializedef:=current_specializedef;
  785. old_parse_generic:=parse_generic;
  786. current_genericdef:=nil;
  787. current_specializedef:=nil;
  788. { create recdef }
  789. recst:=trecordsymtable.create(n,current_settings.packrecords);
  790. current_structdef:=trecorddef.create(n,recst);
  791. result:=current_structdef;
  792. { insert in symtablestack }
  793. symtablestack.push(recst);
  794. { parse record }
  795. consume(_RECORD);
  796. { usage of specialized type inside its generic template }
  797. if assigned(genericdef) then
  798. current_specializedef:=current_structdef
  799. { reject declaration of generic class inside generic class }
  800. else if assigned(genericlist) then
  801. current_genericdef:=current_structdef;
  802. insert_generic_parameter_types(current_structdef,genericdef,genericlist);
  803. parse_generic:=(df_generic in current_structdef.defoptions);
  804. if m_advanced_records in current_settings.modeswitches then
  805. parse_record_members
  806. else
  807. begin
  808. read_record_fields([vd_record]);
  809. consume(_END);
  810. end;
  811. { make the record size aligned }
  812. recst.addalignmentpadding;
  813. { restore symtable stack }
  814. symtablestack.pop(recst);
  815. if trecorddef(current_structdef).is_packed and is_managed_type(current_structdef) then
  816. Message(type_e_no_packed_inittable);
  817. { restore old state }
  818. parse_generic:=old_parse_generic;
  819. current_structdef:=old_current_structdef;
  820. current_genericdef:=old_current_genericdef;
  821. current_specializedef:=old_current_specializedef;
  822. end;
  823. { reads a type definition and returns a pointer to it }
  824. procedure read_named_type(var def : tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
  825. var
  826. pt : tnode;
  827. tt2 : tdef;
  828. aktenumdef : tenumdef;
  829. s : TIDString;
  830. l,v : TConstExprInt;
  831. oldpackrecords : longint;
  832. defpos,storepos : tfileposinfo;
  833. procedure expr_type;
  834. var
  835. pt1,pt2 : tnode;
  836. lv,hv : TConstExprInt;
  837. old_block_type : tblock_type;
  838. dospecialize : boolean;
  839. structdef: tabstractrecorddef;
  840. begin
  841. old_block_type:=block_type;
  842. dospecialize:=false;
  843. { use of current parsed object:
  844. - classes can be used also in classes
  845. - objects can be parameters }
  846. if (token=_ID) then
  847. begin
  848. structdef:=current_structdef;
  849. while assigned(structdef) and (structdef.typ in [objectdef,recorddef]) do
  850. begin
  851. if (structdef.objname^=pattern) then
  852. begin
  853. consume(_ID);
  854. def:=structdef;
  855. exit;
  856. end;
  857. structdef:=tabstractrecorddef(structdef.owner.defowner);
  858. end;
  859. end;
  860. { Generate a specialization in FPC mode? }
  861. dospecialize:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_SPECIALIZE);
  862. { we can't accept a equal in type }
  863. pt1:=comp_expr(false,true);
  864. if not dospecialize and
  865. try_to_consume(_POINTPOINT) then
  866. begin
  867. { get high value of range }
  868. pt2:=comp_expr(false,false);
  869. { make both the same type or give an error. This is not
  870. done when both are integer values, because typecasting
  871. between -3200..3200 will result in a signed-unsigned
  872. conflict and give a range check error (PFV) }
  873. if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
  874. inserttypeconv(pt1,pt2.resultdef);
  875. { both must be evaluated to constants now }
  876. if (pt1.nodetype=ordconstn) and
  877. (pt2.nodetype=ordconstn) then
  878. begin
  879. lv:=tordconstnode(pt1).value;
  880. hv:=tordconstnode(pt2).value;
  881. { Check bounds }
  882. if hv<lv then
  883. message(parser_e_upper_lower_than_lower)
  884. else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then
  885. message(type_e_cant_eval_constant_expr)
  886. else
  887. begin
  888. { All checks passed, create the new def }
  889. case pt1.resultdef.typ of
  890. enumdef :
  891. def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue);
  892. orddef :
  893. begin
  894. if is_char(pt1.resultdef) then
  895. def:=torddef.create(uchar,lv,hv)
  896. else
  897. if is_boolean(pt1.resultdef) then
  898. def:=torddef.create(pasbool,lv,hv)
  899. else if is_signed(pt1.resultdef) then
  900. def:=torddef.create(range_to_basetype(lv,hv),lv,hv)
  901. else
  902. def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
  903. end;
  904. end;
  905. end;
  906. end
  907. else
  908. Message(sym_e_error_in_type_def);
  909. pt2.free;
  910. end
  911. else
  912. begin
  913. { a simple type renaming or generic specialization }
  914. if (pt1.nodetype=typen) then
  915. begin
  916. def:=ttypenode(pt1).resultdef;
  917. { Delphi mode specialization? }
  918. if (m_delphi in current_settings.modeswitches) then
  919. dospecialize:=token=_LSHARPBRACKET;
  920. if dospecialize then
  921. generate_specialization(def,false)
  922. else
  923. begin
  924. if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
  925. begin
  926. def:=current_specializedef
  927. end
  928. else if (def=current_genericdef) then
  929. begin
  930. def:=current_genericdef
  931. end
  932. else if (df_generic in def.defoptions) then
  933. begin
  934. Message(parser_e_no_generics_as_types);
  935. def:=generrordef;
  936. end
  937. else if is_objccategory(def) then
  938. begin
  939. Message(parser_e_no_category_as_types);
  940. def:=generrordef
  941. end
  942. end;
  943. end
  944. else
  945. Message(sym_e_error_in_type_def);
  946. end;
  947. pt1.free;
  948. block_type:=old_block_type;
  949. end;
  950. procedure set_dec;
  951. begin
  952. consume(_SET);
  953. consume(_OF);
  954. read_anon_type(tt2,true);
  955. if assigned(tt2) then
  956. begin
  957. case tt2.typ of
  958. { don't forget that min can be negativ PM }
  959. enumdef :
  960. if (tenumdef(tt2).min>=0) and
  961. (tenumdef(tt2).max<=255) then
  962. // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
  963. def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max)
  964. else
  965. Message(sym_e_ill_type_decl_set);
  966. orddef :
  967. begin
  968. if (torddef(tt2).ordtype<>uvoid) and
  969. (torddef(tt2).ordtype<>uwidechar) and
  970. (torddef(tt2).low>=0) then
  971. // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
  972. if Torddef(tt2).high>int64(high(byte)) then
  973. message(sym_e_ill_type_decl_set)
  974. else
  975. def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue)
  976. else
  977. Message(sym_e_ill_type_decl_set);
  978. end;
  979. else
  980. Message(sym_e_ill_type_decl_set);
  981. end;
  982. end
  983. else
  984. def:=generrordef;
  985. end;
  986. procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:TFPObjectList);
  987. var
  988. lowval,
  989. highval : TConstExprInt;
  990. indexdef : tdef;
  991. hdef : tdef;
  992. arrdef : tarraydef;
  993. procedure setdefdecl(def:tdef);
  994. begin
  995. case def.typ of
  996. enumdef :
  997. begin
  998. lowval:=tenumdef(def).min;
  999. highval:=tenumdef(def).max;
  1000. if (m_fpc in current_settings.modeswitches) and
  1001. (tenumdef(def).has_jumps) then
  1002. Message(type_e_array_index_enums_with_assign_not_possible);
  1003. indexdef:=def;
  1004. end;
  1005. orddef :
  1006. begin
  1007. if torddef(def).ordtype in [uchar,
  1008. u8bit,u16bit,
  1009. s8bit,s16bit,s32bit,
  1010. {$ifdef cpu64bitaddr}
  1011. u32bit,s64bit,
  1012. {$endif cpu64bitaddr}
  1013. pasbool,bool8bit,bool16bit,bool32bit,bool64bit,
  1014. uwidechar] then
  1015. begin
  1016. lowval:=torddef(def).low;
  1017. highval:=torddef(def).high;
  1018. indexdef:=def;
  1019. end
  1020. else
  1021. Message1(parser_e_type_cant_be_used_in_array_index,def.typename);
  1022. end;
  1023. else
  1024. Message(sym_e_error_in_type_def);
  1025. end;
  1026. end;
  1027. var
  1028. old_current_genericdef,
  1029. old_current_specializedef: tstoreddef;
  1030. old_parse_generic: boolean;
  1031. begin
  1032. old_current_genericdef:=current_genericdef;
  1033. old_current_specializedef:=current_specializedef;
  1034. old_parse_generic:=parse_generic;
  1035. current_genericdef:=nil;
  1036. current_specializedef:=nil;
  1037. arrdef:=nil;
  1038. consume(_ARRAY);
  1039. { open array? }
  1040. if try_to_consume(_LECKKLAMMER) then
  1041. begin
  1042. { defaults }
  1043. indexdef:=generrordef;
  1044. { use defaults which don't overflow the compiler }
  1045. lowval:=0;
  1046. highval:=0;
  1047. repeat
  1048. { read the expression and check it, check apart if the
  1049. declaration is an enum declaration because that needs to
  1050. be parsed by readtype (PFV) }
  1051. if token=_LKLAMMER then
  1052. begin
  1053. read_anon_type(hdef,true);
  1054. setdefdecl(hdef);
  1055. end
  1056. else
  1057. begin
  1058. pt:=expr(true);
  1059. if pt.nodetype=typen then
  1060. setdefdecl(pt.resultdef)
  1061. else
  1062. begin
  1063. if (pt.nodetype=rangen) then
  1064. begin
  1065. if (trangenode(pt).left.nodetype=ordconstn) and
  1066. (trangenode(pt).right.nodetype=ordconstn) then
  1067. begin
  1068. { make both the same type or give an error. This is not
  1069. done when both are integer values, because typecasting
  1070. between -3200..3200 will result in a signed-unsigned
  1071. conflict and give a range check error (PFV) }
  1072. if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then
  1073. inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef);
  1074. lowval:=tordconstnode(trangenode(pt).left).value;
  1075. highval:=tordconstnode(trangenode(pt).right).value;
  1076. if highval<lowval then
  1077. begin
  1078. Message(parser_e_array_lower_less_than_upper_bound);
  1079. highval:=lowval;
  1080. end
  1081. else if (lowval<int64(low(aint))) or
  1082. (highval > high(aint)) then
  1083. begin
  1084. Message(parser_e_array_range_out_of_bounds);
  1085. lowval :=0;
  1086. highval:=0;
  1087. end;
  1088. if is_integer(trangenode(pt).left.resultdef) then
  1089. range_to_type(lowval,highval,indexdef)
  1090. else
  1091. indexdef:=trangenode(pt).left.resultdef;
  1092. end
  1093. else
  1094. Message(type_e_cant_eval_constant_expr);
  1095. end
  1096. else
  1097. Message(sym_e_error_in_type_def)
  1098. end;
  1099. pt.free;
  1100. end;
  1101. { if the array is already created add the new arrray
  1102. as element of the existing array, otherwise create a new array }
  1103. if assigned(arrdef) then
  1104. begin
  1105. arrdef.elementdef:=tarraydef.create(lowval.svalue,highval.svalue,indexdef);
  1106. arrdef:=tarraydef(arrdef.elementdef);
  1107. end
  1108. else
  1109. begin
  1110. arrdef:=tarraydef.create(lowval.svalue,highval.svalue,indexdef);
  1111. def:=arrdef;
  1112. end;
  1113. if is_packed then
  1114. include(arrdef.arrayoptions,ado_IsBitPacked);
  1115. if token=_COMMA then
  1116. consume(_COMMA)
  1117. else
  1118. break;
  1119. until false;
  1120. consume(_RECKKLAMMER);
  1121. end
  1122. else
  1123. begin
  1124. if is_packed then
  1125. Message(parser_e_packed_dynamic_open_array);
  1126. arrdef:=tarraydef.create(0,-1,s32inttype);
  1127. include(arrdef.arrayoptions,ado_IsDynamicArray);
  1128. def:=arrdef;
  1129. end;
  1130. if assigned(arrdef) then
  1131. begin
  1132. { usage of specialized type inside its generic template }
  1133. if assigned(genericdef) then
  1134. current_specializedef:=arrdef
  1135. { reject declaration of generic class inside generic class }
  1136. else if assigned(genericlist) then
  1137. current_genericdef:=arrdef;
  1138. symtablestack.push(arrdef.symtable);
  1139. insert_generic_parameter_types(arrdef,genericdef,genericlist);
  1140. parse_generic:=(df_generic in arrdef.defoptions);
  1141. end;
  1142. consume(_OF);
  1143. read_anon_type(tt2,true);
  1144. { set element type of the last array definition }
  1145. if assigned(arrdef) then
  1146. begin
  1147. symtablestack.pop(arrdef.symtable);
  1148. arrdef.elementdef:=tt2;
  1149. if is_packed and
  1150. is_managed_type(tt2) then
  1151. Message(type_e_no_packed_inittable);
  1152. end;
  1153. { restore old state }
  1154. parse_generic:=old_parse_generic;
  1155. current_genericdef:=old_current_genericdef;
  1156. current_specializedef:=old_current_specializedef;
  1157. end;
  1158. const
  1159. SingleTypeOptionsInTypeBlock:array[Boolean] of TSingleTypeOptions = ([],[stoIsForwardDef]);
  1160. var
  1161. p : tnode;
  1162. hdef : tdef;
  1163. pd : tabstractprocdef;
  1164. is_func,
  1165. enumdupmsg, first, is_specialize : boolean;
  1166. newtype : ttypesym;
  1167. oldlocalswitches : tlocalswitches;
  1168. bitpacking: boolean;
  1169. stitem: psymtablestackitem;
  1170. sym: tsym;
  1171. st: tsymtable;
  1172. begin
  1173. def:=nil;
  1174. case token of
  1175. _STRING,_FILE:
  1176. begin
  1177. single_type(def,[stoAllowTypeDef]);
  1178. end;
  1179. _LKLAMMER:
  1180. begin
  1181. consume(_LKLAMMER);
  1182. first:=true;
  1183. { allow negativ value_str }
  1184. l:=int64(-1);
  1185. enumdupmsg:=false;
  1186. { check that we are not adding an enum from specialization
  1187. we can't just use current_specializedef because of inner types
  1188. like specialize array of record }
  1189. is_specialize:=false;
  1190. stitem:=symtablestack.stack;
  1191. while assigned(stitem) do
  1192. begin
  1193. { check records, classes and arrays because they can be specialized }
  1194. if stitem^.symtable.symtabletype in [recordsymtable,ObjectSymtable,arraysymtable] then
  1195. begin
  1196. is_specialize:=is_specialize or (df_specialization in tstoreddef(stitem^.symtable.defowner).defoptions);
  1197. stitem:=stitem^.next;
  1198. end
  1199. else
  1200. break;
  1201. end;
  1202. if not is_specialize then
  1203. aktenumdef:=tenumdef.create
  1204. else
  1205. aktenumdef:=nil;
  1206. repeat
  1207. { if it is a specialization then search the first enum member
  1208. and get the member owner instead of just created enumdef }
  1209. if not assigned(aktenumdef) then
  1210. begin
  1211. searchsym(pattern,sym,st);
  1212. if sym.typ=enumsym then
  1213. aktenumdef:=tenumsym(sym).definition
  1214. else
  1215. internalerror(201101021);
  1216. end;
  1217. s:=orgpattern;
  1218. defpos:=current_tokenpos;
  1219. consume(_ID);
  1220. { only allow assigning of specific numbers under fpc mode }
  1221. if not(m_tp7 in current_settings.modeswitches) and
  1222. (
  1223. { in fpc mode also allow := to be compatible
  1224. with previous 1.0.x versions }
  1225. ((m_fpc in current_settings.modeswitches) and
  1226. try_to_consume(_ASSIGNMENT)) or
  1227. try_to_consume(_EQ)
  1228. ) then
  1229. begin
  1230. oldlocalswitches:=current_settings.localswitches;
  1231. include(current_settings.localswitches,cs_allow_enum_calc);
  1232. p:=comp_expr(true,false);
  1233. current_settings.localswitches:=oldlocalswitches;
  1234. if (p.nodetype=ordconstn) then
  1235. begin
  1236. { we expect an integer or an enum of the
  1237. same type }
  1238. if is_integer(p.resultdef) or
  1239. is_char(p.resultdef) or
  1240. equal_defs(p.resultdef,aktenumdef) then
  1241. v:=tordconstnode(p).value
  1242. else
  1243. IncompatibleTypes(p.resultdef,s32inttype);
  1244. end
  1245. else
  1246. Message(parser_e_illegal_expression);
  1247. p.free;
  1248. { please leave that a note, allows type save }
  1249. { declarations in the win32 units ! }
  1250. if (not first) and (v<=l) and (not enumdupmsg) then
  1251. begin
  1252. Message(parser_n_duplicate_enum);
  1253. enumdupmsg:=true;
  1254. end;
  1255. l:=v;
  1256. end
  1257. else
  1258. inc(l.svalue);
  1259. first:=false;
  1260. { don't generate enum members is this is a specialization because aktenumdef is copied from the generic type }
  1261. if not is_specialize then
  1262. begin
  1263. storepos:=current_tokenpos;
  1264. current_tokenpos:=defpos;
  1265. tenumsymtable(aktenumdef.symtable).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
  1266. if not (cs_scopedenums in current_settings.localswitches) then
  1267. tstoredsymtable(aktenumdef.owner).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
  1268. current_tokenpos:=storepos;
  1269. end;
  1270. until not try_to_consume(_COMMA);
  1271. def:=aktenumdef;
  1272. consume(_RKLAMMER);
  1273. end;
  1274. _ARRAY:
  1275. begin
  1276. array_dec(false,genericdef,genericlist);
  1277. end;
  1278. _SET:
  1279. begin
  1280. set_dec;
  1281. end;
  1282. _CARET:
  1283. begin
  1284. consume(_CARET);
  1285. single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
  1286. def:=tpointerdef.create(tt2);
  1287. if tt2.typ=forwarddef then
  1288. current_module.checkforwarddefs.add(def);
  1289. end;
  1290. _RECORD:
  1291. begin
  1292. def:=record_dec(name,genericdef,genericlist);
  1293. end;
  1294. _PACKED,
  1295. _BITPACKED:
  1296. begin
  1297. bitpacking :=
  1298. (cs_bitpacking in current_settings.localswitches) or
  1299. (token = _BITPACKED);
  1300. consume(token);
  1301. if token=_ARRAY then
  1302. array_dec(bitpacking,genericdef,genericlist)
  1303. else if token=_SET then
  1304. set_dec
  1305. else if token=_FILE then
  1306. single_type(def,[stoAllowTypeDef])
  1307. else
  1308. begin
  1309. oldpackrecords:=current_settings.packrecords;
  1310. if (not bitpacking) or
  1311. (token in [_CLASS,_OBJECT]) then
  1312. current_settings.packrecords:=1
  1313. else
  1314. current_settings.packrecords:=bit_alignment;
  1315. case token of
  1316. _CLASS :
  1317. begin
  1318. consume(_CLASS);
  1319. def:=object_dec(odt_class,name,genericdef,genericlist,nil);
  1320. end;
  1321. _OBJECT :
  1322. begin
  1323. consume(_OBJECT);
  1324. def:=object_dec(odt_object,name,genericdef,genericlist,nil);
  1325. end;
  1326. else
  1327. def:=record_dec(name,genericdef,genericlist);
  1328. end;
  1329. current_settings.packrecords:=oldpackrecords;
  1330. end;
  1331. end;
  1332. _DISPINTERFACE :
  1333. begin
  1334. { need extra check here since interface is a keyword
  1335. in all pascal modes }
  1336. if not(m_class in current_settings.modeswitches) then
  1337. Message(parser_f_need_objfpc_or_delphi_mode);
  1338. consume(token);
  1339. def:=object_dec(odt_dispinterface,name,genericdef,genericlist,nil);
  1340. end;
  1341. _CLASS :
  1342. begin
  1343. consume(token);
  1344. { Delphi only allows class of in type blocks }
  1345. if (token=_OF) and
  1346. (
  1347. not(m_delphi in current_settings.modeswitches) or
  1348. (block_type=bt_type)
  1349. ) then
  1350. begin
  1351. consume(_OF);
  1352. single_type(hdef,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
  1353. if is_class(hdef) or
  1354. is_objcclass(hdef) then
  1355. def:=tclassrefdef.create(hdef)
  1356. else
  1357. if hdef.typ=forwarddef then
  1358. begin
  1359. def:=tclassrefdef.create(hdef);
  1360. current_module.checkforwarddefs.add(def);
  1361. end
  1362. else
  1363. Message1(type_e_class_or_objcclass_type_expected,hdef.typename);
  1364. end
  1365. else
  1366. def:=object_dec(odt_class,name,genericdef,genericlist,nil);
  1367. end;
  1368. _CPPCLASS :
  1369. begin
  1370. consume(token);
  1371. def:=object_dec(odt_cppclass,name,genericdef,genericlist,nil);
  1372. end;
  1373. _OBJCCLASS :
  1374. begin
  1375. if not(m_objectivec1 in current_settings.modeswitches) then
  1376. Message(parser_f_need_objc);
  1377. consume(token);
  1378. def:=object_dec(odt_objcclass,name,genericdef,genericlist,nil);
  1379. end;
  1380. _INTERFACE :
  1381. begin
  1382. { need extra check here since interface is a keyword
  1383. in all pascal modes }
  1384. if not(m_class in current_settings.modeswitches) then
  1385. Message(parser_f_need_objfpc_or_delphi_mode);
  1386. consume(token);
  1387. if current_settings.interfacetype=it_interfacecom then
  1388. def:=object_dec(odt_interfacecom,name,genericdef,genericlist,nil)
  1389. else {it_interfacecorba}
  1390. def:=object_dec(odt_interfacecorba,name,genericdef,genericlist,nil);
  1391. end;
  1392. _OBJCPROTOCOL :
  1393. begin
  1394. if not(m_objectivec1 in current_settings.modeswitches) then
  1395. Message(parser_f_need_objc);
  1396. consume(token);
  1397. def:=object_dec(odt_objcprotocol,name,genericdef,genericlist,nil);
  1398. end;
  1399. _OBJCCATEGORY :
  1400. begin
  1401. if not(m_objectivec1 in current_settings.modeswitches) then
  1402. Message(parser_f_need_objc);
  1403. consume(token);
  1404. def:=object_dec(odt_objccategory,name,genericdef,genericlist,nil);
  1405. end;
  1406. _OBJECT :
  1407. begin
  1408. consume(token);
  1409. def:=object_dec(odt_object,name,genericdef,genericlist,nil);
  1410. end;
  1411. _PROCEDURE,
  1412. _FUNCTION:
  1413. begin
  1414. is_func:=(token=_FUNCTION);
  1415. consume(token);
  1416. pd:=tprocvardef.create(normal_function_level);
  1417. if token=_LKLAMMER then
  1418. parse_parameter_dec(pd);
  1419. if is_func then
  1420. begin
  1421. consume(_COLON);
  1422. single_type(pd.returndef,[]);
  1423. end;
  1424. if try_to_consume(_OF) then
  1425. begin
  1426. consume(_OBJECT);
  1427. include(pd.procoptions,po_methodpointer);
  1428. end
  1429. else if (m_nested_procvars in current_settings.modeswitches) and
  1430. try_to_consume(_IS) then
  1431. begin
  1432. consume(_NESTED);
  1433. pd.parast.symtablelevel:=normal_function_level+1;
  1434. pd.check_mark_as_nested;
  1435. end;
  1436. def:=pd;
  1437. { possible proc directives }
  1438. if parseprocvardir then
  1439. begin
  1440. if check_proc_directive(true) then
  1441. begin
  1442. newtype:=ttypesym.create('unnamed',def);
  1443. parse_var_proc_directives(tsym(newtype));
  1444. newtype.typedef:=nil;
  1445. def.typesym:=nil;
  1446. newtype.free;
  1447. end;
  1448. { Add implicit hidden parameters and function result }
  1449. handle_calling_convention(pd);
  1450. end;
  1451. end;
  1452. else
  1453. if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
  1454. begin
  1455. consume(_KLAMMERAFFE);
  1456. single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
  1457. def:=tpointerdef.create(tt2);
  1458. if tt2.typ=forwarddef then
  1459. current_module.checkforwarddefs.add(def);
  1460. end
  1461. else
  1462. expr_type;
  1463. end;
  1464. if def=nil then
  1465. def:=generrordef;
  1466. end;
  1467. procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  1468. begin
  1469. read_named_type(def,'',nil,nil,parseprocvardir);
  1470. end;
  1471. procedure write_persistent_type_info(st:tsymtable);
  1472. var
  1473. i : longint;
  1474. def : tdef;
  1475. vmtwriter : TVMTWriter;
  1476. begin
  1477. for i:=0 to st.DefList.Count-1 do
  1478. begin
  1479. def:=tdef(st.DefList[i]);
  1480. case def.typ of
  1481. recorddef :
  1482. write_persistent_type_info(trecorddef(def).symtable);
  1483. objectdef :
  1484. begin
  1485. { Skip generics and forward defs }
  1486. if (df_generic in def.defoptions) or
  1487. (oo_is_forward in tobjectdef(def).objectoptions) then
  1488. continue;
  1489. write_persistent_type_info(tobjectdef(def).symtable);
  1490. { Write also VMT if not done yet }
  1491. if not(ds_vmt_written in def.defstates) then
  1492. begin
  1493. vmtwriter:=TVMTWriter.create(tobjectdef(def));
  1494. if is_interface(tobjectdef(def)) then
  1495. vmtwriter.writeinterfaceids;
  1496. if (oo_has_vmt in tobjectdef(def).objectoptions) then
  1497. vmtwriter.writevmt;
  1498. vmtwriter.free;
  1499. include(def.defstates,ds_vmt_written);
  1500. end;
  1501. end;
  1502. procdef :
  1503. begin
  1504. if assigned(tprocdef(def).localst) and
  1505. (tprocdef(def).localst.symtabletype=localsymtable) then
  1506. write_persistent_type_info(tprocdef(def).localst);
  1507. if assigned(tprocdef(def).parast) then
  1508. write_persistent_type_info(tprocdef(def).parast);
  1509. end;
  1510. end;
  1511. { generate always persistent tables for types in the interface so it can
  1512. be reused in other units and give always the same pointer location. }
  1513. { Init }
  1514. if (
  1515. assigned(def.typesym) and
  1516. (st.symtabletype=globalsymtable) and
  1517. not is_objc_class_or_protocol(def)
  1518. ) or
  1519. is_managed_type(def) or
  1520. (ds_init_table_used in def.defstates) then
  1521. RTTIWriter.write_rtti(def,initrtti);
  1522. { RTTI }
  1523. if (
  1524. assigned(def.typesym) and
  1525. (st.symtabletype=globalsymtable) and
  1526. not is_objc_class_or_protocol(def)
  1527. ) or
  1528. (ds_rtti_table_used in def.defstates) then
  1529. RTTIWriter.write_rtti(def,fullrtti);
  1530. end;
  1531. end;
  1532. end.