/compiler/ptype.pas

https://github.com/slibre/freepascal · Pascal · 1805 lines · 1466 code · 84 blank · 255 comment · 195 complexity · 8429cbce16bababc1f1d8aceedbfeb21 MD5 · raw file

Large files are truncated click here to view the full file

  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. { 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. { 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. end
  421. else
  422. begin
  423. if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
  424. begin
  425. def:=current_specializedef
  426. end
  427. else if (def=current_genericdef) then
  428. begin
  429. def:=current_genericdef
  430. end
  431. { when parsing a nested specialization in non-Delphi mode it might
  432. use the name of the topmost generic without type paramaters, thus
  433. def will contain the generic definition, but we need a reference
  434. to the specialization of that generic }
  435. { TODO : only in non-Delphi modes? }
  436. else if assigned(current_structdef) and
  437. (df_specialization in current_structdef.defoptions) and
  438. return_specialization_of_generic(current_structdef,def,t2) then
  439. begin
  440. def:=t2
  441. end
  442. else if (df_generic in def.defoptions) and
  443. not
  444. (
  445. parse_generic and
  446. (current_genericdef.typ in [recorddef,objectdef]) and
  447. (
  448. { if both defs belong to the same generic (e.g. both are
  449. subtypes) then we must allow the usage }
  450. defs_belong_to_same_generic(def,current_genericdef) or
  451. { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
  452. declarations inside a generic }
  453. sym_is_owned_by(srsym,tabstractrecorddef(current_genericdef).symtable)
  454. )
  455. )
  456. then
  457. begin
  458. Message(parser_e_no_generics_as_types);
  459. def:=generrordef;
  460. end
  461. else if (def.typ=undefineddef) and
  462. (sp_generic_dummy in srsym.symoptions) and
  463. parse_generic and
  464. (current_genericdef.typ in [recorddef,objectdef]) and
  465. (Pos(upper(srsym.realname),tabstractrecorddef(current_genericdef).objname^)=1) then
  466. begin
  467. if m_delphi in current_settings.modeswitches then
  468. begin
  469. Message(parser_e_no_generics_as_types);
  470. def:=generrordef;
  471. end
  472. else
  473. def:=current_genericdef;
  474. end
  475. else if is_classhelper(def) and
  476. not (stoParseClassParent in options) then
  477. begin
  478. Message(parser_e_no_category_as_types);
  479. def:=generrordef
  480. end
  481. end;
  482. end;
  483. procedure parse_record_members;
  484. function IsAnonOrLocal: Boolean;
  485. begin
  486. result:=(current_structdef.objname^='') or
  487. not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]);
  488. end;
  489. var
  490. pd : tprocdef;
  491. oldparse_only: boolean;
  492. member_blocktype : tblock_type;
  493. fields_allowed, is_classdef, classfields: boolean;
  494. vdoptions: tvar_dec_options;
  495. begin
  496. { empty record declaration ? }
  497. if (token=_SEMICOLON) then
  498. Exit;
  499. current_structdef.symtable.currentvisibility:=vis_public;
  500. fields_allowed:=true;
  501. is_classdef:=false;
  502. classfields:=false;
  503. member_blocktype:=bt_general;
  504. repeat
  505. case token of
  506. _TYPE :
  507. begin
  508. consume(_TYPE);
  509. member_blocktype:=bt_type;
  510. { local and anonymous records can not have inner types. skip top record symtable }
  511. if IsAnonOrLocal then
  512. Message(parser_e_no_types_in_local_anonymous_records);
  513. end;
  514. _VAR :
  515. begin
  516. consume(_VAR);
  517. fields_allowed:=true;
  518. member_blocktype:=bt_general;
  519. classfields:=is_classdef;
  520. is_classdef:=false;
  521. end;
  522. _CONST:
  523. begin
  524. consume(_CONST);
  525. member_blocktype:=bt_const;
  526. { local and anonymous records can not have constants. skip top record symtable }
  527. if IsAnonOrLocal then
  528. Message(parser_e_no_consts_in_local_anonymous_records);
  529. end;
  530. _ID, _CASE, _OPERATOR :
  531. begin
  532. case idtoken of
  533. _PRIVATE :
  534. begin
  535. consume(_PRIVATE);
  536. current_structdef.symtable.currentvisibility:=vis_private;
  537. include(current_structdef.objectoptions,oo_has_private);
  538. fields_allowed:=true;
  539. is_classdef:=false;
  540. classfields:=false;
  541. member_blocktype:=bt_general;
  542. end;
  543. _PROTECTED :
  544. begin
  545. consume(_PROTECTED);
  546. current_structdef.symtable.currentvisibility:=vis_protected;
  547. include(current_structdef.objectoptions,oo_has_protected);
  548. fields_allowed:=true;
  549. is_classdef:=false;
  550. classfields:=false;
  551. member_blocktype:=bt_general;
  552. end;
  553. _PUBLIC :
  554. begin
  555. consume(_PUBLIC);
  556. current_structdef.symtable.currentvisibility:=vis_public;
  557. fields_allowed:=true;
  558. is_classdef:=false;
  559. classfields:=false;
  560. member_blocktype:=bt_general;
  561. end;
  562. _PUBLISHED :
  563. begin
  564. Message(parser_e_no_record_published);
  565. consume(_PUBLISHED);
  566. current_structdef.symtable.currentvisibility:=vis_published;
  567. fields_allowed:=true;
  568. is_classdef:=false;
  569. classfields:=false;
  570. member_blocktype:=bt_general;
  571. end;
  572. _STRICT :
  573. begin
  574. consume(_STRICT);
  575. if token=_ID then
  576. begin
  577. case idtoken of
  578. _PRIVATE:
  579. begin
  580. consume(_PRIVATE);
  581. current_structdef.symtable.currentvisibility:=vis_strictprivate;
  582. include(current_structdef.objectoptions,oo_has_strictprivate);
  583. end;
  584. _PROTECTED:
  585. begin
  586. consume(_PROTECTED);
  587. current_structdef.symtable.currentvisibility:=vis_strictprotected;
  588. include(current_structdef.objectoptions,oo_has_strictprotected);
  589. end;
  590. else
  591. message(parser_e_protected_or_private_expected);
  592. end;
  593. end
  594. else
  595. message(parser_e_protected_or_private_expected);
  596. fields_allowed:=true;
  597. is_classdef:=false;
  598. classfields:=false;
  599. member_blocktype:=bt_general;
  600. end
  601. else
  602. if is_classdef and (idtoken=_OPERATOR) then
  603. begin
  604. pd:=parse_record_method_dec(current_structdef,is_classdef);
  605. fields_allowed:=false;
  606. is_classdef:=false;
  607. end
  608. else
  609. begin
  610. if member_blocktype=bt_general then
  611. begin
  612. if (not fields_allowed)and(idtoken<>_CASE) then
  613. Message(parser_e_field_not_allowed_here);
  614. vdoptions:=[vd_record];
  615. if classfields then
  616. include(vdoptions,vd_class);
  617. read_record_fields(vdoptions,nil);
  618. end
  619. else if member_blocktype=bt_type then
  620. types_dec(true)
  621. else if member_blocktype=bt_const then
  622. consts_dec(true,true)
  623. else
  624. internalerror(201001110);
  625. end;
  626. end;
  627. end;
  628. _PROPERTY :
  629. begin
  630. if IsAnonOrLocal then
  631. Message(parser_e_no_properties_in_local_anonymous_records);
  632. struct_property_dec(is_classdef);
  633. fields_allowed:=false;
  634. is_classdef:=false;
  635. end;
  636. _CLASS:
  637. begin
  638. is_classdef:=false;
  639. { read class method/field/property }
  640. consume(_CLASS);
  641. { class modifier is only allowed for procedures, functions, }
  642. { constructors, destructors, fields and properties }
  643. if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
  644. not((token=_ID) and (idtoken=_OPERATOR)) then
  645. Message(parser_e_procedure_or_function_expected);
  646. if IsAnonOrLocal then
  647. Message(parser_e_no_class_in_local_anonymous_records);
  648. is_classdef:=true;
  649. end;
  650. _PROCEDURE,
  651. _FUNCTION:
  652. begin
  653. if IsAnonOrLocal then
  654. Message(parser_e_no_methods_in_local_anonymous_records);
  655. pd:=parse_record_method_dec(current_structdef,is_classdef);
  656. fields_allowed:=false;
  657. is_classdef:=false;
  658. end;
  659. _CONSTRUCTOR :
  660. begin
  661. if IsAnonOrLocal then
  662. Message(parser_e_no_methods_in_local_anonymous_records);
  663. if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
  664. Message(parser_w_constructor_should_be_public);
  665. { only 1 class constructor is allowed }
  666. if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
  667. Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
  668. oldparse_only:=parse_only;
  669. parse_only:=true;
  670. if is_classdef then
  671. pd:=class_constructor_head(current_structdef)
  672. else
  673. begin
  674. pd:=constructor_head;
  675. if pd.minparacount = 0 then
  676. MessagePos(pd.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records);
  677. end;
  678. parse_only:=oldparse_only;
  679. fields_allowed:=false;
  680. is_classdef:=false;
  681. end;
  682. _DESTRUCTOR :
  683. begin
  684. if IsAnonOrLocal then
  685. Message(parser_e_no_methods_in_local_anonymous_records);
  686. if not is_classdef then
  687. Message(parser_e_no_destructor_in_records);
  688. { only 1 class destructor is allowed }
  689. if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
  690. Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
  691. oldparse_only:=parse_only;
  692. parse_only:=true;
  693. if is_classdef then
  694. pd:=class_destructor_head(current_structdef)
  695. else
  696. pd:=destructor_head;
  697. parse_only:=oldparse_only;
  698. fields_allowed:=false;
  699. is_classdef:=false;
  700. end;
  701. _END :
  702. begin
  703. {$ifdef jvm}
  704. add_java_default_record_methods_intf(trecorddef(current_structdef));
  705. {$endif}
  706. if target_info.system in systems_typed_constants_node_init then
  707. add_typedconst_init_routine(current_structdef);
  708. consume(_END);
  709. break;
  710. end;
  711. else
  712. consume(_ID); { Give a ident expected message, like tp7 }
  713. end;
  714. until false;
  715. end;
  716. { reads a record declaration }
  717. function record_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
  718. var
  719. old_current_structdef: tabstractrecorddef;
  720. old_current_genericdef,
  721. old_current_specializedef: tstoreddef;
  722. old_parse_generic: boolean;
  723. recst: trecordsymtable;
  724. begin
  725. old_current_structdef:=current_structdef;
  726. old_current_genericdef:=current_genericdef;
  727. old_current_specializedef:=current_specializedef;
  728. old_parse_generic:=parse_generic;
  729. current_genericdef:=nil;
  730. current_specializedef:=nil;
  731. { create recdef }
  732. if (n<>'') or
  733. not(target_info.system in systems_jvm) then
  734. begin
  735. recst:=trecordsymtable.create(n,current_settings.packrecords);
  736. { can't use recst.realname^ instead of n, because recst.realname is
  737. nil in case of an empty name }
  738. current_structdef:=trecorddef.create(n,recst);
  739. end
  740. else
  741. begin
  742. { for the JVM target records always need a name, because they are
  743. represented by a class }
  744. recst:=trecordsymtable.create(current_module.realmodulename^+'__fpc_intern_recname_'+tostr(current_module.deflist.count),current_settings.packrecords);
  745. current_structdef:=trecorddef.create(recst.name^,recst);
  746. end;
  747. result:=current_structdef;
  748. { insert in symtablestack }
  749. symtablestack.push(recst);
  750. { usage of specialized type inside its generic template }
  751. if assigned(genericdef) then
  752. current_specializedef:=current_structdef
  753. { reject declaration of generic class inside generic class }
  754. else if assigned(genericlist) then
  755. current_genericdef:=current_structdef;
  756. { nested types of specializations are specializations as well }
  757. if assigned(old_current_structdef) and
  758. (df_specialization in old_current_structdef.defoptions) then
  759. include(current_structdef.defoptions,df_specialization);
  760. if assigned(old_current_structdef) and
  761. (df_generic in old_current_structdef.defoptions) then
  762. begin
  763. include(current_structdef.defoptions,df_generic);
  764. current_genericdef:=current_structdef;
  765. end;
  766. insert_generic_parameter_types(current_structdef,genericdef,genericlist);
  767. { when we are parsing a generic already then this is a generic as
  768. well }
  769. if old_parse_generic then
  770. include(current_structdef.defoptions, df_generic);
  771. parse_generic:=(df_generic in current_structdef.defoptions);
  772. { in non-Delphi modes we need a strict private symbol without type
  773. count and type parameters in the name to simply resolving }
  774. maybe_insert_generic_rename_symbol(n,genericlist);
  775. if m_advanced_records in current_settings.modeswitches then
  776. begin
  777. parse_record_members;
  778. end
  779. else
  780. begin
  781. read_record_fields([vd_record],nil);
  782. {$ifdef jvm}
  783. { we need a constructor to create temps, a deep copy helper, ... }
  784. add_java_default_record_methods_intf(trecorddef(current_structdef));
  785. {$endif}
  786. if target_info.system in systems_typed_constants_node_init then
  787. add_typedconst_init_routine(current_structdef);
  788. consume(_END);
  789. end;
  790. { make the record size aligned (has to be done before inserting the
  791. parameters, because that may depend on the record's size) }
  792. recst.addalignmentpadding;
  793. { don't keep track of procdefs in a separate list, because the
  794. compiler may add additional procdefs (e.g. property wrappers for
  795. the jvm backend) }
  796. insert_record_hidden_paras(trecorddef(current_structdef));
  797. { restore symtable stack }
  798. symtablestack.pop(recst);
  799. if trecorddef(current_structdef).is_packed and is_managed_type(current_structdef) then
  800. Message(type_e_no_packed_inittable);
  801. { restore old state }
  802. parse_generic:=old_parse_generic;
  803. current_structdef:=old_current_structdef;
  804. current_genericdef:=old_current_genericdef;
  805. current_specializedef:=old_current_specializedef;
  806. end;
  807. { reads a type definition and returns a pointer to it }
  808. procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean);
  809. var
  810. pt : tnode;
  811. tt2 : tdef;
  812. aktenumdef : tenumdef;
  813. s : TIDString;
  814. l,v : TConstExprInt;
  815. oldpackrecords : longint;
  816. defpos,storepos : tfileposinfo;
  817. name: TIDString;
  818. procedure expr_type;
  819. var
  820. pt1,pt2 : tnode;
  821. lv,hv : TConstExprInt;
  822. old_block_type : tblock_type;
  823. dospecialize : boolean;
  824. newdef : tdef;
  825. begin
  826. old_block_type:=block_type;
  827. dospecialize:=false;
  828. { use of current parsed object:
  829. classes, objects, records can be used also in themself }
  830. if (token=_ID) then
  831. if try_parse_structdef_nested_type(def,current_structdef,false) then
  832. exit;
  833. { Generate a specialization in FPC mode? }
  834. dospecialize:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_SPECIALIZE);
  835. { we can't accept a equal in type }
  836. pt1:=comp_expr(false,true);
  837. if not dospecialize and
  838. try_to_consume(_POINTPOINT) then
  839. begin
  840. { get high value of range }
  841. pt2:=comp_expr(false,false);
  842. { make both the same type or give an error. This is not
  843. done when both are integer values, because typecasting
  844. between -3200..3200 will result in a signed-unsigned
  845. conflict and give a range check error (PFV) }
  846. if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
  847. inserttypeconv(pt1,pt2.resultdef);
  848. { both must be evaluated to constants now }
  849. if (pt1.nodetype=ordconstn) and
  850. (pt2.nodetype=ordconstn) then
  851. begin
  852. lv:=tordconstnode(pt1).value;
  853. hv:=tordconstnode(pt2).value;
  854. { Check bounds }
  855. if hv<lv then
  856. message(parser_e_upper_lower_than_lower)
  857. else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then
  858. message(type_e_cant_eval_constant_expr)
  859. else
  860. begin
  861. { All checks passed, create the new def }
  862. case pt1.resultdef.typ of
  863. enumdef :
  864. def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue);
  865. orddef :
  866. begin
  867. if is_char(pt1.resultdef) then
  868. def:=torddef.create(uchar,lv,hv)
  869. else
  870. if is_boolean(pt1.resultdef) then
  871. def:=torddef.create(pasbool8,lv,hv)
  872. else if is_signed(pt1.resultdef) then
  873. def:=torddef.create(range_to_basetype(lv,hv),lv,hv)
  874. else
  875. def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
  876. end;
  877. end;
  878. end;
  879. end
  880. else
  881. Message(sym_e_error_in_type_def);
  882. pt2.free;
  883. end
  884. else
  885. begin
  886. { a simple type renaming or generic specialization }
  887. if (pt1.nodetype=typen) then
  888. begin
  889. def:=ttypenode(pt1).resultdef;
  890. { Delphi mode specialization? }
  891. if (m_delphi in current_settings.modeswitches) then
  892. dospecialize:=token=_LSHARPBRACKET
  893. else
  894. { in non-Delphi modes we might get a inline specialization
  895. without "specialize" or "<T>" of the same type we're
  896. currently parsing, so we need to handle that special }
  897. newdef:=nil;
  898. if not dospecialize and
  899. assigned(ttypenode(pt1).typesym) and
  900. (ttypenode(pt1).typesym.typ=typesym) and
  901. (sp_generic_dummy in ttypenode(pt1).typesym.symoptions) and
  902. assigned(current_structdef) and
  903. (
  904. (
  905. not (m_delphi in current_settings.modeswitches) and
  906. (ttypesym(ttypenode(pt1).typesym).typedef.typ=undefineddef) and
  907. (df_generic in current_structdef.defoptions) and
  908. (ttypesym(ttypenode(pt1).typesym).typedef.owner=current_structdef.owner) and
  909. (upper(ttypenode(pt1).typesym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
  910. ) or (
  911. { this could be a nested specialization which uses
  912. the type name of a surrounding generic to
  913. reference the specialization of said surrounding
  914. class }
  915. (df_specialization in current_structdef.defoptions) and
  916. return_specialization_of_generic(current_structdef,ttypesym(ttypenode(pt1).typesym).typedef,newdef)
  917. )
  918. )
  919. then
  920. begin
  921. if assigned(newdef) then
  922. def:=newdef
  923. else
  924. def:=current_structdef;
  925. if assigned(def) then
  926. { handle nested types }
  927. post_comp_expr_gendef(def)
  928. else
  929. def:=generrordef;
  930. end;
  931. if dospecialize then
  932. begin
  933. generate_specialization(def,false,name);
  934. { handle nested types }
  935. if assigned(def) then
  936. post_comp_expr_gendef(def);
  937. end
  938. else
  939. begin
  940. if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
  941. begin
  942. def:=current_specializedef
  943. end
  944. else if (def=current_genericdef) then
  945. begin
  946. def:=current_genericdef
  947. end
  948. else if (df_generic in def.defoptions) and
  949. { TODO : check once nested generics are allowed }
  950. not
  951. (
  952. parse_generic and
  953. (current_genericdef.typ in [recorddef,objectdef]) and
  954. (def.typ in [recorddef,objectdef]) and
  955. (
  956. { if both defs belong to the same generic (e.g. both are
  957. subtypes) then we must allow the usage }
  958. defs_belong_to_same_generic(def,current_genericdef) or
  959. { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
  960. declarations inside a generic }
  961. (
  962. (ttypenode(pt1).typesym<>nil) and
  963. sym_is_owned_by(ttypenode(pt1).typesym,tabstractrecorddef(current_genericdef).symtable)
  964. )
  965. )
  966. )
  967. then
  968. begin
  969. Message(parser_e_no_generics_as_types);
  970. def:=generrordef;
  971. end
  972. else if is_classhelper(def) then
  973. begin
  974. Message(parser_e_no_category_as_types);
  975. def:=generrordef
  976. end
  977. end;
  978. end
  979. else
  980. Message(sym_e_error_in_type_def);
  981. end;
  982. pt1.free;
  983. block_type:=old_block_type;
  984. end;
  985. procedure set_dec;
  986. begin
  987. consume(_SET);
  988. consume(_OF);
  989. read_anon_type(tt2,true);
  990. if assigned(tt2) then
  991. begin
  992. case tt2.typ of
  993. { don't forget that min can be negativ PM }
  994. enumdef :
  995. if (tenumdef(tt2).min>=0) and
  996. (tenumdef(tt2).max<=255) then
  997. // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
  998. def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max)
  999. else
  1000. Message(sym_e_ill_type_decl_set);
  1001. orddef :
  1002. begin
  1003. if (torddef(tt2).ordtype<>uvoid) and
  1004. (torddef(tt2).ordtype<>uwidechar) and
  1005. (torddef(tt2).low>=0) then
  1006. // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
  1007. if Torddef(tt2).high>int64(high(byte)) then
  1008. message(sym_e_ill_type_decl_set)
  1009. else
  1010. def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue)
  1011. else
  1012. Message(sym_e_ill_type_decl_set);
  1013. end;
  1014. else
  1015. Message(sym_e_ill_type_decl_set);
  1016. end;
  1017. end
  1018. else
  1019. def:=generrordef;
  1020. end;
  1021. procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:TFPObjectList);
  1022. var
  1023. lowval,
  1024. highval : TConstExprInt;
  1025. indexdef : tdef;
  1026. hdef : tdef;
  1027. arrdef : tarraydef;
  1028. procedure setdefdecl(def:tdef);
  1029. begin
  1030. case def.typ of
  1031. enumdef :
  1032. begin
  1033. lowval:=tenumdef(def).min;
  1034. highval:=tenumdef(def).max;
  1035. if (m_fpc in current_settings.modeswitches) and
  1036. (tenumdef(def).has_jumps) then
  1037. Message(type_e_array_index_enums_with_assign_not_possible);
  1038. indexdef:=def;
  1039. end;
  1040. orddef :
  1041. begin
  1042. if torddef(def).ordtype in [uchar,
  1043. u8bit,u16bit,
  1044. s8bit,s16bit,s32bit,
  1045. {$ifdef cpu64bitaddr}
  1046. u32bit,s64bit,
  1047. {$endif cpu64bitaddr}
  1048. pasbool8,pasbool16,pasbool32,pasbool64,
  1049. bool8bit,bool16bit,bool32bit,bool64bit,
  1050. uwidechar] then
  1051. begin
  1052. lowval:=torddef(def).low;
  1053. highval:=torddef(def).high;
  1054. indexdef:=def;
  1055. end
  1056. else
  1057. Message1(parser_e_type_cant_be_used_in_array_index,def.typename);
  1058. end;
  1059. else
  1060. Message(sym_e_error_in_type_def);
  1061. end;
  1062. end;
  1063. var
  1064. old_current_genericdef,
  1065. old_current_specializedef: tstoreddef;
  1066. first,
  1067. old_parse_generic: boolean;
  1068. begin
  1069. old_current_genericdef:=current_genericdef;
  1070. old_current_specializedef:=current_specializedef;
  1071. old_parse_generic:=parse_generic;
  1072. current_genericdef:=nil;
  1073. current_specializedef:=nil;
  1074. first:=true;
  1075. arrdef:=tarraydef.create(0,0,s32inttype);
  1076. consume(_ARRAY);
  1077. { usage of specialized type inside its generic template }
  1078. if assigned(genericdef) then
  1079. current_specializedef:=arrdef
  1080. { reject declaration of generic class inside generic class }
  1081. else if assigned(genericlist) then
  1082. current_genericdef:=arrdef;
  1083. symtablestack.push(arrdef.symtable);
  1084. insert_generic_parameter_types(arrdef,genericdef,genericlist);
  1085. { there are two possibilties for the following to be true:
  1086. * the array declaration itself is generic
  1087. * the array is declared inside a generic
  1088. in both cases we need "parse_generic" and "current_genericdef"
  1089. so that e.g. specializations of another generic inside the
  1090. current generic can be used (either inline ones or "type" ones) }
  1091. parse_generic:=(df_generic in arrdef.defoptions) or old_parse_generic;
  1092. if parse_generic and not assigned(current_genericdef) then
  1093. current_genericdef:=old_current_genericdef;
  1094. { open array? }
  1095. if try_to_consume(_LECKKLAMMER) then
  1096. begin
  1097. { defaults }
  1098. indexdef:=generrordef;
  1099. { use defaults which don't overflow the compiler }
  1100. lowval:=0;
  1101. highval:=0;
  1102. repeat
  1103. { read the expression and check it, check apart if the
  1104. declaration is an enum declaration because that needs to
  1105. be parsed by readtype (PFV) }
  1106. if token=_LKLAMMER then
  1107. begin
  1108. read_anon_type(hdef,true);
  1109. setdefdecl(hdef);
  1110. end
  1111. else
  1112. begin
  1113. pt:=expr(true);
  1114. if pt.nodetype=typen then
  1115. setdefdecl(pt.resultdef)
  1116. else
  1117. begin
  1118. if pt.nodetype=rangen then
  1119. begin
  1120. { pure ordconstn expressions can be checked for
  1121. generics as well, but don't give an error in case
  1122. of parsing a generic if that isn't yet the case }
  1123. if (trangenode(pt).left.nodetype=ordconstn) and
  1124. (trangenode(pt).right.nodetype=ordconstn) then
  1125. begin
  1126. { make both the same type or give an error. This is not
  1127. done when both are integer values, because typecasting