ptype.pas 74 KB

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