* better checks for procvar and methodpointer

compiler/htypechk.pas

@@ -135,71 +135,77 @@ implementation
           stringdef :
              begin
                case def_from^.deftype of
-                stringdef : begin
-                              doconv:=tc_string_2_string;
-                              b:=1;
-                            end;
-                   orddef : begin
-                            { char to string}
-                              if is_char(def_from) then
-                               begin
-                                 doconv:=tc_char_2_string;
-                                 b:=1;
-                               end;
-                            end;
-                 arraydef : begin
-                            { array of char to string, the length check is done by the firstpass of this node }
-                              if is_chararray(def_from) then
-                               begin
-                                 doconv:=tc_chararray_2_string;
-                                 if (not(cs_ansistrings in aktlocalswitches) and
-                                     is_shortstring(def_to)) or
-                                    ((cs_ansistrings in aktlocalswitches) and
-                                     is_ansistring(def_to)) then
-                                  b:=1
-                                 else
-                                  b:=2;
-                               end;
-                            end;
-               pointerdef : begin
-                            { pchar can be assigned to short/ansistrings }
-                              if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
-                               begin
-                                 doconv:=tc_pchar_2_string;
-                                 b:=1;
-                               end;
-                            end;
+                 stringdef :
+                   begin
+                     doconv:=tc_string_2_string;
+                     b:=1;
+                   end;
+                 orddef :
+                   begin
+                   { char to string}
+                     if is_char(def_from) then
+                      begin
+                        doconv:=tc_char_2_string;
+                        b:=1;
+                      end;
+                   end;
+                 arraydef :
+                   begin
+                   { array of char to string, the length check is done by the firstpass of this node }
+                     if is_chararray(def_from) then
+                      begin
+                        doconv:=tc_chararray_2_string;
+                        if (not(cs_ansistrings in aktlocalswitches) and
+                            is_shortstring(def_to)) or
+                           ((cs_ansistrings in aktlocalswitches) and
+                            is_ansistring(def_to)) then
+                         b:=1
+                        else
+                         b:=2;
+                      end;
+                   end;
+                 pointerdef :
+                   begin
+                   { pchar can be assigned to short/ansistrings }
+                     if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
+                      begin
+                        doconv:=tc_pchar_2_string;
+                        b:=1;
+                      end;
+                   end;
                end;
              end;
 
            floatdef :
              begin
                case def_from^.deftype of
-                orddef : begin { ordinal to real }
-                           if is_integer(def_from) then
-                             begin
-                                if pfloatdef(def_to)^.typ=f32bit then
-                                  doconv:=tc_int_2_fix
-                                else
-                                  doconv:=tc_int_2_real;
-                                b:=1;
-                             end;
-                         end;
-              floatdef : begin { 2 float types ? }
-                           if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
-                             doconv:=tc_equal
-                           else
-                             begin
-                                if pfloatdef(def_from)^.typ=f32bit then
-                                  doconv:=tc_fix_2_real
-                                else
-                                  if pfloatdef(def_to)^.typ=f32bit then
-                                    doconv:=tc_real_2_fix
-                                  else
-                                    doconv:=tc_real_2_real;
-                             end;
-                           b:=1;
-                         end;
+                 orddef :
+                   begin { ordinal to real }
+                     if is_integer(def_from) then
+                       begin
+                          if pfloatdef(def_to)^.typ=f32bit then
+                            doconv:=tc_int_2_fix
+                          else
+                            doconv:=tc_int_2_real;
+                          b:=1;
+                       end;
+                   end;
+                 floatdef :
+                   begin { 2 float types ? }
+                     if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
+                       doconv:=tc_equal
+                     else
+                       begin
+                          if pfloatdef(def_from)^.typ=f32bit then
+                            doconv:=tc_fix_2_real
+                          else
+                            if pfloatdef(def_to)^.typ=f32bit then
+                              doconv:=tc_real_2_fix
+                            else
+                              doconv:=tc_real_2_real;
+                       end;
+                     b:=1;
+                   end;
                end;
              end;
 
