pdecl.pas 56 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Does declaration (but not type) parsing 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 pdecl;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,
  23. { global }
  24. globtype,
  25. { symtable }
  26. symsym,symdef,symtype,
  27. { pass_1 }
  28. node;
  29. function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
  30. procedure const_dec(out had_generic:boolean);
  31. procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
  32. procedure label_dec;
  33. procedure type_dec(out had_generic:boolean);
  34. procedure types_dec(in_structure: boolean;out had_generic:boolean;var rtti_attrs_def: trtti_attribute_list);
  35. procedure var_dec(out had_generic:boolean);
  36. procedure threadvar_dec(out had_generic:boolean);
  37. procedure property_dec;
  38. procedure resourcestring_dec(out had_generic:boolean);
  39. procedure parse_rttiattributes(var rtti_attrs_def:trtti_attribute_list);
  40. function parse_forward_declaration(sym:tsym;gentypename,genorgtypename:tidstring;genericdef:tdef;generictypelist:tfphashobjectlist;out newtype:ttypesym):tdef;
  41. implementation
  42. uses
  43. SysUtils,
  44. { common }
  45. cutils,
  46. { global }
  47. globals,tokens,verbose,widestr,constexp,
  48. systems,aasmdata,fmodule,compinnr,
  49. { symtable }
  50. symconst,symbase,symcpu,symcreat,defutil,defcmp,symtable,
  51. { pass 1 }
  52. ninl,ncon,nobj,ngenutil,nld,nmem,ncal,pass_1,
  53. { parser }
  54. scanner,
  55. pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,pparautl,
  56. procdefutil,
  57. {$ifdef jvm}
  58. pjvm,
  59. {$endif}
  60. { cpu-information }
  61. cpuinfo
  62. ;
  63. function is_system_custom_attribute_descendant(def:tdef):boolean;
  64. begin
  65. if not assigned(class_tcustomattribute) then
  66. class_tcustomattribute:=tobjectdef(search_system_type('TCUSTOMATTRIBUTE').typedef);
  67. Result:=def_is_related(def,class_tcustomattribute);
  68. end;
  69. function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
  70. var
  71. hp : tconstsym;
  72. p : tnode;
  73. ps : pconstset;
  74. pd : pbestreal;
  75. pg : pguid;
  76. sp : pchar;
  77. pw : pcompilerwidestring;
  78. storetokenpos : tfileposinfo;
  79. begin
  80. readconstant:=nil;
  81. if orgname='' then
  82. internalerror(9584582);
  83. hp:=nil;
  84. p:=comp_expr([ef_accept_equal]);
  85. nodetype:=p.nodetype;
  86. storetokenpos:=current_tokenpos;
  87. current_tokenpos:=filepos;
  88. case p.nodetype of
  89. ordconstn:
  90. begin
  91. if p.resultdef.typ=pointerdef then
  92. hp:=cconstsym.create_ordptr(orgname,constpointer,tordconstnode(p).value.uvalue,p.resultdef)
  93. else
  94. hp:=cconstsym.create_ord(orgname,constord,tordconstnode(p).value,p.resultdef);
  95. end;
  96. stringconstn:
  97. begin
  98. if is_wide_or_unicode_string(p.resultdef) then
  99. begin
  100. initwidestring(pw);
  101. copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw);
  102. hp:=cconstsym.create_wstring(orgname,constwstring,pw);
  103. end
  104. else
  105. begin
  106. getmem(sp,tstringconstnode(p).len+1);
  107. move(tstringconstnode(p).value_str^,sp^,tstringconstnode(p).len+1);
  108. { if a non-default ansistring code page has been specified,
  109. keep it }
  110. if is_ansistring(p.resultdef) and
  111. (tstringdef(p.resultdef).encoding<>0) then
  112. hp:=cconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,p.resultdef)
  113. else
  114. hp:=cconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,nil);
  115. end;
  116. end;
  117. realconstn :
  118. begin
  119. new(pd);
  120. pd^:=trealconstnode(p).value_real;
  121. hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef);
  122. end;
  123. setconstn :
  124. begin
  125. new(ps);
  126. if assigned(tsetconstnode(p).value_set) then
  127. ps^:=tsetconstnode(p).value_set^
  128. else
  129. ps^:=[];
  130. hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef);
  131. end;
  132. pointerconstn :
  133. begin
  134. hp:=cconstsym.create_ordptr(orgname,constpointer,tpointerconstnode(p).value,p.resultdef);
  135. end;
  136. niln :
  137. begin
  138. hp:=cconstsym.create_ord(orgname,constnil,0,p.resultdef);
  139. end;
  140. typen :
  141. begin
  142. if is_interface(p.resultdef) then
  143. begin
  144. if assigned(tobjectdef(p.resultdef).iidguid) then
  145. begin
  146. new(pg);
  147. pg^:=tobjectdef(p.resultdef).iidguid^;
  148. hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef);
  149. end
  150. else
  151. Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^);
  152. end
  153. else
  154. Message(parser_e_illegal_expression);
  155. end;
  156. inlinen:
  157. begin
  158. { this situation only happens if a intrinsic is parsed that has a
  159. generic type as its argument. As we don't know certain
  160. information about the final type yet, we need to use safe
  161. values (mostly 0, except for (Bit)SizeOf()) }
  162. if not parse_generic then
  163. Message(parser_e_illegal_expression);
  164. case tinlinenode(p).inlinenumber of
  165. in_sizeof_x:
  166. begin
  167. hp:=cconstsym.create_ord(orgname,constord,1,p.resultdef);
  168. end;
  169. in_bitsizeof_x:
  170. begin
  171. hp:=cconstsym.create_ord(orgname,constord,8,p.resultdef);
  172. end;
  173. { add other cases here if necessary }
  174. else
  175. Message(parser_e_illegal_expression);
  176. end;
  177. end;
  178. else
  179. begin
  180. { the node is from a generic parameter constant and is
  181. untyped so we need to pass a placeholder constant
  182. instead of givng an error }
  183. if nf_generic_para in p.flags then
  184. hp:=cconstsym.create_ord(orgname,constnil,0,p.resultdef)
  185. else
  186. Message(parser_e_illegal_expression);
  187. end;
  188. end;
  189. { transfer generic param flag from node to symbol }
  190. if nf_generic_para in p.flags then
  191. begin
  192. include(hp.symoptions,sp_generic_const);
  193. include(hp.symoptions,sp_generic_para);
  194. end;
  195. current_tokenpos:=storetokenpos;
  196. p.free;
  197. readconstant:=hp;
  198. end;
  199. procedure const_dec(out had_generic:boolean);
  200. begin
  201. consume(_CONST);
  202. consts_dec(false,true,had_generic);
  203. end;
  204. procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
  205. var
  206. orgname : TIDString;
  207. hdef : tdef;
  208. sym : tsym;
  209. flags : thccflags;
  210. dummysymoptions : tsymoptions;
  211. deprecatedmsg : pshortstring;
  212. storetokenpos,filepos : tfileposinfo;
  213. nodetype : tnodetype;
  214. old_block_type : tblock_type;
  215. first,
  216. isgeneric,
  217. expect_directive,
  218. skip_initialiser : boolean;
  219. varspez : tvarspez;
  220. asmtype : tasmlisttype;
  221. begin
  222. old_block_type:=block_type;
  223. block_type:=bt_const;
  224. had_generic:=false;
  225. first:=true;
  226. repeat
  227. orgname:=orgpattern;
  228. filepos:=current_tokenpos;
  229. isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
  230. consume(_ID);
  231. case token of
  232. _EQ:
  233. begin
  234. consume(_EQ);
  235. sym:=readconstant(orgname,filepos,nodetype);
  236. { Support hint directives }
  237. dummysymoptions:=[];
  238. deprecatedmsg:=nil;
  239. try_consume_hintdirective(dummysymoptions,deprecatedmsg);
  240. if assigned(sym) then
  241. begin
  242. sym.symoptions:=sym.symoptions+dummysymoptions;
  243. sym.deprecatedmsg:=deprecatedmsg;
  244. sym.visibility:=symtablestack.top.currentvisibility;
  245. symtablestack.top.insertsym(sym);
  246. sym.register_sym;
  247. {$ifdef jvm}
  248. { for the JVM target, some constants need to be
  249. initialized at run time (enums, sets) -> create fake
  250. typed const to do so (at least if they are visible
  251. outside this routine, since we won't directly access
  252. these symbols in the generated code) }
  253. if (symtablestack.top.symtablelevel<normal_function_level) and
  254. assigned(tconstsym(sym).constdef) and
  255. (tconstsym(sym).constdef.typ in [enumdef,setdef]) then
  256. jvm_add_typed_const_initializer(tconstsym(sym));
  257. {$endif}
  258. end
  259. else
  260. stringdispose(deprecatedmsg);
  261. consume(_SEMICOLON);
  262. end;
  263. _COLON:
  264. begin
  265. if not allow_typed_const then
  266. begin
  267. Message(parser_e_no_typed_const);
  268. consume_all_until(_SEMICOLON);
  269. end;
  270. { set the blocktype first so a consume also supports a
  271. caret, to support const s : ^string = nil }
  272. block_type:=bt_const_type;
  273. consume(_COLON);
  274. read_anon_type(hdef,false);
  275. block_type:=bt_const;
  276. { create symbol }
  277. storetokenpos:=current_tokenpos;
  278. current_tokenpos:=filepos;
  279. if not (cs_typed_const_writable in current_settings.localswitches) then
  280. begin
  281. varspez:=vs_const;
  282. asmtype:=al_rotypedconsts;
  283. end
  284. else
  285. begin
  286. varspez:=vs_value;
  287. asmtype:=al_typedconsts;
  288. end;
  289. { if we are dealing with structure const then we need to handle it as a
  290. structure static variable: create a symbol in unit symtable and a reference
  291. to it from the structure or linking will fail }
  292. if symtablestack.top.symtabletype in [recordsymtable,ObjectSymtable] then
  293. begin
  294. { note: we keep hdef so that we might at least read the
  295. constant data correctly for error recovery }
  296. check_allowed_for_var_or_const(hdef,false);
  297. sym:=cfieldvarsym.create(orgname,varspez,hdef,[]);
  298. symtablestack.top.insertsym(sym);
  299. sym:=make_field_static(symtablestack.top,tfieldvarsym(sym));
  300. end
  301. else
  302. begin
  303. sym:=cstaticvarsym.create(orgname,varspez,hdef,[]);
  304. sym.visibility:=symtablestack.top.currentvisibility;
  305. symtablestack.top.insertsym(sym);
  306. end;
  307. sym.register_sym;
  308. current_tokenpos:=storetokenpos;
  309. skip_initialiser:=false;
  310. { Anonymous proctype definitions can have proc directives }
  311. if (
  312. (hdef.typ=procvardef) or
  313. is_funcref(hdef)
  314. ) and
  315. (hdef.typesym=nil) then
  316. begin
  317. { Either "procedure; stdcall" or "procedure stdcall" }
  318. expect_directive:=try_to_consume(_SEMICOLON);
  319. if check_proc_directive(true) then
  320. parse_proctype_directives(hdef)
  321. else if expect_directive then
  322. begin
  323. Message(parser_e_proc_directive_expected);
  324. skip_initialiser:=true;
  325. end;
  326. { add default calling convention }
  327. if hdef.typ=procvardef then
  328. flags:=hcc_default_actions_intf
  329. else
  330. flags:=hcc_default_actions_intf_struct;
  331. handle_calling_convention(hdef,flags);
  332. end;
  333. { Parse the initialiser }
  334. if not skip_initialiser then
  335. begin
  336. consume(_EQ);
  337. read_typed_const(current_asmdata.asmlists[asmtype],tstaticvarsym(sym),in_structure);
  338. end;
  339. end;
  340. else
  341. if not first and isgeneric and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
  342. begin
  343. had_generic:=true;
  344. break;
  345. end
  346. else
  347. { generate an error }
  348. consume(_EQ);
  349. end;
  350. first:=false;
  351. until (token<>_ID) or
  352. (in_structure and
  353. ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
  354. ((m_final_fields in current_settings.modeswitches) and
  355. (idtoken=_FINAL))));
  356. block_type:=old_block_type;
  357. end;
  358. procedure label_dec;
  359. var
  360. labelsym : tlabelsym;
  361. begin
  362. consume(_LABEL);
  363. if not(cs_support_goto in current_settings.moduleswitches) then
  364. Message(sym_e_goto_and_label_not_supported);
  365. repeat
  366. if not(token in [_ID,_INTCONST]) then
  367. consume(_ID)
  368. else
  369. begin
  370. if token=_ID then
  371. labelsym:=clabelsym.create(orgpattern)
  372. else
  373. begin
  374. { strip leading 0's in iso mode }
  375. if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then
  376. while (length(pattern)>1) and (pattern[1]='0') do
  377. delete(pattern,1,1);
  378. labelsym:=clabelsym.create(pattern);
  379. end;
  380. symtablestack.top.insertsym(labelsym);
  381. if m_non_local_goto in current_settings.modeswitches then
  382. begin
  383. if symtablestack.top.symtabletype=localsymtable then
  384. begin
  385. labelsym.jumpbuf:=clocalvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
  386. symtablestack.top.insertsym(labelsym.jumpbuf);
  387. end
  388. else
  389. begin
  390. labelsym.jumpbuf:=cstaticvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
  391. symtablestack.top.insertsym(labelsym.jumpbuf);
  392. cnodeutils.insertbssdata(tstaticvarsym(labelsym.jumpbuf));
  393. end;
  394. include(labelsym.jumpbuf.symoptions,sp_internal);
  395. { the buffer will be setup later, but avoid a hint }
  396. tabstractvarsym(labelsym.jumpbuf).varstate:=vs_written;
  397. end;
  398. consume(token);
  399. end;
  400. if token<>_SEMICOLON then consume(_COMMA);
  401. until not(token in [_ID,_INTCONST]);
  402. consume(_SEMICOLON);
  403. end;
  404. function find_create_constructor(objdef:tobjectdef):tsymentry;
  405. begin
  406. while assigned(objdef) do
  407. begin
  408. result:=objdef.symtable.Find('CREATE');
  409. if assigned(result) then
  410. exit;
  411. objdef:=objdef.childof;
  412. end;
  413. // A class without a constructor called 'create'?!?
  414. internalerror(2012111101);
  415. end;
  416. procedure parse_rttiattributes(var rtti_attrs_def:trtti_attribute_list);
  417. function read_attr_paras:tnode;
  418. var
  419. old_block_type : tblock_type;
  420. begin
  421. if try_to_consume(_LKLAMMER) then
  422. begin
  423. { we only want constants here }
  424. old_block_type:=block_type;
  425. block_type:=bt_const;
  426. result:=parse_paras(false,false,_RKLAMMER);
  427. block_type:=old_block_type;
  428. consume(_RKLAMMER);
  429. end
  430. else
  431. result:=nil;
  432. end;
  433. var
  434. p,paran,pcalln,ptmp : tnode;
  435. i,pcount : sizeint;
  436. paras : array of tnode;
  437. od : tobjectdef;
  438. constrsym : tsymentry;
  439. typesym : ttypesym;
  440. parasok : boolean;
  441. begin
  442. consume(_LECKKLAMMER);
  443. repeat
  444. { Parse attribute type }
  445. p:=factor(false,[ef_type_only,ef_check_attr_suffix]);
  446. if p.nodetype=typen then
  447. begin
  448. typesym:=ttypesym(ttypenode(p).typesym);
  449. od:=tobjectdef(ttypenode(p).typedef);
  450. { Check if the attribute class is related to TCustomAttribute }
  451. if not is_system_custom_attribute_descendant(od) then
  452. begin
  453. incompatibletypes(od,class_tcustomattribute);
  454. read_attr_paras.free;
  455. continue;
  456. end;
  457. paran:=read_attr_paras;
  458. { Search the tprocdef of the constructor which has to be called. }
  459. constrsym:=find_create_constructor(od);
  460. if constrsym.typ<>procsym then
  461. internalerror(2018102301);
  462. pcalln:=ccallnode.create(paran,tprocsym(constrsym),od.symtable,cloadvmtaddrnode.create(p),[],nil);
  463. p:=nil;
  464. typecheckpass(pcalln);
  465. if (pcalln.nodetype=calln) and assigned(tcallnode(pcalln).procdefinition) and not codegenerror then
  466. begin
  467. { TODO: once extended RTTI for methods is supported, reject a
  468. constructor if it doesn't have extended RTTI enabled }
  469. { collect the parameters of the call node as there might be
  470. compile time type conversions (e.g. a Byte parameter being
  471. passed a value > 255) }
  472. paran:=tcallnode(pcalln).left;
  473. { only count visible parameters (thankfully open arrays are not
  474. supported, otherwise we'd need to handle those as well) }
  475. parasok:=true;
  476. paras:=nil;
  477. if assigned(paran) then
  478. begin
  479. ptmp:=paran;
  480. pcount:=0;
  481. while assigned(ptmp) do
  482. begin
  483. if not (vo_is_hidden_para in tcallparanode(ptmp).parasym.varoptions) then
  484. inc(pcount);
  485. ptmp:=tcallparanode(ptmp).right;
  486. end;
  487. setlength(paras,pcount);
  488. ptmp:=paran;
  489. pcount:=0;
  490. while assigned(ptmp) do
  491. begin
  492. if not (vo_is_hidden_para in tcallparanode(ptmp).parasym.varoptions) then
  493. begin
  494. if not is_constnode(tcallparanode(ptmp).left) then
  495. begin
  496. parasok:=false;
  497. messagepos(tcallparanode(ptmp).left.fileinfo,type_e_constant_expr_expected);
  498. end;
  499. paras[high(paras)-pcount]:=tcallparanode(ptmp).left.getcopy;
  500. inc(pcount);
  501. end;
  502. ptmp:=tcallparanode(ptmp).right;
  503. end;
  504. end;
  505. if parasok then
  506. begin
  507. { Add attribute to attribute list which will be added
  508. to the property which is defined next. }
  509. if not assigned(rtti_attrs_def) then
  510. rtti_attrs_def:=trtti_attribute_list.create;
  511. rtti_attrs_def.addattribute(typesym,tcallnode(pcalln).procdefinition,pcalln,paras);
  512. end
  513. else
  514. begin
  515. { cleanup }
  516. pcalln.free;
  517. for i:=0 to high(paras) do
  518. paras[i].free;
  519. end;
  520. end
  521. else
  522. pcalln.free;
  523. end
  524. else
  525. begin
  526. Message(type_e_type_id_expected);
  527. { try to recover by nevertheless reading the parameters (if any) }
  528. read_attr_paras.free;
  529. end;
  530. p.free;
  531. until not try_to_consume(_COMMA);
  532. consume(_RECKKLAMMER);
  533. end;
  534. function parse_forward_declaration(sym:tsym;gentypename,genorgtypename:tidstring;genericdef:tdef;generictypelist:tfphashobjectlist;out newtype:ttypesym):tdef;
  535. var
  536. wasforward : boolean;
  537. objecttype : tobjecttyp;
  538. gendef : tstoreddef;
  539. begin
  540. newtype:=nil;
  541. wasforward:=false;
  542. if ((token=_CLASS) or
  543. (token=_INTERFACE) or
  544. (token=_DISPINTERFACE) or
  545. (token=_OBJCCLASS) or
  546. (token=_OBJCPROTOCOL) or
  547. (token=_OBJCCATEGORY)) and
  548. (assigned(ttypesym(sym).typedef)) and
  549. is_implicit_pointer_object_type(ttypesym(sym).typedef) and
  550. (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
  551. begin
  552. wasforward:=true;
  553. objecttype:=odt_none;
  554. case token of
  555. _CLASS :
  556. objecttype:=default_class_type;
  557. _INTERFACE :
  558. case current_settings.interfacetype of
  559. it_interfacecom:
  560. objecttype:=odt_interfacecom;
  561. it_interfacecorba:
  562. objecttype:=odt_interfacecorba;
  563. it_interfacejava:
  564. objecttype:=odt_interfacejava;
  565. end;
  566. _DISPINTERFACE :
  567. objecttype:=odt_dispinterface;
  568. _OBJCCLASS,
  569. _OBJCCATEGORY :
  570. objecttype:=odt_objcclass;
  571. _OBJCPROTOCOL :
  572. objecttype:=odt_objcprotocol;
  573. else
  574. internalerror(200811072);
  575. end;
  576. consume(token);
  577. if assigned(genericdef) then
  578. gendef:=tstoreddef(genericdef)
  579. else
  580. { determine the generic def in case we are in a nested type
  581. of a specialization }
  582. gendef:=determine_generic_def(gentypename);
  583. { we can ignore the result, the definition is modified }
  584. object_dec(objecttype,genorgtypename,newtype,gendef,generictypelist,tobjectdef(ttypesym(sym).typedef),ht_none);
  585. if wasforward and
  586. (tobjectdef(ttypesym(sym).typedef).objecttype<>objecttype) then
  587. Message1(type_e_forward_interface_type_does_not_match,tobjectdef(ttypesym(sym).typedef).GetTypeName);
  588. newtype:=ttypesym(sym);
  589. result:=newtype.typedef;
  590. end
  591. else
  592. begin
  593. message1(parser_h_type_redef,genorgtypename);
  594. result:=generrordef;
  595. end;
  596. end;
  597. { From http://clang.llvm.org/docs/LanguageExtensions.html#objective-c-features :
  598. To determine whether a method has an inferred related result type, the first word in the camel-case selector
  599. (e.g., “init” in “initWithObjects”) is considered, and the method will have a related result type if its return
  600. type is compatible with the type of its class and if:
  601. * the first word is "alloc" or "new", and the method is a class method, or
  602. * the first word is "autorelease", "init", "retain", or "self", and the method is an instance method.
  603. If a method with a related result type is overridden by a subclass method, the subclass method must also return
  604. a type that is compatible with the subclass type.
  605. }
  606. procedure pd_set_objc_related_result(def: tobject; para: pointer);
  607. var
  608. pd: tprocdef;
  609. i, firstcamelend: longint;
  610. inferresult: boolean;
  611. begin
  612. if tdef(def).typ<>procdef then
  613. exit;
  614. pd:=tprocdef(def);
  615. if not(po_msgstr in pd.procoptions) then
  616. internalerror(2019082401);
  617. firstcamelend:=length(pd.messageinf.str^);
  618. for i:=1 to length(pd.messageinf.str^) do
  619. if pd.messageinf.str^[i] in ['A'..'Z'] then
  620. begin
  621. firstcamelend:=pred(i);
  622. break;
  623. end;
  624. case copy(pd.messageinf.str^,1,firstcamelend) of
  625. 'alloc',
  626. 'new':
  627. inferresult:=po_classmethod in pd.procoptions;
  628. 'autorelease',
  629. 'init',
  630. 'retain',
  631. 'self':
  632. inferresult:=not(po_classmethod in pd.procoptions);
  633. else
  634. inferresult:=false;
  635. end;
  636. if inferresult and
  637. def_is_related(tdef(pd.procsym.owner.defowner),pd.returndef) then
  638. include(pd.procoptions,po_objc_related_result_type);
  639. end;
  640. procedure types_dec(in_structure: boolean;out had_generic:boolean;var rtti_attrs_def: trtti_attribute_list);
  641. procedure finalize_class_external_status(od: tobjectdef);
  642. begin
  643. if [oo_is_external,oo_is_forward] <= od.objectoptions then
  644. begin
  645. { formal definition: x = objcclass external; }
  646. exclude(od.objectoptions,oo_is_forward);
  647. include(od.objectoptions,oo_is_formal);
  648. end;
  649. end;
  650. var
  651. typename,orgtypename,
  652. gentypename,genorgtypename : TIDString;
  653. newtype : ttypesym;
  654. dummysym,
  655. sym : tsym;
  656. hdef,
  657. hdef2 : tdef;
  658. defpos,storetokenpos : tfileposinfo;
  659. old_block_type : tblock_type;
  660. old_checkforwarddefs: TFPObjectList;
  661. flags : thccflags;
  662. setdummysym,
  663. first,
  664. isgeneric,
  665. isunique,
  666. istyperenaming : boolean;
  667. generictypelist : tfphashobjectlist;
  668. localgenerictokenbuf : tdynamicarray;
  669. p:tnode;
  670. gendef : tstoreddef;
  671. s : shortstring;
  672. i : longint;
  673. {$ifdef x86}
  674. segment_register: string;
  675. {$endif x86}
  676. begin
  677. old_block_type:=block_type;
  678. { save unit container of forward declarations -
  679. we can be inside nested class type block }
  680. old_checkforwarddefs:=current_module.checkforwarddefs;
  681. current_module.checkforwarddefs:=TFPObjectList.Create(false);
  682. block_type:=bt_type;
  683. hdef:=nil;
  684. first:=true;
  685. had_generic:=false;
  686. repeat
  687. defpos:=current_tokenpos;
  688. istyperenaming:=false;
  689. setdummysym:=false;
  690. generictypelist:=nil;
  691. localgenerictokenbuf:=nil;
  692. { class attribute definitions? }
  693. if m_prefixed_attributes in current_settings.modeswitches then
  694. while token=_LECKKLAMMER do
  695. parse_rttiattributes(rtti_attrs_def);
  696. { fpc generic declaration? }
  697. if first then
  698. had_generic:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
  699. isgeneric:=had_generic;
  700. typename:=pattern;
  701. orgtypename:=orgpattern;
  702. consume(_ID);
  703. { delphi generic declaration? }
  704. if (m_delphi in current_settings.modeswitches) then
  705. isgeneric:=token=_LSHARPBRACKET;
  706. { Generic type declaration? }
  707. if isgeneric then
  708. begin
  709. if assigned(current_genericdef) then
  710. Message(parser_f_no_generic_inside_generic);
  711. consume(_LSHARPBRACKET);
  712. generictypelist:=parse_generic_parameters(true);
  713. consume(_RSHARPBRACKET);
  714. str(generictypelist.Count,s);
  715. gentypename:=typename+'$'+s;
  716. genorgtypename:=orgtypename+'$'+s;
  717. end
  718. else
  719. begin
  720. gentypename:=typename;
  721. genorgtypename:=orgtypename;
  722. end;
  723. consume(_EQ);
  724. { support 'ttype=type word' syntax }
  725. isunique:=try_to_consume(_TYPE);
  726. { MacPas object model is more like Delphi's than like TP's, but }
  727. { uses the object keyword instead of class }
  728. if (m_mac in current_settings.modeswitches) and
  729. (token = _OBJECT) then
  730. token := _CLASS;
  731. { Start recording a generic template }
  732. if assigned(generictypelist) then
  733. begin
  734. localgenerictokenbuf:=tdynamicarray.create(256);
  735. current_scanner.startrecordtokens(localgenerictokenbuf);
  736. end;
  737. { is the type already defined? -- must be in the current symtable,
  738. not in a nested symtable or one higher up the stack -> don't
  739. use searchsym & friends! }
  740. sym:=tsym(symtablestack.top.find(gentypename));
  741. newtype:=nil;
  742. { found a symbol with this name? }
  743. if assigned(sym) then
  744. begin
  745. if (sym.typ=typesym) and
  746. { this should not be a symbol that was created by a generic
  747. that was declared earlier }
  748. not (
  749. (ttypesym(sym).typedef.typ=undefineddef) and
  750. (sp_generic_dummy in sym.symoptions)
  751. ) then
  752. begin
  753. hdef:=parse_forward_declaration(sym,gentypename,genorgtypename,nil,generictypelist,newtype);
  754. end;
  755. end;
  756. { no old type reused ? Then insert this new type }
  757. if not assigned(newtype) then
  758. begin
  759. if isgeneric then
  760. begin
  761. { we are not freeing the type parameters, so register them }
  762. for i:=0 to generictypelist.count-1 do
  763. begin
  764. tstoredsym(generictypelist[i]).register_sym;
  765. if tstoredsym(generictypelist[i]).typ=typesym then
  766. tstoreddef(ttypesym(generictypelist[i]).typedef).register_def;
  767. end;
  768. end;
  769. { insert the new type first with an errordef, so that
  770. referencing the type before it's really set it
  771. will give an error (PFV) }
  772. hdef:=generrordef;
  773. gendef:=nil;
  774. storetokenpos:=current_tokenpos;
  775. if isgeneric then
  776. begin
  777. { for generics we need to check whether a non-generic type
  778. already exists and if not we need to insert a symbol with
  779. the non-generic name (available in (org)typename) that is a
  780. undefineddef, so that inline specializations can be used }
  781. sym:=tsym(symtablestack.top.Find(typename));
  782. if not assigned(sym) then
  783. begin
  784. sym:=ctypesym.create(orgtypename,cundefineddef.create(true));
  785. Include(sym.symoptions,sp_generic_dummy);
  786. ttypesym(sym).typedef.typesym:=sym;
  787. sym.visibility:=symtablestack.top.currentvisibility;
  788. symtablestack.top.insertsym(sym);
  789. ttypesym(sym).typedef.owner:=sym.owner;
  790. end
  791. else
  792. { this is not allowed in non-Delphi modes }
  793. if not (m_delphi in current_settings.modeswitches) then
  794. Message1(sym_e_duplicate_id,genorgtypename)
  795. else
  796. begin
  797. { we need to find this symbol even if it's a variable or
  798. something else when doing an inline specialization }
  799. Include(sym.symoptions,sp_generic_dummy);
  800. add_generic_dummysym(sym);
  801. end;
  802. end
  803. else
  804. begin
  805. if assigned(sym) and (sym.typ=typesym) and
  806. (ttypesym(sym).typedef.typ=undefineddef) and
  807. (sp_generic_dummy in sym.symoptions) then
  808. begin
  809. { this is a symbol that was added by an earlier generic
  810. declaration, reuse it }
  811. newtype:=ttypesym(sym);
  812. newtype.typedef:=hdef;
  813. { use the correct casing }
  814. newtype.RealName:=genorgtypename;
  815. sym:=nil;
  816. end;
  817. { determine the generic def in case we are in a nested type
  818. of a specialization }
  819. gendef:=determine_generic_def(gentypename);
  820. end;
  821. { insert a new type if we don't reuse an existing symbol }
  822. if not assigned(newtype) then
  823. begin
  824. newtype:=ctypesym.create(genorgtypename,hdef);
  825. newtype.visibility:=symtablestack.top.currentvisibility;
  826. symtablestack.top.insertsym(newtype);
  827. end;
  828. current_tokenpos:=defpos;
  829. current_tokenpos:=storetokenpos;
  830. { read the type definition }
  831. read_named_type(hdef,newtype,gendef,generictypelist,false,isunique);
  832. { update the definition of the type }
  833. if assigned(hdef) then
  834. begin
  835. if assigned(hdef.typesym) then
  836. begin
  837. istyperenaming:=true;
  838. include(newtype.symoptions,sp_explicitrename);
  839. end;
  840. if isunique then
  841. begin
  842. if is_objc_class_or_protocol(hdef) or
  843. is_java_class_or_interface(hdef) then
  844. Message(parser_e_unique_unsupported);
  845. if is_object(hdef) or
  846. is_class_or_interface_or_dispinterface(hdef) then
  847. begin
  848. { just create a copy that is a child of the original class class type; this is
  849. Delphi-compatible }
  850. hdef2:=tstoreddef(hdef).getcopy;
  851. tobjectdef(hdef2).childof:=tobjectdef(hdef);
  852. hdef:=hdef2;
  853. end
  854. else
  855. begin
  856. hdef:=tstoreddef(hdef).getcopy;
  857. { check if it is an ansistirng(codepage) declaration }
  858. if is_ansistring(hdef) and try_to_consume(_LKLAMMER) then
  859. begin
  860. p:=comp_expr([ef_accept_equal]);
  861. consume(_RKLAMMER);
  862. if not is_constintnode(p) then
  863. begin
  864. Message(parser_e_illegal_expression);
  865. { error recovery }
  866. end
  867. else
  868. begin
  869. if (tordconstnode(p).value<0) or (tordconstnode(p).value>65535) then
  870. begin
  871. Message(parser_e_invalid_codepage);
  872. tordconstnode(p).value:=0;
  873. end;
  874. tstringdef(hdef).encoding:=int64(tordconstnode(p).value);
  875. end;
  876. p.free;
  877. end;
  878. if (hdef.typ in [pointerdef,classrefdef]) and
  879. (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then
  880. current_module.checkforwarddefs.add(hdef);
  881. end;
  882. include(hdef.defoptions,df_unique);
  883. end;
  884. if not assigned(hdef.typesym) then
  885. begin
  886. hdef.typesym:=newtype;
  887. if sp_generic_dummy in newtype.symoptions then
  888. add_generic_dummysym(newtype);
  889. end;
  890. end;
  891. { in non-Delphi modes we need a reference to the generic def
  892. without the generic suffix, so it can be found easily when
  893. parsing method implementations }
  894. if isgeneric and assigned(sym) and
  895. not (m_delphi in current_settings.modeswitches) and
  896. (ttypesym(sym).typedef.typ=undefineddef) then
  897. begin
  898. { don't free the undefineddef as the defids rely on the count
  899. of the defs in the def list of the module}
  900. ttypesym(sym).typedef:=hdef;
  901. setdummysym:=true;
  902. end;
  903. newtype.typedef:=hdef;
  904. { ensure that the type is registered when no specialization is
  905. currently done }
  906. if (current_scanner.replay_stack_depth=0) and
  907. (
  908. (hdef.typ<>procvardef) or
  909. not (po_is_function_ref in tprocdef(hdef).procoptions)
  910. ) then
  911. hdef.register_def;
  912. { KAZ: handle TGUID declaration in system unit }
  913. if (cs_compilesystem in current_settings.moduleswitches) and
  914. assigned(hdef) and
  915. (hdef.typ=recorddef) then
  916. begin
  917. if not assigned(rec_tguid) and
  918. (gentypename='TGUID') and
  919. (hdef.size=16) then
  920. rec_tguid:=trecorddef(hdef)
  921. else if not assigned(rec_jmp_buf) and
  922. (gentypename='JMP_BUF') then
  923. rec_jmp_buf:=trecorddef(hdef)
  924. else if not assigned(rec_exceptaddr) and
  925. (gentypename='TEXCEPTADDR') then
  926. rec_exceptaddr:=trecorddef(hdef);
  927. end;
  928. end;
  929. if assigned(hdef) then
  930. begin
  931. case hdef.typ of
  932. pointerdef :
  933. begin
  934. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  935. consume(_SEMICOLON);
  936. {$ifdef x86}
  937. {$ifdef i8086}
  938. if try_to_consume(_HUGE) then
  939. begin
  940. tcpupointerdef(hdef).x86pointertyp:=x86pt_huge;
  941. consume(_SEMICOLON);
  942. end
  943. else
  944. {$endif i8086}
  945. if try_to_consume(_FAR) then
  946. begin
  947. {$if defined(i8086)}
  948. tcpupointerdef(hdef).x86pointertyp:=x86pt_far;
  949. {$elseif defined(i386)}
  950. tcpupointerdef(hdef).x86pointertyp:=x86pt_near_fs;
  951. {$elseif defined(x86_64)}
  952. { for compatibility with previous versions of fpc,
  953. far pointer = regular pointer on x86_64 }
  954. Message1(parser_w_ptr_type_ignored,'FAR');
  955. {$endif}
  956. consume(_SEMICOLON);
  957. end
  958. else
  959. if try_to_consume(_NEAR) then
  960. begin
  961. if token <> _SEMICOLON then
  962. begin
  963. segment_register:=get_stringconst;
  964. case UpCase(segment_register) of
  965. 'CS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_cs;
  966. 'DS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_ds;
  967. 'SS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_ss;
  968. 'ES': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_es;
  969. 'FS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_fs;
  970. 'GS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_gs;
  971. else
  972. Message(asmr_e_invalid_register);
  973. end;
  974. end
  975. else
  976. tcpupointerdef(hdef).x86pointertyp:=x86pt_near;
  977. consume(_SEMICOLON);
  978. end;
  979. {$else x86}
  980. { Previous versions of FPC support declaring a pointer as
  981. far even on non-x86 platforms. }
  982. if try_to_consume(_FAR) then
  983. begin
  984. Message1(parser_w_ptr_type_ignored,'FAR');
  985. consume(_SEMICOLON);
  986. end;
  987. {$endif x86}
  988. end;
  989. procvardef :
  990. begin
  991. { in case of type renaming, don't parse proc directives }
  992. if istyperenaming then
  993. begin
  994. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  995. consume(_SEMICOLON);
  996. end
  997. else
  998. begin
  999. if not check_proc_directive(true) then
  1000. begin
  1001. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  1002. consume(_SEMICOLON);
  1003. end;
  1004. parse_proctype_directives(tprocvardef(hdef));
  1005. if po_is_function_ref in tprocvardef(hdef).procoptions then
  1006. begin
  1007. if not (m_function_references in current_settings.modeswitches) and
  1008. not (po_is_block in tprocvardef(hdef).procoptions) then
  1009. messagepos(storetokenpos,sym_e_error_in_type_def)
  1010. else
  1011. begin
  1012. if setdummysym then
  1013. dummysym:=sym
  1014. else
  1015. dummysym:=nil;
  1016. adjust_funcref(hdef,newtype,dummysym);
  1017. end;
  1018. if current_scanner.replay_stack_depth=0 then
  1019. hdef.register_def;
  1020. end;
  1021. if hdef.typ=procvardef then
  1022. flags:=hcc_default_actions_intf
  1023. else
  1024. flags:=hcc_default_actions_intf_struct;
  1025. handle_calling_convention(hdef,flags);
  1026. if (hdef.typ=procvardef) and (po_is_function_ref in tprocvardef(hdef).procoptions) then
  1027. begin
  1028. if (po_is_block in tprocvardef(hdef).procoptions) and
  1029. not (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then
  1030. message(type_e_cblock_callconv);
  1031. end;
  1032. if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
  1033. consume(_SEMICOLON);
  1034. end;
  1035. end;
  1036. objectdef :
  1037. begin
  1038. if is_funcref(hdef) then
  1039. begin
  1040. if not check_proc_directive(true) then
  1041. begin
  1042. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  1043. consume(_SEMICOLON);
  1044. end;
  1045. parse_proctype_directives(hdef);
  1046. if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
  1047. consume(_SEMICOLON);
  1048. end
  1049. else
  1050. begin
  1051. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  1052. consume(_SEMICOLON);
  1053. end;
  1054. { change a forward and external class declaration into
  1055. formal external definition, so the compiler does not
  1056. expect an real definition later }
  1057. if is_objc_class_or_protocol(hdef) or
  1058. is_java_class_or_interface(hdef) then
  1059. finalize_class_external_status(tobjectdef(hdef));
  1060. { Build VMT indexes, skip for type renaming and forward classes }
  1061. if not istyperenaming and
  1062. not(oo_is_forward in tobjectdef(hdef).objectoptions) then
  1063. build_vmt(tobjectdef(hdef));
  1064. { In case of an objcclass, verify that all methods have a message
  1065. name set. We only check this now, because message names can be set
  1066. during the protocol (interface) mapping. At the same time, set the
  1067. mangled names (these depend on the "external" name of the class),
  1068. and mark private fields of external classes as "used" (to avoid
  1069. bogus notes about them being unused)
  1070. }
  1071. { watch out for crashes in case of errors }
  1072. if is_objc_class_or_protocol(hdef) and
  1073. (not is_objccategory(hdef) or
  1074. assigned(tobjectdef(hdef).childof)) then
  1075. begin
  1076. tobjectdef(hdef).finish_objc_data;
  1077. tobjectdef(hdef).symtable.DefList.ForEachCall(@pd_set_objc_related_result,nil);
  1078. end;
  1079. if is_cppclass(hdef) then
  1080. tobjectdef(hdef).finish_cpp_data;
  1081. end;
  1082. recorddef :
  1083. begin
  1084. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  1085. consume(_SEMICOLON);
  1086. end;
  1087. else
  1088. begin
  1089. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  1090. consume(_SEMICOLON);
  1091. end;
  1092. end;
  1093. { if we have a real type definition or a unique type we may bind
  1094. attributes to this def }
  1095. if not istyperenaming or isunique then
  1096. trtti_attribute_list.bind(rtti_attrs_def,tstoreddef(hdef).rtti_attribute_list);
  1097. if df_generic in hdef.defoptions then
  1098. { flag parent symtables that they now contain a generic }
  1099. hdef.owner.includeoption(sto_has_generic);
  1100. end;
  1101. if isgeneric and (not(hdef.typ in [objectdef,recorddef,arraydef,procvardef])
  1102. or is_objectpascal_helper(hdef)) then
  1103. message(parser_e_cant_create_generics_of_this_type);
  1104. { Stop recording a generic template }
  1105. if assigned(generictypelist) then
  1106. begin
  1107. current_scanner.stoprecordtokens;
  1108. tstoreddef(hdef).generictokenbuf:=localgenerictokenbuf;
  1109. { Generic is never a type renaming }
  1110. hdef.typesym:=newtype;
  1111. { reusing a forward declared type also reuses the type parameters,
  1112. so free them if they haven't been used }
  1113. for i:=0 to generictypelist.count-1 do
  1114. begin
  1115. if (tstoredsym(generictypelist[i]).typ=typesym) and
  1116. not ttypesym(generictypelist[i]).typedef.is_registered then
  1117. ttypesym(generictypelist[i]).typedef.free;
  1118. if not tstoredsym(generictypelist[i]).is_registered then
  1119. tstoredsym(generictypelist[i]).free;
  1120. end;
  1121. generictypelist.free;
  1122. end;
  1123. if not (m_delphi in current_settings.modeswitches) and
  1124. (token=_ID) and (idtoken=_GENERIC) then
  1125. begin
  1126. had_generic:=true;
  1127. consume(_ID);
  1128. if token in [_PROCEDURE,_FUNCTION,_CLASS] then
  1129. break;
  1130. end
  1131. else
  1132. had_generic:=false;
  1133. first:=false;
  1134. if assigned(rtti_attrs_def) and (rtti_attrs_def.get_attribute_count>0) then
  1135. Message1(parser_e_unbound_attribute,trtti_attribute(rtti_attrs_def.rtti_attributes[0]).typesym.prettyname);
  1136. {$ifdef DEBUG_NODE_XML}
  1137. if Assigned(hdef) then
  1138. hdef.XMLPrintDef(newtype);
  1139. {$endif DEBUG_NODE_XML}
  1140. until ((token<>_ID) and (token<>_LECKKLAMMER)) or
  1141. (in_structure and
  1142. ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
  1143. ((m_final_fields in current_settings.modeswitches) and
  1144. (idtoken=_FINAL))));
  1145. { resolve type block forward declarations and restore a unit
  1146. container for them }
  1147. resolve_forward_types;
  1148. current_module.checkforwarddefs.free;
  1149. current_module.checkforwarddefs:=old_checkforwarddefs;
  1150. block_type:=old_block_type;
  1151. end;
  1152. { reads a type declaration to the symbol table }
  1153. procedure type_dec(out had_generic:boolean);
  1154. var
  1155. rtti_attrs_def: trtti_attribute_list;
  1156. begin
  1157. consume(_TYPE);
  1158. rtti_attrs_def := nil;
  1159. types_dec(false,had_generic,rtti_attrs_def);
  1160. rtti_attrs_def.free;
  1161. end;
  1162. procedure var_dec(out had_generic:boolean);
  1163. { parses variable declarations and inserts them in }
  1164. { the top symbol table of symtablestack }
  1165. begin
  1166. consume(_VAR);
  1167. read_var_decls([vd_check_generic],had_generic);
  1168. end;
  1169. procedure property_dec;
  1170. { parses a global property (fpc mode feature) }
  1171. var
  1172. old_block_type: tblock_type;
  1173. begin
  1174. consume(_PROPERTY);
  1175. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  1176. message(parser_e_property_only_sgr);
  1177. old_block_type:=block_type;
  1178. block_type:=bt_const;
  1179. repeat
  1180. read_property_dec(false, nil);
  1181. consume(_SEMICOLON);
  1182. until token<>_ID;
  1183. block_type:=old_block_type;
  1184. end;
  1185. procedure threadvar_dec(out had_generic:boolean);
  1186. { parses thread variable declarations and inserts them in }
  1187. { the top symbol table of symtablestack }
  1188. begin
  1189. consume(_THREADVAR);
  1190. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  1191. message(parser_e_threadvars_only_sg);
  1192. if f_threading in features then
  1193. read_var_decls([vd_threadvar,vd_check_generic],had_generic)
  1194. else
  1195. begin
  1196. Message1(parser_f_unsupported_feature,featurestr[f_threading]);
  1197. read_var_decls([vd_check_generic],had_generic);
  1198. end;
  1199. end;
  1200. procedure resourcestring_dec(out had_generic:boolean);
  1201. var
  1202. orgname : TIDString;
  1203. p : tnode;
  1204. dummysymoptions : tsymoptions;
  1205. deprecatedmsg : pshortstring;
  1206. storetokenpos,filepos : tfileposinfo;
  1207. old_block_type : tblock_type;
  1208. sp : pchar;
  1209. sym : tsym;
  1210. first,
  1211. isgeneric : boolean;
  1212. begin
  1213. if target_info.system in systems_managed_vm then
  1214. message(parser_e_feature_unsupported_for_vm);
  1215. consume(_RESOURCESTRING);
  1216. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  1217. message(parser_e_resourcestring_only_sg);
  1218. first:=true;
  1219. had_generic:=false;
  1220. old_block_type:=block_type;
  1221. block_type:=bt_const;
  1222. repeat
  1223. orgname:=orgpattern;
  1224. filepos:=current_tokenpos;
  1225. isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
  1226. consume(_ID);
  1227. case token of
  1228. _EQ:
  1229. begin
  1230. consume(_EQ);
  1231. p:=comp_expr([ef_accept_equal]);
  1232. storetokenpos:=current_tokenpos;
  1233. current_tokenpos:=filepos;
  1234. sym:=nil;
  1235. case p.nodetype of
  1236. ordconstn:
  1237. begin
  1238. if is_constcharnode(p) then
  1239. begin
  1240. getmem(sp,2);
  1241. sp[0]:=chr(tordconstnode(p).value.svalue);
  1242. sp[1]:=#0;
  1243. sym:=cconstsym.create_string(orgname,constresourcestring,sp,1,nil);
  1244. end
  1245. else
  1246. Message(parser_e_illegal_expression);
  1247. end;
  1248. stringconstn:
  1249. with Tstringconstnode(p) do
  1250. begin
  1251. { resourcestrings are currently always single byte }
  1252. if cst_type in [cst_widestring,cst_unicodestring] then
  1253. changestringtype(getansistringdef);
  1254. getmem(sp,len+1);
  1255. move(value_str^,sp^,len+1);
  1256. sym:=cconstsym.create_string(orgname,constresourcestring,sp,len,nil);
  1257. end;
  1258. else
  1259. Message(parser_e_illegal_expression);
  1260. end;
  1261. current_tokenpos:=storetokenpos;
  1262. { Support hint directives }
  1263. dummysymoptions:=[];
  1264. deprecatedmsg:=nil;
  1265. try_consume_hintdirective(dummysymoptions,deprecatedmsg);
  1266. if assigned(sym) then
  1267. begin
  1268. sym.symoptions:=sym.symoptions+dummysymoptions;
  1269. sym.deprecatedmsg:=deprecatedmsg;
  1270. symtablestack.top.insertsym(sym);
  1271. end
  1272. else
  1273. stringdispose(deprecatedmsg);
  1274. consume(_SEMICOLON);
  1275. p.free;
  1276. end;
  1277. else
  1278. if not first and isgeneric and
  1279. (token in [_PROCEDURE, _FUNCTION, _CLASS]) then
  1280. begin
  1281. had_generic:=true;
  1282. break;
  1283. end
  1284. else
  1285. consume(_EQ);
  1286. end;
  1287. first:=false;
  1288. until token<>_ID;
  1289. block_type:=old_block_type;
  1290. end;
  1291. end.