Browse Source

* containsself fixes
* checktypes()

peter 26 years ago
parent
commit
e8bf496ae8
11 changed files with 313 additions and 271 deletions
  1. 5 3
      compiler/cg386add.pas
  2. 63 55
      compiler/cg386cal.pas
  3. 5 12
      compiler/cg386mem.pas
  4. 1 0
      compiler/msgidx.inc
  5. 116 114
      compiler/msgtxt.inc
  6. 5 3
      compiler/pass_2.pas
  7. 63 61
      compiler/pdecl.pas
  8. 15 12
      compiler/pexpr.pas
  9. 10 6
      compiler/tccal.pas
  10. 6 2
      compiler/tree.pas
  11. 24 3
      compiler/types.pas

+ 5 - 3
compiler/cg386add.pas

@@ -146,8 +146,6 @@ implementation
         href       : treference;
         pushed,
         cmpop      : boolean;
-        hr : treference;
-
       begin
         { string operations are not commutative }
         if p^.swaped then
@@ -2030,7 +2028,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.56  1999-05-17 21:56:58  florian
+  Revision 1.57  1999-05-18 14:15:18  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.56  1999/05/17 21:56:58  florian
     * new temporary ansistring handling
 
   Revision 1.55  1999/05/10 14:37:49  pierre

+ 63 - 55
compiler/cg386cal.pas

@@ -250,17 +250,17 @@ implementation
               inlinecode:=p^.right;
               { set it to the same lexical level as the local symtable, becuase
                 the para's are stored there }
-              p^.procdefinition^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel;
+              pprocdef(p^.procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel;
               if assigned(p^.left) then
                 inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size);
-              p^.procdefinition^.parast^.address_fixup:=inlinecode^.para_offset;
+              pprocdef(p^.procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset;
 {$ifdef extdebug}
              Comment(V_debug,
                'inlined parasymtable is at offset '
-               +tostr(p^.procdefinition^.parast^.address_fixup));
+               +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup));
              exprasmlist^.concat(new(pai_asm_comment,init(
                strpnew('inlined parasymtable is at offset '
-               +tostr(p^.procdefinition^.parast^.address_fixup)))));
+               +tostr(pprocdef(p^.procdefinition^.parast)^.address_fixup)))));
 {$endif extdebug}
               p^.right:=nil;
               { disable further inlining of the same proc
@@ -287,10 +287,10 @@ implementation
                 iolabel:=nil;
 
               { save all used registers }
-              pushusedregisters(pushed,p^.procdefinition^.usedregisters);
+              pushusedregisters(pushed,pprocdef(p^.procdefinition)^.usedregisters);
 
               { give used registers through }
-              usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
+              usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters;
            end
          else
            begin
@@ -355,12 +355,12 @@ implementation
            begin
               { be found elsewhere }
               if inlined then
-                para_offset:=p^.procdefinition^.parast^.address_fixup+
-                  p^.procdefinition^.parast^.datasize
+                para_offset:=pprocdef(p^.procdefinition)^.parast^.address_fixup+
+                  pprocdef(p^.procdefinition)^.parast^.datasize
               else
                 para_offset:=0;
               if assigned(p^.right) then
-                secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
+                secondcallparan(p^.left,pabstractprocdef(p^.right^.resulttype)^.para1,
                   (p^.procdefinition^.options and poleftright)<>0,
                   inlined,(p^.procdefinition^.options and (pocdecl or postdcall))<>0,para_offset)
               else
@@ -571,34 +571,36 @@ implementation
                                               end;
                                          end;
                                       end;
-                                    { when calling a class method, we have
-                                      to load ESI with the VMT !
-                                      But that's wrong, if we call a class method via self
-                                    }
-                                    if ((p^.procdefinition^.options and poclassmethod)<>0)
-                                       and not(p^.methodpointer^.resulttype^.deftype=classrefdef) then
+                                    { when calling a class method, we have to load ESI with the VMT !
+                                      But, not for a class method via self }
+                                    if ((p^.procdefinition^.options and pocontainsself)=0) then
                                       begin
-                                         { class method needs current VMT }
-                                         new(r);
-                                         reset_reference(r^);
-                                         r^.base:=R_ESI;
-                                         r^.offset:= p^.procdefinition^._class^.vmt_offset;
-                                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
+                                        if ((p^.procdefinition^.options and poclassmethod)<>0)
+                                           and not(p^.methodpointer^.resulttype^.deftype=classrefdef) then
+                                          begin
+                                             { class method needs current VMT }
+                                             new(r);
+                                             reset_reference(r^);
+                                             r^.base:=R_ESI;
+                                             r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
+                                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
+                                          end;
+
+                                        { direct call to destructor: don't remove data! }
+                                        if ((p^.procdefinition^.options and podestructor)<>0) and
+                                          (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                          (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
+                                          exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,1)));
+
+                                        { direct call to class constructor, don't allocate memory }
+                                        if ((p^.procdefinition^.options and poconstructor)<>0) and
+                                          (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                          (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
+                                          exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0)))
+                                        else
+                                          exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
                                       end;
 
-                                    { direct call to destructor: don't remove data! }
-                                    if ((p^.procdefinition^.options and podestructor)<>0) and
-                                      (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                      (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
-                                      exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,1)));
-
-                                    { direct call to class constructor, don't allocate memory }
-                                    if ((p^.procdefinition^.options and poconstructor)<>0) and
-                                      (p^.methodpointer^.resulttype^.deftype=objectdef) and
-                                      (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
-                                      exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0)))
-                                    else
-                                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
                                     if is_con_or_destructor then
                                       begin
                                          { classes don't get a VMT pointer pushed }
@@ -635,7 +637,7 @@ implementation
                              new(r);
                              reset_reference(r^);
                              r^.base:=R_ESI;
-                             r^.offset:= p^.procdefinition^._class^.vmt_offset;
+                             r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
                           end
                         else
@@ -656,7 +658,7 @@ implementation
 
               { push base pointer ?}
               if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and
-                ((p^.procdefinition^.parast^.symtablelevel)>normal_function_level) then
+                ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then
                 begin
                    { if we call a nested function in a method, we must      }
                    { push also SELF!                                        }
@@ -668,7 +670,7 @@ implementation
                         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
                      end;
                    }
-                   if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then
+                   if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
                      begin
                         new(r);
                         reset_reference(r^);
@@ -678,11 +680,11 @@ implementation
                      end
                      { this is only true if the difference is one !!
                        but it cannot be more !! }