@@ -232,23 +238,25 @@ implementation
                else
                 begin
                   case def_from^.deftype of
-                   pointerdef : begin
-                                  if is_zero_based_array(def_to) and
-                                     is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
-                                   begin
-                                     doconv:=tc_pointer_2_array;
-                                     b:=1;
-                                   end;
-                                end;
-                    stringdef : begin
-                                  { string to array of char}
-                                  if (not(is_special_array(def_to)) or is_open_array(def_to)) and
-                                    is_equal(parraydef(def_to)^.definition,cchardef) then
-                                   begin
-                                     doconv:=tc_string_2_chararray;
-                                     b:=1;
-                                   end;
-                                end;
+                    pointerdef :
+                      begin
+                        if is_zero_based_array(def_to) and
+                           is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
+                         begin
+                           doconv:=tc_pointer_2_array;
+                           b:=1;
+                         end;
+                      end;
+                    stringdef :
+                      begin
+                        { string to array of char}
+                        if (not(is_special_array(def_to)) or is_open_array(def_to)) and
+                          is_equal(parraydef(def_to)^.definition,cchardef) then
+                         begin
+                           doconv:=tc_string_2_chararray;
+                           b:=1;
+                         end;
+                      end;
                   end;
                 end;
              end;
@@ -256,77 +264,83 @@ implementation
            pointerdef :
              begin
                case def_from^.deftype of
