pdecobj.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805
  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,symtype,symdef;
  23. { parses a object declaration }
  24. function object_dec(const n : stringid;genericdef:tstoreddef;genericlist:tsinglelist;fd : tobjectdef) : tdef;
  25. implementation
  26. uses
  27. cutils,
  28. globals,verbose,systems,tokens,
  29. symconst,symbase,symsym,
  30. node,nld,nmem,ncon,ncnv,ncal,
  31. scanner,
  32. pbase,pexpr,pdecsub,pdecvar,ptype
  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 object_dec(const n : stringid;genericdef:tstoreddef;genericlist:tsinglelist;fd : tobjectdef) : tdef;
  40. { this function parses an object or class declaration }
  41. var
  42. there_is_a_destructor : boolean;
  43. classtype : tobjectdeftype;
  44. // childof : tobjectdef;
  45. function constructor_head:tprocdef;
  46. var
  47. pd : tprocdef;
  48. begin
  49. consume(_CONSTRUCTOR);
  50. { must be at same level as in implementation }
  51. parse_proc_head(aktobjectdef,potype_constructor,pd);
  52. if not assigned(pd) then
  53. begin
  54. consume(_SEMICOLON);
  55. exit;
  56. end;
  57. if (cs_constructor_name in aktglobalswitches) and
  58. (pd.procsym.name<>'INIT') then
  59. Message(parser_e_constructorname_must_be_init);
  60. consume(_SEMICOLON);
  61. include(aktobjectdef.objectoptions,oo_has_constructor);
  62. { Set return type, class constructors return the
  63. created instance, object constructors return boolean }
  64. if is_class(pd._class) then
  65. pd.rettype.setdef(pd._class)
  66. else
  67. pd.rettype:=booltype;
  68. constructor_head:=pd;
  69. end;
  70. procedure property_dec;
  71. var
  72. p : tpropertysym;
  73. begin
  74. { check for a class }
  75. if not((is_class_or_interface(aktobjectdef)) or
  76. (not(m_tp7 in aktmodeswitches) and (is_object(aktobjectdef)))) then
  77. Message(parser_e_syntax_error);
  78. consume(_PROPERTY);
  79. p:=read_property_dec(aktobjectdef);
  80. consume(_SEMICOLON);
  81. if try_to_consume(_DEFAULT) then
  82. begin
  83. if oo_has_default_property in aktobjectdef.objectoptions then
  84. message(parser_e_only_one_default_property);
  85. include(aktobjectdef.objectoptions,oo_has_default_property);
  86. include(p.propoptions,ppo_defaultproperty);
  87. if not(ppo_hasparameters in p.propoptions) then
  88. message(parser_e_property_need_paras);
  89. consume(_SEMICOLON);
  90. end;
  91. { hint directives, these can be separated by semicolons here,
  92. that needs to be handled here with a loop (PFV) }
  93. while try_consume_hintdirective(p.symoptions) do
  94. Consume(_SEMICOLON);
  95. end;
  96. function destructor_head:tprocdef;
  97. var
  98. pd : tprocdef;
  99. begin
  100. consume(_DESTRUCTOR);
  101. parse_proc_head(aktobjectdef,potype_destructor,pd);
  102. if not assigned(pd) then
  103. begin
  104. consume(_SEMICOLON);
  105. exit;
  106. end;
  107. if (cs_constructor_name in aktglobalswitches) and
  108. (pd.procsym.name<>'DONE') then
  109. Message(parser_e_destructorname_must_be_done);
  110. if not(pd.maxparacount=0) and
  111. (m_fpc in aktmodeswitches) then
  112. Message(parser_e_no_paras_for_destructor);
  113. consume(_SEMICOLON);
  114. include(aktobjectdef.objectoptions,oo_has_destructor);
  115. { no return value }
  116. pd.rettype:=voidtype;
  117. destructor_head:=pd;
  118. end;
  119. var
  120. pcrd : tclassrefdef;
  121. tt : ttype;
  122. old_object_option : tsymoptions;
  123. oldparse_only : boolean;
  124. storetypecanbeforward : boolean;
  125. procedure setclassattributes;
  126. begin
  127. { publishable }
  128. if classtype in [odt_interfacecom,odt_class] then
  129. begin
  130. aktobjectdef.objecttype:=classtype;
  131. { set published flag in $M+ mode or it is inherited }
  132. if (cs_generate_rtti in aktlocalswitches) or
  133. (assigned(aktobjectdef.childof) and
  134. (oo_can_have_published in aktobjectdef.childof.objectoptions)) then
  135. include(aktobjectdef.objectoptions,oo_can_have_published);
  136. { in "publishable" classes the default access type is published, this is
  137. done separate from above if-statement because the option can be
  138. inherited from the forward class definition }
  139. if (oo_can_have_published in aktobjectdef.objectoptions) then
  140. current_object_option:=[sp_published];
  141. end;
  142. end;
  143. procedure setinterfacemethodoptions;
  144. var
  145. i: longint;
  146. defs: TIndexArray;
  147. pd: tdef;
  148. begin
  149. include(aktobjectdef.objectoptions,oo_has_virtual);
  150. defs:=aktobjectdef.symtable.defindex;
  151. for i:=1 to defs.count do
  152. begin
  153. pd:=tdef(defs.search(i));
  154. if pd.deftype=procdef then
  155. begin
  156. tprocdef(pd).extnumber:=aktobjectdef.lastvtableindex;
  157. inc(aktobjectdef.lastvtableindex);
  158. include(tprocdef(pd).procoptions,po_virtualmethod);
  159. tprocdef(pd).forwarddef:=false;
  160. end;
  161. end;
  162. end;
  163. function readobjecttype : boolean;
  164. begin
  165. readobjecttype:=true;
  166. { distinguish classes and objects }
  167. case token of
  168. _OBJECT:
  169. begin
  170. classtype:=odt_object;
  171. consume(_OBJECT)
  172. end;
  173. _CPPCLASS:
  174. begin
  175. classtype:=odt_cppclass;
  176. consume(_CPPCLASS);
  177. end;
  178. _DISPINTERFACE:
  179. begin
  180. { need extra check here since interface is a keyword
  181. in all pascal modes }
  182. if not(m_class in aktmodeswitches) then
  183. Message(parser_f_need_objfpc_or_delphi_mode);
  184. classtype:=odt_dispinterface;
  185. consume(_DISPINTERFACE);
  186. { no forward declaration }
  187. if not(assigned(fd)) and (token=_SEMICOLON) then
  188. begin
  189. { also anonym objects aren't allow (o : object a : longint; end;) }
  190. if n='' then
  191. Message(parser_f_no_anonym_objects);
  192. aktobjectdef:=tobjectdef.create(classtype,n,nil);
  193. include(aktobjectdef.objectoptions,oo_is_forward);
  194. object_dec:=aktobjectdef;
  195. typecanbeforward:=storetypecanbeforward;
  196. readobjecttype:=false;
  197. exit;
  198. end;
  199. end;
  200. _INTERFACE:
  201. begin
  202. { need extra check here since interface is a keyword
  203. in all pascal modes }
  204. if not(m_class in aktmodeswitches) then
  205. Message(parser_f_need_objfpc_or_delphi_mode);
  206. if aktinterfacetype=it_interfacecom then
  207. classtype:=odt_interfacecom
  208. else {it_interfacecorba}
  209. classtype:=odt_interfacecorba;
  210. consume(_INTERFACE);
  211. { forward declaration }
  212. if not(assigned(fd)) and (token=_SEMICOLON) then
  213. begin
  214. { also anonym objects aren't allow (o : object a : longint; end;) }
  215. if n='' then
  216. Message(parser_f_no_anonym_objects);
  217. aktobjectdef:=tobjectdef.create(classtype,n,nil);
  218. if (cs_compilesystem in aktmoduleswitches) and
  219. (classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then
  220. interface_iunknown:=aktobjectdef;
  221. include(aktobjectdef.objectoptions,oo_is_forward);
  222. if (cs_generate_rtti in aktlocalswitches) and
  223. (classtype=odt_interfacecom) then
  224. include(aktobjectdef.objectoptions,oo_can_have_published);
  225. object_dec:=aktobjectdef;
  226. typecanbeforward:=storetypecanbeforward;
  227. readobjecttype:=false;
  228. exit;
  229. end;
  230. end;
  231. _CLASS:
  232. begin
  233. classtype:=odt_class;
  234. consume(_CLASS);
  235. if not(assigned(fd)) and
  236. (token=_OF) and
  237. { Delphi only allows class of in type blocks.
  238. Note that when parsing the type of a variable declaration
  239. the blocktype is bt_type so the check for typecanbeforward
  240. is also necessary (PFV) }
  241. (((block_type=bt_type) and typecanbeforward) or
  242. not(m_delphi in aktmodeswitches)) then
  243. begin
  244. { a hack, but it's easy to handle }
  245. { class reference type }
  246. consume(_OF);
  247. single_type(tt,typecanbeforward);
  248. { accept hp1, if is a forward def or a class }
  249. if (tt.def.deftype=forwarddef) or
  250. is_class(tt.def) then
  251. begin
  252. pcrd:=tclassrefdef.create(tt);
  253. object_dec:=pcrd;
  254. end
  255. else
  256. begin
  257. object_dec:=generrortype.def;
  258. Message1(type_e_class_type_expected,generrortype.def.typename);
  259. end;
  260. typecanbeforward:=storetypecanbeforward;
  261. readobjecttype:=false;
  262. exit;
  263. end
  264. { forward class }
  265. else if not(assigned(fd)) and (token=_SEMICOLON) then
  266. begin
  267. { also anonym objects aren't allow (o : object a : longint; end;) }
  268. if n='' then
  269. Message(parser_f_no_anonym_objects);
  270. aktobjectdef:=tobjectdef.create(odt_class,n,nil);
  271. if (cs_compilesystem in aktmoduleswitches) and (upper(n)='TOBJECT') then
  272. class_tobject:=aktobjectdef;
  273. aktobjectdef.objecttype:=odt_class;
  274. include(aktobjectdef.objectoptions,oo_is_forward);
  275. if (cs_generate_rtti in aktlocalswitches) then
  276. include(aktobjectdef.objectoptions,oo_can_have_published);
  277. { all classes must have a vmt !! at offset zero }
  278. if not(oo_has_vmt in aktobjectdef.objectoptions) then
  279. aktobjectdef.insertvmt;
  280. object_dec:=aktobjectdef;
  281. typecanbeforward:=storetypecanbeforward;
  282. readobjecttype:=false;
  283. exit;
  284. end;
  285. end;
  286. else
  287. begin
  288. classtype:=odt_class; { this is error but try to recover }
  289. consume(_OBJECT);
  290. end;
  291. end;
  292. end;
  293. procedure handleimplementedinterface(implintf : tobjectdef);
  294. begin
  295. if not is_interface(implintf) then
  296. begin
  297. Message1(type_e_interface_type_expected,implintf.typename);
  298. exit;
  299. end;
  300. if aktobjectdef.implementedinterfaces.searchintf(implintf)<>-1 then
  301. Message1(sym_e_duplicate_id,implintf.name)
  302. else
  303. begin
  304. { allocate and prepare the GUID only if the class
  305. implements some interfaces.
  306. }
  307. if aktobjectdef.implementedinterfaces.count = 0 then
  308. aktobjectdef.prepareguid;
  309. aktobjectdef.implementedinterfaces.addintf(implintf);
  310. end;
  311. end;
  312. procedure readimplementedinterfaces;
  313. var
  314. tt : ttype;
  315. begin
  316. while try_to_consume(_COMMA) do
  317. begin
  318. id_type(tt,false);
  319. if (tt.def.deftype<>objectdef) then
  320. begin
  321. Message1(type_e_interface_type_expected,tt.def.typename);
  322. continue;
  323. end;
  324. handleimplementedinterface(tobjectdef(tt.def));
  325. end;
  326. end;
  327. procedure readinterfaceiid;
  328. var
  329. p : tnode;
  330. valid : boolean;
  331. begin
  332. p:=comp_expr(true);
  333. if p.nodetype=stringconstn then
  334. begin
  335. stringdispose(aktobjectdef.iidstr);
  336. aktobjectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
  337. p.free;
  338. valid:=string2guid(aktobjectdef.iidstr^,aktobjectdef.iidguid^);
  339. if (classtype=odt_interfacecom) and not assigned(aktobjectdef.iidguid) and not valid then
  340. Message(parser_e_improper_guid_syntax);
  341. end
  342. else
  343. begin
  344. p.free;
  345. Message(parser_e_illegal_expression);
  346. end;
  347. end;
  348. procedure readparentclasses;
  349. var
  350. intfchildof,
  351. childof : tobjectdef;
  352. tt : ttype;
  353. hasparentdefined : boolean;
  354. begin
  355. childof:=nil;
  356. intfchildof:=nil;
  357. hasparentdefined:=false;
  358. { reads the parent class }
  359. if try_to_consume(_LKLAMMER) then
  360. begin
  361. id_type(tt,false);
  362. if (not assigned(tt.def)) or
  363. (tt.def.deftype<>objectdef) then
  364. begin
  365. if assigned(tt.def) then
  366. Message1(type_e_class_type_expected,childof.typename);
  367. end
  368. else
  369. begin
  370. childof:=tobjectdef(tt.def);
  371. { a mix of class, interfaces, objects and cppclasses
  372. isn't allowed }
  373. case classtype of
  374. odt_class:
  375. if not(is_class(childof)) then
  376. begin
  377. if is_interface(childof) then
  378. begin
  379. { we insert the interface after the child
  380. is set, see below
  381. }
  382. intfchildof:=childof;
  383. childof:=class_tobject;
  384. end
  385. else
  386. Message(parser_e_mix_of_classes_and_objects);
  387. end;
  388. odt_interfacecorba,
  389. odt_interfacecom:
  390. if not(is_interface(childof)) then
  391. Message(parser_e_mix_of_classes_and_objects);
  392. odt_cppclass:
  393. if not(is_cppclass(childof)) then
  394. Message(parser_e_mix_of_classes_and_objects);
  395. odt_object:
  396. if not(is_object(childof)) then
  397. Message(parser_e_mix_of_classes_and_objects);
  398. odt_dispinterface:
  399. Message(parser_e_dispinterface_cant_have_parent);
  400. end;
  401. end;
  402. hasparentdefined:=true;
  403. end;
  404. { if no parent class, then a class get tobject as parent }
  405. if not assigned(childof) then
  406. begin
  407. case classtype of
  408. odt_class:
  409. if aktobjectdef<>class_tobject then
  410. childof:=class_tobject;
  411. odt_interfacecom:
  412. if aktobjectdef<>interface_iunknown then
  413. childof:=interface_iunknown;
  414. end;
  415. end;
  416. if assigned(childof) then
  417. begin
  418. { Forbid not completly defined objects to be used as parents. This will
  419. also prevent circular loops of classes, because we set the forward flag
  420. at the start of the new definition and will reset it below after the
  421. parent has been set }
  422. if not(oo_is_forward in childof.objectoptions) then
  423. aktobjectdef.set_parent(childof)
  424. else
  425. Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
  426. end;
  427. { remove forward flag, is resolved }
  428. exclude(aktobjectdef.objectoptions,oo_is_forward);
  429. if hasparentdefined then
  430. begin
  431. if aktobjectdef.objecttype=odt_class then
  432. begin
  433. if assigned(intfchildof) then
  434. handleimplementedinterface(intfchildof);
  435. readimplementedinterfaces;
  436. end;
  437. consume(_RKLAMMER);
  438. end;
  439. { read GUID }
  440. if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
  441. try_to_consume(_LECKKLAMMER) then
  442. begin
  443. readinterfaceiid;
  444. consume(_RECKKLAMMER);
  445. end
  446. else if (classtype=odt_dispinterface) then
  447. message(parser_e_dispinterface_needs_a_guid);
  448. end;
  449. procedure chkcpp(pd:tprocdef);
  450. begin
  451. if is_cppclass(pd._class) then
  452. begin
  453. pd.proccalloption:=pocall_cppdecl;
  454. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  455. end;
  456. end;
  457. var
  458. pd : tprocdef;
  459. dummysymoptions : tsymoptions;
  460. generictype : ttypesym;
  461. begin
  462. old_object_option:=current_object_option;
  463. { objects and class types can't be declared local }
  464. if not(symtablestack.symtabletype in [globalsymtable,staticsymtable]) then
  465. Message(parser_e_no_local_objects);
  466. storetypecanbeforward:=typecanbeforward;
  467. { for tp7 don't allow forward types }
  468. if (m_tp7 in aktmodeswitches) then
  469. typecanbeforward:=false;
  470. if not(readobjecttype) then
  471. exit;
  472. if assigned(fd) then
  473. aktobjectdef:=fd
  474. else
  475. begin
  476. { anonym objects aren't allow (o : object a : longint; end;) }
  477. if n='' then
  478. Message(parser_f_no_anonym_objects);
  479. aktobjectdef:=tobjectdef.create(classtype,n,nil);
  480. { include forward flag, it'll be removed after the parent class have been
  481. added. This is to prevent circular childof loops }
  482. include(aktobjectdef.objectoptions,oo_is_forward);
  483. end;
  484. { read list of parent classes }
  485. readparentclasses;
  486. { default access is public }
  487. there_is_a_destructor:=false;
  488. current_object_option:=[sp_public];
  489. { set class flags and inherits published }
  490. setclassattributes;
  491. aktobjectdef.symtable.next:=symtablestack;
  492. symtablestack:=aktobjectdef.symtable;
  493. testcurobject:=1;
  494. { add generic type parameters }
  495. aktobjectdef.genericdef:=genericdef;
  496. if assigned(genericlist) then
  497. begin
  498. generictype:=ttypesym(genericlist.first);
  499. while assigned(generictype) do
  500. begin
  501. if generictype.restype.def.deftype=undefineddef then
  502. include(aktobjectdef.defoptions,df_generic)
  503. else
  504. include(aktobjectdef.defoptions,df_specialization);
  505. symtablestack.insert(generictype);
  506. generictype:=ttypesym(generictype.listnext);
  507. end;
  508. end;
  509. { short class declaration ? }
  510. if (classtype<>odt_class) or (token<>_SEMICOLON) then
  511. begin
  512. { Parse componenten }
  513. repeat
  514. case token of
  515. _ID :
  516. begin
  517. case idtoken of
  518. _PRIVATE :
  519. begin
  520. if is_interface(aktobjectdef) then
  521. Message(parser_e_no_access_specifier_in_interfaces);
  522. consume(_PRIVATE);
  523. current_object_option:=[sp_private];
  524. include(aktobjectdef.objectoptions,oo_has_private);
  525. end;
  526. _PROTECTED :
  527. begin
  528. if is_interface(aktobjectdef) then
  529. Message(parser_e_no_access_specifier_in_interfaces);
  530. consume(_PROTECTED);
  531. current_object_option:=[sp_protected];
  532. include(aktobjectdef.objectoptions,oo_has_protected);
  533. end;
  534. _PUBLIC :
  535. begin
  536. if is_interface(aktobjectdef) then
  537. Message(parser_e_no_access_specifier_in_interfaces);
  538. consume(_PUBLIC);
  539. current_object_option:=[sp_public];
  540. end;
  541. _PUBLISHED :
  542. begin
  543. { we've to check for a pushlished section in non- }
  544. { publishable classes later, if a real declaration }
  545. { this is the way, delphi does it }
  546. if is_interface(aktobjectdef) then
  547. Message(parser_e_no_access_specifier_in_interfaces);
  548. consume(_PUBLISHED);
  549. current_object_option:=[sp_published];
  550. end;
  551. _STRICT :
  552. begin
  553. if is_interface(aktobjectdef) then
  554. Message(parser_e_no_access_specifier_in_interfaces);
  555. consume(_STRICT);
  556. if token=_ID then
  557. begin
  558. case idtoken of
  559. _PRIVATE:
  560. begin
  561. consume(_PRIVATE);
  562. current_object_option:=[sp_strictprivate];
  563. include(aktobjectdef.objectoptions,oo_has_strictprivate);
  564. end;
  565. _PROTECTED:
  566. begin
  567. consume(_PROTECTED);
  568. current_object_option:=[sp_strictprotected];
  569. include(aktobjectdef.objectoptions,oo_has_strictprotected);
  570. end;
  571. else
  572. message(parser_e_protected_or_private_expected);
  573. end;
  574. end
  575. else
  576. message(parser_e_protected_or_private_expected);
  577. end;
  578. else
  579. begin
  580. if is_interface(aktobjectdef) then
  581. Message(parser_e_no_vars_in_interfaces);
  582. if (sp_published in current_object_option) and
  583. not(oo_can_have_published in aktobjectdef.objectoptions) then
  584. Message(parser_e_cant_have_published);
  585. read_var_decs([vd_object]);
  586. end;
  587. end;
  588. end;
  589. _PROPERTY :
  590. begin
  591. property_dec;
  592. end;
  593. _PROCEDURE,
  594. _FUNCTION,
  595. _CLASS :
  596. begin
  597. if (sp_published in current_object_option) and
  598. not(oo_can_have_published in aktobjectdef.objectoptions) then
  599. Message(parser_e_cant_have_published);
  600. oldparse_only:=parse_only;
  601. parse_only:=true;
  602. pd:=parse_proc_dec(aktobjectdef);
  603. { this is for error recovery as well as forward }
  604. { interface mappings, i.e. mapping to a method }
  605. { which isn't declared yet }
  606. if assigned(pd) then
  607. begin
  608. parse_object_proc_directives(pd);
  609. { all Macintosh Object Pascal methods are virtual. }
  610. { this can't be a class method, because macpas mode }
  611. { has no m_class }
  612. if (m_mac in aktmodeswitches) then
  613. include(pd.procoptions,po_virtualmethod);
  614. handle_calling_convention(pd);
  615. { add definition to procsym }
  616. proc_add_definition(pd);
  617. { add procdef options to objectdef options }
  618. if (po_msgint in pd.procoptions) then
  619. include(aktobjectdef.objectoptions,oo_has_msgint);
  620. if (po_msgstr in pd.procoptions) then
  621. include(aktobjectdef.objectoptions,oo_has_msgstr);
  622. if (po_virtualmethod in pd.procoptions) then
  623. include(aktobjectdef.objectoptions,oo_has_virtual);
  624. chkcpp(pd);
  625. end;
  626. { Support hint directives }
  627. dummysymoptions:=[];
  628. while try_consume_hintdirective(dummysymoptions) do
  629. Consume(_SEMICOLON);
  630. if assigned(pd) then
  631. pd.symoptions:=pd.symoptions+dummysymoptions;
  632. parse_only:=oldparse_only;
  633. end;
  634. _CONSTRUCTOR :
  635. begin
  636. if (sp_published in current_object_option) and
  637. not(oo_can_have_published in aktobjectdef.objectoptions) then
  638. Message(parser_e_cant_have_published);
  639. if not(sp_public in current_object_option) and
  640. not(sp_published in current_object_option) then
  641. Message(parser_w_constructor_should_be_public);
  642. if is_interface(aktobjectdef) then
  643. Message(parser_e_no_con_des_in_interfaces);
  644. oldparse_only:=parse_only;
  645. parse_only:=true;
  646. pd:=constructor_head;
  647. parse_object_proc_directives(pd);
  648. handle_calling_convention(pd);
  649. { add definition to procsym }
  650. proc_add_definition(pd);
  651. { add procdef options to objectdef options }
  652. if (po_virtualmethod in pd.procoptions) then
  653. include(aktobjectdef.objectoptions,oo_has_virtual);
  654. chkcpp(pd);
  655. { Support hint directives }
  656. dummysymoptions:=[];
  657. while try_consume_hintdirective(dummysymoptions) do
  658. Consume(_SEMICOLON);
  659. if assigned(pd) then
  660. pd.symoptions:=pd.symoptions+dummysymoptions;
  661. parse_only:=oldparse_only;
  662. end;
  663. _DESTRUCTOR :
  664. begin
  665. if (sp_published in current_object_option) and
  666. not(oo_can_have_published in aktobjectdef.objectoptions) then
  667. Message(parser_e_cant_have_published);
  668. if there_is_a_destructor then
  669. Message(parser_n_only_one_destructor);
  670. if is_interface(aktobjectdef) then
  671. Message(parser_e_no_con_des_in_interfaces);
  672. if not(sp_public in current_object_option) then
  673. Message(parser_w_destructor_should_be_public);
  674. there_is_a_destructor:=true;
  675. oldparse_only:=parse_only;
  676. parse_only:=true;
  677. pd:=destructor_head;
  678. parse_object_proc_directives(pd);
  679. handle_calling_convention(pd);
  680. { add definition to procsym }
  681. proc_add_definition(pd);
  682. { add procdef options to objectdef options }
  683. if (po_virtualmethod in pd.procoptions) then
  684. include(aktobjectdef.objectoptions,oo_has_virtual);
  685. chkcpp(pd);
  686. { Support hint directives }
  687. dummysymoptions:=[];
  688. while try_consume_hintdirective(dummysymoptions) do
  689. Consume(_SEMICOLON);
  690. if assigned(pd) then
  691. pd.symoptions:=pd.symoptions+dummysymoptions;
  692. parse_only:=oldparse_only;
  693. end;
  694. _END :
  695. begin
  696. consume(_END);
  697. break;
  698. end;
  699. else
  700. consume(_ID); { Give a ident expected message, like tp7 }
  701. end;
  702. until false;
  703. end;
  704. { generate vmt space if needed }
  705. if not(oo_has_vmt in aktobjectdef.objectoptions) and
  706. (([oo_has_virtual,oo_has_constructor,oo_has_destructor]*aktobjectdef.objectoptions<>[]) or
  707. (classtype in [odt_class])
  708. ) then
  709. aktobjectdef.insertvmt;
  710. if is_interface(aktobjectdef) then
  711. setinterfacemethodoptions;
  712. { return defined objectdef }
  713. result:=aktobjectdef;
  714. { restore old state }
  715. aktobjectdef:=nil;
  716. testcurobject:=0;
  717. typecanbeforward:=storetypecanbeforward;
  718. symtablestack:=symtablestack.next;
  719. current_object_option:=old_object_option;
  720. end;
  721. end.