-                   else if (lexlevel=p^.procdefinition^.parast^.symtablelevel-1) then
+                   else if (lexlevel=pprocdef(p^.procdefinition)^.parast^.symtablelevel-1) then
                      begin
                         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer)))
                      end
-                   else if (lexlevel>p^.procdefinition^.parast^.symtablelevel) then
+                   else if (lexlevel>pprocdef(p^.procdefinition)^.parast^.symtablelevel) then
                      begin
                         hregister:=getregister32;
                         new(r);
@@ -690,7 +692,7 @@ implementation
                         r^.offset:=procinfo.framepointer_offset;
                         r^.base:=procinfo.framepointer;
                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister)));
-                        for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do
+                        for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do
                           begin
                              new(r);
                              reset_reference(r^);
@@ -735,7 +737,7 @@ implementation
                             reset_reference(r^);
                             r^.base:=R_ESI;
                             { this is one point where we need vmt_offset (PM) }
-                            r^.offset:= p^.procdefinition^._class^.vmt_offset;
+                            r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset;
                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
                             new(r);
                             reset_reference(r^);
@@ -756,9 +758,9 @@ implementation
                        r^.base:=R_EDI;
                      end;
                    }
-                   if p^.procdefinition^.extnumber=-1 then
+                   if pprocdef(p^.procdefinition)^.extnumber=-1 then
                         internalerror($Da);
-                   r^.offset:=p^.procdefinition^.extnumber*4+12;
+                   r^.offset:=pprocdef(p^.procdefinition)^.extnumber*4+12;
 {$ifndef TESTOBJEXT}
                    if (cs_check_range in aktlocalswitches) then
                      begin
@@ -769,7 +771,7 @@ implementation
                    if (cs_check_range in aktlocalswitches) then
                      begin
                         exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,
-                          newasmsymbol(p^.procdefinition^._class^.vmt_mangledname))));
+                          newasmsymbol(pprocdef(p^.procdefinition)^._class^.vmt_mangledname))));
                         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base)));
                         emitcall('FPC_CHECK_OBJECT_EXT',true);
                      end;
@@ -777,7 +779,7 @@ implementation
                    exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r)));
                 end
               else if not inlined then
-                emitcall(p^.procdefinition^.mangledname,
+                emitcall(pprocdef(p^.procdefinition)^.mangledname,
                   (p^.symtableproc^.symtabletype=unitsymtable) or
                   ((p^.symtableproc^.symtabletype=objectsymtable) and
                   (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))or
@@ -791,7 +793,7 @@ implementation
                    { process the inlinecode }
                    secondpass(inlinecode);
                    { free the args }
-                   ungetpersistanttemp(p^.procdefinition^.parast^.address_fixup);
+                   ungetpersistanttemp(pprocdef(p^.procdefinition)^.parast^.address_fixup);
                 end;
            end
          else
@@ -816,15 +818,17 @@ implementation
                         hregister:=R_EDI;
                      end;
 
-                   inc(p^.right^.location.reference.offset,4);
-
-                   { load ESI }
-                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
-                     newreference(p^.right^.location.reference),R_ESI)));
-                   { push self pointer }
-                   exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
 
-                   dec(p^.right^.location.reference.offset,4);
+                   if ((p^.procdefinition^.options and pocontainsself)=0) then
+                     begin
+                       { load ESI }
+                       inc(p^.right^.location.reference.offset,4);
+                       exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                         newreference(p^.right^.location.reference),R_ESI)));
+                       dec(p^.right^.location.reference.offset,4);
+                       { push self pointer }
+                       exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                     end;
 
                    if hregister=R_NO then
                      exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference))))
@@ -1188,7 +1192,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.81  1999-05-18 09:52:17  peter
+  Revision 1.82  1999-05-18 14:15:23  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.81  1999/05/18 09:52:17  peter
     * procedure of object and addrn fixes
 
   Revision 1.80  1999/05/17 23:51:37  peter

+ 5 - 12
compiler/cg386mem.pas

@@ -824,9 +824,6 @@ implementation
 
     procedure secondwith(var p : ptree);
       var
-        ref : treference;
-        symtable : psymtable;
-        i : longint;
         usetemp : boolean;
       begin
          if assigned(p^.left) then
@@ -871,14 +868,6 @@ implementation
                   del_reference(p^.left^.location.reference);
                 end;
 
-               { the offset relative to (%ebp) is only needed here! }
-{               symtable:=p^.withsymtable;
-               for i:=1 to p^.tablecount do
-                 begin
-                    symtable^.datasize:=ref.offset;
-                    symtable:=symtable^.next;
-                 end; }
-
                { p^.right can be optimize out !!! }
                if assigned(p^.right) then
                  secondpass(p^.right);
@@ -895,7 +884,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.39  1999-05-17 23:51:39  peter
+  Revision 1.40  1999-05-18 14:15:26  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.39  1999/05/17 23:51:39  peter
     * with temp vars now use a reference with a persistant temp instead
       of setting datasize
 

+ 1 - 0
compiler/msgidx.inc

