pdecobj.pas 36 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Does object 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 pdecobj;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,
  22. globtype,symconst,symtype,symdef;
  23. { parses a object declaration }
  24. function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tobjectdef;
  25. implementation
  26. uses
  27. cutils,
  28. globals,verbose,systems,tokens,
  29. symbase,symsym,symtable,
  30. node,nld,nmem,ncon,ncnv,ncal,
  31. fmodule,scanner,
  32. pbase,pexpr,pdecsub,pdecvar,ptype,pdecl
  33. ;
  34. const
  35. { Please leave this here, this module should NOT use
  36. these variables.
  37. Declaring it as string here results in an error when compiling (PFV) }
  38. current_procinfo = 'error';
  39. function constructor_head:tprocdef;
  40. var
  41. pd : tprocdef;
  42. begin
  43. result:=nil;
  44. consume(_CONSTRUCTOR);
  45. { must be at same level as in implementation }
  46. parse_proc_head(current_objectdef,potype_constructor,pd);
  47. if not assigned(pd) then
  48. begin
  49. consume(_SEMICOLON);
  50. exit;
  51. end;
  52. if (cs_constructor_name in current_settings.globalswitches) and
  53. (pd.procsym.name<>'INIT') then
  54. Message(parser_e_constructorname_must_be_init);
  55. consume(_SEMICOLON);
  56. include(current_objectdef.objectoptions,oo_has_constructor);
  57. { Set return type, class constructors return the
  58. created instance, object constructors return boolean }
  59. if is_class(pd._class) then
  60. pd.returndef:=pd._class
  61. else
  62. {$ifdef CPU64bitaddr}
  63. pd.returndef:=bool64type;
  64. {$else CPU64bitaddr}
  65. pd.returndef:=bool32type;
  66. {$endif CPU64bitaddr}
  67. result:=pd;
  68. end;
  69. procedure property_dec(is_classproperty:boolean);
  70. var
  71. p : tpropertysym;
  72. begin
  73. { check for a class }
  74. if not((is_class_or_interface_or_dispinterface(current_objectdef)) or
  75. (not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
  76. Message(parser_e_syntax_error);
  77. consume(_PROPERTY);
  78. p:=read_property_dec(is_classproperty, current_objectdef);
  79. consume(_SEMICOLON);
  80. if try_to_consume(_DEFAULT) then
  81. begin
  82. if oo_has_default_property in current_objectdef.objectoptions then
  83. message(parser_e_only_one_default_property);
  84. include(current_objectdef.objectoptions,oo_has_default_property);
  85. include(p.propoptions,ppo_defaultproperty);
  86. if not(ppo_hasparameters in p.propoptions) then
  87. message(parser_e_property_need_paras);
  88. if (token=_COLON) then
  89. begin
  90. Message(parser_e_field_not_allowed_here);
  91. consume_all_until(_SEMICOLON);
  92. end;
  93. consume(_SEMICOLON);
  94. end;
  95. { parse possible enumerator modifier }
  96. if try_to_consume(_ENUMERATOR) then
  97. begin
  98. if (token = _ID) then
  99. begin
  100. if pattern='CURRENT' then
  101. begin
  102. if oo_has_enumerator_current in current_objectdef.objectoptions then
  103. message(parser_e_only_one_enumerator_current);
  104. if not p.propaccesslist[palt_read].empty then
  105. begin
  106. include(current_objectdef.objectoptions,oo_has_enumerator_current);
  107. include(p.propoptions,ppo_enumerator_current);
  108. end
  109. else
  110. Message(parser_e_enumerator_current_is_not_valid) // property has no reader
  111. end
  112. else
  113. Message1(parser_e_invalid_enumerator_identifier, pattern);
  114. consume(token);
  115. end
  116. else
  117. Message(parser_e_enumerator_identifier_required);
  118. consume(_SEMICOLON);
  119. end;
  120. { hint directives, these can be separated by semicolons here,
  121. that needs to be handled here with a loop (PFV) }
  122. while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do
  123. Consume(_SEMICOLON);
  124. end;
  125. function destructor_head:tprocdef;
  126. var
  127. pd : tprocdef;
  128. begin
  129. result:=nil;
  130. consume(_DESTRUCTOR);
  131. parse_proc_head(current_objectdef,potype_destructor,pd);
  132. if not assigned(pd) then
  133. begin
  134. consume(_SEMICOLON);
  135. exit;
  136. end;
  137. if (cs_constructor_name in current_settings.globalswitches) and
  138. (pd.procsym.name<>'DONE') then
  139. Message(parser_e_destructorname_must_be_done);
  140. if not(pd.maxparacount=0) and
  141. (m_fpc in current_settings.modeswitches) then
  142. Message(parser_e_no_paras_for_destructor);
  143. consume(_SEMICOLON);
  144. include(current_objectdef.objectoptions,oo_has_destructor);
  145. { no return value }
  146. pd.returndef:=voidtype;
  147. result:=pd;
  148. end;
  149. procedure setinterfacemethodoptions;
  150. var
  151. i : longint;
  152. def : tdef;
  153. begin
  154. include(current_objectdef.objectoptions,oo_has_virtual);
  155. for i:=0 to current_objectdef.symtable.DefList.count-1 do
  156. begin
  157. def:=tdef(current_objectdef.symtable.DefList[i]);
  158. if assigned(def) and
  159. (def.typ=procdef) then
  160. begin
  161. include(tprocdef(def).procoptions,po_virtualmethod);
  162. tprocdef(def).forwarddef:=false;
  163. end;
  164. end;
  165. end;
  166. procedure setobjcclassmethodoptions;
  167. var
  168. i : longint;
  169. def : tdef;
  170. begin
  171. for i:=0 to current_objectdef.symtable.DefList.count-1 do
  172. begin
  173. def:=tdef(current_objectdef.symtable.DefList[i]);
  174. if assigned(def) and
  175. (def.typ=procdef) then
  176. begin
  177. include(tprocdef(def).procoptions,po_virtualmethod);
  178. end;
  179. end;
  180. end;
  181. procedure handleImplementedInterface(intfdef : tobjectdef);
  182. begin
  183. if not is_interface(intfdef) then
  184. begin
  185. Message1(type_e_interface_type_expected,intfdef.typename);
  186. exit;
  187. end;
  188. if current_objectdef.find_implemented_interface(intfdef)<>nil then
  189. Message1(sym_e_duplicate_id,intfdef.objname^)
  190. else
  191. begin
  192. { allocate and prepare the GUID only if the class
  193. implements some interfaces. }
  194. if current_objectdef.ImplementedInterfaces.count = 0 then
  195. current_objectdef.prepareguid;
  196. current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
  197. end;
  198. end;
  199. procedure handleImplementedProtocol(intfdef : tobjectdef);
  200. begin
  201. if not is_objcprotocol(intfdef) then
  202. begin
  203. Message1(type_e_protocol_type_expected,intfdef.typename);
  204. exit;
  205. end;
  206. if current_objectdef.find_implemented_interface(intfdef)<>nil then
  207. Message1(sym_e_duplicate_id,intfdef.objname^)
  208. else
  209. begin
  210. current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
  211. end;
  212. end;
  213. procedure readImplementedInterfacesAndProtocols(intf: boolean);
  214. var
  215. hdef : tdef;
  216. begin
  217. while try_to_consume(_COMMA) do
  218. begin
  219. id_type(hdef,false);
  220. if (hdef.typ<>objectdef) then
  221. begin
  222. if intf then
  223. Message1(type_e_interface_type_expected,hdef.typename)
  224. else
  225. Message1(type_e_protocol_type_expected,hdef.typename);
  226. continue;
  227. end;
  228. if intf then
  229. handleImplementedInterface(tobjectdef(hdef))
  230. else
  231. handleImplementedProtocol(tobjectdef(hdef));
  232. end;
  233. end;
  234. procedure readinterfaceiid;
  235. var
  236. p : tnode;
  237. valid : boolean;
  238. begin
  239. p:=comp_expr(true);
  240. if p.nodetype=stringconstn then
  241. begin
  242. stringdispose(current_objectdef.iidstr);
  243. current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str));
  244. valid:=string2guid(current_objectdef.iidstr^,current_objectdef.iidguid^);
  245. if (current_objectdef.objecttype in [odt_interfacecom,odt_dispinterface]) and
  246. not valid then
  247. Message(parser_e_improper_guid_syntax);
  248. include(current_objectdef.objectoptions,oo_has_valid_guid);
  249. end
  250. else
  251. Message(parser_e_illegal_expression);
  252. p.free;
  253. end;
  254. procedure parse_object_options;
  255. begin
  256. if current_objectdef.objecttype = odt_class then
  257. begin
  258. while true do
  259. begin
  260. if try_to_consume(_ABSTRACT) then
  261. include(current_objectdef.objectoptions,oo_is_abstract)
  262. else
  263. if try_to_consume(_SEALED) then
  264. include(current_objectdef.objectoptions,oo_is_sealed)
  265. else
  266. break;
  267. end;
  268. if [oo_is_abstract, oo_is_sealed] * current_objectdef.objectoptions = [oo_is_abstract, oo_is_sealed] then
  269. Message(parser_e_abstract_and_sealed_conflict);
  270. end;
  271. end;
  272. procedure parse_parent_classes;
  273. var
  274. intfchildof,
  275. childof : tobjectdef;
  276. hdef : tdef;
  277. hasparentdefined : boolean;
  278. begin
  279. childof:=nil;
  280. intfchildof:=nil;
  281. hasparentdefined:=false;
  282. { reads the parent class }
  283. if (token=_LKLAMMER) or
  284. is_objccategory(current_objectdef) then
  285. begin
  286. consume(_LKLAMMER);
  287. { use single_type instead of id_type for specialize support }
  288. single_type(hdef,false,false);
  289. if (not assigned(hdef)) or
  290. (hdef.typ<>objectdef) then
  291. begin
  292. if assigned(hdef) then
  293. Message1(type_e_class_type_expected,hdef.typename)
  294. else if is_objccategory(current_objectdef) then
  295. { a category must specify the class to extend }
  296. Message(type_e_objcclass_type_expected);
  297. end
  298. else
  299. begin
  300. childof:=tobjectdef(hdef);
  301. { a mix of class, interfaces, objects and cppclasses
  302. isn't allowed }
  303. case current_objectdef.objecttype of
  304. odt_class:
  305. if not(is_class(childof)) then
  306. begin
  307. if is_interface(childof) then
  308. begin
  309. { we insert the interface after the child
  310. is set, see below
  311. }
  312. intfchildof:=childof;
  313. childof:=class_tobject;
  314. end
  315. else
  316. Message(parser_e_mix_of_classes_and_objects);
  317. end
  318. else
  319. if oo_is_sealed in childof.objectoptions then
  320. Message1(parser_e_sealed_descendant,childof.typename);
  321. odt_interfacecorba,
  322. odt_interfacecom:
  323. begin
  324. if not(is_interface(childof)) then
  325. Message(parser_e_mix_of_classes_and_objects);
  326. current_objectdef.objecttype:=childof.objecttype;
  327. current_objectdef.objecttype:=current_objectdef.objecttype;
  328. end;
  329. odt_cppclass:
  330. if not(is_cppclass(childof)) then
  331. Message(parser_e_mix_of_classes_and_objects);
  332. odt_objcclass:
  333. if not(is_objcclass(childof) or
  334. is_objccategory(childof)) then
  335. begin
  336. if is_objcprotocol(childof) then
  337. begin
  338. if not(oo_is_classhelper in current_objectdef.objectoptions) then
  339. begin
  340. intfchildof:=childof;
  341. childof:=nil;
  342. CGMessage(parser_h_no_objc_parent);
  343. end
  344. else
  345. { a category must specify the class to extend }
  346. CGMessage(type_e_objcclass_type_expected);
  347. end
  348. else
  349. Message(parser_e_mix_of_classes_and_objects);
  350. end;
  351. odt_objcprotocol:
  352. begin
  353. if not(is_objcprotocol(childof)) then
  354. Message(parser_e_mix_of_classes_and_objects);
  355. intfchildof:=childof;
  356. childof:=nil;
  357. end;
  358. odt_object:
  359. if not(is_object(childof)) then
  360. Message(parser_e_mix_of_classes_and_objects);
  361. odt_dispinterface:
  362. Message(parser_e_dispinterface_cant_have_parent);
  363. end;
  364. end;
  365. hasparentdefined:=true;
  366. end;
  367. { no generic as parents }
  368. if assigned(childof) and
  369. (df_generic in childof.defoptions) then
  370. begin
  371. Message(parser_e_no_generics_as_types);
  372. childof:=nil;
  373. end;
  374. { if no parent class, then a class get tobject as parent }
  375. if not assigned(childof) then
  376. begin
  377. case current_objectdef.objecttype of
  378. odt_class:
  379. if current_objectdef<>class_tobject then
  380. childof:=class_tobject;
  381. odt_interfacecom:
  382. if current_objectdef<>interface_iunknown then
  383. childof:=interface_iunknown;
  384. odt_objcclass:
  385. CGMessage(parser_h_no_objc_parent);
  386. end;
  387. end;
  388. if assigned(childof) then
  389. begin
  390. { Forbid not completly defined objects to be used as parents. This will
  391. also prevent circular loops of classes, because we set the forward flag
  392. at the start of the new definition and will reset it below after the
  393. parent has been set }
  394. if not(oo_is_forward in childof.objectoptions) then
  395. current_objectdef.set_parent(childof)
  396. else
  397. Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
  398. end;
  399. { remove forward flag, is resolved }
  400. exclude(current_objectdef.objectoptions,oo_is_forward);
  401. if hasparentdefined then
  402. begin
  403. if current_objectdef.objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
  404. begin
  405. if assigned(intfchildof) then
  406. if current_objectdef.objecttype=odt_class then
  407. handleImplementedInterface(intfchildof)
  408. else
  409. handleImplementedProtocol(intfchildof);
  410. readImplementedInterfacesAndProtocols(current_objectdef.objecttype=odt_class);
  411. end;
  412. consume(_RKLAMMER);
  413. end;
  414. end;
  415. procedure parse_guid;
  416. begin
  417. { read GUID }
  418. if (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
  419. try_to_consume(_LECKKLAMMER) then
  420. begin
  421. readinterfaceiid;
  422. consume(_RECKKLAMMER);
  423. end
  424. else if (current_objectdef.objecttype=odt_dispinterface) then
  425. message(parser_e_dispinterface_needs_a_guid);
  426. end;
  427. procedure insert_generic_parameter_types(genericdef:tstoreddef;genericlist:TFPObjectList);
  428. var
  429. i : longint;
  430. generictype : ttypesym;
  431. begin
  432. current_objectdef.genericdef:=genericdef;
  433. if not assigned(genericlist) then
  434. exit;
  435. for i:=0 to genericlist.count-1 do
  436. begin
  437. generictype:=ttypesym(genericlist[i]);
  438. if generictype.typedef.typ=undefineddef then
  439. include(current_objectdef.defoptions,df_generic)
  440. else
  441. include(current_objectdef.defoptions,df_specialization);
  442. symtablestack.top.insert(generictype);
  443. end;
  444. end;
  445. procedure parse_object_members;
  446. procedure chkobjc(pd: tprocdef);
  447. begin
  448. if is_objc_class_or_protocol(pd._class) then
  449. begin
  450. include(pd.procoptions,po_objc);
  451. end;
  452. end;
  453. procedure chkcpp(pd:tprocdef);
  454. begin
  455. { nothing currently }
  456. end;
  457. procedure maybe_parse_hint_directives(pd:tprocdef);
  458. var
  459. dummysymoptions : tsymoptions;
  460. deprecatedmsg : pshortstring;
  461. begin
  462. dummysymoptions:=[];
  463. deprecatedmsg:=nil;
  464. while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
  465. Consume(_SEMICOLON);
  466. if assigned(pd) then
  467. begin
  468. pd.symoptions:=pd.symoptions+dummysymoptions;
  469. pd.deprecatedmsg:=deprecatedmsg;
  470. end
  471. else
  472. stringdispose(deprecatedmsg);
  473. end;
  474. var
  475. pd : tprocdef;
  476. has_destructor,
  477. oldparse_only,
  478. old_parse_generic : boolean;
  479. object_member_blocktype : tblock_type;
  480. fields_allowed, is_classdef, classfields: boolean;
  481. begin
  482. { empty class declaration ? }
  483. if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and
  484. (token=_SEMICOLON) then
  485. exit;
  486. old_parse_generic:=parse_generic;
  487. parse_generic:=(df_generic in current_objectdef.defoptions);
  488. { in "publishable" classes the default access type is published }
  489. if (oo_can_have_published in current_objectdef.objectoptions) then
  490. current_objectdef.symtable.currentvisibility:=vis_published
  491. else
  492. current_objectdef.symtable.currentvisibility:=vis_public;
  493. testcurobject:=1;
  494. has_destructor:=false;
  495. fields_allowed:=true;
  496. is_classdef:=false;
  497. classfields:=false;
  498. object_member_blocktype:=bt_general;
  499. repeat
  500. case token of
  501. _TYPE :
  502. begin
  503. if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
  504. Message(parser_e_type_and_var_only_in_generics);
  505. consume(_TYPE);
  506. object_member_blocktype:=bt_type;
  507. end;
  508. _VAR :
  509. begin
  510. if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
  511. (current_objectdef.objecttype<>odt_class) then
  512. Message(parser_e_type_and_var_only_in_generics);
  513. consume(_VAR);
  514. fields_allowed:=true;
  515. object_member_blocktype:=bt_general;
  516. classfields:=is_classdef;
  517. is_classdef:=false;
  518. end;
  519. _ID :
  520. begin
  521. if is_objcprotocol(current_objectdef) and
  522. ((idtoken=_REQUIRED) or
  523. (idtoken=_OPTIONAL)) then
  524. begin
  525. current_objectdef.symtable.currentlyoptional:=(idtoken=_OPTIONAL);
  526. consume(idtoken)
  527. end
  528. else case idtoken of
  529. _PRIVATE :
  530. begin
  531. if is_interface(current_objectdef) or
  532. is_objc_protocol_or_category(current_objectdef) then
  533. Message(parser_e_no_access_specifier_in_interfaces);
  534. consume(_PRIVATE);
  535. current_objectdef.symtable.currentvisibility:=vis_private;
  536. include(current_objectdef.objectoptions,oo_has_private);
  537. fields_allowed:=true;
  538. end;
  539. _PROTECTED :
  540. begin
  541. if is_interface(current_objectdef) or
  542. is_objc_protocol_or_category(current_objectdef) then
  543. Message(parser_e_no_access_specifier_in_interfaces);
  544. consume(_PROTECTED);
  545. current_objectdef.symtable.currentvisibility:=vis_protected;
  546. include(current_objectdef.objectoptions,oo_has_protected);
  547. fields_allowed:=true;
  548. end;
  549. _PUBLIC :
  550. begin
  551. if is_interface(current_objectdef) or
  552. is_objc_protocol_or_category(current_objectdef) then
  553. Message(parser_e_no_access_specifier_in_interfaces);
  554. consume(_PUBLIC);
  555. current_objectdef.symtable.currentvisibility:=vis_public;
  556. fields_allowed:=true;
  557. end;
  558. _PUBLISHED :
  559. begin
  560. { we've to check for a pushlished section in non- }
  561. { publishable classes later, if a real declaration }
  562. { this is the way, delphi does it }
  563. if is_interface(current_objectdef) then
  564. Message(parser_e_no_access_specifier_in_interfaces);
  565. { Objective-C classes do not support "published",
  566. as basically everything is published. }
  567. if is_objc_class_or_protocol(current_objectdef) then
  568. Message(parser_e_no_objc_published);
  569. consume(_PUBLISHED);
  570. current_objectdef.symtable.currentvisibility:=vis_published;
  571. fields_allowed:=true;
  572. end;
  573. _STRICT :
  574. begin
  575. if is_interface(current_objectdef) or
  576. is_objc_protocol_or_category(current_objectdef) then
  577. Message(parser_e_no_access_specifier_in_interfaces);
  578. consume(_STRICT);
  579. if token=_ID then
  580. begin
  581. case idtoken of
  582. _PRIVATE:
  583. begin
  584. consume(_PRIVATE);
  585. current_objectdef.symtable.currentvisibility:=vis_strictprivate;
  586. include(current_objectdef.objectoptions,oo_has_strictprivate);
  587. end;
  588. _PROTECTED:
  589. begin
  590. consume(_PROTECTED);
  591. current_objectdef.symtable.currentvisibility:=vis_strictprotected;
  592. include(current_objectdef.objectoptions,oo_has_strictprotected);
  593. end;
  594. else
  595. message(parser_e_protected_or_private_expected);
  596. end;
  597. end
  598. else
  599. message(parser_e_protected_or_private_expected);
  600. fields_allowed:=true;
  601. end;
  602. else
  603. begin
  604. if object_member_blocktype=bt_general then
  605. begin
  606. if is_interface(current_objectdef) or
  607. is_objc_protocol_or_category(current_objectdef) then
  608. Message(parser_e_no_vars_in_interfaces);
  609. if (current_objectdef.symtable.currentvisibility=vis_published) and
  610. not(oo_can_have_published in current_objectdef.objectoptions) then
  611. Message(parser_e_cant_have_published);
  612. if (not fields_allowed) then
  613. Message(parser_e_field_not_allowed_here);
  614. if classfields then
  615. read_record_fields([vd_object,vd_class])
  616. else
  617. read_record_fields([vd_object])
  618. end
  619. else
  620. types_dec;
  621. end;
  622. end;
  623. end;
  624. _PROPERTY :
  625. begin
  626. property_dec(is_classdef);
  627. fields_allowed:=false;
  628. is_classdef:=false;
  629. end;
  630. _CLASS:
  631. begin
  632. is_classdef:=false;
  633. { read class method }
  634. if try_to_consume(_CLASS) then
  635. begin
  636. { class method only allowed for procedures and functions }
  637. if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR]) then
  638. Message(parser_e_procedure_or_function_expected);
  639. if is_interface(current_objectdef) then
  640. Message(parser_e_no_static_method_in_interfaces)
  641. else
  642. { class methods are also allowed for Objective-C protocols }
  643. is_classdef:=true;
  644. end;
  645. end;
  646. _PROCEDURE,
  647. _FUNCTION:
  648. begin
  649. if (current_objectdef.symtable.currentvisibility=vis_published) and
  650. not(oo_can_have_published in current_objectdef.objectoptions) then
  651. Message(parser_e_cant_have_published);
  652. oldparse_only:=parse_only;
  653. parse_only:=true;
  654. pd:=parse_proc_dec(is_classdef, current_objectdef);
  655. { this is for error recovery as well as forward }
  656. { interface mappings, i.e. mapping to a method }
  657. { which isn't declared yet }
  658. if assigned(pd) then
  659. begin
  660. parse_object_proc_directives(pd);
  661. { all Macintosh Object Pascal methods are virtual. }
  662. { this can't be a class method, because macpas mode }
  663. { has no m_class }
  664. if (m_mac in current_settings.modeswitches) then
  665. include(pd.procoptions,po_virtualmethod);
  666. handle_calling_convention(pd);
  667. { add definition to procsym }
  668. proc_add_definition(pd);
  669. { add procdef options to objectdef options }
  670. if (po_msgint in pd.procoptions) then
  671. include(current_objectdef.objectoptions,oo_has_msgint);
  672. if (po_msgstr in pd.procoptions) then
  673. include(current_objectdef.objectoptions,oo_has_msgstr);
  674. if (po_virtualmethod in pd.procoptions) then
  675. include(current_objectdef.objectoptions,oo_has_virtual);
  676. chkcpp(pd);
  677. chkobjc(pd);
  678. end;
  679. maybe_parse_hint_directives(pd);
  680. parse_only:=oldparse_only;
  681. fields_allowed:=false;
  682. is_classdef:=false;
  683. end;
  684. _CONSTRUCTOR :
  685. begin
  686. if (current_objectdef.symtable.currentvisibility=vis_published) and
  687. not(oo_can_have_published in current_objectdef.objectoptions) then
  688. Message(parser_e_cant_have_published);
  689. if not(current_objectdef.symtable.currentvisibility in [vis_public,vis_published]) then
  690. Message(parser_w_constructor_should_be_public);
  691. if is_interface(current_objectdef) then
  692. Message(parser_e_no_con_des_in_interfaces);
  693. { Objective-C does not know the concept of a constructor }
  694. if is_objc_class_or_protocol(current_objectdef) then
  695. Message(parser_e_objc_no_constructor_destructor);
  696. oldparse_only:=parse_only;
  697. parse_only:=true;
  698. pd:=constructor_head;
  699. parse_object_proc_directives(pd);
  700. handle_calling_convention(pd);
  701. { add definition to procsym }
  702. proc_add_definition(pd);
  703. { add procdef options to objectdef options }
  704. if (po_virtualmethod in pd.procoptions) then
  705. include(current_objectdef.objectoptions,oo_has_virtual);
  706. chkcpp(pd);
  707. maybe_parse_hint_directives(pd);
  708. parse_only:=oldparse_only;
  709. fields_allowed:=false;
  710. end;
  711. _DESTRUCTOR :
  712. begin
  713. if (current_objectdef.symtable.currentvisibility=vis_published) and
  714. not(oo_can_have_published in current_objectdef.objectoptions) then
  715. Message(parser_e_cant_have_published);
  716. if has_destructor then
  717. Message(parser_n_only_one_destructor);
  718. has_destructor:=true;
  719. if is_interface(current_objectdef) then
  720. Message(parser_e_no_con_des_in_interfaces);
  721. if (current_objectdef.symtable.currentvisibility<>vis_public) then
  722. Message(parser_w_destructor_should_be_public);
  723. { Objective-C does not know the concept of a destructor }
  724. if is_objc_class_or_protocol(current_objectdef) then
  725. Message(parser_e_objc_no_constructor_destructor);
  726. oldparse_only:=parse_only;
  727. parse_only:=true;
  728. pd:=destructor_head;
  729. parse_object_proc_directives(pd);
  730. handle_calling_convention(pd);
  731. { add definition to procsym }
  732. proc_add_definition(pd);
  733. { add procdef options to objectdef options }
  734. if (po_virtualmethod in pd.procoptions) then
  735. include(current_objectdef.objectoptions,oo_has_virtual);
  736. chkcpp(pd);
  737. maybe_parse_hint_directives(pd);
  738. parse_only:=oldparse_only;
  739. fields_allowed:=false;
  740. end;
  741. _END :
  742. begin
  743. consume(_END);
  744. break;
  745. end;
  746. else
  747. consume(_ID); { Give a ident expected message, like tp7 }
  748. end;
  749. until false;
  750. { restore }
  751. testcurobject:=0;
  752. parse_generic:=old_parse_generic;
  753. end;
  754. function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tobjectdef;
  755. var
  756. old_current_objectdef : tobjectdef;
  757. begin
  758. old_current_objectdef:=current_objectdef;
  759. current_objectdef:=nil;
  760. { objects and class types can't be declared local }
  761. if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable]) and
  762. not assigned(genericlist) then
  763. Message(parser_e_no_local_objects);
  764. { reuse forward objectdef? }
  765. if assigned(fd) then
  766. begin
  767. if fd.objecttype<>objecttype then
  768. begin
  769. Message(parser_e_forward_mismatch);
  770. { recover }
  771. current_objectdef:=tobjectdef.create(current_objectdef.objecttype,n,nil);
  772. include(current_objectdef.objectoptions,oo_is_forward);
  773. end
  774. else
  775. current_objectdef:=fd
  776. end
  777. else
  778. begin
  779. { anonym objects aren't allow (o : object a : longint; end;) }
  780. if n='' then
  781. Message(parser_f_no_anonym_objects);
  782. { create new class }
  783. current_objectdef:=tobjectdef.create(objecttype,n,nil);
  784. { include always the forward flag, it'll be removed after the parent class have been
  785. added. This is to prevent circular childof loops }
  786. include(current_objectdef.objectoptions,oo_is_forward);
  787. if (cs_compilesystem in current_settings.moduleswitches) then
  788. begin
  789. case current_objectdef.objecttype of
  790. odt_interfacecom :
  791. if (current_objectdef.objname^='IUNKNOWN') then
  792. interface_iunknown:=current_objectdef;
  793. odt_class :
  794. if (current_objectdef.objname^='TOBJECT') then
  795. class_tobject:=current_objectdef;
  796. end;
  797. end;
  798. if (current_module.modulename^='OBJCBASE') then
  799. begin
  800. case current_objectdef.objecttype of
  801. odt_objcclass:
  802. if (current_objectdef.objname^='Protocol') then
  803. objc_protocoltype:=current_objectdef;
  804. end;
  805. end;
  806. end;
  807. { set published flag in $M+ mode, it can also be inherited and will
  808. be added when the parent class set with tobjectdef.set_parent (PFV) }
  809. if (cs_generate_rtti in current_settings.localswitches) and
  810. (current_objectdef.objecttype in [odt_interfacecom,odt_class]) then
  811. include(current_objectdef.objectoptions,oo_can_have_published);
  812. { forward def? }
  813. if not assigned(fd) and
  814. (token=_SEMICOLON) then
  815. begin
  816. { add to the list of definitions to check that the forward
  817. is resolved. this is required for delphi mode }
  818. current_module.checkforwarddefs.add(current_objectdef);
  819. end
  820. else
  821. begin
  822. { change objccategories into objcclass helpers }
  823. if (objecttype=odt_objccategory) then
  824. begin
  825. current_objectdef.objecttype:=odt_objcclass;
  826. include(current_objectdef.objectoptions,oo_is_classhelper);
  827. end;
  828. { parse list of options (abstract / sealed) }
  829. parse_object_options;
  830. { parse list of parent classes }
  831. parse_parent_classes;
  832. { parse optional GUID for interfaces }
  833. parse_guid;
  834. { parse and insert object members }
  835. symtablestack.push(current_objectdef.symtable);
  836. insert_generic_parameter_types(genericdef,genericlist);
  837. parse_object_members;
  838. symtablestack.pop(current_objectdef.symtable);
  839. end;
  840. { generate vmt space if needed }
  841. if not(oo_has_vmt in current_objectdef.objectoptions) and
  842. (
  843. ([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_objectdef.objectoptions<>[]) or
  844. (current_objectdef.objecttype in [odt_class])
  845. ) then
  846. current_objectdef.insertvmt;
  847. { for implemented classes with a vmt check if there is a constructor }
  848. if (oo_has_vmt in current_objectdef.objectoptions) and
  849. not(oo_is_forward in current_objectdef.objectoptions) and
  850. not(oo_has_constructor in current_objectdef.objectoptions) and
  851. not is_objc_class_or_protocol(current_objectdef) then
  852. Message1(parser_w_virtual_without_constructor,current_objectdef.objrealname^);
  853. if is_interface(current_objectdef) or
  854. is_objcprotocol(current_objectdef) then
  855. setinterfacemethodoptions
  856. else if is_objcclass(current_objectdef) then
  857. setobjcclassmethodoptions;
  858. { return defined objectdef }
  859. result:=current_objectdef;
  860. { restore old state }
  861. current_objectdef:=old_current_objectdef;
  862. end;
  863. end.