diff --git a/compiler/cg386cnv.pas b/compiler/cg386cnv.pas index 4f92339103..b6bee2a819 100644 --- a/compiler/cg386cnv.pas +++ b/compiler/cg386cnv.pas @@ -161,8 +161,6 @@ implementation type tsecondconvproc = procedure(pto,pfrom : ptree;convtyp : tconverttype); -{$ifndef OLDCNV} - procedure second_int_to_int(pto,pfrom : ptree;convtyp : tconverttype); var op : tasmop; @@ -238,355 +236,6 @@ implementation end; end; -{$else} - - procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); - { - produces if necessary rangecheckcode - } - var - hp : preference; - hregister : tregister; - neglabel,poslabel : plabel; - is_register : boolean; - begin - { convert from p2 to p1 } - { range check from enums is not made yet !!} - { and its probably not easy } - if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then - exit; - { range checking is different for u32bit } - { lets try to generate it allways } - if (cs_check_range in aktlocalswitches) and - { with $R+ explicit type conversations in TP aren't range checked! } - (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and - ((porddef(p1)^.low>porddef(p2)^.low) or - (porddef(p1)^.highporddef(p1)^.high then - begin - getlabel(neglabel); - getlabel(poslabel); - exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hregister,hregister))); - emitl(A_JL,neglabel); - end; - exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); - if porddef(p1)^.low>porddef(p1)^.high then - begin - hp:=new_reference(R_NO,0); - hp^.symbol:=newasmsymbol(porddef(p1)^.getrangecheckstring); - { second part here !! } - hp^.offset:=8; - emitjmp(C_None,poslabel); - emitlab(neglabel); - exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); - emitlab(poslabel); - end; - end; - end; - - - procedure second_only_rangecheck(pto,pfrom : ptree;convtyp : tconverttype); - - begin - maybe_rangechecking(pto,pfrom^.resulttype,pto^.resulttype); - end; - - - procedure second_smaller(pto,pfrom : ptree;convtyp : tconverttype); - - var - hregister,destregister : tregister; - ref : boolean; - hpp : preference; - - begin - ref:=false; - { problems with enums !! } - if (cs_check_range in aktlocalswitches) and - { with $R+ explicit type conversations in TP aren't range checked! } - (not(pto^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and - (pto^.resulttype^.deftype=orddef) and - (pfrom^.resulttype^.deftype=orddef) then - begin - if porddef(pfrom^.resulttype)^.typ=u32bit then - begin - { when doing range checking for u32bit, we have some trouble } - { because BOUND assumes signed values } - { first, we check if the values is greater than 2^31: } - { the u32bit rangenr contains the appropriate rangenr } - porddef(pfrom^.resulttype)^.genrangecheck; - hregister:=R_EDI; - if (pto^.location.loc=LOC_REGISTER) or - (pto^.location.loc=LOC_CREGISTER) then - hregister:=pto^.location.register - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(pto^.location.reference),R_EDI))); - hpp:=new_reference(R_NO,0); - hpp^.symbol:=newasmsymbol(porddef(pfrom^.resulttype)^.getrangecheckstring); - exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); - - { then we do a normal range check } - porddef(pto^.resulttype)^.genrangecheck; - hpp:=new_reference(R_NO,0); - hpp^.symbol:=newasmsymbol(porddef(pto^.resulttype)^.getrangecheckstring); - exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); - end - else - if ((porddef(pto^.resulttype)^.low>porddef(pfrom^.resulttype)^.low) or - (porddef(pto^.resulttype)^.highLOC_CREGISTER) then - begin - del_reference(pfrom^.location.reference); - { we can do this here as we need no temp inside second_bigger } - ungetiftemp(pfrom^.location.reference); - end; - { this is wrong !!! - gives me movl (%eax),%eax - for the length(string !!! - use only for constant values } - {Constant cannot be loaded into registers using MOVZX!} - if (pfrom^.location.loc<>LOC_MEM) or (not pfrom^.location.reference.is_immediate) then - case convtyp of - tc_u8bit_2_s32bit,tc_u8bit_2_u32bit : - begin - if is_register then - hregister:=reg8toreg32(pfrom^.location.register) - else hregister:=getregister32; - op:=A_MOVZX; - opsize:=S_BL; - end; - { here what do we do for negative values ? } - tc_s8bit_2_s32bit,tc_s8bit_2_u32bit : - begin - if is_register then - hregister:=reg8toreg32(pfrom^.location.register) - else hregister:=getregister32; - op:=A_MOVSX; - opsize:=S_BL; - end; - tc_u16bit_2_s32bit,tc_u16bit_2_u32bit : - begin - if is_register then - hregister:=reg16toreg32(pfrom^.location.register) - else hregister:=getregister32; - op:=A_MOVZX; - opsize:=S_WL; - end; - tc_s16bit_2_s32bit,tc_s16bit_2_u32bit : - begin - if is_register then - hregister:=reg16toreg32(pfrom^.location.register) - else hregister:=getregister32; - op:=A_MOVSX; - opsize:=S_WL; - end; - tc_s8bit_2_u16bit, - tc_u8bit_2_s16bit, - tc_u8bit_2_u16bit : - begin - if is_register then - hregister:=reg8toreg16(pfrom^.location.register) - else hregister:=reg32toreg16(getregister32); - op:=A_MOVZX; - opsize:=S_BW; - end; - tc_s8bit_2_s16bit : - begin - if is_register then - hregister:=reg8toreg16(pfrom^.location.register) - else hregister:=reg32toreg16(getregister32); - op:=A_MOVSX; - opsize:=S_BW; - end; - end - else - case convtyp of - tc_u8bit_2_s32bit, - tc_s8bit_2_s32bit, - tc_u16bit_2_s32bit, - tc_s16bit_2_s32bit, - tc_u8bit_2_u32bit, - tc_s8bit_2_u32bit, - tc_u16bit_2_u32bit, - tc_s16bit_2_u32bit: - begin - hregister:=getregister32; - op:=A_MOV; - opsize:=S_L; - end; - tc_s8bit_2_u16bit, - tc_s8bit_2_s16bit, - tc_u8bit_2_s16bit, - tc_u8bit_2_u16bit: - begin - hregister:=reg32toreg16(getregister32); - op:=A_MOV; - opsize:=S_W; - end; - end; - if is_register then - begin - emit_reg_reg(op,opsize,pfrom^.location.register,hregister); - end - else - begin - if pfrom^.location.loc=LOC_CREGISTER then - emit_reg_reg(op,opsize,pfrom^.location.register,hregister) - else exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, - newreference(pfrom^.location.reference),hregister))); - end; - clear_location(pto^.location); - pto^.location.loc:=LOC_REGISTER; - pto^.location.register:=hregister; - maybe_rangechecking(pfrom,pfrom^.resulttype,pto^.resulttype); - end; - -{$endif} - var ltemptoremove : plinkedlist; @@ -803,35 +452,61 @@ implementation { to a string } procedure second_chararray_to_string(pto,pfrom : ptree;convtyp : tconverttype); var + pushed : tpushed; l : longint; begin + { calc the length of the array } + l:=parraydef(pfrom^.resulttype)^.highrange-parraydef(pfrom^.resulttype)^.lowrange+1; { this is a type conversion which copies the data, so we can't } { return a reference } clear_location(pto^.location); pto^.location.loc:=LOC_MEM; - { first get the memory for the string } - gettempofsizereference(256,pto^.location.reference); - - { calc the length of the array } - l:=parraydef(pfrom^.resulttype)^.highrange- - parraydef(pfrom^.resulttype)^.lowrange+1; - - if l>255 then - CGMessage(type_e_mismatch); - - { write the length } - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,l, - newreference(pto^.location.reference)))); - - { copy to first char of string } - inc(pto^.location.reference.offset); - - { generates the copy code } - { and we need the source never } - concatcopy(pfrom^.location.reference,pto^.location.reference,l,true,false); - - { correct the string location } - dec(pto^.location.reference.offset); + case pstringdef(pto^.resulttype)^.string_typ of + st_shortstring : + begin + if l>255 then + begin + CGMessage(type_e_mismatch); + l:=255; + end; + { first get the memory for the string } + gettempofsizereference(256,pto^.location.reference); + { write the length } + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,l, + newreference(pto^.location.reference)))); + { copy to first char of string } + inc(pto^.location.reference.offset); + { generates the copy code } + { and we need the source never } + concatcopy(pfrom^.location.reference,pto^.location.reference,l,true,false); + { correct the string location } + dec(pto^.location.reference.offset); + end; + st_ansistring : + begin + gettempofsizereference(4,pto^.location.reference); + ltemptoremove^.concat(new(ptemptodestroy,init(pto^.location.reference,pto^.resulttype))); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,0,newreference(pto^.location.reference)))); + release_loc(pfrom^.location); + pushusedregisters(pushed,$ff); + push_int(l); + emitpushreferenceaddr(exprasmlist,pfrom^.location.reference); + emitpushreferenceaddr(exprasmlist,pto^.location.reference); + emitcall('FPC_CHARARRAY_TO_ANSISTR',true); + popusedregisters(pushed); + maybe_loadesi; + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; end; @@ -1127,7 +802,6 @@ implementation getlabel(truelabel); getlabel(falselabel); secondpass(pfrom); -{$ifndef OLDBOOL} { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (pto^.explizit) and @@ -1141,7 +815,6 @@ implementation falselabel:=oldfalselabel; exit; end; -{$endif ndef OLDBOOL} clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; del_reference(pfrom^.location.reference); @@ -1248,7 +921,6 @@ implementation hregister : tregister; begin clear_location(pto^.location); -{$ifndef OLDBOOL} { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (pto^.explizit) and @@ -1258,7 +930,6 @@ implementation set_location(pto^.location,pfrom^.location); exit; end; -{$endif ndef OLDBOOL} pto^.location.loc:=LOC_REGISTER; del_reference(pfrom^.location.reference); case pfrom^.location.loc of @@ -1426,7 +1097,6 @@ implementation procedure secondtypeconv(var p : ptree); const secondconvert : array[tconverttype] of tsecondconvproc = ( -{$ifndef OLDCNV} second_nothing, {equal} second_nothing, {not_possible} second_string_to_string, @@ -1451,39 +1121,8 @@ implementation second_nothing, {arrayconstructor_to_set} second_load_smallset ); -{$else} - second_nothing,second_nothing, - second_bigger,second_only_rangecheck, - second_bigger,second_bigger,second_bigger, - second_smaller,second_smaller, - second_smaller,second_string_to_string, - second_cstring_to_pchar,second_string_to_chararray, - second_array_to_pointer,second_pointer_to_array, - second_char_to_string,second_bigger, - second_bigger,second_bigger, - second_smaller,second_smaller, - second_smaller,second_smaller, - second_bigger,second_smaller, - second_only_rangecheck,second_bigger, - second_bigger,second_bigger, - second_bigger,second_only_rangecheck, - second_smaller,second_smaller, - second_smaller,second_smaller, - second_bool_to_int,second_int_to_bool, - second_int_to_real,second_real_to_fix, - second_fix_to_real,second_int_to_fix,second_real_to_real, - second_chararray_to_string, - second_proc_to_procvar, - { is constant char to pchar, is done by firstpass } - second_nothing, - second_load_smallset, - second_ansistring_to_pchar, - second_pchar_to_string, - second_nothing); -{$endif} var oldrl,oldlrl : plinkedlist; - begin { the ansi string disposing is a little bit hairy: } oldrl:=temptoremove; @@ -1624,7 +1263,10 @@ implementation end. { $Log$ - Revision 1.59 1999-03-01 15:46:18 peter + Revision 1.60 1999-03-02 18:24:19 peter + * fixed overloading of array of char + + Revision 1.59 1999/03/01 15:46:18 peter * ag386bin finally make cycles correct * prefixes are now also normal opcodes diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 229a36725d..4bb4120a70 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -35,7 +35,7 @@ interface { Conversion } function isconvertable(def_from,def_to : pdef; var doconv : tconverttype;fromtreetype : ttreetyp; - explicit : boolean) : boolean; + explicit : boolean) : byte; { Register Allocation } procedure make_not_regable(p : ptree); @@ -62,10 +62,14 @@ implementation 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) : boolean; -{$ifndef OLDCNV} + explicit : boolean) : byte; + { Tbasetype: uauto,uvoid,uchar, u8bit,u16bit,u32bit, s8bit,s16bit,s32, @@ -85,83 +89,19 @@ implementation (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_int_2_bool)); -{$else} - const - 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_int_2_bool,tc_int_2_bool), - {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_int_2_bool,tc_only_rangechecks32bit,tc_int_2_bool), - {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_int_2_bool,tc_int_2_bool,tc_only_rangechecks32bit)); -{$endif} var - b : boolean; + b : byte; hd1,hd2 : pdef; begin { safety check } if not(assigned(def_from) and assigned(def_to)) then begin - isconvertable:=false; + isconvertable:=0; exit; end; - b:=false; + 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 @@ -170,9 +110,8 @@ implementation case def_from^.deftype of orddef : begin -{$ifndef OLDCNV} doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]]; - b:=true; + b:=1; if (doconv=tc_not_possible) or ((doconv=tc_int_2_bool) and (not explicit) and @@ -180,24 +119,13 @@ implementation ((doconv=tc_bool_2_int) and (not explicit) and (not is_boolean(def_to))) then - b:=false; -{$else} - doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ]; - b:=true; - if (doconv=tc_not_possible) or - ((doconv=tc_int_2_bool) and - (not explicit) and - (not is_boolean(def_from))) then - b:=false; -{$endif} + b:=0; end; -{$ifndef OLDCNV} enumdef : begin doconv:=tc_int_2_int; - b:=true; + b:=1; end; -{$endif} end; end; @@ -206,14 +134,14 @@ implementation case def_from^.deftype of stringdef : begin doconv:=tc_string_2_string; - b:=true; + b:=1; end; orddef : begin { char to string} if is_char(def_from) then begin doconv:=tc_char_2_string; - b:=true; + b:=1; end; end; arraydef : begin @@ -221,7 +149,13 @@ implementation if is_equal(parraydef(def_from)^.definition,cchardef) then begin doconv:=tc_chararray_2_string; - b:=true; + 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 @@ -229,7 +163,7 @@ implementation if is_pchar(def_from) and not(m_tp in aktmodeswitches) then begin doconv:=tc_pchar_2_string; - b:=true; + b:=1; end; end; end; @@ -245,7 +179,7 @@ implementation doconv:=tc_int_2_fix else doconv:=tc_int_2_real; - b:=true; + b:=1; end; end; floatdef : begin { 2 float types ? } @@ -268,7 +202,7 @@ implementation CGMessage(type_w_convert_real_2_comp); {$endif} end; - b:=true; + b:=1; end; end; end; @@ -285,7 +219,8 @@ implementation hd2:=penumdef(def_to)^.basedef else hd2:=def_to; - b:=(hd1=hd2); + if (hd1=hd2) then + b:=1; end; end; @@ -296,7 +231,7 @@ implementation is_equal(parraydef(def_to)^.definition,def_from) then begin doconv:=tc_equal; - b:=true; + b:=1; end else begin @@ -306,7 +241,7 @@ implementation is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then begin doconv:=tc_pointer_2_array; - b:=true; + b:=1; end; end; stringdef : begin @@ -314,7 +249,7 @@ implementation if is_equal(parraydef(def_to)^.definition,cchardef) then begin doconv:=tc_string_2_chararray; - b:=true; + b:=1; end; end; end; @@ -330,7 +265,7 @@ implementation is_pchar(def_to) then begin doconv:=tc_cstring_2_pchar; - b:=true; + b:=1; end; end; orddef : begin @@ -339,7 +274,7 @@ implementation is_pchar(def_to) then begin doconv:=tc_cchar_2_pchar; - b:=true; + b:=1; end; end; arraydef : begin @@ -348,7 +283,7 @@ implementation is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then begin doconv:=tc_array_2_pointer; - b:=true; + b:=1; end; end; pointerdef : begin @@ -366,7 +301,7 @@ implementation is_equal(ppointerdef(def_from)^.definition,voiddef) then begin doconv:=tc_equal; - b:=true; + b:=1; end; end; procvardef : begin @@ -377,7 +312,7 @@ implementation (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; - b:=true; + b:=1; end; end; classrefdef, @@ -392,7 +327,7 @@ implementation (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; - b:=true; + b:=1; end; end; end; @@ -404,7 +339,7 @@ implementation if (def_from^.deftype=arraydef) and (parraydef(def_from)^.IsConstructor) then begin doconv:=tc_arrayconstructor_2_set; - b:=true; + b:=1; end; end; @@ -415,7 +350,8 @@ implementation begin def_from^.deftype:=procvardef; doconv:=tc_proc_2_procvar; - b:=is_equal(def_from,def_to); + if is_equal(def_from,def_to) then + b:=1; def_from^.deftype:=procdef; end else @@ -427,14 +363,14 @@ implementation (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; - b:=true; + b:=1; end else { nil is compatible with procvars } if (fromtreetype=niln) then begin doconv:=tc_equal; - b:=true; + b:=1; end; end; @@ -445,14 +381,15 @@ implementation pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then begin doconv:=tc_equal; - b:=pobjectdef(def_from)^.isrelated(pobjectdef(def_to)); + 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:=true; + b:=1; end; end; @@ -462,15 +399,16 @@ implementation if (def_from^.deftype=classrefdef) then begin doconv:=tc_equal; - b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated( - pobjectdef(pclassrefdef(def_to)^.definition)); + 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:=true; + b:=1; end; end; @@ -506,7 +444,7 @@ implementation ) then begin doconv:=tc_equal; - b:=true; + b:=1; end end; @@ -514,7 +452,7 @@ implementation begin { assignment overwritten ?? } if is_assignment_overloaded(def_from,def_to) then - b:=true; + b:=1; end; end; @@ -524,7 +462,7 @@ implementation and (pstringdef(def_to)^.string_typ in [st_ansistring,st_widestring]) then begin doconv:=tc_equal; - b:=true; + b:=1; end else } @@ -537,7 +475,7 @@ implementation (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; - b:=true; + b:=1; end else } @@ -549,7 +487,7 @@ implementation (porddef(ppointerdef(def_to)^.definition)^.typ=uchar) then begin doconv:=tc_ansistring_2_pchar; - b:=true; + b:=1; end else } @@ -706,8 +644,7 @@ implementation 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 + (isconvertable(from_def,passproc^.para1^.data,convtyp,ordconstn,false)=1) then begin is_assignment_overloaded:=true; break; @@ -719,7 +656,10 @@ implementation end. { $Log$ - Revision 1.16 1999-01-27 13:53:27 pierre + 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 diff --git a/compiler/symdefh.inc b/compiler/symdefh.inc index fda172116d..d61a4f20c0 100644 --- a/compiler/symdefh.inc +++ b/compiler/symdefh.inc @@ -103,6 +103,7 @@ next : pdefcoll; paratyp : tvarspez; argconvtyp : targconvtyp; + convertlevel : byte; end; tfiletype = (ft_text,ft_typed,ft_untyped); @@ -504,7 +505,10 @@ { $Log$ - Revision 1.17 1999-03-01 13:45:06 pierre + Revision 1.18 1999-03-02 18:24:21 peter + * fixed overloading of array of char + + Revision 1.17 1999/03/01 13:45:06 pierre + added staticppusymtable symtable type for local browsing Revision 1.16 1999/02/22 20:13:39 florian diff --git a/compiler/tccal.pas b/compiler/tccal.pas index ee96aac6d8..3b1f421e4e 100644 --- a/compiler/tccal.pas +++ b/compiler/tccal.pas @@ -517,37 +517,22 @@ implementation pd:=aktcallprocsym^.definition; while assigned(pd) do begin - { we should also check that the overloaded function - has been declared in a unit that is in the uses !! } - { pd^.owner should be in the symtablestack !! } - { Laenge der deklarierten Parameterliste feststellen: } - { not necessary why nextprocsym field } - {st:=symtablestack; - if (pd^.owner^.symtabletype<>objectsymtable) then - while assigned(st) do - begin - if (st=pd^.owner) then break; - st:=st^.next; - end; - if assigned(st) then } + pdc:=pd^.para1; + l:=0; + while assigned(pdc) do begin - pdc:=pd^.para1; - l:=0; - while assigned(pdc) do - begin - inc(l); - pdc:=pdc^.next; - end; - { only when the # of parameter are equal } - if (l=paralength) then - begin - new(hp); - hp^.data:=pd; - hp^.next:=procs; - hp^.nextpara:=pd^.para1; - hp^.firstpara:=pd^.para1; - procs:=hp; - end; + inc(l); + pdc:=pdc^.next; + end; + { only when the # of parameter are equal } + if (l=paralength) then + begin + new(hp); + hp^.data:=pd; + hp^.next:=procs; + hp^.nextpara:=pd^.para1; + hp^.firstpara:=pd^.para1; + procs:=hp; end; pd:=pd^.nextoverloaded; end; @@ -570,7 +555,15 @@ implementation while assigned(pt) do begin dec(l); - { matches a parameter of one procedure exact ? } + { walk all procedures and determine how this parameter matches and set: + 1. pt^.exact_match_found if one parameter has an exact match + 2. exactmatch if an equal or exact match is found + + 3. para^.argconvtyp to exact,equal or convertable + (when convertable then also convertlevel is set) + 4. pt^.convlevel1found if there is a convertlevel=1 + 5. pt^.convlevel2found if there is a convertlevel=2 + } exactmatch:=false; hp:=procs; while assigned(hp) do @@ -587,61 +580,57 @@ implementation exactmatch:=true; end else - hp^.nextpara^.argconvtyp:=act_convertable; + begin + hp^.nextpara^.argconvtyp:=act_convertable; + hp^.nextpara^.convertlevel:=isconvertable(pt^.resulttype,hp^.nextpara^.data, + hcvt,pt^.left^.treetype,false); + case hp^.nextpara^.convertlevel of + 1 : pt^.convlevel1found:=true; + 2 : pt^.convlevel2found:=true; + end; + end; + hp:=hp^.next; end; - { .... if yes, del all the other procedures } + { If there was an exactmatch then delete all convertables } if exactmatch then begin - { the first .... } - while (assigned(procs)) and not(is_equal(pt,procs^.nextpara^.data)) do - begin - hp:=procs^.next; - dispose(procs); - procs:=hp; - end; - { and the others } - hp:=procs; - while (assigned(hp)) and assigned(hp^.next) do - begin - if not(is_equal(pt,hp^.next^.nextpara^.data)) then - begin - hp2:=hp^.next^.next; - dispose(hp^.next); - hp^.next:=hp2; - end - else - hp:=hp^.next; - end; + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep if not convertable } + if (hp^.nextpara^.argconvtyp<>act_convertable) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; end - { when a parameter matches exact, remove all procs - which need typeconvs } else + { No exact match was found, remove all procedures that are + not convertable (convertlevel=0) } begin - { the first... } - while (assigned(procs)) and - not(isconvertable(pt^.resulttype,procs^.nextpara^.data, - hcvt,pt^.left^.treetype,false)) do - begin - hp:=procs^.next; - dispose(procs); - procs:=hp; - end; - { and the others } - hp:=procs; - while (assigned(hp)) and assigned(hp^.next) do - begin - if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data, - hcvt,pt^.left^.treetype,false)) then - begin - hp2:=hp^.next^.next; - dispose(hp^.next); - hp^.next:=hp2; - end - else - hp:=hp^.next; - end; + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep if not convertable } + if (hp^.nextpara^.convertlevel<>0) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; end; { update nextpara for all procedures } hp:=procs; @@ -657,6 +646,8 @@ implementation pt:=nil; end; + { All parameters are checked, check if there are any + procedures left } if not assigned(procs) then begin { there is an error, must be wrong type, because @@ -769,17 +760,18 @@ implementation end; end; - { reset nextpara for all procs left } - hp:=procs; - while assigned(hp) do - begin - hp^.nextpara:=hp^.firstpara; - hp:=hp^.next; - end; - - { let's try to eliminate equal is exact is there } - if assigned(procs^.next) then + { let's try to eliminate equal if there is an exact match + is there } + if assigned(procs) and assigned(procs^.next) then begin + { reset nextpara for all procs left } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.firstpara; + hp:=hp^.next; + end; + pt:=p^.left; while assigned(pt) do begin @@ -791,15 +783,13 @@ implementation begin hp2:=hp^.next; { keep the exact matches, dispose the others } - if (hp^.nextpara^.data=pt^.resulttype) then + if (hp^.nextpara^.argconvtyp=act_exact) then begin hp^.next:=procs; procs:=hp; end else - begin - dispose(hp); - end; + dispose(hp); hp:=hp2; end; end; @@ -814,10 +804,59 @@ implementation end; end; - if assigned(procs^.next) then + { Check if there are convertlevel 1 and 2 differences + left for the parameters, then discard all convertlevel + 2 procedures. The value of convlevelXfound can still + be used, because all convertables are still here or + not } + if assigned(procs) and assigned(procs^.next) then + begin + { reset nextpara for all procs left } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.firstpara; + hp:=hp^.next; + end; + + pt:=p^.left; + while assigned(pt) do + begin + if pt^.convlevel1found and pt^.convlevel2found then + begin + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep all not act_convertable and all convertlevels=1 } + if (hp^.nextpara^.argconvtyp<>act_convertable) or + (hp^.nextpara^.convertlevel=1) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; + end; + { update nextpara for all procedures } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.nextpara^.next; + hp:=hp^.next; + end; + pt:=pt^.right; + end; + end; + + if not(assigned(procs)) or assigned(procs^.next) then begin CGMessage(cg_e_cant_choose_overload_function); aktcallprocsym^.write_parameter_lists; + exit; end; {$ifdef TEST_PROCSYMS} if (procs=nil) and assigned(nextprocsym) then @@ -1078,7 +1117,10 @@ implementation end. { $Log$ - Revision 1.25 1999-02-22 15:09:44 florian + Revision 1.26 1999-03-02 18:24:22 peter + * fixed overloading of array of char + + Revision 1.25 1999/02/22 15:09:44 florian * behaviaor of PROTECTED and PRIVATE fixed, works now like TP/Delphi Revision 1.24 1999/02/22 02:15:45 peter diff --git a/compiler/tccnv.pas b/compiler/tccnv.pas index b757efb732..9bb6a62e6e 100644 --- a/compiler/tccnv.pas +++ b/compiler/tccnv.pas @@ -239,8 +239,6 @@ implementation type tfirstconvproc = procedure(var p : ptree); -{$ifndef OLDCNV} - procedure first_int_to_int(var p : ptree); begin if (p^.registers32=0) and @@ -252,14 +250,6 @@ implementation end; end; -{$else} - procedure first_bigger_smaller(var p : ptree); - begin - if (p^.left^.location.loc<>LOC_REGISTER) and (p^.registers32=0) then - p^.registers32:=1; - p^.location.loc:=LOC_REGISTER; - end; -{$endif} procedure first_cstring_to_pchar(var p : ptree); begin @@ -454,51 +444,29 @@ implementation end; -{$ifdef OLDCNV} - procedure first_locmem(var p : ptree); - begin - p^.location.loc:=LOC_MEM; - end; -{$endif} - - procedure first_bool_to_int(var p : ptree); begin -{$ifndef OLDBOOL} { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (p^.explizit) and (p^.left^.resulttype^.size=p^.resulttype^.size) and (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then exit; -{$endif ndef OLDBOOL} p^.location.loc:=LOC_REGISTER; - { Florian I think this is overestimated - but I still do not really understand how to get this right (PM) } - { Hmmm, I think we need only one reg to return the result of } - { this node => so } if p^.registers32<1 then p^.registers32:=1; - { should work (FK) - p^.registers32:=p^.left^.registers32+1;} end; procedure first_int_to_bool(var p : ptree); begin -{$ifndef OLDBOOL} { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (p^.explizit) and (p^.left^.resulttype^.size=p^.resulttype^.size) and (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then exit; -{$endif ndef OLDBOOL} p^.location.loc:=LOC_REGISTER; - { Florian I think this is overestimated - but I still do not really understand how to get this right (PM) } - { Hmmm, I think we need only one reg to return the result of } - { this node => so } p^.left:=gentypeconvnode(p^.left,s32bitdef); { need if bool to bool !! not very nice !! } @@ -506,9 +474,6 @@ implementation firstpass(p^.left); if p^.registers32<1 then p^.registers32:=1; -{ p^.resulttype:=booldef; } - { should work (FK) - p^.registers32:=p^.left^.registers32+1;} end; @@ -570,7 +535,6 @@ implementation proctype : tdeftype; const firstconvert : array[tconverttype] of tfirstconvproc = ( -{$ifndef OLDCNV} first_nothing, {equal} first_nothing, {not_possible} first_string_to_string, @@ -595,34 +559,6 @@ implementation first_arrayconstructor_to_set, first_load_smallset ); -{$else} - first_nothing,first_nothing, - first_bigger_smaller,first_nothing,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_string_to_string, - first_cstring_to_pchar,first_string_to_chararray, - first_array_to_pointer,first_pointer_to_array, - first_char_to_string,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_bigger_smaller, - first_bool_to_int,first_int_to_bool, - first_int_to_real,first_real_to_fix, - first_fix_to_real,first_int_to_fix,first_real_to_real, - first_locmem,first_proc_to_procvar, - first_cchar_to_pchar, - first_load_smallset, - first_ansistring_to_pchar, - first_pchar_to_string, - first_arrayconstructor_to_set); -{$endif} begin aprocdef:=nil; { if explicite type cast, then run firstpass } @@ -695,8 +631,7 @@ implementation exit; end; - if (not(isconvertable(p^.left^.resulttype,p^.resulttype, - p^.convtyp,p^.left^.treetype,p^.explizit))) then + if isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype,p^.explizit)=0 then begin {Procedures have a resulttype of voiddef and functions of their own resulttype. They will therefore always be incompatible with @@ -823,8 +758,7 @@ implementation end else begin - if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp, - ordconstn { only Dummy},false ) then + if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then CGMessage(cg_e_illegal_type_conversion); end; @@ -844,8 +778,7 @@ implementation end else begin - if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp, - ordconstn { nur Dummy},false ) then + if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then CGMessage(cg_e_illegal_type_conversion); end; end @@ -866,8 +799,7 @@ implementation begin { this is wrong because it converts to a 4 byte long var !! if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then } - if not isconvertable(p^.left^.resulttype,u8bitdef, - p^.convtyp,ordconstn { nur Dummy},false ) then + if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then CGMessage(cg_e_illegal_type_conversion); end; end @@ -979,7 +911,10 @@ implementation end. { $Log$ - Revision 1.19 1999-02-22 02:15:46 peter + Revision 1.20 1999-03-02 18:24:23 peter + * fixed overloading of array of char + + Revision 1.19 1999/02/22 02:15:46 peter * updates for ag386bin Revision 1.18 1999/01/27 14:56:57 pierre diff --git a/compiler/tcmem.pas b/compiler/tcmem.pas index b23cc47505..6ac625663e 100644 --- a/compiler/tcmem.pas +++ b/compiler/tcmem.pas @@ -381,11 +381,9 @@ implementation { range check only for arrays } if (p^.left^.resulttype^.deftype=arraydef) then begin - if not(isconvertable(p^.right^.resulttype, - parraydef(p^.left^.resulttype)^.rangedef, - ct,ordconstn,false)) and - not(is_equal(p^.right^.resulttype, - parraydef(p^.left^.resulttype)^.rangedef)) then + if (isconvertable(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangedef, + ct,ordconstn,false)=0) and + not(is_equal(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangedef)) then CGMessage(type_e_mismatch); end; { Never convert a boolean or a char !} @@ -557,7 +555,10 @@ implementation end. { $Log$ - Revision 1.11 1999-02-22 02:15:54 peter + Revision 1.12 1999-03-02 18:24:24 peter + * fixed overloading of array of char + + Revision 1.11 1999/02/22 02:15:54 peter * updates for ag386bin Revision 1.10 1999/02/04 11:44:47 florian diff --git a/compiler/tree.pas b/compiler/tree.pas index 92697a8c38..ba50ef3e4c 100644 --- a/compiler/tree.pas +++ b/compiler/tree.pas @@ -131,7 +131,6 @@ unit tree; loadvmtn ); -{$ifndef OLDCNV} tconverttype = ( tc_equal, tc_not_possible, @@ -157,32 +156,6 @@ unit tree; tc_arrayconstructor_2_set, tc_load_smallset ); -{$else} - tconverttype = (tc_equal,tc_not_possible,tc_u8bit_2_s32bit, - tc_only_rangechecks32bit,tc_s8bit_2_s32bit, - tc_u16bit_2_s32bit,tc_s16bit_2_s32bit, - tc_s32bit_2_s16bit,tc_s32bit_2_u8bit, - tc_s32bit_2_u16bit,tc_string_2_string, - tc_cstring_2_pchar,tc_string_2_chararray, - tc_array_2_pointer,tc_pointer_2_array, - tc_char_2_string,tc_u8bit_2_s16bit, - tc_u8bit_2_u16bit,tc_s8bit_2_s16bit, - tc_s16bit_2_s8bit,tc_s16bit_2_u8bit, - tc_u16bit_2_s8bit,tc_u16bit_2_u8bit, - tc_s8bit_2_u16bit,tc_s32bit_2_s8bit, - tc_s32bit_2_u32bit,tc_s16bit_2_u32bit, - tc_s8bit_2_u32bit,tc_u16bit_2_u32bit, - tc_u8bit_2_u32bit,tc_u32bit_2_s32bit, - tc_u32bit_2_s8bit,tc_u32bit_2_u8bit, - tc_u32bit_2_s16bit,tc_u32bit_2_u16bit, - tc_bool_2_int,tc_int_2_bool, - tc_int_2_real,tc_real_2_fix, - tc_fix_2_real,tc_int_2_fix,tc_real_2_real, - tc_chararray_2_string, - tc_proc_2_procvar,tc_cchar_2_pchar,tc_load_smallset, - tc_ansistring_2_pchar,tc_pchar_2_string, - tc_arrayconstructor_2_set); -{$endif} { allows to determine which elementes are to be replaced } tdisposetyp = (dt_nothing,dt_leftright,dt_left,dt_leftrighthigh, @@ -237,7 +210,8 @@ unit tree; {$endif extdebug} case treetype : ttreetyp of addn : (use_strconcat : boolean;string_typ : tstringtype); - callparan : (is_colon_para : boolean;exact_match_found : boolean;hightree:ptree); + callparan : (is_colon_para : boolean;exact_match_found, + convlevel1found,convlevel2found:boolean;hightree:ptree); assignn : (assigntyp : tassigntyp;concat_string : boolean); loadn : (symtableentry : psym;symtable : psymtable; is_absolute,is_first : boolean); @@ -657,6 +631,8 @@ unit tree; p^.registersfpu:=0; p^.resulttype:=nil; p^.exact_match_found:=false; + p^.convlevel1found:=false; + p^.convlevel2found:=false; p^.is_colon_para:=false; p^.hightree:=nil; set_file_line(expr,p); @@ -1669,7 +1645,10 @@ unit tree; end. { $Log$ - Revision 1.67 1999-02-25 21:02:56 peter + Revision 1.68 1999-03-02 18:24:25 peter + * fixed overloading of array of char + + Revision 1.67 1999/02/25 21:02:56 peter * ag386bin updates + coff writer