@@ -202,6 +202,7 @@ type tmsgconst=(
   parser_e_no_object_override,
   type_e_mismatch,
   type_e_incompatible_types,
+  type_e_not_equal_types,
   type_e_integer_expr_expected,
   type_e_ordinal_expr_expected,
   type_e_type_id_expected,

+ 116 - 114
compiler/msgtxt.inc

@@ -215,217 +215,218 @@ const msgtxt : array[0..000095,1..240] of char=(
   'E_OVERRIDE can'#039't be used in objects'#000+
   'E_Type mismatch'#000+
   'E_Incompa','tible types: got $1 expected $2'#000+
+  'E_Type mismatch between $1 and $2'#000+
   'E_Integer expression expected'#000+
   'E_Ordinal expression expected'#000+
   'E_Type identifier expected'#000+
   'E_Variable identifier expected'#000+
   'E_pointer type expected'#000+
   'E_class type expected'#000+
-  'E_Variable or type indentifier expected'#000+
-  'E_Ca','n'#039't evaluate constant expression'#000+
+  'E_Variable',' or type indentifier expected'#000+
+  'E_Can'#039't evaluate constant expression'#000+
   'E_Set elements are not compatible'#000+
   'E_Operation not implemented for sets'#000+
   'W_Automatic type conversion from floating type to COMP which is an int'+
   'eger type'#000+
-  'H_use DIV instead to get an integer result'#000+
-  'E_string type','s doesn'#039't match, because of $V+ mode'#000+
+  'H_use DIV instead to g','et an integer result'#000+
+  'E_string types doesn'#039't match, because of $V+ mode'#000+
   'E_succ or pred on enums with assignments not possible'#000+
   'E_Can'#039't read or write variables of this type'#000+
   'E_Type conflict between set elements'#000+
-  'W_lo/hi(longint/dword) returns the upper/lower word'#000+
-  'E_Integer or re','al expression expected'#000+
+  'W_lo/hi(longint/dword) returns th','e upper/lower word'#000+
+  'E_Integer or real expression expected'#000+
   'E_Wrong type in array constructor'#000+
   'E_Incompatible type for arg #$1: Got $2, expected $3'#000+
   'E_Identifier not found $1'#000+
   'F_Internal Error in SymTableStack()'#000+
   'E_Duplicate identifier $1'#000+
-  'H_Identifier already defined in $1 at line',' $2'#000+
+  'H_Identi','fier already defined in $1 at line $2'#000+
   'E_Unknown identifier $1'#000+
   'E_Forward declaration not solved $1'#000+
   'F_Identifier type already defined as type'#000+
   'E_Error in type definition'#000+
   'E_Type identifier not defined'#000+
   'E_Forward type not resolved $1'#000+
-  'E_Only static variables can be used in static ','methods or outside met'+
+  'E_Only stati','c variables can be used in static methods or outside met'+
   'hods'#000+
   'E_Invalid call to tvarsym.mangledname()'#000+
   'F_record or class type expected'#000+
   'E_Instances of classes or objects with an abstract method are not allo'+
   'wed'#000+
   'W_Label not defined $1'#000+
-  'E_Illegal label declaration'#000+
-  'E_GOTO und LABEL',' are not supported (use switch -Sg)'#000+
+  'E_Illegal ','label declaration'#000+
+  'E_GOTO und LABEL are not supported (use switch -Sg)'#000+
   'E_Label not found'#000+
   'E_identifier isn'#039't a label'#000+
   'E_label already defined'#000+
   'E_illegal type declaration of set elements'#000+
   'E_Forward class definition not resolved $1'#000+
-  'H_Parameter not used $1'#000+
-  'N_Local variable not used',' $1'#000+
+  'H_Parameter not',' used $1'#000+
+  'N_Local variable not used $1'#000+
   'E_Set type expected'#000+
   'W_Function result does not seem to be set'#000+
   'E_Unknown record field identifier $1'#000+
   'W_Local variable $1 does not seem to be initialized'#000+
   'E_identifier idents no member $1'#000+
-  'B_Found declaration: $1'#000+
+  'B_Found declaratio','n: $1'#000+
   'E_BREAK not allowed'#000+
-  'E_CONTIN','UE not allowed'#000+
+  'E_CONTINUE not allowed'#000+
   'E_Expression too complicated - FPU stack overflow'#000+
   'E_Illegal expression'#000+
   'E_Invalid integer expression'#000+
   'E_Illegal qualifier'#000+
   'E_High range limit < low range limit'#000+
   'E_Illegal counter variable'#000+
-  'E_Can'#039't determine which overloaded functi','on to call'#000+
+  'E_Can'#039't',' determine which overloaded function to call'#000+
   'E_Parameter list size exceeds 65535 bytes'#000+
   'E_Illegal type conversion'#000+
   'E_File types must be var parameters'#000+
   'E_The use of a far pointer isn'#039't allowed there'#000+
   'E_illegal call by reference parameters'#000+
-  'E_EXPORT declared functions can'#039't be ca','lled'#000+
+  'E_EXP','ORT declared functions can'#039't be called'#000+
   'W_Possible illegal call of constructor or destructor (doesn'#039't matc'+
   'h to this context)'#000+
   'N_Inefficient code'#000+
   'W_unreachable code'#000+
   'E_procedure call with stackframe ESP/SP'#000+
-  'E_Abstract methods can'#039't be called directly'#000+
-  'F_Internal Error in getfloat','reg(), allocation failure'#000+
+  'E_Abstract methods can'#039't be called dir','ectly'#000+
+  'F_Internal Error in getfloatreg(), allocation failure'#000+
   'F_Unknown float type'#000+
   'F_SecondVecn() base defined twice'#000+
   'F_Extended cg68k not supported'#000+
   'F_32-bit unsigned not supported in MC68000 mode'#000+
   'F_Internal Error in secondinline()'#000+
-  'D_Register $1 weight $2 $3'#000+
-  'E_Stack limit exce','deed in local routine'#000+
+  'D_Register ','$1 weight $2 $3'#000+
+  'E_Stack limit excedeed in local routine'#000+
   'D_Stack frame is omitted'#000+
   'E_Object or class methods can'#039't be inline.'#000+
   'E_Procvar calls can'#039't be inline.'#000+
   'E_No code for inline procedure stored'#000+
-  'E_Element zero of an ansi/wide- or longstring can'#039't be accessed, u'+
-  'se (set)lengt','h instead'#000+
+  'E_Element zero of an ansi/wide- or longstring',' can'#039't be accessed,'+
+  ' use (set)length instead'#000+
   'E_Include and exclude not implemented in this case'#000+
   'W_Probably illegal constant passed to internal math function'#000+
   'E_Constructors or destructors can not be called inside a '#039'with'#039+
   ' clause'#000+
-  'E_Cannot call message handler method directly'#000+
-  'D','_Starting $1 styled assembler parsing'#000+
+  'E_Cannot call',' message handler method directly'#000+
+  'D_Starting $1 styled assembler parsing'#000+
   'D_Finished $1 styled assembler parsing'#000+
   'E_Non-label pattern contains @'#000+
   'W_Override operator not supported'#000+
   'E_Error building record offset'#000+
-  'E_OFFSET used without identifier'#000+
-  'E_Cannot use local variable or par','ameters here'#000+
+  'E_OFFSET used without identifier'#000,
+  'E_Cannot use local variable or parameters here'#000+
   'E_need to use OFFSET here'#000+
   'E_Cannot use multiple relocatable symbols'#000+
   'E_Relocatable symbol can only be added'#000+
   'E_Invalid constant expression'#000+
   'E_Relocatable symbol is not allowed'#000+
-  'E_Invalid reference syntax'#000+
-  'E_Local symbols not allowed',' as references'#000+
+  'E_Invalid reference ','syntax'#000+
+  'E_Local symbols not allowed as references'#000+
   'E_Invalid base and index register usage'#000+
   'E_Wrong scale factor specified'#000+
   'E_Multiple index register usage'#000+
   'E_Invalid operand type'#000+
   'E_Invalid string as opcode operand: $1'#000+
-  'W_@CODE and @DATA not supported'#000+
-  'E_Null label references are ','not allowed'#000+
+  'W_@CODE and @DATA not supp','orted'#000+
+  'E_Null label references are not allowed'#000+
   'F_Divide by zero in asm evaluator'#000+
   'F_Evaluator stack overflow'#000+
   'F_Evaluator stack underflow'#000+
   'F_Invalid numeric format in asm evaluator'#000+
   'F_Invalid Operator in asm evaluator'#000+
-  'E_escape sequence ignored: $1'#000+
+  'E_escape sequence ignored: ','$1'#000+
   'E_Invalid symbol reference'#000+
-  'W_Fw','ait can cause emulation problems with emu387'#000+
+  'W_Fwait can cause emulation problems with emu387'#000+
   'W_Calling an overload function in assembler'#000+
   'E_Unsupported symbol type for operand'#000+
   'E_Constant value out of bounds'#000+
   'E_Error converting decimal $1'#000+
-  'E_Error converting octal $1'#000+
-  'E_Error converting binar','y $1'#000+
+  'E_Error converting',' octal $1'#000+
+  'E_Error converting binary $1'#000+
   'E_Error converting hexadecimal $1'#000+
   'H_$1 translated to $2'#000+
   'W_$1 is associated to an overloaded function'#000+
   'E_Cannot use SELF outside a method'#000+
   'E_Cannot use __SELF outside a method'#000+
-  'E_Cannot use __OLDEBP outside a nested procedure'#000+
-  'W_Functions w','ith void return value can'#039't return any value in asm'+
-  ' code'#000+
+  'E_Cannot use __OLDEBP outsid','e a nested procedure'#000+
+  'W_Functions with void return value can'#039't return any value in asm c'+
+  'ode'#000+
   'E_SEG not supported'#000+
   'E_Size suffix and destination or source size do not match'#000+
   'W_Size suffix and destination or source size do not match'#000+
-  'E_Assembler syntax error'#000+
-  'E_Invalid combination ','of opcode and operands'#000+
+  'E_Assembler s','yntax error'#000+
+  'E_Invalid combination of opcode and operands'#000+
   'E_Assemler syntax error in operand'#000+
   'E_Assemler syntax error in constant'#000+
   'E_Invalid String expression'#000+
   '32bit constant created for address'#000+
   'E_Invalid or missing opcode'#000+
-  'E_Invalid combination of prefix and opcode: $1'#000+
-  'E_Invali','d combination of override and opcode: $1'#000+
+  'E_Invalid combination',' of prefix and opcode: $1'#000+
+  'E_Invalid combination of override and opcode: $1'#000+
   'E_Too many operands on line'#000+
   'W_NEAR ignored'#000+
   'W_FAR ignored'#000+
   'E_Duplicate local symbol $1'#000+
   'E_Undefined local symbol $1'#000+
   'E_Unknown label identifier $1'#000+
-  'E_Invalid floating point register name'#000+
-  'E_NOR not support','ed'#000+
+  'E_Invalid floating poi','nt register name'#000+
+  'E_NOR not supported'#000+
   'W_Modulo not supported'#000+
   'E_Invalid floating point constant $1'#000+
   'E_Invalid floating point expression'#000+
   'E_Wrong symbol type'#000+
   'E_Cannot index a local var or parameter with a register'#000+
-  'E_Invalid segment override expression'#000+
-  'W_Identifier $1 supposed ex','ternal'#000+
+  'E_Invalid segment override expr','ession'#000+
+  'W_Identifier $1 supposed external'#000+
   'E_Strings not allowed as constants'#000+
   'No type of variable specified'#000+
   'E_assembler code not returned to text section'#000+
   'E_Not a directive or local symbol $1'#000+
   'E_Using a defined name as a local label'#000+
-  'F_Too many assembler files'#000+
-  'F_Selected assembl','er output not supported'#000+
+  'F_Too many ','assembler files'#000+
+  'F_Selected assembler output not supported'#000+
   'F_Comp not supported'#000+
   'F_Direct not support for binary writers'#000+
   'E_Allocating of data is only allowed in bss section'#000+
   'F_No binary writer selected'#000+
   'E_Asm: Opcode $1 not in table'#000+
-  'E_Asm: $1 invalid combination of opcode and o','perands'#000+
+  'E_Asm: $1 i','nvalid combination of opcode and operands'#000+
   'E_Asm: 16 Bit references not supported'#000+
   'E_Asm: Invalid effective address'#000+
   'E_Asm: Immediate or reference expected'#000+
   'E_Asm: $1 value exceeds bounds $2'#000+
   'E_Asm: Short jump is out of range $1'#000+
-  'W_Source operating system redefined'#000+
-  'I_Assembling (','pipe) $1'#000+
+  'W_Source operati','ng system redefined'#000+
+  'I_Assembling (pipe) $1'#000+
   'E_Can'#039't create assember file $1'#000+
   'W_Assembler $1 not found, switching to external assembling'#000+
   'T_Using assembler: $1'#000+
   'W_Error while assembling exitcode $1'#000+
-  'W_Can'#039't call the assembler, error $1 switching to external assembl'+
-  'ing'#000+
-  'I_Assemblin','g $1'#000+
+  'W_Can'#039't call the assembler, error $1 switching ','to external assem'+
+  'bling'#000+
+  'I_Assembling $1'#000+
   'W_Linker $1 not found, switching to external linking'#000+
   'T_Using linker: $1'#000+
   'W_Object $1 not found, Linking may fail !'#000+
   'W_Library $1 not found, Linking may fail !'#000+
   'W_Error while linking'#000+
-  'W_Can'#039't call the linker, switching to external linking'#000+
-  'I','_Linking $1'#000+
+  'W_Can'#039't call the linke','r, switching to external linking'#000+
+  'I_Linking $1'#000+
   'W_binder not found, switching to external binding'#000+
   'W_ar not found, switching to external ar'#000+
   'E_Dynamic Libraries not supported'#000+
   'I_Closing script $1'#000+
-  'W_resource compiler not found, switching to external mode'#000+
+  'W_resource compiler not found, switching to exter','nal mode'#000+
   'I_Compiling resource $1'#000+
-  'F','_Can'#039't post process executable $1'#000+
+  'F_Can'#039't post process executable $1'#000+
   'F_Can'#039't open executable $1'#000+
   'X_Size of Code: $1 bytes'#000+
   'X_Size of initialized data: $1 bytes'#000+
   'X_Size of uninitialized data: $1 bytes'#000+
   'X_Stack space reserved: $1 bytes'#000+
-  'X_Stack space commited: $1 bytes'#000+
-  'T_Unitsearch',': $1'#000+
+  'X_Stack spa','ce commited: $1 bytes'#000+
+  'T_Unitsearch: $1'#000+
   'T_PPU Loading $1'#000+
   'U_PPU Name: $1'#000+
   'U_PPU Flags: $1'#000+
@@ -434,8 +435,8 @@ const msgtxt : array[0..000095,1..240] of char=(
   'U_PPU File too short'#000+
   'U_PPU Invalid Header (no PPU at the begin)'#000+
   'U_PPU Invalid Version $1'#000+
-  'U_PPU is compiled for an other processor'#000+
-  'U_PPU is compiled for an oth','er target'#000+
+  'U_PPU is compiled for an other proc','essor'#000+
+  'U_PPU is compiled for an other target'#000+
   'U_PPU Source: $1'#000+
   'U_Writing $1'#000+
   'F_Can'#039't Write PPU-File'#000+
@@ -445,88 +446,88 @@ const msgtxt : array[0..000095,1..240] of char=(
   'F_PPU Dbx count problem'#000+
   'E_Illegal unit name: $1'#000+
   'F_Too much units'#000+
-  'F_Circular unit reference between $','1 and $2'#000+
+  'F','_Circular unit reference between $1 and $2'#000+
   'F_Can'#039't compile unit $1, no sources available'#000+
   'W_Compiling the system unit requires the -Us switch'#000+
   'F_There were $1 errors compiling module, stopping'#000+
   'U_Load from $1 ($2) unit $3'#000+
-  'U_Recompiling $1, checksum changed for $2'#000+
-  'U_Recompiling',' $1, source found only'#000+
+  'U_Recompiling $1, che','cksum changed for $2'#000+
+  'U_Recompiling $1, source found only'#000+
   'U_Recompiling unit, static lib is older than ppufile'#000+
   'U_Recompiling unit, shared lib is older than ppufile'#000+
   'U_Recompiling unit, obj and asm are older than ppufile'#000+
-  'U_Recompiling unit, obj is older than asm'#000+
-  'U_Parsing inte','rface of $1'#000+
+  'U_Recompiling unit, ob','j is older than asm'#000+
+  'U_Parsing interface of $1'#000+
   'U_Parsing implementation of $1'#000+
   'U_Second load for unit $1'#000+
   'U_PPU Check file $1 time $2'#000+
   '$1 [options] <inputfile> [options]'#000+
   'W_Only one source file supported'#000+
   'W_DEF file can be created only for OS/2'#000+
-  'E_nested response files are not sup','ported'#000+
+  'E','_nested response files are not supported'#000+
   'F_No source file name in command line'#000+
   'E_Illegal parameter: $1'#000+
   'H_-? writes help pages'#000+
   'F_Too many config files nested'#000+
   'F_Unable to open file $1'#000+
   'N_Reading further options from $1'#000+
-  'W_Target is already set to: $1'#000+
-  'W_Shared libs not supported',' on DOS platform, reverting to static'#000+
+  'W_Target is already set ','to: $1'#000+
+  'W_Shared libs not supported on DOS platform, reverting to static'#000+
   'F_too many IF(N)DEFs'#000+
   'F_too many ENDIFs'#000+
   'F_open conditional at the end of the file'#000+
   'W_Debug information generation is not supported by this executable'#000+
-  'H_Try recompiling with -dGDB'#000+
-  'W_You are using the obsol','ete switch $1'#000+
-  'W_You are using the obsolete switch $1, please use $2'#000+
+  'H_Try recompiling wi','th -dGDB'#000+
+  'E_You are using the obsolete switch $1'#000+
+  'E_You are using the obsolete switch $1, please use $2'#000+
   'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
   'Copyright (c) 1993-98 by Florian Klaempfl'#000+
-  'Free Pascal Compiler version $FPCVER'#000+
+  'Free Pascal Compiler version $FPC','VER'#000+
   #000+
   'Compiler Date  : $FPCDATE'#000+
-  'Com','piler Target: $FPCTARGET'#000+
+  'Compiler Target: $FPCTARGET'#000+
   #000+
   'This program comes under the GNU General Public Licence'#000+
   'For more information read COPYING.FPC'#000+
   #000+
   'Report bugs,suggestions etc to:'#000+
   '                 [email protected]'#000+
-  '**0*_put + after a boolean switch op','tion to enable it, - to disable '+
+  '**','0*_put + after a boolean switch option to enable it, - to disable '+
   'it'#000+
   '**1a_the compiler doesn'#039't delete the generated assembler file'#000+
   '**2al_list sourcecode lines in assembler file'#000+
   '**2ar_list register allocation/release info in assembler file'#000+
-  '**2at_list temp allocation/release ','info in assembler file'#000+
+  '*','*2at_list temp allocation/release info in assembler file'#000+
   '**1b_generate browser info'#000+
   '**2bl_generate local symbol info'#000+
   '**1B_build all modules'#000+
   '**1C<x>_code generation options:'#000+
   '3*2CD_create dynamic library'#000+
-  '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#000+
+  '**2Ch<n>_<n> bytes heap (between 1023 ','and 67107840)'#000+
   '**2Ci_IO-checking'#000+
-  '**','2Cn_omit linking stage'#000+
+  '**2Cn_omit linking stage'#000+
   '**2Co_check overflow of integer operations'#000+
   '**2Cr_range checking'#000+
   '**2Cs<n>_set stack size to <n>'#000+
   '**2Ct_stack checking'#000+
   '3*2CS_create static library'#000+
   '3*2Cx_use smartlinking'#000+
-  '**1d<x>_defines the symbol <x>'#000+
-  '*O1D_generate a DEF',' file'#000+
+  '**1d<x>_defines ','the symbol <x>'#000+
+  '*O1D_generate a DEF file'#000+
   '*O2Dd<x>_set description to <x>'#000+
   '*O2Dw_PM application'#000+
   '**1e<x>_set path to executable'#000+
   '**1E_same as -Cn'#000+
   '**1F<x>_set file names and paths:'#000+
-  '**2FD<x>_sets the directory where to search for compiler utilities'#000+
-  '**2Fe<x>_redirect error output t','o <x>'#000+
+  '**2FD<x>_sets the directory where to search for compiler utilitie','s'#000+
+  '**2Fe<x>_redirect error output to <x>'#000+
   '**2FE<x>_set exe/unit output path to <x>'#000+
   '**2Fi<x>_adds <x> to include path'#000+
   '**2Fl<x>_adds <x> to library path'#000+
   '*L2FL<x>_uses <x> as dynamic linker'#000+
   '**2Fo<x>_adds <x> to object path'#000+
-  '**2Fr<x>_load error message file <x>'#000+
-  '**2Fu<x>_adds <x> t','o unit path'#000+
+  '**2Fr<x>_load error me','ssage file <x>'#000+
+  '**2Fu<x>_adds <x> to unit path'#000+
   '**2FU<x>_set unit output path to <x>, overrides -FE'#000+
   '*g1g<x>_generate debugger information:'#000+
   '*g2gg_use gsym'#000+
@@ -534,101 +535,102 @@ const msgtxt : array[0..000095,1..240] of char=(
   '*g2gh_use heap trace unit'#000+
   '**1i_information'#000+
   '**2iD_return compiler date'#000+
-  '**2iV_return compiler version'#000+
-  '**2iSO_r','eturn compiler OS'#000+
+  '**2i','V_return compiler version'#000+
+  '**2iSO_return compiler OS'#000+
   '**2iSP_return compiler processor'#000+
   '**2iTO_return target OS'#000+
   '**2iTP_return target processor'#000+
   '**1I<x>_adds <x> to include path'#000+
   '**1k<x>_Pass <x> to the linker'#000+
   '**1l_write logo'#000+
-  '**1n_don'#039't read the default config file'#000+
-  '**1o<x>_change',' the name of the executable produced to <x>'#000+
+  '**1n_don'#039't read the ','default config file'#000+
+  '**1o<x>_change the name of the executable produced to <x>'#000+
   '**1pg_generate profile code for gprof'#000+
   '*L1P_use pipes instead of creating temporary assembler files'#000+
   '**1S<x>_syntax options:'#000+
-  '**2S2_switch some Delphi 2 extensions on'#000+
-  '**2Sc_supports operators like C ','(*=,+=,/= and -=)'#000+
+  '**2S2_switch some Delphi 2 extensions o','n'#000+
+  '**2Sc_supports operators like C (*=,+=,/= and -=)'#000+
   '**2Sd_tries to be Delphi compatible'#000+
   '**2Se_compiler stops after the first error'#000+
   '**2Sg_allow LABEL and GOTO'#000+
   '**2Sh_Use ansistrings'#000+
   '**2Si_support C++ styled INLINE'#000+
-  '**2Sm_support macros like C (global)'#000+
-  '**2So_tries to be TP/BP 7','.0 compatible'#000+
+  '**2Sm_support macros like C ','(global)'#000+
+  '**2So_tries to be TP/BP 7.0 compatible'#000+
   '**2Sp_tries to be gpc compatible'#000+
   '**2Ss_constructor name must be init (destructor must be done)'#000+
   '**2St_allow static keyword in objects'#000+
   '**1s_don'#039't call assembler and linker (only with -a)'#000+
-  '**1u<x>_undefines the symbol <x>'#000+
-  '**1U_uni','t options:'#000+
+  '**1u<x>','_undefines the symbol <x>'#000+
+  '**1U_unit options:'#000+
   '**2Un_don'#039't check the unit name'#000+
   '**2Us_compile a system unit'#000+
   '**1v<x>_Be verbose. <x> is a combination of the following letters:'#000+
   '**2*_e : Show errors (default)       d : Show debug info'#000+
-  '**2*_w : Show warnings               u : Show',' unit info'#000+
+  '**2*_w : Sh','ow warnings               u : Show unit info'#000+
   '**2*_n : Show notes                  t : Show tried/used files'#000+
   '**2*_h : Show hints                  m : Show defined macros'#000+
   '**2*_i : Show general info           p : Show compiled procedures'#000+
-  '**2*_l : Show linenumbers            c ',': Show conditionals'#000+
+  '**2*_','l : Show linenumbers            c : Show conditionals'#000+
   '**2*_a : Show everything             0 : Show nothing (except errors)'#000+
   '**2*_b : Show all procedure          r : Rhide/GCC compatibility mode'#000+
-  '**2*_    declarations if an error    x : Executable info (Win32 only)'#000+
-  '**2*_    o','ccurs'#000+
+  '**2*_    declarations if an error    x : Execu','table info (Win32 only'+
+  ')'#000+
+  '**2*_    occurs'#000+
   '**1X_executable options:'#000+
   '*L2Xc_link with the c library'#000+
   '**2XD_link with dynamic libraries (defines FPC_LINK_DYNAMIC)'#000+
   '**2Xs_strip all symbols from executable'#000+
-  '**2XS_link with static libraries (defines FPC_LINK_STATIC)'#000+
-  '**0*_Processor spec','ific options:'#000+
+  '**2XS_link with static libraries (defines FP','C_LINK_STATIC)'#000+
+  '**0*_Processor specific options:'#000+
   '3*1A<x>_output format:'#000+
   '3*2Ao_coff file using GNU AS'#000+
   '3*2Anasmcoff_coff file using Nasm'#000+
   '3*2Anasmelf_elf32 (Linux) file using Nasm'#000+
   '3*2Anasmobj_obj file using Nasm'#000+
-  '3*2Amasm_obj file using Masm (Mircosoft)'#000+
-  '3*2Atasm_obj file using T','asm (Borland)'#000+
+  '3*2Amasm_obj file using Masm (Mi','rcosoft)'#000+
+  '3*2Atasm_obj file using Tasm (Borland)'#000+
   '3*1R<x>_assembler reading style:'#000+
   '3*2Ratt_read AT&T style assembler'#000+
   '3*2Rintel_read Intel style assembler'#000+
   '3*2Rdirect_copy assembler text directly to assembler file'#000+
   '3*1O<x>_optimizations:'#000+
-  '3*2Og_generate smaller code'#000+
-  '3*2OG_generat','e faster code (default)'#000+
+  '3*2Og_g','enerate smaller code'#000+
+  '3*2OG_generate faster code (default)'#000+
   '3*2Or_keep certain variables in registers (still BUGGY!!!)'#000+
   '3*2Ou_enable uncertain optimizations (see docs)'#000+
   '3*2O1_level 1 optimizations (quick optimizations)'#000+
-  '3*2O2_level 2 optimizations (-O1 + slower optimizations)'#000+
-  '3*','2O3_level 3 optimizations (same as -O2u)'#000+
+  '3*2O2_level 2 optimizatio','ns (-O1 + slower optimizations)'#000+
+  '3*2O3_level 3 optimizations (same as -O2u)'#000+
   '3*2Op<x>_target processor:'#000+
   '3*3Op1_set target processor to 386/486'#000+
   '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000+
-  '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#000+
-  '3*1T<x>_Target operating',' system:'#000+
+  '3*3Op3_set target processor to PPro/PII/c6x8','6/K6 (tm)'#000+
+  '3*1T<x>_Target operating system:'#000+
   '3*2TGO32V1_version 1 of DJ Delorie DOS extender'#000+
   '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#000+
   '3*2TLINUX_Linux'#000+
   '3*2TOS2_OS/2 2.x'#000+
   '3*2TWin32_Windows 32 Bit'#000+
   '6*1A<x>_output format'#000+
-  '6*2Ao_Unix o-file using GNU AS'#000+
-  '6*2Agas_GNU Motorola ass','embler'#000+
+  '6*2Ao_Unix o-file usi','ng GNU AS'#000+
+  '6*2Agas_GNU Motorola assembler'#000+
   '6*2Amit_MIT Syntax (old GAS)'#000+
   '6*2Amot_Standard Motorola assembler'#000+
   '6*1O_optimizations:'#000+
   '6*2Oa_turn on the optimizer'#000+
   '6*2Og_generate smaller code'#000+
   '6*2OG_generate faster code (default)'#000+
-  '6*2Ox_optimize maximum (still BUGGY!!!)'#000+
-  '6*2O2_set targe','t processor to a MC68020+'#000+
+  '6*2Ox_optimize maximu','m (still BUGGY!!!)'#000+
+  '6*2O2_set target processor to a MC68020+'#000+
   '6*1R<x>_assembler reading style:'#000+
   '6*2RMOT_read motorola style assembler'#000+
   '6*1T<x>_Target operating system:'#000+
   '6*2TAMIGA_Commodore Amiga'#000+
   '6*2TATARI_Atari ST/STe/TT'#000+
-  '6*2TMACOS_Macintosh m68k'#000+
+  '6*2TMACOS_Macintosh m68k',#000+
   '6*2TLINUX_Linux-68k'#000+
   '**1*_'#000+
-  '**1?_sh','ows this help'#000+
+  '**1?_shows this help'#000+
   '**1h_shows this help without waiting'#000
 );

+ 5 - 3
compiler/pass_2.pas

@@ -89,8 +89,6 @@ implementation
 
       var
          hp : ptree;
-         oldrl : plinkedlist;
-
       begin
          hp:=p;
          while assigned(hp) do
@@ -557,7 +555,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.21  1999-05-17 21:57:11  florian
+  Revision 1.22  1999-05-18 14:15:50  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.21  1999/05/17 21:57:11  florian
     * new temporary ansistring handling
 
   Revision 1.20  1999/05/02 21:33:54  florian

+ 63 - 61
compiler/pdecl.pas

@@ -1661,7 +1661,7 @@ unit pdecl;
 
     var
        sc : pstringcontainer;
-       s : string;
+       hs1,s : string;
        p : pdef;
        varspez : tvarspez;
        procvardef : pprocvardef;
@@ -1673,65 +1673,65 @@ unit pdecl;
             consume(LKLAMMER);
             inc(testcurobject);
             repeat
-              case token of
-                _VAR :
-                  begin
-                    consume(_VAR);
-                    varspez:=vs_var;
-                  end;
-                _CONST :
-                  begin
-                    consume(_CONST);
-                    varspez:=vs_const;
-                  end;
+              if try_to_consume(_VAR) then
+               varspez:=vs_var
               else
-                varspez:=vs_value;
-              end;
-
-              sc:=idlist;
-              if (token=COLON) or (varspez=vs_value) then
-                begin
-                   consume(COLON);
-                   if token=_ARRAY then
-                     begin
-                       consume(_ARRAY);
-                       consume(_OF);
-                     { define range and type of range }
-                       p:=new(Parraydef,init(0,-1,s32bitdef));
-                     { array of const ? }
-                       if (token=_CONST) and (m_objpas in aktmodeswitches) then
+               if try_to_consume(_CONST) then
+                 varspez:=vs_const
+               else
+                 varspez:=vs_value;
+              { self method ? }
+              if idtoken=_SELF then
+               begin
+                 procvardef^.options:=procvardef^.options or pocontainsself;
+                 consume(idtoken);
+                 consume(COLON);
+                 p:=single_type(hs1);
+                 procvardef^.concatdef(p,vs_value);
+               end
+              else
+               begin
+                 sc:=idlist;
+                 if (token=COLON) or (varspez=vs_value) then
+                   begin
+                      consume(COLON);
+                      if token=_ARRAY then
                         begin
-                          consume(_CONST);
-                          srsym:=nil;
-                          if assigned(objpasunit) then
-                           getsymonlyin(objpasunit,'TVARREC');
-                          if not assigned(srsym) then
-                           InternalError(1234124);
-                          Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
-                          Parraydef(p)^.IsArrayOfConst:=true;
+                          consume(_ARRAY);
+                          consume(_OF);
+                        { define range and type of range }
+                          p:=new(Parraydef,init(0,-1,s32bitdef));
+                        { array of const ? }
+                          if (token=_CONST) and (m_objpas in aktmodeswitches) then
+                           begin
+                             consume(_CONST);
+                             srsym:=nil;
+                             if assigned(objpasunit) then
+                              getsymonlyin(objpasunit,'TVARREC');
+                             if not assigned(srsym) then
+                              InternalError(1234124);
+                             Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
+                             Parraydef(p)^.IsArrayOfConst:=true;
+                           end
+                          else
+                           begin
+                           { define field type }
+                             Parraydef(p)^.definition:=single_type(s);
+                           end;
                         end
-                       else
-                        begin
-                        { define field type }
-                          Parraydef(p)^.definition:=single_type(s);
-                        end;
-                     end
-                   else
-                     p:=single_type(s);
-                end
-              else
-                p:=cformaldef;
-              while not sc^.empty do
-                begin
-                   s:=sc^.get;
-                   procvardef^.concatdef(p,varspez);
-                end;
-              dispose(sc,done);
-              if token=SEMICOLON then
-                consume(SEMICOLON)
-              else
-                break;
-            until false;
+                      else
+                        p:=single_type(s);
+                   end
+                 else
+                   p:=cformaldef;
+                 while not sc^.empty do
+                   begin
+                      s:=sc^.get;
+                      procvardef^.concatdef(p,varspez);
+                   end;
+                 dispose(sc,done);
+               end;
+            until not try_to_consume(SEMICOLON);
             dec(testcurobject);
             consume(RKLAMMER);
          end;
@@ -1775,9 +1775,7 @@ unit pdecl;
                else
                  begin
                  { check types }
-                   if not is_equal(pt1^.resulttype,pt2^.resulttype) then
-                     Message(type_e_mismatch)
-                   else
+                   if CheckTypes(pt1^.resulttype,pt2^.resulttype) then
                      begin
                      { Check bounds }
                        if pt2^.value<pt1^.value then
@@ -2230,7 +2228,11 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.117  1999-05-17 21:57:12  florian
+  Revision 1.118  1999-05-18 14:15:51  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.117  1999/05/17 21:57:12  florian
     * new temporary ansistring handling
 
   Revision 1.116  1999/05/13 21:59:34  peter

+ 15 - 12
compiler/pexpr.pas

@@ -540,30 +540,29 @@ unit pexpr;
       end;
 
     procedure handle_procvar(procvar : pprocvardef;var t : ptree);
-
+      var
+        hp : ptree;
       begin
+         hp:=nil;
          if ((procvar^.options and pomethodpointer)<>0) then
            begin
               if assigned(t^.methodpointer) and
                  (t^.methodpointer^.resulttype^.deftype=objectdef) and
                  (pobjectdef(t^.methodpointer^.resulttype)^.isclass) and
                  (proc_to_procvar_equal(procvar,pprocsym(t^.symtableentry)^.definition)) then
-                begin
-                   t^.treetype:=loadn;
-                   t^.disposetyp:=dt_left;
-                   t^.left:=t^.methodpointer;
-                   t^.resulttype:=pprocsym(t^.symtableprocentry)^.definition;
-                   t^.symtableentry:=pvarsym(t^.symtableprocentry);
-                end
+                hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
               else
                 Message(type_e_mismatch);
            end
          else if (proc_to_procvar_equal(getprocvardef,pprocsym(t^.symtableentry)^.definition)) then
            begin
-              t^.treetype:=loadn;
-              t^.resulttype:=pprocsym(t^.symtableprocentry)^.definition;
-              t^.symtableentry:=t^.symtableprocentry;
+              hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
            end;
+        if assigned(hp) then
+         begin
+           disposetree(t);
+           t:=hp;
+         end;
       end;
 
     { the following procedure handles the access to a property symbol }
@@ -1990,7 +1989,11 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.107  1999-05-18 09:52:18  peter
+  Revision 1.108  1999-05-18 14:15:54  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.107  1999/05/18 09:52:18  peter
     * procedure of object and addrn fixes
 
   Revision 1.106  1999/05/16 17:06:31  peter

+ 10 - 6
compiler/tccal.pas

@@ -480,7 +480,7 @@ implementation
               p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef;
               { this was missing, leads to a bug below if
                 the procvar is a function }
-              p^.procdefinition:=pprocdef(p^.right^.resulttype);
+              p^.procdefinition:=pabstractprocdef(p^.right^.resulttype);
            end
          else
          { not a procedure variable }
@@ -974,8 +974,8 @@ implementation
                    { p^.treetype:=procinlinen; }
                    if not assigned(p^.right) then
                      begin
-                        if assigned(p^.procdefinition^.code) then
-                          inlinecode:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
+                        if assigned(pprocdef(p^.procdefinition)^.code) then
+                          inlinecode:=genprocinlinenode(p,ptree(pprocdef(p^.procdefinition)^.code))
                         else
                           CGMessage(cg_e_no_code_for_inline_stored);
                         if assigned(inlinecode) then
@@ -1003,14 +1003,14 @@ implementation
 {$ifdef i386}
               for regi:=R_EAX to R_EDI do
                 begin
-                   if (p^.procdefinition^.usedregisters and ($80 shr word(regi)))<>0 then
+                   if (pprocdef(p^.procdefinition)^.usedregisters and ($80 shr word(regi)))<>0 then
                      inc(reg_pushes[regi],t_times*2);
                 end;
 {$endif}
 {$ifdef m68k}
              for regi:=R_D0 to R_A6 do
                begin
-                  if (p^.procdefinition^.usedregisters and ($800 shr word(regi)))<>0 then
+                  if (pprocdef(p^.procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
                     inc(reg_pushes[regi],t_times*2);
                end;
 {$endif}
@@ -1147,7 +1147,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.42  1999-05-17 23:51:43  peter
+  Revision 1.43  1999-05-18 14:15:58  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.42  1999/05/17 23:51:43  peter
     * with temp vars now use a reference with a persistant temp instead
       of setting datasize
 

+ 6 - 2
compiler/tree.pas

@@ -220,7 +220,7 @@ unit tree;
              loadn : (symtableentry : psym;symtable : psymtable;
                       is_absolute,is_first : boolean);
              calln : (symtableprocentry : pprocsym;
-                      symtableproc : psymtable;procdefinition : pprocdef;
+                      symtableproc : psymtable;procdefinition : pabstractprocdef;
                       methodpointer : ptree;
                       no_check,unit_specific,
                       return_value_used,static_call : boolean);
@@ -1733,7 +1733,11 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.81  1999-05-18 09:52:22  peter
+  Revision 1.82  1999-05-18 14:15:59  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.81  1999/05/18 09:52:22  peter
     * procedure of object and addrn fixes
 
   Revision 1.80  1999/05/17 23:51:48  peter

+ 24 - 3
compiler/types.pas

@@ -108,6 +108,9 @@ interface
     { to use on other types                              }
     function is_subequal(def1, def2: pdef): boolean;
 
+    { same as is_equal, but with error message if failed }
+    function CheckTypes(def1,def2 : pdef) : boolean;
+
     { true, if two parameter lists are equal        }
     { if value_equal_const is true, call by value   }
     { and call by const parameter are assumed as    }
@@ -612,8 +615,8 @@ implementation
 
     function is_equal(def1,def2 : pdef) : boolean;
       const
-         procvarmask = not(poassembler or pomethodpointer or povirtualmethod or pooverridingmethod or
-                           pocontainsself or pomsgstr or pomsgint);
+         procvarmask = not(poassembler or pomethodpointer or povirtualmethod or
+                           pooverridingmethod or pomsgint or pomsgstr);
       var
          b : boolean;
          hd : pdef;
@@ -789,11 +792,29 @@ implementation
         end; { endif assigned ... }
       end;
 
+    function CheckTypes(def1,def2 : pdef) : boolean;
+      begin
+        if not is_equal(def1,def2) then
+         begin
+           { Crash prevention }
+           if (not assigned(def1)) or (not assigned(def2)) then
+             Message(type_e_mismatch)
+           else
+             Message2(type_e_not_equal_types,def1^.typename,def2^.typename);
+           CheckTypes:=false;
+         end
+        else
+         CheckTypes:=true;
+      end;
 
 end.
 {
   $Log$
-  Revision 1.59  1999-05-18 09:52:24  peter
+  Revision 1.60  1999-05-18 14:16:01  peter
+    * containsself fixes
+    * checktypes()
+
+  Revision 1.59  1999/05/18 09:52:24  peter
     * procedure of object and addrn fixes
 
   Revision 1.58  1999/04/19 09:29:51  pierre