{ $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; allow_array_constructor : boolean = false; { Conversion } function isconvertable(def_from,def_to : pdef; var doconv : tconverttype;fromtreetype : ttreetyp; explicit : boolean) : boolean; { 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 cobjects,verbose,systems,globals, aasm,types, hcodegen; {**************************************************************************** Convert ****************************************************************************} function isconvertable(def_from,def_to : pdef; var doconv : tconverttype;fromtreetype : ttreetyp; explicit : boolean) : boolean; const { Tbasetype: uauto,uvoid,uchar, u8bit,u16bit,u32bit, s8bit,s16bit,s32, bool8bit,bool16bit,boot32bit } basedefconverts : array[tbasetype,tbasetype] of tconverttype = {uauto} ((tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible), {uvoid} (tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible), {uchar} (tc_not_possible,tc_not_possible,tc_only_rangechecks32bit, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible, tc_not_possible,tc_not_possible,tc_not_possible), {u8bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_only_rangechecks32bit,tc_u8bit_2_u16bit,tc_u8bit_2_u32bit, tc_only_rangechecks32bit,tc_u8bit_2_s16bit,tc_u8bit_2_s32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {u16bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_u16bit_2_u8bit,tc_only_rangechecks32bit,tc_u16bit_2_u32bit, tc_u16bit_2_s8bit,tc_only_rangechecks32bit,tc_u16bit_2_s32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {u32bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_u32bit_2_u8bit,tc_u32bit_2_u16bit,tc_only_rangechecks32bit, tc_u32bit_2_s8bit,tc_u32bit_2_s16bit,tc_only_rangechecks32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {s8bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_only_rangechecks32bit,tc_s8bit_2_u16bit,tc_s8bit_2_u32bit, tc_only_rangechecks32bit,tc_s8bit_2_s16bit,tc_s8bit_2_s32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {s16bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_s16bit_2_u8bit,tc_only_rangechecks32bit,tc_s16bit_2_u32bit, tc_s16bit_2_s8bit,tc_only_rangechecks32bit,tc_s16bit_2_s32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {s32bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_s32bit_2_u8bit,tc_s32bit_2_u16bit,tc_only_rangechecks32bit, tc_s32bit_2_s8bit,tc_s32bit_2_s16bit,tc_only_rangechecks32bit, tc_int_2_bool,tc_int_2_bool,tc_int_2_bool), {bool8bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_only_rangechecks32bit,tc_bool_2_int,tc_bool_2_int), {bool16bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_only_rangechecks32bit,tc_bool_2_int), {bool32bit} (tc_not_possible,tc_not_possible,tc_not_possible, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_bool_2_int,tc_only_rangechecks32bit)); var b : boolean; hd1,hd2 : pdef; begin { safety check } if not(assigned(def_from) and assigned(def_to)) then begin isconvertable:=false; exit; end; b:=false; { handle ord to ord first } if (def_from^.deftype=orddef) and (def_to^.deftype=orddef) then begin doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ]; { Don't allow automatic int->bool. Very Bad Hack !!!! (PFV) } if (doconv=tc_int_2_bool) and (not explicit) then b:=false else if doconv<>tc_not_possible then b:=true; end else if (def_from^.deftype=orddef) and (def_to^.deftype=floatdef) then begin if pfloatdef(def_to)^.typ=f32bit then doconv:=tc_int_2_fix else doconv:=tc_int_2_real; b:=true; end else { 2 float types ? } if (def_from^.deftype=floatdef) and (def_to^.deftype=floatdef) then begin 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; { comp isn't a floating type } {$ifdef i386} if (pfloatdef(def_to)^.typ=s64bit) and (pfloatdef(def_from)^.typ<>s64bit) and not (explicit) then CGMessage(type_w_convert_real_2_comp); {$endif} end; b:=true; end else { enum to enum } if (def_from^.deftype=enumdef) and (def_to^.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; b:=(hd1=hd2); end else { assignment overwritten ?? } if is_assignment_overloaded(def_from,def_to) then b:=true else if (def_from^.deftype=pointerdef) and (def_to^.deftype=arraydef) and (parraydef(def_to)^.lowrange=0) and is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then begin doconv:=tc_pointer_to_array; b:=true; end else if (def_from^.deftype=arraydef) and (def_to^.deftype=pointerdef) and (parraydef(def_from)^.lowrange=0) and is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then begin doconv:=tc_array_to_pointer; b:=true; end else if (def_from^.deftype=arraydef) and (def_to^.deftype=setdef) and (parraydef(def_from)^.IsConstructor) then begin doconv:=tc_arrayconstructor_2_set; b:=true; end else { 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 (def_to^.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:=true; end else { object pascal objects } if (def_from^.deftype=objectdef) and (def_to^.deftype=objectdef) {and pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then begin doconv:=tc_equal; b:=pobjectdef(def_from)^.isrelated( pobjectdef(def_to)); end else { 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 (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:=true; end else { class reference types } if (def_from^.deftype=classrefdef) and (def_from^.deftype=classrefdef) then begin doconv:=tc_equal; b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated( pobjectdef(pclassrefdef(def_to)^.definition)); end else if (def_from^.deftype=pointerdef) and (def_to^.deftype=pointerdef) then 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:=true; end end else if (def_from^.deftype=stringdef) and (def_to^.deftype=stringdef) then begin doconv:=tc_string_to_string; b:=true; end else { char to string} if is_equal(def_from,cchardef) and (def_to^.deftype=stringdef) then begin doconv:=tc_char_to_string; b:=true; end else { string constant to zero terminated string constant } if (fromtreetype=stringconstn) and is_pchar(def_to) then begin doconv:=tc_cstring_charpointer; b:=true; end else { array of char to string, the length check is done by the firstpass of this node } if (def_from^.deftype=stringdef) and ((def_to^.deftype=arraydef) and is_equal(parraydef(def_to)^.definition,cchardef)) then begin doconv:=tc_string_chararray; b:=true; end else { string to array of char, the length check is done by the firstpass of this node } if ((def_from^.deftype=arraydef) and is_equal(parraydef(def_from)^.definition,cchardef)) and (def_to^.deftype=stringdef) then begin doconv:=tc_chararray_2_string; b:=true; end else if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) then begin if (def_to^.deftype=pointerdef) and is_equal(ppointerdef(def_to)^.definition,cchardef) then begin doconv:=tc_cchar_charpointer; b:=true; end; end else if (def_to^.deftype=procvardef) and (def_from^.deftype=procdef) then begin def_from^.deftype:=procvardef; doconv:=tc_proc2procvar; b:=is_equal(def_from,def_to); def_from^.deftype:=procdef; end else { nil is compatible with class instances } if (fromtreetype=niln) and (def_to^.deftype=objectdef) and (pobjectdef(def_to)^.isclass) then begin doconv:=tc_equal; b:=true; end else { nil is compatible with class references } if (fromtreetype=niln) and (def_to^.deftype=classrefdef) then begin doconv:=tc_equal; b:=true; end else { nil is compatible with procvars } if (fromtreetype=niln) and (def_to^.deftype=procvardef) then begin doconv:=tc_equal; b:=true; end else { 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:=true; 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:=true; 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:=true; end else } { pchar can be assigned to short/ansistrings } if (def_to^.deftype=stringdef) and ((def_from^.deftype=pointerdef) and (ppointerdef(def_from)^.definition^.deftype=orddef) and (porddef(ppointerdef(def_from)^.definition)^.typ=uchar)) then begin if (pstringdef(def_to)^.string_typ in [st_shortstring,st_ansistring]) then begin doconv:=tc_pchar_2_string; b:=true; end; end else { procedure variable can be assigned to an void pointer } { Not anymore. Use the @ operator now.} if not (cs_tp_compatible in aktmoduleswitches) then begin if (def_from^.deftype=procvardef) 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:=true; end; end; 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)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 { nur Dummy},false ) then begin is_assignment_overloaded:=true; break; end; passproc:=passproc^.nextoverloaded; end; end; end. { $Log$ Revision 1.1 1998-09-23 20:42:22 peter * splitted pass_1 }