mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-10-31 14:31:38 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			719 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
			
		
		
	
	
			719 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
| {
 | |
|     $Id$
 | |
|     Copyright (c) 1996-98 by Florian Klaempfl
 | |
| 
 | |
|     This unit exports some help routines for the type checking
 | |
| 
 | |
|     This program is free software; you can redistribute it and/or modify
 | |
|     it under the terms of the GNU General Public License as published by
 | |
|     the Free Software Foundation; either version 2 of the License, or
 | |
|     (at your option) any later version.
 | |
| 
 | |
|     This program is distributed in the hope that it will be useful,
 | |
|     but WITHOUT ANY WARRANTY; without even the implied warranty of
 | |
|     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 | |
|     GNU General Public License for more details.
 | |
| 
 | |
|     You should have received a copy of the GNU General Public License
 | |
|     along with this program; if not, write to the Free Software
 | |
|     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 | |
| 
 | |
|  ****************************************************************************
 | |
| }
 | |
| unit htypechk;
 | |
| interface
 | |
| 
 | |
|     uses
 | |
|       tree,symtable;
 | |
| 
 | |
|     const
 | |
|     { firstcallparan without varspez we don't count the ref }
 | |
|        count_ref : boolean = true;
 | |
|        get_para_resulttype : boolean = false;
 | |
|        allow_array_constructor : boolean = false;
 | |
| 
 | |
| 
 | |
|     { Conversion }
 | |
|     function isconvertable(def_from,def_to : pdef;
 | |
|              var doconv : tconverttype;fromtreetype : ttreetyp;
 | |
|              explicit : boolean) : byte;
 | |
| 
 | |
|     { Register Allocation }
 | |
|     procedure make_not_regable(p : ptree);
 | |
|     procedure left_right_max(p : ptree);
 | |
|     procedure calcregisters(p : ptree;r32,fpu,mmx : word);
 | |
| 
 | |
|     { subroutine handling }
 | |
|     procedure test_protected_sym(sym : psym);
 | |
|     procedure test_protected(p : ptree);
 | |
|     function  is_procsym_load(p:Ptree):boolean;
 | |
|     function  is_procsym_call(p:Ptree):boolean;
 | |
|     function  is_assignment_overloaded(from_def,to_def : pdef) : boolean;
 | |
| 
 | |
| 
 | |
| implementation
 | |
| 
 | |
|     uses
 | |
|        globtype,systems,tokens,
 | |
|        cobjects,verbose,globals,
 | |
|        types,
 | |
|        hcodegen;
 | |
| 
 | |
| {****************************************************************************
 | |
|                              Convert
 | |
| ****************************************************************************}
 | |
| 
 | |
|     { Returns:
 | |
|        0 - Not convertable
 | |
|        1 - Convertable
 | |
|        2 - Convertable, but not first choice }
 | |
|     function isconvertable(def_from,def_to : pdef;
 | |
|              var doconv : tconverttype;fromtreetype : ttreetyp;
 | |
|              explicit : boolean) : byte;
 | |
| 
 | |
|       { Tbasetype:  uauto,uvoid,uchar,
 | |
|                     u8bit,u16bit,u32bit,
 | |
|                     s8bit,s16bit,s32,
 | |
|                     bool8bit,bool16bit,bool32bit,
 | |
|                     u64bit,s64bitint }
 | |
|       type
 | |
|         tbasedef=(bvoid,bchar,bint,bbool);
 | |
|       const
 | |
|         basedeftbl:array[tbasetype] of tbasedef =
 | |
|           (bvoid,bvoid,bchar,
 | |
|            bint,bint,bint,
 | |
|            bint,bint,bint,
 | |
|            bbool,bbool,bbool,bint,bint);
 | |
| 
 | |
|         basedefconverts : array[tbasedef,tbasedef] of tconverttype =
 | |
|          ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
 | |
|           (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible),
 | |
|           (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
 | |
|           (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
 | |
| 
 | |
|       var
 | |
|          b : byte;
 | |
|          hd1,hd2 : pdef;
 | |
|       begin
 | |
|        { safety check }
 | |
|          if not(assigned(def_from) and assigned(def_to)) then
 | |
|           begin
 | |
|             isconvertable:=0;
 | |
|             exit;
 | |
|           end;
 | |
| 
 | |
|          b:=0;
 | |
|        { we walk the wanted (def_to) types and check then the def_from
 | |
|          types if there is a conversion possible }
 | |
|          case def_to^.deftype of
 | |
|            orddef :
 | |
|              begin
 | |
|                case def_from^.deftype of
 | |
|                  orddef :
 | |
|                    begin
 | |
|                      doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]];
 | |
|                      b:=1;
 | |
|                      if (doconv=tc_not_possible) or
 | |
|                         ((doconv=tc_int_2_bool) and
 | |
|                          (not explicit) and
 | |
|                          (not is_boolean(def_from))) or
 | |
|                         ((doconv=tc_bool_2_int) and
 | |
|                          (not explicit) and
 | |
|                          (not is_boolean(def_to))) then
 | |
|                        b:=0;
 | |
|                    end;
 | |
|                  enumdef :
 | |
|                    begin
 | |
|                      doconv:=tc_int_2_int;
 | |
|                      b:=1;
 | |
|                    end;
 | |
|                end;
 | |
|              end;
 | |
| 
 | |
|           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
 | |
|                             { string to array of char, the length check is done by the firstpass of this node }
 | |
|                               if is_equal(parraydef(def_from)^.definition,cchardef) 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;
 | |
|                end;
 | |
|              end;
 | |
| 
 | |
|            enumdef :
 | |
|              begin
 | |
|                if (def_from^.deftype=enumdef) then
 | |
|                 begin
 | |
|                   if assigned(penumdef(def_from)^.basedef) then
 | |
|                    hd1:=penumdef(def_from)^.basedef
 | |
|                   else
 | |
|                    hd1:=def_from;
 | |
|                   if assigned(penumdef(def_to)^.basedef) then
 | |
|                    hd2:=penumdef(def_to)^.basedef
 | |
|                   else
 | |
|                    hd2:=def_to;
 | |
|                   if (hd1=hd2) then
 | |
|                    b:=1;
 | |
|                 end;
 | |
|              end;
 | |
| 
 | |
|            arraydef :
 | |
|              begin
 | |
|              { open array is also compatible with a single element of its base type }
 | |
|                if is_open_array(def_to) and
 | |
|                   is_equal(parraydef(def_to)^.definition,def_from) then
 | |
|                 begin
 | |
|                   doconv:=tc_equal;
 | |
|                   b:=1;
 | |
|                 end
 | |
|                else
 | |
|                 begin
 | |
|                   case def_from^.deftype of
 | |
|                    pointerdef : begin
 | |
|                                   if (parraydef(def_to)^.lowrange=0) and
 | |
|                                      is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
 | |
|                                    begin
 | |
|                                      doconv:=tc_pointer_2_array;
 | |
|                                      b:=1;
 | |
|                                    end;
 | |
|                                 end;
 | |
|                     stringdef : begin
 | |
|                                   { array of char to string }
 | |
|                                   if is_equal(parraydef(def_to)^.definition,cchardef) then
 | |
|                                    begin
 | |
|                                      doconv:=tc_string_2_chararray;
 | |
|                                      b:=1;
 | |
|                                    end;
 | |
|                                 end;
 | |
|                   end;
 | |
|                 end;
 | |
|              end;
 | |
| 
 | |
|            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 (parraydef(def_from)^.lowrange=0) 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;
 | |
| 
 | |
|            setdef :
 | |
|              begin
 | |
|                { automatic arrayconstructor -> set conversion }
 | |
|                if (def_from^.deftype=arraydef) and (parraydef(def_from)^.IsConstructor) then
 | |
|                 begin
 | |
|                   doconv:=tc_arrayconstructor_2_set;
 | |
|                   b:=1;
 | |
|                 end;
 | |
|              end;
 | |
| 
 | |
|            procvardef :
 | |
|              begin
 | |
|                { 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
 | |
|                    b:=1;
 | |
|                   def_from^.deftype:=procdef;
 | |
|                 end
 | |
|                else
 | |
|                 { for example delphi allows the assignement from pointers }
 | |
|                 { to procedure variables                                  }
 | |
|                 if (m_pointer_2_procedure in aktmodeswitches) and
 | |
|                   (def_from^.deftype=pointerdef) and
 | |
|                   (ppointerdef(def_from)^.definition^.deftype=orddef) and
 | |
|                   (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then
 | |
|                 begin
 | |
|                    doconv:=tc_equal;
 | |
|                    b:=1;
 | |
|                 end
 | |
|                else
 | |
|                { nil is compatible with procvars }
 | |
|                 if (fromtreetype=niln) then
 | |
|                  begin
 | |
|                    doconv:=tc_equal;
 | |
|                    b:=1;
 | |
|                  end;
 | |
|              end;
 | |
| 
 | |
|            objectdef :
 | |
|              begin
 | |
|                { object pascal objects }
 | |
|                if (def_from^.deftype=objectdef) {and
 | |
|                   pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
 | |
|                 begin
 | |
|                   doconv:=tc_equal;
 | |
|                   if pobjectdef(def_from)^.isrelated(pobjectdef(def_to)) then
 | |
|                    b:=1;
 | |
|                 end
 | |
|                else
 | |
|                 { nil is compatible with class instances }
 | |
|                 if (fromtreetype=niln) and (pobjectdef(def_to)^.isclass) then
 | |
|                  begin
 | |
|                    doconv:=tc_equal;
 | |
|                    b:=1;
 | |
|                  end;
 | |
|              end;
 | |
| 
 | |
|            classrefdef :
 | |
|              begin
 | |
|                { class reference types }
 | |
|                if (def_from^.deftype=classrefdef) then
 | |
|                 begin
 | |
|                   doconv:=tc_equal;
 | |
|                   if pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated(
 | |
|                        pobjectdef(pclassrefdef(def_to)^.definition)) then
 | |
|                    b:=1;
 | |
|                 end
 | |
|                else
 | |
|                 { nil is compatible with class references }
 | |
|                 if (fromtreetype=niln) then
 | |
|                  begin
 | |
|                    doconv:=tc_equal;
 | |
|                    b:=1;
 | |
|                  end;
 | |
|              end;
 | |
| 
 | |
|            filedef :
 | |
|              begin
 | |
|                { typed files are all equal to the abstract file type
 | |
|                name TYPEDFILE in system.pp in is_equal in types.pas
 | |
|                the problem is that it sholud be also compatible to FILE
 | |
|                but this would leed to a problem for ASSIGN RESET and REWRITE
 | |
|                when trying to find the good overloaded function !!
 | |
|                so all file function are doubled in system.pp
 | |
|                this is not very beautiful !!}
 | |
|                if (def_from^.deftype=filedef) and
 | |
|                   (
 | |
|                    (
 | |
|                     (pfiledef(def_from)^.filetype = ft_typed) and
 | |
|                     (pfiledef(def_to)^.filetype = ft_typed) and
 | |
|                     (
 | |
|                      (pfiledef(def_from)^.typed_as = pdef(voiddef)) or
 | |
|                      (pfiledef(def_to)^.typed_as = pdef(voiddef))
 | |
|                     )
 | |
|                    ) or
 | |
|                    (
 | |
|                     (
 | |
|                      (pfiledef(def_from)^.filetype = ft_untyped) and
 | |
|                      (pfiledef(def_to)^.filetype = ft_typed)
 | |
|                     ) or
 | |
|                     (
 | |
|                      (pfiledef(def_from)^.filetype = ft_typed) and
 | |
|                      (pfiledef(def_to)^.filetype = ft_untyped)
 | |
|                     )
 | |
|                    )
 | |
|                   ) then
 | |
|                  begin
 | |
|                     doconv:=tc_equal;
 | |
|                     b:=1;
 | |
|                  end
 | |
|              end;
 | |
| 
 | |
|            else
 | |
|              begin
 | |
|              { assignment overwritten ?? }
 | |
|                if is_assignment_overloaded(def_from,def_to) then
 | |
|                 b:=1;
 | |
|              end;
 | |
|          end;
 | |
| 
 | |
|            { nil is compatible with ansi- and wide strings }
 | |
|            { no, that isn't true, (FK)
 | |
|            if (fromtreetype=niln) and (def_to^.deftype=stringdef)
 | |
|              and (pstringdef(def_to)^.string_typ in [st_ansistring,st_widestring]) then
 | |
|              begin
 | |
|                 doconv:=tc_equal;
 | |
|                 b:=1;
 | |
|              end
 | |
|          else
 | |
|            }
 | |
|            { ansi- and wide strings can be assigned to void pointers }
 | |
|            { no, (FK)
 | |
|            if (def_from^.deftype=stringdef) and
 | |
|              (pstringdef(def_from)^.string_typ in [st_ansistring,st_widestring]) and
 | |
|              (def_to^.deftype=pointerdef) and
 | |
|              (ppointerdef(def_to)^.definition^.deftype=orddef) and
 | |
|              (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
 | |
|              begin
 | |
|                 doconv:=tc_equal;
 | |
|                 b:=1;
 | |
|              end
 | |
|          else
 | |
|            }
 | |
|            { ansistrings can be assigned to pchar
 | |
|              this needs an explicit type cast (FK)
 | |
|            if is_ansistring(def_from) and
 | |
|              (def_to^.deftype=pointerdef) and
 | |
|              (ppointerdef(def_to)^.definition^.deftype=orddef) and
 | |
|              (porddef(ppointerdef(def_to)^.definition)^.typ=uchar) then
 | |
|              begin
 | |
|                 doconv:=tc_ansistring_2_pchar;
 | |
|                 b:=1;
 | |
|              end
 | |
|          else
 | |
|            }
 | |
|         isconvertable:=b;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                           Register Calculation
 | |
| ****************************************************************************}
 | |
| 
 | |
|     { marks an lvalue as "unregable" }
 | |
|     procedure make_not_regable(p : ptree);
 | |
|       begin
 | |
|          case p^.treetype of
 | |
|             typeconvn :
 | |
|               make_not_regable(p^.left);
 | |
|             loadn :
 | |
|               if p^.symtableentry^.typ=varsym then
 | |
|                 pvarsym(p^.symtableentry)^.var_options :=
 | |
|                   pvarsym(p^.symtableentry)^.var_options and not vo_regable;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure left_right_max(p : ptree);
 | |
|       begin
 | |
|         if assigned(p^.left) then
 | |
|          begin
 | |
|            if assigned(p^.right) then
 | |
|             begin
 | |
|               p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
 | |
|               p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
 | |
| {$ifdef SUPPORT_MMX}
 | |
|               p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
 | |
| {$endif SUPPORT_MMX}
 | |
|             end
 | |
|            else
 | |
|             begin
 | |
|               p^.registers32:=p^.left^.registers32;
 | |
|               p^.registersfpu:=p^.left^.registersfpu;
 | |
| {$ifdef SUPPORT_MMX}
 | |
|               p^.registersmmx:=p^.left^.registersmmx;
 | |
| {$endif SUPPORT_MMX}
 | |
|             end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
|     { calculates the needed registers for a binary operator }
 | |
|     procedure calcregisters(p : ptree;r32,fpu,mmx : word);
 | |
| 
 | |
|       begin
 | |
|          left_right_max(p);
 | |
| 
 | |
|       { Only when the difference between the left and right registers < the
 | |
|         wanted registers allocate the amount of registers }
 | |
| 
 | |
|         if assigned(p^.left) then
 | |
|          begin
 | |
|            if assigned(p^.right) then
 | |
|             begin
 | |
|               if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
 | |
|                inc(p^.registers32,r32);
 | |
|               if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
 | |
|                inc(p^.registersfpu,fpu);
 | |
| {$ifdef SUPPORT_MMX}
 | |
|               if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
 | |
|                inc(p^.registersmmx,mmx);
 | |
| {$endif SUPPORT_MMX}
 | |
|             end
 | |
|            else
 | |
|             begin
 | |
|               if (p^.left^.registers32<r32) then
 | |
|                inc(p^.registers32,r32);
 | |
|               if (p^.left^.registersfpu<fpu) then
 | |
|                inc(p^.registersfpu,fpu);
 | |
| {$ifdef SUPPORT_MMX}
 | |
|               if (p^.left^.registersmmx<mmx) then
 | |
|                inc(p^.registersmmx,mmx);
 | |
| {$endif SUPPORT_MMX}
 | |
|             end;
 | |
|          end;
 | |
| 
 | |
|          { error CGMessage, if more than 8 floating point }
 | |
|          { registers are needed                         }
 | |
|          if p^.registersfpu>8 then
 | |
|           CGMessage(cg_e_too_complex_expr);
 | |
|       end;
 | |
| 
 | |
| {****************************************************************************
 | |
|                           Subroutine Handling
 | |
| ****************************************************************************}
 | |
| 
 | |
| { protected field handling
 | |
|   protected field can not appear in
 | |
|   var parameters of function !!
 | |
|   this can only be done after we have determined the
 | |
|   overloaded function
 | |
|   this is the reason why it is not in the parser, PM }
 | |
| 
 | |
|     procedure test_protected_sym(sym : psym);
 | |
|       begin
 | |
|          if ((sym^.properties and sp_protected)<>0) and
 | |
|            ((sym^.owner^.symtabletype=unitsymtable) or
 | |
|             ((sym^.owner^.symtabletype=objectsymtable) and
 | |
|            (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))) then
 | |
|           CGMessage(parser_e_cant_access_protected_member);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure test_protected(p : ptree);
 | |
|       begin
 | |
|         case p^.treetype of
 | |
|          loadn : test_protected_sym(p^.symtableentry);
 | |
|      typeconvn : test_protected(p^.left);
 | |
|         derefn : test_protected(p^.left);
 | |
|     subscriptn : begin
 | |
|                  { test_protected(p^.left);
 | |
|                    Is a field of a protected var
 | |
|                    also protected ???  PM }
 | |
|                    test_protected_sym(p^.vs);
 | |
|                  end;
 | |
|         end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function is_procsym_load(p:Ptree):boolean;
 | |
|       begin
 | |
|          is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
 | |
|                           ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
 | |
|                           and (p^.left^.symtableentry^.typ=procsym)) ;
 | |
|       end;
 | |
| 
 | |
|    { change a proc call to a procload for assignment to a procvar }
 | |
|    { this can only happen for proc/function without arguments }
 | |
|     function is_procsym_call(p:Ptree):boolean;
 | |
|       begin
 | |
|         is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
 | |
|              (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
 | |
|              ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
 | |
|        var
 | |
|           passproc : pprocdef;
 | |
|           convtyp : tconverttype;
 | |
|        begin
 | |
|           is_assignment_overloaded:=false;
 | |
|           if assigned(overloaded_operators[assignment]) then
 | |
|             passproc:=overloaded_operators[assignment]^.definition
 | |
|           else
 | |
|             exit;
 | |
|           while passproc<>nil do
 | |
|             begin
 | |
|               if is_equal(passproc^.retdef,to_def) and
 | |
|                  (isconvertable(from_def,passproc^.para1^.data,convtyp,ordconstn,false)=1) then
 | |
|                 begin
 | |
|                    is_assignment_overloaded:=true;
 | |
|                    break;
 | |
|                 end;
 | |
|               passproc:=passproc^.nextoverloaded;
 | |
|             end;
 | |
|        end;
 | |
| 
 | |
| end.
 | |
| {
 | |
|   $Log$
 | |
|   Revision 1.20  1999-04-15 08:56:27  peter
 | |
|     * fixed bool-bool conversion
 | |
| 
 | |
|   Revision 1.19  1999/03/24 23:17:02  peter
 | |
|     * fixed bugs 212,222,225,227,229,231,233
 | |
| 
 | |
|   Revision 1.18  1999/03/06 17:25:19  peter
 | |
|     * moved comp<->real warning so it doesn't occure everytime that
 | |
|       isconvertable is called with
 | |
| 
 | |
|   Revision 1.17  1999/03/02 18:24:20  peter
 | |
|     * fixed overloading of array of char
 | |
| 
 | |
|   Revision 1.16  1999/01/27 13:53:27  pierre
 | |
|   htypechk.pas
 | |
| 
 | |
|   Revision 1.15  1999/01/27 13:12:10  pierre
 | |
|    * bool to int must be explicit
 | |
| 
 | |
|   Revision 1.14  1999/01/19 15:55:32  pierre
 | |
|    * fix for boolean to comp conversion (now disabled)
 | |
| 
 | |
|   Revision 1.13  1998/12/15 17:11:37  peter
 | |
|     * string:=pchar not allowed in tp mode
 | |
| 
 | |
|   Revision 1.12  1998/12/11 00:03:18  peter
 | |
|     + globtype,tokens,version unit splitted from globals
 | |
| 
 | |
|   Revision 1.11  1998/12/10 09:47:21  florian
 | |
|     + basic operations with int64/qord (compiler with -dint64)
 | |
|     + rtti of enumerations extended: names are now written
 | |
| 
 | |
|   Revision 1.10  1998/11/29 12:40:23  peter
 | |
|     * newcnv -> not oldcnv
 | |
| 
 | |
|   Revision 1.9  1998/11/26 13:10:42  peter
 | |
|     * new int - int conversion -dNEWCNV
 | |
|     * some function renamings
 | |
| 
 | |
|   Revision 1.8  1998/11/17 00:36:42  peter
 | |
|     * more ansistring fixes
 | |
| 
 | |
|   Revision 1.7  1998/10/14 13:33:24  peter
 | |
|     * fixed small typo
 | |
| 
 | |
|   Revision 1.6  1998/10/14 12:53:38  peter
 | |
|     * fixed small tp7 things
 | |
|     * boolean:=longbool and longbool fixed
 | |
| 
 | |
|   Revision 1.5  1998/10/12 09:49:58  florian
 | |
|     + support of <procedure var type>:=<pointer> in delphi mode added
 | |
| 
 | |
|   Revision 1.4  1998/09/30 16:42:52  peter
 | |
|     * fixed bool-bool cnv
 | |
| 
 | |
|   Revision 1.3  1998/09/24 23:49:05  peter
 | |
|     + aktmodeswitches
 | |
| 
 | |
|   Revision 1.2  1998/09/24 09:02:14  peter
 | |
|     * rewritten isconvertable to use case
 | |
|     * array of .. and single variable are compatible
 | |
| 
 | |
|   Revision 1.1  1998/09/23 20:42:22  peter
 | |
|     * splitted pass_1
 | |
| 
 | |
| }
 | 
