ptype.pas 63 KB

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