pdecobj.pas 32 KB

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