-               stringdef : begin
-                             { string constant to zero terminated string constant }
-                             if (fromtreetype=stringconstn) and
-                                is_pchar(def_to) then
-                              begin
-                                doconv:=tc_cstring_2_pchar;
-                                b:=1;
-                              end;
-                           end;
-                  orddef : begin
-                             { char constant to zero terminated string constant }
-                             if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and
-                                is_pchar(def_to) then
-                              begin
-                                doconv:=tc_cchar_2_pchar;
-                                b:=1;
-                              end;
-                           end;
-                arraydef : begin
-                             { chararray to pointer }
-                             if is_zero_based_array(def_from) and
-                                is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
-                              begin
-                                doconv:=tc_array_2_pointer;
-                                b:=1;
-                              end;
-                           end;
-              pointerdef : begin
-                             { child class pointer can be assigned to anchestor pointers }
-                             if (
-                                 (ppointerdef(def_from)^.definition^.deftype=objectdef) and
-                                 (ppointerdef(def_to)^.definition^.deftype=objectdef) and
-                                 pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
-                                   pobjectdef(ppointerdef(def_to)^.definition))
-                                ) or
-                                { all pointers can be assigned to void-pointer }
-                                is_equal(ppointerdef(def_to)^.definition,voiddef) or
-                                { in my opnion, is this not clean pascal }
-                                { well, but it's handy to use, it isn't ? (FK) }
-                                is_equal(ppointerdef(def_from)^.definition,voiddef) then
-                               begin
-                                 doconv:=tc_equal;
-                                 b:=1;
-                               end;
-                           end;
-              procvardef : begin
-                             { procedure variable can be assigned to an void pointer }
-                             { Not anymore. Use the @ operator now.}
-                             if not(m_tp_procvar in aktmodeswitches) and
-                                (ppointerdef(def_to)^.definition^.deftype=orddef) and
-                                (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
-                              begin
-                                doconv:=tc_equal;
-                                b:=1;
-                              end;
-                           end;
-             classrefdef,
-               objectdef : begin
-                             { class types and class reference type
-                               can be assigned to void pointers      }
-                             if (
-                                 ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.isclass) or
-                                 (def_from^.deftype=classrefdef)
-                                ) and
-                                (ppointerdef(def_to)^.definition^.deftype=orddef) and
-                                (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
-                               begin
-                                 doconv:=tc_equal;
-                                 b:=1;
-                               end;
-                           end;
+                 stringdef :
+                   begin
+                     { string constant to zero terminated string constant }
+                     if (fromtreetype=stringconstn) and
+                        is_pchar(def_to) then
+                      begin
+                        doconv:=tc_cstring_2_pchar;
+                        b:=1;
+                      end;
+                   end;
+                 orddef :
+                   begin
+                     { char constant to zero terminated string constant }
+                     if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and
+                        is_pchar(def_to) then
+                      begin
+                        doconv:=tc_cchar_2_pchar;
+                        b:=1;
+                      end;
+                   end;
+                 arraydef :
+                   begin
+                     { chararray to pointer }
+                     if is_zero_based_array(def_from) and
+                        is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
+                      begin
+                        doconv:=tc_array_2_pointer;
+                        b:=1;
+                      end;
+                   end;
+                 pointerdef :
+                   begin
+                     { child class pointer can be assigned to anchestor pointers }
+                     if (
+                         (ppointerdef(def_from)^.definition^.deftype=objectdef) and
+                         (ppointerdef(def_to)^.definition^.deftype=objectdef) and
+                         pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
+                           pobjectdef(ppointerdef(def_to)^.definition))
+                        ) or
+                        { all pointers can be assigned to void-pointer }
+                        is_equal(ppointerdef(def_to)^.definition,voiddef) or
+                        { in my opnion, is this not clean pascal }
+                        { well, but it's handy to use, it isn't ? (FK) }
+                        is_equal(ppointerdef(def_from)^.definition,voiddef) then
+                       begin
+                         doconv:=tc_equal;
+                         b:=1;
+                       end;
+                   end;
+                 procvardef :
+                   begin
+                     { procedure variable can be assigned to an void pointer }
+                     { Not anymore. Use the @ operator now.}
+                     if not(m_tp_procvar in aktmodeswitches) and
+                        (ppointerdef(def_to)^.definition^.deftype=orddef) and
+                        (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
+                      begin
+                        doconv:=tc_equal;
+                        b:=1;
+                      end;
+                   end;
+                 classrefdef,
+                 objectdef :
+                   begin
+                     { class types and class reference type
+                       can be assigned to void pointers      }
+                     if (
+                         ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.isclass) or
+                         (def_from^.deftype=classrefdef)
+                        ) and
+                        (ppointerdef(def_to)^.definition^.deftype=orddef) and
+                        (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
+                       begin
+                         doconv:=tc_equal;
+                         b:=1;
+                       end;
+                   end;
                end;
              end;
 
@@ -345,11 +359,9 @@ implementation
                { proc -> procvar }
                if (def_from^.deftype=procdef) then
                 begin
-                  def_from^.deftype:=procvardef;
                   doconv:=tc_proc_2_procvar;
-                  if is_equal(def_from,def_to) then
+                  if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
                    b:=1;
-                  def_from^.deftype:=procdef;
                 end
                else
                 { for example delphi allows the assignement from pointers }
@@ -649,7 +661,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.26  1999-05-20 14:58:26  peter
+  Revision 1.27  1999-06-01 19:27:47  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.26  1999/05/20 14:58:26  peter
     * fixed arrayconstruct->set conversion which didn't work for enum sets
 
   Revision 1.25  1999/05/19 20:40:12  florian

compiler/msgidx.inc

@@ -223,6 +223,7 @@ type tmsgconst=(
   type_e_integer_or_real_expr_expected,
   type_e_wrong_type_in_array_constructor,
   type_e_wrong_parameter_type,
+  type_e_no_method_and_procedure_not_compatible,
   sym_e_id_not_found,
   sym_f_internal_error_in_symtablestack,
   sym_e_duplicate_id,

compiler/msgtxt.inc

@@ -237,194 +237,195 @@ const msgtxt : array[0..000095,1..240] of char=(
   '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_Method (variable) and Procedure (variable) are not compatible'#000+
   'E_Identifier not found $1'#000+
-  'F_Internal Error in SymTableStack()'#000+
+  'F_','Internal Error in SymTableStack()'#000+
   'E_Duplicate identifier $1'#000+
-  'H_Id','entifier already defined in $1 at line $2'#000+
+  'H_Identifier 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_Typ','e identifier not defined'#000+
   'E_Forward type not resolved $1'#000+
-  'E_Only s','tatic variables can be used in static methods or outside met'+
-  'hods'#000+
+  'E_Only static variables can be used in static methods or outside metho'+
+  'ds'#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+
+  'E_Instances of classes or objects with ','an abstract method are not al'+
+  'lowed'#000+
   'W_Label not defined $1'#000+
-  'E_Ille','gal label declaration'#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_illegal type declaration of set',' elements'#000+
   'E_Forward class definition not resolved $1'#000+
-  'H_Parameter',' 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+
+  'W_Local variable $1 does not seem t','o be initialized'#000+
   'W_Variable $1 does not seem to be initialized'#000+
-  'E','_identifier idents no member $1'#000+
+  'E_identifier idents no member $1'#000+
   'B_Found declaration: $1'#000+
   'E_BREAK 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_Inva','lid integer expression'#000+
   'E_Illegal qualifier'#000+
-  'E_High range limit < ','low range limit'#000+
+  'E_High range limit < low range limit'#000+
   'E_Illegal counter variable'#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_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 called'#000+
   'W_Possible illegal call of constructor or destructor (doesn'#039't matc'+
   'h to this context)'#000+
-  'N_Inefficient code'#000+
+  'N_','Inefficient code'#000+
   'W_unreachable code'#000+
-  'E_procedure call with stackf','rame ESP/SP'#000+
+  'E_procedure call with stackframe ESP/SP'#000+
   'E_Abstract methods can'#039't be called directly'#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 m','ode'#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 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 st','ored'#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)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+
+  'W_Probably illegal constant pas','sed 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+
   'D_Finished $1 styled assembler parsing'#000+
-  'E_Non-label pattern contains @'#000+
+  'E_Non-label pat','tern contains @'#000+
   'W_Override operator not supported'#000+
-  'E_Error buildi','ng record offset'#000+
+  'E_Error building record offset'#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_Relocatab','le symbol can only be added'#000+
   'E_Invalid constant expression'#000+
-  'E_Relo','catable symbol is not allowed'#000+
+  'E_Relocatable symbol is not allowed'#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_Mult','iple index register usage'#000+
   'E_Invalid operand type'#000+
-  'E_Invalid strin','g as opcode operand: $1'#000+
+  'E_Invalid string as opcode operand: $1'#000+
   'W_@CODE and @DATA not supported'#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_Evaluator stack u','nderflow'#000+
   'F_Invalid numeric format in asm evaluator'#000+
-  'F_Invalid Ope','rator in asm evaluator'#000+
+  'F_Invalid Operator in asm evaluator'#000+
   'E_escape sequence ignored: $1'#000+
   'E_Invalid symbol reference'#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 bound','s'#000+
+  'E_U','nsupported 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 binary $1'#000+
   'E_Error converting hexadecimal $1'#000+
   'H_$1 translated to $2'#000+
-  'W_$1 is associated to an overloaded function'#000+
+  'W_$1 is associated to an overlo','aded function'#000+
   'E_Cannot use SELF outside a method'#000+
-  'E_Cannot use OL','DEBP outside a nested procedure'#000+
+  'E_Cannot use OLDEBP outside 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+
+  'E_Size suffix and destination or source size do not ma','tch'#000+
   'W_Size suffix and destination or source size do not match'#000+
-  'E_','Assembler syntax error'#000+
+  'E_Assembler syntax 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+
+  '32bit con','stant created for address'#000+
   'E_Invalid or missing opcode'#000+
-  'E_Invalid ','combination of prefix 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_Und','efined local symbol $1'#000+
   'E_Unknown label identifier $1'#000+
-  'E_Invalid f','loating point register name'#000+
+  'E_Invalid floating point 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 ov','erride expression'#000+
+  'E_Cannot ind','ex a local var or parameter with a register'#000+
+  'E_Invalid segment override expression'#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,
+  'E_Not a direc','tive or local symbol $1'#000+
+  'E_Using a defined name as a local label'#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+
+  'E_Allocating of data is only allowed in bss se','ction'#000+
   'F_No binary writer selected'#000+
-  'E_Asm: Opcode $1 not in table'#000,
+  'E_Asm: Opcode $1 not in table'#000+
   'E_Asm: $1 invalid 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: $1 va','lue exceeds bounds $2'#000+
   'E_Asm: Short jump is out of range $1'#000+
-  'W_Sou','rce operating system redefined'#000+
+  'W_Source operating 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 assem'+
-  'bling'#000+
+  'W_Error w','hile assembling exitcode $1'#000+
+  'W_Can'#039't call the assembler, error $1 switching to external assembl'+
+  'ing'#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_Library $1',' not found, Linking may fail !'#000+
   'W_Error while linking'#000+
-  'W_Can'#039't cal','l the linker, switching to external linking'#000+
+  'W_Can'#039't call the linker, 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+
+  'E_Dynamic Libraries not supp','orted'#000+
   'I_Closing script $1'#000+
-  'W_resource compiler not found, switchi','ng to external mode'#000+
+  'W_resource compiler not found, switching to external mode'#000+
   'I_Compiling resource $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_Size o','f uninitialized data: $1 bytes'#000+
+  'X_Stack space reserved: $1 bytes'#000+
   'X_Stack space commited: $1 bytes'#000+
   'T_Unitsearch: $1'#000+
   'T_PPU Loading $1'#000+
@@ -433,201 +434,201 @@ const msgtxt : array[0..000095,1..240] of char=(
   'U_PPU Crc: $1'#000+
   'U_PPU Time: $1'#000+
   'U_PPU File too short'#000+
-  'U_PPU Invalid Header (no PPU at the begin)'#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 other processor'#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+
   'F_reading PPU-File'#000+
   'F_unexpected end of PPU-File'#000+
-  'F_Invalid PPU-File entry: $1'#000+
+  'F_Invalid PPU-File e','ntry: $1'#000+
   'F_PPU Dbx count problem'#000+
   'E_Illegal unit name: $1'#000+
-  'F_Too m','uch units'#000+
+  'F_Too much units'#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+
+  'F_There were $1 errors c','ompiling module, stopping'#000+
   'U_Load from $1 ($2) unit $3'#000+
-  'U_Recompil','ing $1, checksum changed for $2'#000+
+  'U_Recompiling $1, checksum 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_Recompili','ng unit, obj is older than asm'#000+
+  'U_','Recompiling unit, obj and asm are older than ppufile'#000+
+  'U_Recompiling unit, obj 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+
+  '$1 [options] <inputfile> [options]',#000+
   'W_Only one source file supported'#000+
-  'W_DEF file can be created only',' for OS/2'#000+
+  'W_DEF file can be created only for OS/2'#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+
+  'F_Unable',' to open file $1'#000+
   'N_Reading further options from $1'#000+
-  'W_Target is a','lready set to: $1'#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 rec','ompiling with -dGDB'#000+
+  'W_Debug info','rmation generation is not supported by this executable'#000+
+  'H_Try recompiling with -dGDB'#000+
   'E_You are using the obsolete switch $1'#000+
   'E_You are using the obsolete switch $1, please use $2'#000+
   'N_Switching assembler to default source writing assembler'#000+
-  'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
-  'Copyri','ght (c) 1993-98 by Florian Klaempfl'#000+
+  'Free ','Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
+  'Copyright (c) 1993-98 by Florian Klaempfl'#000+
   'Free Pascal Compiler version $FPCVER'#000+
   #000+
   'Compiler Date  : $FPCDATE'#000+
   'Compiler Target: $FPCTARGET'#000+
   #000+
-  'This program comes under the GNU General Public Licence'#000+
+  'This program comes under the GNU General Public',' Licence'#000+
   'For more information read COPYING.FPC'#000+
   #000+
-  'Report bugs,sugg','estions etc to:'#000+
+  'Report bugs,suggestions etc to:'#000+
   '                 [email protected]'#000+
   '**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+
+  '**1a_the compiler doesn'#039't delete the g','enerated 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+
   '**1b_generate browser info'#000+
-  '**2bl_generate local symbol info'#000+
+  '**2bl_generate local sy','mbol info'#000+
   '**1B_build all modules'#000+
-  '**1C<x>_code generation options',':'#000+
+  '**1C<x>_code generation options:'#000+
   '3*2CD_create dynamic library'#000+
   '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#000+
   '**2Ci_IO-checking'#000+
   '**2Cn_omit linking stage'#000+
   '**2Co_check overflow of integer operations'#000+
-  '**2Cr_range checking'#000+
+  '**2Cr_r','ange checking'#000+
   '**2Cs<n>_set stack size to <n>'#000+
-  '**2Ct_stack checkin','g'#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+
   '*O2Dd<x>_set description to <x>'#000+
   '*O2Dw_PM application'#000+
-  '**1e<x>_set path to executable'#000+
+  '**1e<x>_set pa','th to executable'#000+
   '**1E_same as -Cn'#000+
-  '**1F<x>_set file names and pat','hs:'#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 to <x>'#000+
   '**2FE<x>_set exe/unit output path to <x>'#000+
-  '**2Fi<x>_adds <x> to include path'#000+
+  '**2Fi<x>_adds <x> to inclu','de path'#000+
   '**2Fl<x>_adds <x> to library path'#000+
-  '*L2FL<x>_uses <x> as d','ynamic linker'#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> to unit path'#000+
   '**2FU<x>_set unit output path to <x>, overrides -FE'#000+
-  '*g1g<x>_generate debugger information:'#000+
+  '*g1g<x>_g','enerate debugger information:'#000+
   '*g2gg_use gsym'#000+
   '*g2gd_use dbx'#000+
-  '*g2gh','_use heap trace unit'#000+
+  '*g2gh_use heap trace unit'#000+
   '**1i_information'#000+
   '**2iD_return compiler date'#000+
   '**2iV_return compiler version'#000+
   '**2iSO_return compiler OS'#000+
   '**2iSP_return compiler processor'#000+
-  '**2iTO_return target OS'#000+
+  '**2iTO_return target O','S'#000+
   '**2iTP_return target processor'#000+
-  '**1I<x>_adds <x> to include pat','h'#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+
-  '**1pg_generate profile code for gprof'#000+
-  '*L1P_use pipes instead of creating temporary assembler ','files'#000+
+  '**1pg_generate profile code f','or 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+
   '**2Sd_tries to be Delphi compatible'#000+
-  '**2Se_compiler stops after the first error'#000+
+  '**2Se_compiler stop','s after the first error'#000+
   '**2Sg_allow LABEL and GOTO'#000+
-  '**2Sh_Use ans','istrings'#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+
   '**2Sp_tries to be gpc compatible'#000+
-  '**2Ss_constructor name must be init (destructor must be done)'#000+
-  '**2St_allow static keyword i','n objects'#000+
+  '**2Ss_constructor name mus','t 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_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+
+  '**','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*_n : Show notes                  t : Show tried/used files'#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*_i : Show general info           p : Show compiled procedures'#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 mod'+
-  'e'#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*_    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+
+  '**2XD_link w','ith 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 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*2Anas','mcoff_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 (Microsoft)'#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*2Ratt_read AT&T style as','sembler'#000+
   '3*2Rintel_read Intel style assembler'#000+
-  '3*2Rdirect_copy ass','embler text directly to assembler file'#000+
+  '3*2Rdirect_copy assembler text directly to assembler file'#000+
   '3*1O<x>_optimizations:'#000+
   '3*2Og_generate smaller code'#000+
   '3*2OG_generate faster code (default)'#000+
-  '3*2Or_keep certain variables in registers (still BUGGY!!!)'#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*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*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*3Op','1_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*2TGO32V1_version 1 of DJ Delorie DOS extender'#000+
-  '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#000+
+  '3*2TGO32V2_versi','on 2 of DJ Delorie DOS extender'#000+
   '3*2TLINUX_Linux'#000+
-  '3*2TOS2_OS/2 2.x',#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 assembler'#000+
   '6*2Amit_MIT Syntax (old GAS)'#000+
   '6*2Amot_Standard Motorola assembler'#000+
-  '6*1O_optimizations:'#000+
+  '6','*1O_optimizations:'#000+
   '6*2Oa_turn on the optimizer'#000+
-  '6*2Og_generate sm','aller code'#000+
+  '6*2Og_generate smaller code'#000+
   '6*2OG_generate faster code (default)'#000+
   '6*2Ox_optimize maximum (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*2RMOT_read m','otorola style assembler'#000+
   '6*1T<x>_Target operating system:'#000+
-  '6*2TAMI','GA_Commodore Amiga'#000+
+  '6*2TAMIGA_Commodore Amiga'#000+
   '6*2TATARI_Atari ST/STe/TT'#000+
   '6*2TMACOS_Macintosh m68k'#000+
   '6*2TLINUX_Linux-68k'#000+

compiler/pdecl.pas

@@ -1040,11 +1040,14 @@ unit pdecl;
                        assigned(propertyparas)
                        ) then
                        Message(parser_e_property_cant_have_a_default_value);
+                     { Get the result of the default, the firstpass is
+                       needed to support values like -1 }
                      pt:=comp_expr(true);
+                     do_firstpass(pt);
                      if p^.proptype^.deftype=setdef then
                        begin
-                          do_firstpass(pt);
-                          arrayconstructor_to_set(pt);
+                         arrayconstructor_to_set(pt);
+                         do_firstpass(pt);
                        end;
                      pt:=gentypeconvnode(pt,p^.proptype);
                      do_firstpass(pt);
@@ -2216,7 +2219,10 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.124  1999-06-01 14:45:51  peter
+  Revision 1.125  1999-06-01 19:27:53  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.124  1999/06/01 14:45:51  peter
     * @procvar is now always needed for FPC
 
   Revision 1.123  1999/05/27 19:44:45  peter

compiler/pexpr.pas

@@ -545,12 +545,12 @@ unit pexpr;
               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
+                 (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
                 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
+         else if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,getprocvardef)) then
            begin
               hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
            end;
@@ -732,7 +732,7 @@ unit pexpr;
                       p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
                       do_proc_call(getaddr or
                         (getprocvar and
-                        proc_to_procvar_equal(getprocvardef,pprocsym(sym)^.definition))
+                        proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
                         ,again,p1,pd);
                       { now we know the real method e.g. we can check for }
                       { a class method                              }
@@ -1083,7 +1083,7 @@ unit pexpr;
                               p1^.unit_specific:=unit_specific;
                               do_proc_call(getaddr or
                                 (getprocvar and
-                                proc_to_procvar_equal(getprocvardef,pprocsym(srsym)^.definition)),
+                                proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
                                 again,p1,pd);
                               if possible_error and
                                  ((p1^.procdefinition^.options and poclassmethod)=0) then
@@ -1410,7 +1410,7 @@ unit pexpr;
                   begin
                     if (pd^.deftype=procvardef) then
                      begin
-                       if getprocvar and proc_to_procvar_equal(pprocvardef(pd),getprocvardef) then
+                       if getprocvar and is_equal(pd,getprocvardef) then
                          again:=false
                        else
                          if (token=LKLAMMER) or
@@ -1985,7 +1985,10 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.109  1999-05-27 19:44:46  peter
+  Revision 1.110  1999-06-01 19:27:55  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.109  1999/05/27 19:44:46  peter
     * removed oldasm
     * plabel -> pasmlabel
     * -a switches to source writing automaticly

compiler/symconst.inc

@@ -71,10 +71,12 @@
        pomsgint         = $10000000; { method for int message handling }
        posavestdregs    = $20000000; { save std regs cdecl and stdcall need that ! }
        pocontainsself   = $40000000; { self is passed explicit to the compiler }
-       { relevant options for assigning a proc or a procvar to a procvar }
        posafecall       = $80000000; { safe call calling conventions }
+
+       { relevant options for assigning a proc or a procvar to a procvar }
        po_compatibility_options = $7FFFFFFF-
-         (pomethodpointer+povirtualmethod+pooverridingmethod);
+         (poassembler+pomsgstr+pomsgint+
+          povirtualmethod+pooverridingmethod+pomethodpointer);
 
        { options for objects and classes }
        oo_is_abstract  = $1;         { true, if the object/class has an abstract }
@@ -109,7 +111,10 @@
 
 {
   $Log$
-  Revision 1.9  1999-05-24 08:55:29  florian
+  Revision 1.10  1999-06-01 19:27:56  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.9  1999/05/24 08:55:29  florian
     * non working safecall directiv implemented, I don't know if we
       need it
 

compiler/tccal.pas

@@ -391,7 +391,7 @@ implementation
              (
               (m_tp_procvar in aktmodeswitches) and
               (def^.deftype=procvardef) and (p^.left^.treetype=calln) and
-              (proc_to_procvar_equal(p^.left^.procdefinition,pprocvardef(def)))
+              (proc_to_procvar_equal(pprocdef(p^.left^.procdefinition),pprocvardef(def)))
              )
              ;
         end;
@@ -1172,7 +1172,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.50  1999-06-01 14:46:00  peter
+  Revision 1.51  1999-06-01 19:27:57  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.50  1999/06/01 14:46:00  peter
     * @procvar is now always needed for FPC
 
   Revision 1.49  1999/05/31 20:34:51  peter

compiler/types.pas

@@ -143,7 +143,7 @@ interface
     function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
 
     { true if a function can be assigned to a procvar }
-    function proc_to_procvar_equal(def1,def2 : pabstractprocdef) : boolean;
+    function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean;
 
     { if l isn't in the range of def a range check error is generated and
       the value is placed within the range }
@@ -203,8 +203,20 @@ implementation
 
 
     { true if a function can be assigned to a procvar }
-    function proc_to_procvar_equal(def1,def2 : pabstractprocdef) : boolean;
+    function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean;
+      var
+        ismethod : boolean;
       begin
+         proc_to_procvar_equal:=false;
+         { check for method pointer }
+         ismethod:=(def1^.owner^.symtabletype=objectsymtable) and
+                   (pobjectdef(def1^.owner^.defowner)^.isclass);
+         if ismethod<>((def2^.options and pomethodpointer)<>0) then
+          begin
+            Message(type_e_no_method_and_procedure_not_compatible);
+            exit;
+          end;
+         { check the other things }
          if is_equal(def1^.retdef,def2^.retdef) and
             equal_paras(def1^.para1,def2^.para1,false) and
             ((def1^.options and po_compatibility_options)=
@@ -668,9 +680,6 @@ implementation
 
 
     function is_equal(def1,def2 : pdef) : boolean;
-      const
-         procvarmask = not(poassembler or pomethodpointer or povirtualmethod or
-                           pooverridingmethod or pomsgint or pomsgstr);
       var
          b : boolean;
          hd : pdef;
@@ -771,7 +780,8 @@ implementation
                 { poassembler isn't important for compatibility }
                 { if a method is assigned to a methodpointer    }
                 { is checked before                             }
-                b:=((pprocvardef(def1)^.options and procvarmask)=(pprocvardef(def2)^.options and procvarmask)) and
+                b:=((pprocvardef(def1)^.options and po_compatibility_options)=
+                    (pprocvardef(def2)^.options and po_compatibility_options)) and
                    is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
                 { now evalute the parameters }
                 if b then
@@ -876,7 +886,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.67  1999-05-31 22:54:19  peter
+  Revision 1.68  1999-06-01 19:27:58  peter
+    * better checks for procvar and methodpointer
+
+  Revision 1.67  1999/05/31 22:54:19  peter
     * when range check error is found then fix the value to be within the
       range