pdecl.pas 40 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988
  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,
  27. { pass_1 }
  28. node;
  29. function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
  30. procedure const_dec;
  31. procedure consts_dec(in_structure, allow_typed_const: boolean);
  32. procedure label_dec;
  33. procedure type_dec;
  34. procedure types_dec(in_structure: boolean);
  35. procedure var_dec;
  36. procedure threadvar_dec;
  37. procedure property_dec;
  38. procedure resourcestring_dec;
  39. implementation
  40. uses
  41. { common }
  42. cutils,
  43. { global }
  44. globals,tokens,verbose,widestr,constexp,
  45. systems,aasmdata,fmodule,
  46. { symtable }
  47. symconst,symbase,symtype,symtable,symcreat,defutil,
  48. { pass 1 }
  49. htypechk,ninl,ncon,nobj,ngenutil,
  50. { parser }
  51. scanner,
  52. pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,
  53. {$ifdef jvm}
  54. pjvm,
  55. {$endif}
  56. { cpu-information }
  57. cpuinfo
  58. ;
  59. function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
  60. var
  61. hp : tconstsym;
  62. p : tnode;
  63. ps : pconstset;
  64. pd : pbestreal;
  65. pg : pguid;
  66. sp : pchar;
  67. pw : pcompilerwidestring;
  68. storetokenpos : tfileposinfo;
  69. begin
  70. readconstant:=nil;
  71. if orgname='' then
  72. internalerror(9584582);
  73. hp:=nil;
  74. p:=comp_expr(true,false);
  75. nodetype:=p.nodetype;
  76. storetokenpos:=current_tokenpos;
  77. current_tokenpos:=filepos;
  78. case p.nodetype of
  79. ordconstn:
  80. begin
  81. if p.resultdef.typ=pointerdef then
  82. hp:=tconstsym.create_ordptr(orgname,constpointer,tordconstnode(p).value.uvalue,p.resultdef)
  83. else
  84. hp:=tconstsym.create_ord(orgname,constord,tordconstnode(p).value,p.resultdef);
  85. end;
  86. stringconstn:
  87. begin
  88. if is_wide_or_unicode_string(p.resultdef) then
  89. begin
  90. initwidestring(pw);
  91. copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw);
  92. hp:=tconstsym.create_wstring(orgname,constwstring,pw);
  93. end
  94. else
  95. begin
  96. getmem(sp,tstringconstnode(p).len+1);
  97. move(tstringconstnode(p).value_str^,sp^,tstringconstnode(p).len+1);
  98. { if a non-default ansistring code page has been specified,
  99. keep it }
  100. if is_ansistring(p.resultdef) and
  101. (tstringdef(p.resultdef).encoding<>0) then
  102. hp:=tconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,p.resultdef)
  103. else
  104. hp:=tconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,nil);
  105. end;
  106. end;
  107. realconstn :
  108. begin
  109. new(pd);
  110. pd^:=trealconstnode(p).value_real;
  111. hp:=tconstsym.create_ptr(orgname,constreal,pd,p.resultdef);
  112. end;
  113. setconstn :
  114. begin
  115. new(ps);
  116. ps^:=tsetconstnode(p).value_set^;
  117. hp:=tconstsym.create_ptr(orgname,constset,ps,p.resultdef);
  118. end;
  119. pointerconstn :
  120. begin
  121. hp:=tconstsym.create_ordptr(orgname,constpointer,tpointerconstnode(p).value,p.resultdef);
  122. end;
  123. niln :
  124. begin
  125. hp:=tconstsym.create_ord(orgname,constnil,0,p.resultdef);
  126. end;
  127. typen :
  128. begin
  129. if is_interface(p.resultdef) then
  130. begin
  131. if assigned(tobjectdef(p.resultdef).iidguid) then
  132. begin
  133. new(pg);
  134. pg^:=tobjectdef(p.resultdef).iidguid^;
  135. hp:=tconstsym.create_ptr(orgname,constguid,pg,p.resultdef);
  136. end
  137. else
  138. Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^);
  139. end
  140. else
  141. Message(parser_e_illegal_expression);
  142. end;
  143. inlinen:
  144. begin
  145. { this situation only happens if a intrinsic is parsed that has a
  146. generic type as its argument. As we don't know certain
  147. information about the final type yet, we need to use safe
  148. values (mostly 0) }
  149. if not parse_generic then
  150. Message(parser_e_illegal_expression);
  151. case tinlinenode(p).inlinenumber of
  152. in_sizeof_x,
  153. in_bitsizeof_x:
  154. begin
  155. hp:=tconstsym.create_ord(orgname,constord,0,p.resultdef);
  156. end;
  157. { add other cases here if necessary }
  158. else
  159. Message(parser_e_illegal_expression);
  160. end;
  161. end;
  162. else
  163. Message(parser_e_illegal_expression);
  164. end;
  165. current_tokenpos:=storetokenpos;
  166. p.free;
  167. readconstant:=hp;
  168. end;
  169. procedure const_dec;
  170. begin
  171. consume(_CONST);
  172. consts_dec(false,true);
  173. end;
  174. procedure consts_dec(in_structure, allow_typed_const: boolean);
  175. var
  176. orgname : TIDString;
  177. hdef : tdef;
  178. sym : tsym;
  179. dummysymoptions : tsymoptions;
  180. deprecatedmsg : pshortstring;
  181. storetokenpos,filepos : tfileposinfo;
  182. nodetype : tnodetype;
  183. old_block_type : tblock_type;
  184. skipequal : boolean;
  185. tclist : tasmlist;
  186. varspez : tvarspez;
  187. begin
  188. old_block_type:=block_type;
  189. block_type:=bt_const;
  190. repeat
  191. orgname:=orgpattern;
  192. filepos:=current_tokenpos;
  193. consume(_ID);
  194. case token of
  195. _EQ:
  196. begin
  197. consume(_EQ);
  198. sym:=readconstant(orgname,filepos,nodetype);
  199. { Support hint directives }
  200. dummysymoptions:=[];
  201. deprecatedmsg:=nil;
  202. try_consume_hintdirective(dummysymoptions,deprecatedmsg);
  203. if assigned(sym) then
  204. begin
  205. sym.symoptions:=sym.symoptions+dummysymoptions;
  206. sym.deprecatedmsg:=deprecatedmsg;
  207. sym.visibility:=symtablestack.top.currentvisibility;
  208. symtablestack.top.insert(sym);
  209. {$ifdef jvm}
  210. { for the JVM target, some constants need to be
  211. initialized at run time (enums, sets) -> create fake
  212. typed const to do so }
  213. if assigned(tconstsym(sym).constdef) and
  214. (tconstsym(sym).constdef.typ in [enumdef,setdef]) then
  215. jvm_add_typed_const_initializer(tconstsym(sym));
  216. {$endif}
  217. end
  218. else
  219. stringdispose(deprecatedmsg);
  220. consume(_SEMICOLON);
  221. end;
  222. _COLON:
  223. begin
  224. if not allow_typed_const then
  225. begin
  226. Message(parser_e_no_typed_const);
  227. consume_all_until(_SEMICOLON);
  228. end;
  229. { set the blocktype first so a consume also supports a
  230. caret, to support const s : ^string = nil }
  231. block_type:=bt_const_type;
  232. consume(_COLON);
  233. read_anon_type(hdef,false);
  234. block_type:=bt_const;
  235. skipequal:=false;
  236. { create symbol }
  237. storetokenpos:=current_tokenpos;
  238. current_tokenpos:=filepos;
  239. if not (cs_typed_const_writable in current_settings.localswitches) then
  240. varspez:=vs_const
  241. else
  242. varspez:=vs_value;
  243. { if we are dealing with structure const then we need to handle it as a
  244. structure static variable: create a symbol in unit symtable and a reference
  245. to it from the structure or linking will fail }
  246. if symtablestack.top.symtabletype in [recordsymtable,ObjectSymtable] then
  247. begin
  248. sym:=tfieldvarsym.create(orgname,varspez,hdef,[]);
  249. symtablestack.top.insert(sym);
  250. sym:=make_field_static(symtablestack.top,tfieldvarsym(sym));
  251. end
  252. else
  253. begin
  254. sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
  255. sym.visibility:=symtablestack.top.currentvisibility;
  256. symtablestack.top.insert(sym);
  257. end;
  258. current_tokenpos:=storetokenpos;
  259. { procvar can have proc directives, but not type references }
  260. if (hdef.typ=procvardef) and
  261. (hdef.typesym=nil) then
  262. begin
  263. { support p : procedure;stdcall=nil; }
  264. if try_to_consume(_SEMICOLON) then
  265. begin
  266. if check_proc_directive(true) then
  267. parse_var_proc_directives(sym)
  268. else
  269. begin
  270. Message(parser_e_proc_directive_expected);
  271. skipequal:=true;
  272. end;
  273. end
  274. else
  275. { support p : procedure stdcall=nil; }
  276. begin
  277. if check_proc_directive(true) then
  278. parse_var_proc_directives(sym);
  279. end;
  280. { add default calling convention }
  281. handle_calling_convention(tabstractprocdef(hdef));
  282. end;
  283. if not skipequal then
  284. begin
  285. { get init value }
  286. consume(_EQ);
  287. if (cs_typed_const_writable in current_settings.localswitches) then
  288. tclist:=current_asmdata.asmlists[al_typedconsts]
  289. else
  290. tclist:=current_asmdata.asmlists[al_rotypedconsts];
  291. read_typed_const(tclist,tstaticvarsym(sym),in_structure);
  292. end;
  293. end;
  294. else
  295. { generate an error }
  296. consume(_EQ);
  297. end;
  298. until (token<>_ID) or
  299. (in_structure and
  300. ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
  301. ((m_final_fields in current_settings.modeswitches) and
  302. (idtoken=_FINAL))));
  303. block_type:=old_block_type;
  304. end;
  305. procedure label_dec;
  306. var
  307. labelsym : tlabelsym;
  308. begin
  309. consume(_LABEL);
  310. if not(cs_support_goto in current_settings.moduleswitches) then
  311. Message(sym_e_goto_and_label_not_supported);
  312. repeat
  313. if not(token in [_ID,_INTCONST]) then
  314. consume(_ID)
  315. else
  316. begin
  317. if token=_ID then
  318. labelsym:=tlabelsym.create(orgpattern)
  319. else
  320. labelsym:=tlabelsym.create(pattern);
  321. symtablestack.top.insert(labelsym);
  322. if m_non_local_goto in current_settings.modeswitches then
  323. begin
  324. if symtablestack.top.symtabletype=localsymtable then
  325. begin
  326. labelsym.jumpbuf:=tlocalvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
  327. symtablestack.top.insert(labelsym.jumpbuf);
  328. end
  329. else
  330. begin
  331. labelsym.jumpbuf:=tstaticvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]);
  332. symtablestack.top.insert(labelsym.jumpbuf);
  333. cnodeutils.insertbssdata(tstaticvarsym(labelsym.jumpbuf));
  334. end;
  335. include(labelsym.jumpbuf.symoptions,sp_internal);
  336. { the buffer will be setup later, but avoid a hint }
  337. tabstractvarsym(labelsym.jumpbuf).varstate:=vs_written;
  338. end;
  339. consume(token);
  340. end;
  341. if token<>_SEMICOLON then consume(_COMMA);
  342. until not(token in [_ID,_INTCONST]);
  343. consume(_SEMICOLON);
  344. end;
  345. procedure types_dec(in_structure: boolean);
  346. function determine_generic_def(name:tidstring):tstoreddef;
  347. var
  348. hashedid : THashedIDString;
  349. pd : tprocdef;
  350. sym : tsym;
  351. begin
  352. result:=nil;
  353. { check whether this is a declaration of a type inside a
  354. specialization }
  355. if assigned(current_structdef) and
  356. (df_specialization in current_structdef.defoptions) then
  357. begin
  358. if not assigned(current_structdef.genericdef) or
  359. not (current_structdef.genericdef.typ in [recorddef,objectdef]) then
  360. internalerror(2011052301);
  361. hashedid.id:=name;
  362. { we could be inside a method of the specialization
  363. instead of its declaration, so check that first (as
  364. local nested types aren't allowed we don't need to
  365. walk the symtablestack to find the localsymtable) }
  366. if symtablestack.top.symtabletype=localsymtable then
  367. begin
  368. { we are in a method }
  369. if not assigned(symtablestack.top.defowner) or
  370. (symtablestack.top.defowner.typ<>procdef) then
  371. internalerror(2011120701);
  372. pd:=tprocdef(symtablestack.top.defowner);
  373. if not assigned(pd.genericdef) or (pd.genericdef.typ<>procdef) then
  374. internalerror(2011120702);
  375. sym:=tsym(tprocdef(pd.genericdef).localst.findwithhash(hashedid));
  376. end
  377. else
  378. sym:=nil;
  379. if not assigned(sym) or not (sym.typ=typesym) then
  380. begin
  381. { now search in the declaration of the generic }
  382. sym:=tsym(tabstractrecorddef(current_structdef.genericdef).symtable.findwithhash(hashedid));
  383. if not assigned(sym) or not (sym.typ=typesym) then
  384. internalerror(2011052302);
  385. end;
  386. { use the corresponding type in the generic's symtable as
  387. genericdef for the specialized type }
  388. result:=tstoreddef(ttypesym(sym).typedef);
  389. end;
  390. end;
  391. procedure finalize_class_external_status(od: tobjectdef);
  392. begin
  393. if [oo_is_external,oo_is_forward] <= od.objectoptions then
  394. begin
  395. { formal definition: x = objcclass external; }
  396. exclude(od.objectoptions,oo_is_forward);
  397. include(od.objectoptions,oo_is_formal);
  398. end;
  399. end;
  400. var
  401. typename,orgtypename,
  402. gentypename,genorgtypename : TIDString;
  403. newtype : ttypesym;
  404. sym : tsym;
  405. hdef : tdef;
  406. defpos,storetokenpos : tfileposinfo;
  407. old_block_type : tblock_type;
  408. old_checkforwarddefs: TFPObjectList;
  409. objecttype : tobjecttyp;
  410. isgeneric,
  411. isunique,
  412. istyperenaming : boolean;
  413. generictypelist : TFPObjectList;
  414. generictokenbuf : tdynamicarray;
  415. vmtbuilder : TVMTBuilder;
  416. p:tnode;
  417. gendef : tstoreddef;
  418. s : shortstring;
  419. {$ifdef x86}
  420. segment_register: string;
  421. {$endif x86}
  422. begin
  423. old_block_type:=block_type;
  424. { save unit container of forward declarations -
  425. we can be inside nested class type block }
  426. old_checkforwarddefs:=current_module.checkforwarddefs;
  427. current_module.checkforwarddefs:=TFPObjectList.Create(false);
  428. block_type:=bt_type;
  429. repeat
  430. defpos:=current_tokenpos;
  431. istyperenaming:=false;
  432. generictypelist:=nil;
  433. generictokenbuf:=nil;
  434. { fpc generic declaration? }
  435. isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
  436. typename:=pattern;
  437. orgtypename:=orgpattern;
  438. consume(_ID);
  439. { delphi generic declaration? }
  440. if (m_delphi in current_settings.modeswitches) then
  441. isgeneric:=token=_LSHARPBRACKET;
  442. { Generic type declaration? }
  443. if isgeneric then
  444. begin
  445. if assigned(current_genericdef) then
  446. Message(parser_f_no_generic_inside_generic);
  447. consume(_LSHARPBRACKET);
  448. generictypelist:=parse_generic_parameters(true);
  449. consume(_RSHARPBRACKET);
  450. str(generictypelist.Count,s);
  451. gentypename:=typename+'$'+s;
  452. genorgtypename:=orgtypename+'$'+s;
  453. end
  454. else
  455. begin
  456. gentypename:=typename;
  457. genorgtypename:=orgtypename;
  458. end;
  459. consume(_EQ);
  460. { support 'ttype=type word' syntax }
  461. isunique:=try_to_consume(_TYPE);
  462. { MacPas object model is more like Delphi's than like TP's, but }
  463. { uses the object keyword instead of class }
  464. if (m_mac in current_settings.modeswitches) and
  465. (token = _OBJECT) then
  466. token := _CLASS;
  467. { Start recording a generic template }
  468. if assigned(generictypelist) then
  469. begin
  470. generictokenbuf:=tdynamicarray.create(256);
  471. current_scanner.startrecordtokens(generictokenbuf);
  472. end;
  473. { is the type already defined? -- must be in the current symtable,
  474. not in a nested symtable or one higher up the stack -> don't
  475. use searchsym & frinds! }
  476. sym:=tsym(symtablestack.top.find(gentypename));
  477. newtype:=nil;
  478. { found a symbol with this name? }
  479. if assigned(sym) then
  480. begin
  481. if (sym.typ=typesym) and
  482. { this should not be a symbol that was created by a generic
  483. that was declared earlier }
  484. not (
  485. (ttypesym(sym).typedef.typ=undefineddef) and
  486. (sp_generic_dummy in sym.symoptions)
  487. ) then
  488. begin
  489. if ((token=_CLASS) or
  490. (token=_INTERFACE) or
  491. (token=_DISPINTERFACE) or
  492. (token=_OBJCCLASS) or
  493. (token=_OBJCPROTOCOL) or
  494. (token=_OBJCCATEGORY)) and
  495. (assigned(ttypesym(sym).typedef)) and
  496. is_implicit_pointer_object_type(ttypesym(sym).typedef) and
  497. (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
  498. begin
  499. case token of
  500. _CLASS :
  501. objecttype:=default_class_type;
  502. _INTERFACE :
  503. case current_settings.interfacetype of
  504. it_interfacecom:
  505. objecttype:=odt_interfacecom;
  506. it_interfacecorba:
  507. objecttype:=odt_interfacecorba;
  508. it_interfacejava:
  509. objecttype:=odt_interfacejava;
  510. else
  511. internalerror(2010122611);
  512. end;
  513. _DISPINTERFACE :
  514. objecttype:=odt_dispinterface;
  515. _OBJCCLASS,
  516. _OBJCCATEGORY :
  517. objecttype:=odt_objcclass;
  518. _OBJCPROTOCOL :
  519. objecttype:=odt_objcprotocol;
  520. else
  521. internalerror(200811072);
  522. end;
  523. consume(token);
  524. { determine the generic def in case we are in a nested type
  525. of a specialization }
  526. gendef:=determine_generic_def(gentypename);
  527. { we can ignore the result, the definition is modified }
  528. object_dec(objecttype,genorgtypename,newtype,gendef,generictypelist,tobjectdef(ttypesym(sym).typedef),ht_none);
  529. newtype:=ttypesym(sym);
  530. hdef:=newtype.typedef;
  531. end
  532. else
  533. message1(parser_h_type_redef,genorgtypename);
  534. end;
  535. end;
  536. { no old type reused ? Then insert this new type }
  537. if not assigned(newtype) then
  538. begin
  539. { insert the new type first with an errordef, so that
  540. referencing the type before it's really set it
  541. will give an error (PFV) }
  542. hdef:=generrordef;
  543. gendef:=nil;
  544. storetokenpos:=current_tokenpos;
  545. if isgeneric then
  546. begin
  547. { for generics we need to check whether a non-generic type
  548. already exists and if not we need to insert a symbol with
  549. the non-generic name (available in (org)typename) that is a
  550. undefineddef, so that inline specializations can be used }
  551. sym:=tsym(symtablestack.top.Find(typename));
  552. if not assigned(sym) then
  553. begin
  554. sym:=ttypesym.create(orgtypename,tundefineddef.create);
  555. Include(sym.symoptions,sp_generic_dummy);
  556. ttypesym(sym).typedef.typesym:=sym;
  557. sym.visibility:=symtablestack.top.currentvisibility;
  558. symtablestack.top.insert(sym);
  559. ttypesym(sym).typedef.owner:=sym.owner;
  560. end
  561. else
  562. { this is not allowed in non-Delphi modes }
  563. if not (m_delphi in current_settings.modeswitches) then
  564. Message1(sym_e_duplicate_id,genorgtypename)
  565. else
  566. { we need to find this symbol even if it's a variable or
  567. something else when doing an inline specialization }
  568. Include(sym.symoptions,sp_generic_dummy);
  569. end
  570. else
  571. begin
  572. if assigned(sym) and (sym.typ=typesym) and
  573. (ttypesym(sym).typedef.typ=undefineddef) and
  574. (sp_generic_dummy in sym.symoptions) then
  575. begin
  576. { this is a symbol that was added by an earlier generic
  577. declaration, reuse it }
  578. newtype:=ttypesym(sym);
  579. newtype.typedef:=hdef;
  580. sym:=nil;
  581. end;
  582. { determine the generic def in case we are in a nested type
  583. of a specialization }
  584. gendef:=determine_generic_def(gentypename);
  585. end;
  586. { insert a new type if we don't reuse an existing symbol }
  587. if not assigned(newtype) then
  588. begin
  589. newtype:=ttypesym.create(genorgtypename,hdef);
  590. newtype.visibility:=symtablestack.top.currentvisibility;
  591. symtablestack.top.insert(newtype);
  592. end;
  593. current_tokenpos:=defpos;
  594. current_tokenpos:=storetokenpos;
  595. { read the type definition }
  596. read_named_type(hdef,newtype,gendef,generictypelist,false,isunique);
  597. { update the definition of the type }
  598. if assigned(hdef) then
  599. begin
  600. if df_generic in hdef.defoptions then
  601. { flag parent symtables that they now contain a generic }
  602. hdef.owner.includeoption(sto_has_generic);
  603. if assigned(hdef.typesym) then
  604. begin
  605. istyperenaming:=true;
  606. include(newtype.symoptions,sp_explicitrename);
  607. end;
  608. if isunique then
  609. begin
  610. if is_objc_class_or_protocol(hdef) or
  611. is_java_class_or_interface(hdef) then
  612. Message(parser_e_unique_unsupported);
  613. hdef:=tstoreddef(hdef).getcopy;
  614. { check if it is an ansistirng(codepage) declaration }
  615. if is_ansistring(hdef) and try_to_consume(_LKLAMMER) then
  616. begin
  617. p:=comp_expr(true,false);
  618. consume(_RKLAMMER);
  619. if not is_constintnode(p) then
  620. begin
  621. Message(parser_e_illegal_expression);
  622. { error recovery }
  623. end
  624. else
  625. begin
  626. if (tordconstnode(p).value<0) or (tordconstnode(p).value>65535) then
  627. begin
  628. Message(parser_e_invalid_codepage);
  629. tordconstnode(p).value:=0;
  630. end;
  631. tstringdef(hdef).encoding:=int64(tordconstnode(p).value);
  632. end;
  633. p.free;
  634. end;
  635. { fix name, it is used e.g. for tables }
  636. if is_class_or_interface_or_dispinterface(hdef) then
  637. with tobjectdef(hdef) do
  638. begin
  639. stringdispose(objname);
  640. stringdispose(objrealname);
  641. objrealname:=stringdup(genorgtypename);
  642. objname:=stringdup(upper(genorgtypename));
  643. end;
  644. include(hdef.defoptions,df_unique);
  645. if (hdef.typ in [pointerdef,classrefdef]) and
  646. (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then
  647. current_module.checkforwarddefs.add(hdef);
  648. end;
  649. if not assigned(hdef.typesym) then
  650. hdef.typesym:=newtype;
  651. end;
  652. { in non-Delphi modes we need a reference to the generic def
  653. without the generic suffix, so it can be found easily when
  654. parsing method implementations }
  655. if isgeneric and assigned(sym) and
  656. not (m_delphi in current_settings.modeswitches) and
  657. (ttypesym(sym).typedef.typ=undefineddef) then
  658. { don't free the undefineddef as the defids rely on the count
  659. of the defs in the def list of the module}
  660. ttypesym(sym).typedef:=hdef;
  661. newtype.typedef:=hdef;
  662. { KAZ: handle TGUID declaration in system unit }
  663. if (cs_compilesystem in current_settings.moduleswitches) and not assigned(rec_tguid) and
  664. (gentypename='TGUID') and { name: TGUID and size=16 bytes that is 128 bits }
  665. assigned(hdef) and (hdef.typ=recorddef) and (hdef.size=16) then
  666. rec_tguid:=trecorddef(hdef);
  667. end;
  668. if assigned(hdef) then
  669. begin
  670. case hdef.typ of
  671. pointerdef :
  672. begin
  673. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  674. consume(_SEMICOLON);
  675. {$ifdef x86}
  676. if try_to_consume(_FAR) then
  677. begin
  678. {$if defined(i8086)}
  679. tpointerdef(hdef).x86pointertyp:=x86pt_far;
  680. {$elseif defined(i386)}
  681. tpointerdef(hdef).x86pointertyp:=x86pt_near_fs;
  682. {$elseif defined(x86_64)}
  683. { for compatibility with previous versions of fpc,
  684. far pointer = regular pointer on x86_64 }
  685. { TODO: decide if we still want to keep this }
  686. {$endif}
  687. consume(_SEMICOLON);
  688. end
  689. else
  690. if try_to_consume(_NEAR) then
  691. begin
  692. if token <> _SEMICOLON then
  693. begin
  694. segment_register:=get_stringconst;
  695. case UpCase(segment_register) of
  696. 'CS': tpointerdef(hdef).x86pointertyp:=x86pt_near_cs;
  697. 'DS': tpointerdef(hdef).x86pointertyp:=x86pt_near_ds;
  698. 'SS': tpointerdef(hdef).x86pointertyp:=x86pt_near_ss;
  699. 'ES': tpointerdef(hdef).x86pointertyp:=x86pt_near_es;
  700. 'FS': tpointerdef(hdef).x86pointertyp:=x86pt_near_fs;
  701. 'GS': tpointerdef(hdef).x86pointertyp:=x86pt_near_gs;
  702. else
  703. Message(asmr_e_invalid_register);
  704. end;
  705. end
  706. else
  707. tpointerdef(hdef).x86pointertyp:=x86pt_near;
  708. consume(_SEMICOLON);
  709. end;
  710. {$else x86}
  711. { Previous versions of FPC support declaring a pointer as
  712. far even on non-x86 platforms.
  713. TODO: decide if we still want to keep this }
  714. if try_to_consume(_FAR) then
  715. begin
  716. consume(_SEMICOLON);
  717. end;
  718. {$endif x86}
  719. end;
  720. procvardef :
  721. begin
  722. { in case of type renaming, don't parse proc directives }
  723. if istyperenaming then
  724. begin
  725. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  726. consume(_SEMICOLON);
  727. end
  728. else
  729. begin
  730. if not check_proc_directive(true) then
  731. begin
  732. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  733. consume(_SEMICOLON);
  734. end;
  735. parse_var_proc_directives(tsym(newtype));
  736. handle_calling_convention(tprocvardef(hdef));
  737. if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
  738. consume(_SEMICOLON);
  739. end;
  740. end;
  741. objectdef :
  742. begin
  743. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  744. consume(_SEMICOLON);
  745. { change a forward and external class declaration into
  746. formal external definition, so the compiler does not
  747. expect an real definition later }
  748. if is_objc_class_or_protocol(hdef) or
  749. is_java_class_or_interface(hdef) then
  750. finalize_class_external_status(tobjectdef(hdef));
  751. { Build VMT indexes, skip for type renaming and forward classes }
  752. if (hdef.typesym=newtype) and
  753. not(oo_is_forward in tobjectdef(hdef).objectoptions) and
  754. not(df_generic in hdef.defoptions) then
  755. begin
  756. vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef));
  757. vmtbuilder.generate_vmt;
  758. vmtbuilder.free;
  759. end;
  760. { In case of an objcclass, verify that all methods have a message
  761. name set. We only check this now, because message names can be set
  762. during the protocol (interface) mapping. At the same time, set the
  763. mangled names (these depend on the "external" name of the class),
  764. and mark private fields of external classes as "used" (to avoid
  765. bogus notes about them being unused)
  766. }
  767. { watch out for crashes in case of errors }
  768. if is_objc_class_or_protocol(hdef) and
  769. (not is_objccategory(hdef) or
  770. assigned(tobjectdef(hdef).childof)) then
  771. tobjectdef(hdef).finish_objc_data;
  772. if is_cppclass(hdef) then
  773. tobjectdef(hdef).finish_cpp_data;
  774. end;
  775. recorddef :
  776. begin
  777. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  778. consume(_SEMICOLON);
  779. end;
  780. else
  781. begin
  782. try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg);
  783. consume(_SEMICOLON);
  784. end;
  785. end;
  786. end;
  787. if isgeneric and (not(hdef.typ in [objectdef,recorddef,arraydef,procvardef])
  788. or is_objectpascal_helper(hdef)) then
  789. message(parser_e_cant_create_generics_of_this_type);
  790. { Stop recording a generic template }
  791. if assigned(generictypelist) then
  792. begin
  793. current_scanner.stoprecordtokens;
  794. tstoreddef(hdef).generictokenbuf:=generictokenbuf;
  795. { Generic is never a type renaming }
  796. hdef.typesym:=newtype;
  797. generictypelist.free;
  798. end;
  799. until (token<>_ID) or
  800. (in_structure and
  801. ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
  802. ((m_final_fields in current_settings.modeswitches) and
  803. (idtoken=_FINAL))));
  804. { resolve type block forward declarations and restore a unit
  805. container for them }
  806. resolve_forward_types;
  807. current_module.checkforwarddefs.free;
  808. current_module.checkforwarddefs:=old_checkforwarddefs;
  809. block_type:=old_block_type;
  810. end;
  811. { reads a type declaration to the symbol table }
  812. procedure type_dec;
  813. begin
  814. consume(_TYPE);
  815. types_dec(false);
  816. end;
  817. procedure var_dec;
  818. { parses variable declarations and inserts them in }
  819. { the top symbol table of symtablestack }
  820. begin
  821. consume(_VAR);
  822. read_var_decls([]);
  823. end;
  824. procedure property_dec;
  825. { parses a global property (fpc mode feature) }
  826. var
  827. old_block_type: tblock_type;
  828. begin
  829. consume(_PROPERTY);
  830. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  831. message(parser_e_resourcestring_only_sg);
  832. old_block_type:=block_type;
  833. block_type:=bt_const;
  834. repeat
  835. read_property_dec(false, nil);
  836. consume(_SEMICOLON);
  837. until token<>_ID;
  838. block_type:=old_block_type;
  839. end;
  840. procedure threadvar_dec;
  841. { parses thread variable declarations and inserts them in }
  842. { the top symbol table of symtablestack }
  843. begin
  844. consume(_THREADVAR);
  845. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  846. message(parser_e_threadvars_only_sg);
  847. if f_threading in features then
  848. read_var_decls([vd_threadvar])
  849. else
  850. begin
  851. Message(parser_f_unsupported_feature);
  852. read_var_decls([]);
  853. end;
  854. end;
  855. procedure resourcestring_dec;
  856. var
  857. orgname : TIDString;
  858. p : tnode;
  859. dummysymoptions : tsymoptions;
  860. deprecatedmsg : pshortstring;
  861. storetokenpos,filepos : tfileposinfo;
  862. old_block_type : tblock_type;
  863. sp : pchar;
  864. sym : tsym;
  865. begin
  866. if target_info.system in systems_managed_vm then
  867. message(parser_e_feature_unsupported_for_vm);
  868. consume(_RESOURCESTRING);
  869. if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
  870. message(parser_e_resourcestring_only_sg);
  871. old_block_type:=block_type;
  872. block_type:=bt_const;
  873. repeat
  874. orgname:=orgpattern;
  875. filepos:=current_tokenpos;
  876. consume(_ID);
  877. case token of
  878. _EQ:
  879. begin
  880. consume(_EQ);
  881. p:=comp_expr(true,false);
  882. storetokenpos:=current_tokenpos;
  883. current_tokenpos:=filepos;
  884. sym:=nil;
  885. case p.nodetype of
  886. ordconstn:
  887. begin
  888. if is_constcharnode(p) then
  889. begin
  890. getmem(sp,2);
  891. sp[0]:=chr(tordconstnode(p).value.svalue);
  892. sp[1]:=#0;
  893. sym:=tconstsym.create_string(orgname,constresourcestring,sp,1,nil);
  894. end
  895. else
  896. Message(parser_e_illegal_expression);
  897. end;
  898. stringconstn:
  899. with Tstringconstnode(p) do
  900. begin
  901. getmem(sp,len+1);
  902. move(value_str^,sp^,len+1);
  903. sym:=tconstsym.create_string(orgname,constresourcestring,sp,len,nil);
  904. end;
  905. else
  906. Message(parser_e_illegal_expression);
  907. end;
  908. current_tokenpos:=storetokenpos;
  909. { Support hint directives }
  910. dummysymoptions:=[];
  911. deprecatedmsg:=nil;
  912. try_consume_hintdirective(dummysymoptions,deprecatedmsg);
  913. if assigned(sym) then
  914. begin
  915. sym.symoptions:=sym.symoptions+dummysymoptions;
  916. sym.deprecatedmsg:=deprecatedmsg;
  917. symtablestack.top.insert(sym);
  918. end
  919. else
  920. stringdispose(deprecatedmsg);
  921. consume(_SEMICOLON);
  922. p.free;
  923. end;
  924. else consume(_EQ);
  925. end;
  926. until token<>_ID;
  927. block_type:=old_block_type;
  928. end;
  929. end.