summaryrefslogtreecommitdiff
path: root/compiler/pdecobj.pas
blob: 840e9d91c104170eca9c29d3f743174dfbe9197a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
{
    Copyright (c) 1998-2002 by Florian Klaempfl

    Does object types for Free Pascal

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit pdecobj;

{$i fpcdefs.inc}

interface

    uses
      cclasses,
      globtype,symtype,symdef;

    { parses a object declaration }
    function object_dec(const n : stringid;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;

implementation

    uses
      cutils,
      globals,verbose,systems,tokens,
      symconst,symbase,symsym,symtable,
      node,nld,nmem,ncon,ncnv,ncal,
      scanner,
      pbase,pexpr,pdecsub,pdecvar,ptype
      ;

    const
      { Please leave this here, this module should NOT use
        these variables.
        Declaring it as string here results in an error when compiling (PFV) }
      current_procinfo = 'error';


    function object_dec(const n : stringid;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
    { this function parses an object or class declaration }
      var
         there_is_a_destructor : boolean;
         classtype : tobjectdeftype;

      function constructor_head:tprocdef;
        var
          pd : tprocdef;
        begin
           consume(_CONSTRUCTOR);
           { must be at same level as in implementation }
           parse_proc_head(aktobjectdef,potype_constructor,pd);
           if not assigned(pd) then
             begin
               consume(_SEMICOLON);
               exit;
             end;
           if (cs_constructor_name in aktglobalswitches) and
              (pd.procsym.name<>'INIT') then
             Message(parser_e_constructorname_must_be_init);
           consume(_SEMICOLON);
           include(aktobjectdef.objectoptions,oo_has_constructor);
           { Set return type, class constructors return the
             created instance, object constructors return boolean }
           if is_class(pd._class) then
             pd.rettype.setdef(pd._class)
           else
{$ifdef CPU64bit}
             pd.rettype:=bool64type;
{$else CPU64bit}
             pd.rettype:=bool32type;
{$endif CPU64bit}
           constructor_head:=pd;
        end;


      procedure property_dec;
        var
          p : tpropertysym;
        begin
           { check for a class }
           if not((is_class_or_interface_or_dispinterface(aktobjectdef)) or
              (not(m_tp7 in aktmodeswitches) and (is_object(aktobjectdef)))) then
             Message(parser_e_syntax_error);
           consume(_PROPERTY);
           p:=read_property_dec(aktobjectdef);
           consume(_SEMICOLON);
           if try_to_consume(_DEFAULT) then
             begin
               if oo_has_default_property in aktobjectdef.objectoptions then
                 message(parser_e_only_one_default_property);
               include(aktobjectdef.objectoptions,oo_has_default_property);
               include(p.propoptions,ppo_defaultproperty);
               if not(ppo_hasparameters in p.propoptions) then
                 message(parser_e_property_need_paras);
               consume(_SEMICOLON);
             end;
           { hint directives, these can be separated by semicolons here,
             that needs to be handled here with a loop (PFV) }
           while try_consume_hintdirective(p.symoptions) do
             Consume(_SEMICOLON);
        end;


      function destructor_head:tprocdef;
        var
          pd : tprocdef;
        begin
           consume(_DESTRUCTOR);
           parse_proc_head(aktobjectdef,potype_destructor,pd);
           if not assigned(pd) then
             begin
               consume(_SEMICOLON);
               exit;
             end;
           if (cs_constructor_name in aktglobalswitches) and
              (pd.procsym.name<>'DONE') then
             Message(parser_e_destructorname_must_be_done);
           if not(pd.maxparacount=0) and
              (m_fpc in aktmodeswitches) then
             Message(parser_e_no_paras_for_destructor);
           consume(_SEMICOLON);
           include(aktobjectdef.objectoptions,oo_has_destructor);
           { no return value }
           pd.rettype:=voidtype;
           destructor_head:=pd;
        end;

      var
         pcrd       : tclassrefdef;
         tt     : ttype;
         old_object_option : tsymoptions;
         oldparse_only : boolean;
         storetypecanbeforward : boolean;

      procedure setclassattributes;

        begin
           { publishable }
           if classtype in [odt_interfacecom,odt_class] then
             begin
                aktobjectdef.objecttype:=classtype;
                { set published flag in $M+ mode or it is inherited }
                if (cs_generate_rtti in aktlocalswitches) or
                    (assigned(aktobjectdef.childof) and
                     (oo_can_have_published in aktobjectdef.childof.objectoptions)) then
                  include(aktobjectdef.objectoptions,oo_can_have_published);
                { in "publishable" classes the default access type is published, this is
                  done separate from above if-statement because the option can be
                  inherited from the forward class definition }
                if (oo_can_have_published in aktobjectdef.objectoptions) then
                  current_object_option:=[sp_published];
             end;
        end;


      procedure setinterfacemethodoptions;

        var
          i: longint;
          defs: TIndexArray;
          pd: tdef;
        begin
          include(aktobjectdef.objectoptions,oo_has_virtual);
          defs:=aktobjectdef.symtable.defindex;
          for i:=1 to defs.count do
            begin
              pd:=tdef(defs.search(i));
              if assigned(pd) and
                 (pd.deftype=procdef) then
                begin
                  tprocdef(pd).extnumber:=aktobjectdef.lastvtableindex;
                  inc(aktobjectdef.lastvtableindex);
                  include(tprocdef(pd).procoptions,po_virtualmethod);
                  tprocdef(pd).forwarddef:=false;
                end;
            end;
        end;

      function readobjecttype : boolean;

        begin
           readobjecttype:=true;
           { distinguish classes and objects }
           case token of
              _OBJECT:
                begin
                   classtype:=odt_object;
                   consume(_OBJECT)
                end;
              _CPPCLASS:
                begin
                   classtype:=odt_cppclass;
                   consume(_CPPCLASS);
                end;
              _DISPINTERFACE:
                begin
                   { need extra check here since interface is a keyword
                     in all pascal modes }
                   if not(m_class in aktmodeswitches) then
                     Message(parser_f_need_objfpc_or_delphi_mode);
                   classtype:=odt_dispinterface;
                   consume(_DISPINTERFACE);
                   { no forward declaration }
                   if not(assigned(fd)) and (token=_SEMICOLON) then
                     begin
                       { also anonym objects aren't allow (o : object a : longint; end;) }
                       if n='' then
                         Message(parser_f_no_anonym_objects);
                       aktobjectdef:=tobjectdef.create(classtype,n,nil);
                       include(aktobjectdef.objectoptions,oo_is_forward);
                       object_dec:=aktobjectdef;
                       typecanbeforward:=storetypecanbeforward;
                       readobjecttype:=false;
                       exit;
                     end;
                end;
              _INTERFACE:
                begin
                   { need extra check here since interface is a keyword
                     in all pascal modes }
                   if not(m_class in aktmodeswitches) then
                     Message(parser_f_need_objfpc_or_delphi_mode);
                   if aktinterfacetype=it_interfacecom then
                     classtype:=odt_interfacecom
                   else {it_interfacecorba}
                     classtype:=odt_interfacecorba;
                   consume(_INTERFACE);
                   { forward declaration }
                   if not(assigned(fd)) and (token=_SEMICOLON) then
                     begin
                       { also anonym objects aren't allow (o : object a : longint; end;) }
                       if n='' then
                         Message(parser_f_no_anonym_objects);
                       aktobjectdef:=tobjectdef.create(classtype,n,nil);
                       if (cs_compilesystem in aktmoduleswitches) and
                          (classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then
                         interface_iunknown:=aktobjectdef;
                       include(aktobjectdef.objectoptions,oo_is_forward);
                       if (cs_generate_rtti in aktlocalswitches) and
                          (classtype=odt_interfacecom) then
                         include(aktobjectdef.objectoptions,oo_can_have_published);
                       object_dec:=aktobjectdef;
                       typecanbeforward:=storetypecanbeforward;
                       readobjecttype:=false;
                       exit;
                     end;
                end;
              _CLASS:
                begin
                   classtype:=odt_class;
                   consume(_CLASS);
                   if not(assigned(fd)) and
                      (token=_OF) and
                      { Delphi only allows class of in type blocks.
                        Note that when parsing the type of a variable declaration
                        the blocktype is bt_type so the check for typecanbeforward
                        is also necessary (PFV) }
                      (((block_type=bt_type) and typecanbeforward) or
                       not(m_delphi in aktmodeswitches)) then
                     begin
                        { a hack, but it's easy to handle }
                        { class reference type }
                        consume(_OF);
                        single_type(tt,typecanbeforward);

                        { accept hp1, if is a forward def or a class }
                        if (tt.def.deftype=forwarddef) or
                           is_class(tt.def) then
                          begin
                             pcrd:=tclassrefdef.create(tt);
                             object_dec:=pcrd;
                          end
                        else
                          begin
                             object_dec:=generrortype.def;
                             Message1(type_e_class_type_expected,generrortype.def.typename);
                          end;
                        typecanbeforward:=storetypecanbeforward;
                        readobjecttype:=false;
                        exit;
                     end
                   { forward class }
                   else if not(assigned(fd)) and (token=_SEMICOLON) then
                     begin
                        { also anonym objects aren't allow (o : object a : longint; end;) }
                        if n='' then
                          Message(parser_f_no_anonym_objects);
                        aktobjectdef:=tobjectdef.create(odt_class,n,nil);
                        if (cs_compilesystem in aktmoduleswitches) and (upper(n)='TOBJECT') then
                          class_tobject:=aktobjectdef;
                        aktobjectdef.objecttype:=odt_class;
                        include(aktobjectdef.objectoptions,oo_is_forward);
                        if (cs_generate_rtti in aktlocalswitches) then
                          include(aktobjectdef.objectoptions,oo_can_have_published);
                        { all classes must have a vmt !!  at offset zero }
                        if not(oo_has_vmt in aktobjectdef.objectoptions) then
                          aktobjectdef.insertvmt;
                        object_dec:=aktobjectdef;
                        typecanbeforward:=storetypecanbeforward;
                        readobjecttype:=false;
                        exit;
                     end;
                end;
              else
                begin
                   classtype:=odt_class; { this is error but try to recover }
                   consume(_OBJECT);
                end;
           end;
        end;

      procedure handleimplementedinterface(implintf : tobjectdef);

        begin
            if not is_interface(implintf) then
              begin
                 Message1(type_e_interface_type_expected,implintf.typename);
                 exit;
              end;
            if aktobjectdef.implementedinterfaces.searchintf(implintf)<>-1 then
              Message1(sym_e_duplicate_id,implintf.name)
            else
              begin
                 { allocate and prepare the GUID only if the class
                   implements some interfaces.
                 }
                 if aktobjectdef.implementedinterfaces.count = 0 then
                   aktobjectdef.prepareguid;
                 aktobjectdef.implementedinterfaces.addintf(implintf);
              end;
        end;

      procedure readimplementedinterfaces;
        var
          tt      : ttype;
        begin
          while try_to_consume(_COMMA) do
            begin
               id_type(tt,false);
               if (tt.def.deftype<>objectdef) then
                 begin
                    Message1(type_e_interface_type_expected,tt.def.typename);
                    continue;
                 end;
               handleimplementedinterface(tobjectdef(tt.def));
            end;
        end;

      procedure readinterfaceiid;
        var
          p : tnode;
          valid : boolean;
        begin
          p:=comp_expr(true);
          if p.nodetype=stringconstn then
            begin
              stringdispose(aktobjectdef.iidstr);
              aktobjectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
              p.free;
              valid:=string2guid(aktobjectdef.iidstr^,aktobjectdef.iidguid^);
              if (classtype in [odt_interfacecom,odt_dispinterface]) and not assigned(aktobjectdef.iidguid) and not valid then
                Message(parser_e_improper_guid_syntax);
            end
          else
            begin
              p.free;
              Message(parser_e_illegal_expression);
            end;
        end;


      procedure readparentclasses;
        var
           intfchildof,
           childof : tobjectdef;
           tt : ttype;
           hasparentdefined : boolean;
        begin
          childof:=nil;
          intfchildof:=nil;
          hasparentdefined:=false;

          { reads the parent class }
          if try_to_consume(_LKLAMMER) then
            begin
              id_type(tt,false);
              if (not assigned(tt.def)) or
                 (tt.def.deftype<>objectdef) then
                begin
                  if assigned(tt.def) then
                    Message1(type_e_class_type_expected,tt.def.typename);
                end
              else
                begin
                  childof:=tobjectdef(tt.def);
                  { a mix of class, interfaces, objects and cppclasses
                    isn't allowed }
                  case classtype of
                     odt_class:
                       if not(is_class(childof)) then
                         begin
                            if is_interface(childof) then
                              begin
                                 { we insert the interface after the child
                                   is set, see below
                                 }
                                 intfchildof:=childof;
                                 childof:=class_tobject;
                              end
                            else
                              Message(parser_e_mix_of_classes_and_objects);
                         end;
                     odt_interfacecorba,
                     odt_interfacecom:
                       if not(is_interface(childof)) then
                         Message(parser_e_mix_of_classes_and_objects);
                     odt_cppclass:
                       if not(is_cppclass(childof)) then
                         Message(parser_e_mix_of_classes_and_objects);
                     odt_object:
                       if not(is_object(childof)) then
                         Message(parser_e_mix_of_classes_and_objects);
                     odt_dispinterface:
                       Message(parser_e_dispinterface_cant_have_parent);
                  end;
                end;
              hasparentdefined:=true;
            end;

          { if no parent class, then a class get tobject as parent }
          if not assigned(childof) then
            begin
              case classtype of
                odt_class:
                  if aktobjectdef<>class_tobject then
                    childof:=class_tobject;
                odt_interfacecom:
                  if aktobjectdef<>interface_iunknown then
                    childof:=interface_iunknown;
              end;
            end;

          if assigned(childof) then
            begin
              { Forbid not completly defined objects to be used as parents. This will
                also prevent circular loops of classes, because we set the forward flag
                at the start of the new definition and will reset it below after the
                parent has been set }
              if not(oo_is_forward in childof.objectoptions) then
                aktobjectdef.set_parent(childof)
              else
                Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
            end;

          { remove forward flag, is resolved }
          exclude(aktobjectdef.objectoptions,oo_is_forward);

          if hasparentdefined then
            begin
              if aktobjectdef.objecttype=odt_class then
                begin
                  if assigned(intfchildof) then
                    handleimplementedinterface(intfchildof);
                  readimplementedinterfaces;
                end;
              consume(_RKLAMMER);
            end;

          { read GUID }
          if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
             try_to_consume(_LECKKLAMMER) then
            begin
              readinterfaceiid;
              consume(_RECKKLAMMER);
            end
          else if (classtype=odt_dispinterface) then
            message(parser_e_dispinterface_needs_a_guid);
        end;

        procedure chkcpp(pd:tprocdef);
        begin
           if is_cppclass(pd._class) then
            begin
              pd.proccalloption:=pocall_cppdecl;
              pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
            end;
        end;

      var
        pd : tprocdef;
        dummysymoptions : tsymoptions;
        i : longint;
        generictype : ttypesym;
      begin
         old_object_option:=current_object_option;

         { objects and class types can't be declared local }
         if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable]) then
           Message(parser_e_no_local_objects);

         storetypecanbeforward:=typecanbeforward;
         { for tp7 don't allow forward types }
         if (m_tp7 in aktmodeswitches) then
           typecanbeforward:=false;

         if not(readobjecttype) then
           exit;

         if assigned(fd) then
           aktobjectdef:=fd
         else
           begin
             { anonym objects aren't allow (o : object a : longint; end;) }
             if n='' then
               Message(parser_f_no_anonym_objects);
             aktobjectdef:=tobjectdef.create(classtype,n,nil);
             { include forward flag, it'll be removed after the parent class have been
               added. This is to prevent circular childof loops }
             include(aktobjectdef.objectoptions,oo_is_forward);
           end;

         { read list of parent classes }
         readparentclasses;

         { default access is public }
         there_is_a_destructor:=false;
         current_object_option:=[sp_public];

         { set class flags and inherits published }
         setclassattributes;

         symtablestack.push(aktobjectdef.symtable);
         testcurobject:=1;

         { add generic type parameters }
         aktobjectdef.genericdef:=genericdef;
         if assigned(genericlist) then
           begin
             for i:=0 to genericlist.count-1 do
               begin
                 generictype:=ttypesym(genericlist[i]);
                 if generictype.restype.def.deftype=undefineddef then
                   include(aktobjectdef.defoptions,df_generic)
                 else
                   include(aktobjectdef.defoptions,df_specialization);
                 symtablestack.top.insert(generictype);
               end;
           end;

         { short class declaration ? }
         if (classtype<>odt_class) or (token<>_SEMICOLON) then
          begin
          { Parse componenten }
            repeat
              case token of
                _ID :
                  begin
                    case idtoken of
                      _PRIVATE :
                        begin
                          if is_interface(aktobjectdef) then
                             Message(parser_e_no_access_specifier_in_interfaces);
                           consume(_PRIVATE);
                           current_object_option:=[sp_private];
                           include(aktobjectdef.objectoptions,oo_has_private);
                         end;
                       _PROTECTED :
                         begin
                           if is_interface(aktobjectdef) then
                             Message(parser_e_no_access_specifier_in_interfaces);
                           consume(_PROTECTED);
                           current_object_option:=[sp_protected];
                           include(aktobjectdef.objectoptions,oo_has_protected);
                         end;
                       _PUBLIC :
                         begin
                           if is_interface(aktobjectdef) then
                             Message(parser_e_no_access_specifier_in_interfaces);
                           consume(_PUBLIC);
                           current_object_option:=[sp_public];
                         end;
                       _PUBLISHED :
                         begin
                           { we've to check for a pushlished section in non-  }
                           { publishable classes later, if a real declaration }
                           { this is the way, delphi does it                  }
                           if is_interface(aktobjectdef) then
                             Message(parser_e_no_access_specifier_in_interfaces);
                           consume(_PUBLISHED);
                           current_object_option:=[sp_published];
                         end;
                       _STRICT :
                         begin
                           if is_interface(aktobjectdef) then
                              Message(parser_e_no_access_specifier_in_interfaces);
                            consume(_STRICT);
                            if token=_ID then
                              begin
                                case idtoken of
                                  _PRIVATE:
                                    begin
                                      consume(_PRIVATE);
                                      current_object_option:=[sp_strictprivate];
                                      include(aktobjectdef.objectoptions,oo_has_strictprivate);
                                    end;
                                  _PROTECTED:
                                    begin
                                      consume(_PROTECTED);
                                      current_object_option:=[sp_strictprotected];
                                      include(aktobjectdef.objectoptions,oo_has_strictprotected);
                                    end;
                                  else
                                    message(parser_e_protected_or_private_expected);
                                end;
                              end
                            else
                              message(parser_e_protected_or_private_expected);
                          end;
                        else
                          begin
                            if is_interface(aktobjectdef) then
                              Message(parser_e_no_vars_in_interfaces);

                            if (sp_published in current_object_option) and
                              not(oo_can_have_published in aktobjectdef.objectoptions) then
                              Message(parser_e_cant_have_published);

                            read_record_fields([vd_object]);
                          end;
                    end;
                  end;
                _PROPERTY :
                  begin
                    property_dec;
                  end;
                _PROCEDURE,
                _FUNCTION,
                _CLASS :
                  begin
                    if (sp_published in current_object_option) and
                       not(oo_can_have_published in aktobjectdef.objectoptions) then
                      Message(parser_e_cant_have_published);

                    oldparse_only:=parse_only;
                    parse_only:=true;
                    pd:=parse_proc_dec(aktobjectdef);

                    { this is for error recovery as well as forward }
                    { interface mappings, i.e. mapping to a method  }
                    { which isn't declared yet                      }
                    if assigned(pd) then
                     begin
                       parse_object_proc_directives(pd);

                       { all Macintosh Object Pascal methods are virtual.  }
                       { this can't be a class method, because macpas mode }
                       { has no m_class                                    }
                       if (m_mac in aktmodeswitches) then
                         include(pd.procoptions,po_virtualmethod);

                       handle_calling_convention(pd);

                       { add definition to procsym }
                       proc_add_definition(pd);

                       { add procdef options to objectdef options }
                       if (po_msgint in pd.procoptions) then
                        include(aktobjectdef.objectoptions,oo_has_msgint);
                       if (po_msgstr in pd.procoptions) then
                         include(aktobjectdef.objectoptions,oo_has_msgstr);
                       if (po_virtualmethod in pd.procoptions) then
                         include(aktobjectdef.objectoptions,oo_has_virtual);

                       chkcpp(pd);
                     end;

                    { Support hint directives }
                    dummysymoptions:=[];
                    while try_consume_hintdirective(dummysymoptions) do
                      Consume(_SEMICOLON);
                    if assigned(pd) then
                      pd.symoptions:=pd.symoptions+dummysymoptions;

                    parse_only:=oldparse_only;
                  end;
                _CONSTRUCTOR :
                  begin
                    if (sp_published in current_object_option) and
                      not(oo_can_have_published in aktobjectdef.objectoptions) then
                      Message(parser_e_cant_have_published);

                    if not(sp_public in current_object_option) and
                       not(sp_published in current_object_option) then
                      Message(parser_w_constructor_should_be_public);

                    if is_interface(aktobjectdef) then
                      Message(parser_e_no_con_des_in_interfaces);

                    oldparse_only:=parse_only;
                    parse_only:=true;
                    pd:=constructor_head;
                    parse_object_proc_directives(pd);
                    handle_calling_convention(pd);

                    { add definition to procsym }
                    proc_add_definition(pd);

                    { add procdef options to objectdef options }
                    if (po_virtualmethod in pd.procoptions) then
                      include(aktobjectdef.objectoptions,oo_has_virtual);
                    chkcpp(pd);

                    { Support hint directives }
                    dummysymoptions:=[];
                    while try_consume_hintdirective(dummysymoptions) do
                      Consume(_SEMICOLON);
                    if assigned(pd) then
                      pd.symoptions:=pd.symoptions+dummysymoptions;

                    parse_only:=oldparse_only;
                  end;
                _DESTRUCTOR :
                  begin
                    if (sp_published in current_object_option) and
                      not(oo_can_have_published in aktobjectdef.objectoptions) then
                      Message(parser_e_cant_have_published);

                    if there_is_a_destructor then
                      Message(parser_n_only_one_destructor);

                    if is_interface(aktobjectdef) then
                      Message(parser_e_no_con_des_in_interfaces);

                    if not(sp_public in current_object_option) then
                      Message(parser_w_destructor_should_be_public);

                    there_is_a_destructor:=true;
                    oldparse_only:=parse_only;
                    parse_only:=true;
                    pd:=destructor_head;
                    parse_object_proc_directives(pd);
                    handle_calling_convention(pd);

                    { add definition to procsym }
                    proc_add_definition(pd);

                    { add procdef options to objectdef options }
                    if (po_virtualmethod in pd.procoptions) then
                      include(aktobjectdef.objectoptions,oo_has_virtual);

                    chkcpp(pd);

                    { Support hint directives }
                    dummysymoptions:=[];
                    while try_consume_hintdirective(dummysymoptions) do
                      Consume(_SEMICOLON);
                    if assigned(pd) then
                      pd.symoptions:=pd.symoptions+dummysymoptions;

                    parse_only:=oldparse_only;
                  end;
                _END :
                  begin
                    consume(_END);
                    break;
                  end;
                else
                  consume(_ID); { Give a ident expected message, like tp7 }
              end;
            until false;
          end;

         { generate vmt space if needed }
         if not(oo_has_vmt in aktobjectdef.objectoptions) and
            (([oo_has_virtual,oo_has_constructor,oo_has_destructor]*aktobjectdef.objectoptions<>[]) or
             (classtype in [odt_class])
            ) then
           aktobjectdef.insertvmt;

         if is_interface(aktobjectdef) then
           setinterfacemethodoptions;

         { remove symtable from stack }
         symtablestack.pop(aktobjectdef.symtable);

         { return defined objectdef }
         result:=aktobjectdef;

         { restore old state }
         aktobjectdef:=nil;
         testcurobject:=0;
         typecanbeforward:=storetypecanbeforward;
         current_object_option:=old_object_option;
      end;

end.