ptype.pas 71 KB

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