ptype.pas 61 KB

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