ptype.pas 63 KB

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