paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-27 10:31:41 +01:00
Code Issues Packages Projects Releases Wiki Activity

* lot of compile updates for cg11

Browse Source
This commit is contained in:
peter 2000-10-01 19:48:23 +00:00
parent 13db1a0ef0
commit 38951f5ce1
25 changed files with 1817 additions and 1562 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
compiler/assemble.pas
View File

@ -52,7 +52,8 @@ type
objfile,
as_bin : string;
SmartAsm : boolean;
smarthcount : longint;
SmartFilesCount,
SmartHeaderCount : longint;
place : TCutPlace; { special 'end' file for import dir ? }
{outfile}
AsmSize,
@ -80,8 +81,6 @@ type
procedure WriteAsmList;virtual;
end;
var
SmartLinkFilesCnt : longint;
Procedure GenerateAsm(smart:boolean);
Procedure OnlyAsm;
@ -230,7 +229,7 @@ begin
begin
if SmartAsm then
begin
if (SmartLinkFilesCnt<=1) then
if (SmartFilesCount<=1) then
Message1(exec_i_assembling_smart,name);
end
else
@ -253,22 +252,22 @@ procedure TAsmList.NextSmartName;
var
s : string;
begin
inc(SmartLinkFilesCnt);
if SmartLinkFilesCnt>999999 then
inc(SmartFilesCount);
if SmartFilesCount>999999 then
Message(asmw_f_too_many_asm_files);
case place of
cut_begin :
begin
inc(smarthcount);
s:=current_module^.asmprefix^+tostr(smarthcount)+'h';
inc(SmartHeaderCount);
s:=current_module^.asmprefix^+tostr(SmartHeaderCount)+'h';
end;
cut_normal :
s:=current_module^.asmprefix^+tostr(smarthcount)+'s';
s:=current_module^.asmprefix^+tostr(SmartHeaderCount)+'s';
cut_end :
s:=current_module^.asmprefix^+tostr(smarthcount)+'t';
s:=current_module^.asmprefix^+tostr(SmartHeaderCount)+'t';
end;
AsmFile:=Path+FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.asmext);
ObjFile:=Path+FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.objext);
AsmFile:=Path+FixFileName(s+tostr(SmartFilesCount)+target_info.asmext);
ObjFile:=Path+FixFileName(s+tostr(SmartFilesCount)+target_info.objext);
{ insert in container so it can be cleared after the linking }
SmartLinkOFiles.Insert(Objfile);
end;
@ -470,11 +469,11 @@ begin
objfile:=current_module^.objfilename^;
name:=FixFileName(current_module^.modulename^);
OutCnt:=0;
SmartLinkFilesCnt:=0;
SmartFilesCount:=0;
SmartLinkOFiles.Clear;
place:=cut_normal;
SmartAsm:=smart;
SmartHCount:=0;
SmartHeaderCount:=0;
{ Which path will be used ? }
if SmartAsm then
begin
@ -597,7 +596,10 @@ end;
end.
{
$Log$
Revision 1.5 2000-09-24 15:06:11 peter
Revision 1.6 2000-10-01 19:48:23 peter
* lot of compile updates for cg11
Revision 1.5 2000/09/24 15:06:11 peter
* use defines.inc
Revision 1.4 2000/08/27 16:11:49 peter

638
compiler/cgai386.pas
View File

@ -29,9 +29,7 @@ interface
uses
cobjects,
{$ifdef CG11}
node,
{$else}
{$ifndef CG11}
tree,
{$endif}
cpubase,cpuasm,
@ -112,20 +110,21 @@ interface
procedure incrstringref(t : pdef;const ref : treference);
procedure decrstringref(t : pdef;const ref : treference);
function maybe_push(needed : byte;p : {$ifdef CG11}tnode{$else}ptree{$endif};isint64 : boolean) : boolean;
procedure push_int(l : longint);
procedure emit_push_mem(const ref : treference);
procedure emitpushreferenceaddr(const ref : treference);
{$ifndef CG11}
function maybe_push(needed : byte;p : {$ifdef CG11}tnode{$else}ptree{$endif};isint64 : boolean) : boolean;
procedure pushsetelement(p : {$ifdef CG11}tnode{$else}ptree{$endif});
procedure restore(p : {$ifdef CG11}tnode{$else}ptree{$endif};isint64 : boolean);
procedure push_value_para(p:{$ifdef CG11}tnode{$else}ptree{$endif};inlined,is_cdecl:boolean;
para_offset:longint;alignment : longint);
{$ifdef TEMPS_NOT_PUSH}
{ does the same as restore, but uses temp. space instead of pushing }
function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean;
procedure restorefromtemp(p : ptree;isint64 : boolean);
{$endif TEMPS_NOT_PUSH}
{$endif}
procedure floatload(t : tfloattype;const ref : treference);
procedure floatstore(t : tfloattype;const ref : treference);
@ -133,12 +132,14 @@ interface
procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
procedure maybe_loadesi;
procedure maketojumpbool(p : {$ifdef CG11}tnode{$else}ptree{$endif});
procedure emitloadord2reg(const location:Tlocation;orddef:Porddef;destreg:Tregister;delloc:boolean);
procedure emitoverflowcheck(p:{$ifdef CG11}tnode{$else}ptree{$endif});
procedure emitrangecheck(p:{$ifdef CG11}tnode{$else}ptree{$endif};todef:pdef);
procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean);
procedure firstcomplex(p : {$ifdef CG11}tnode{$else}ptree{$endif});
{$ifndef CG11}
procedure maketojumpbool(p : ptree);
procedure emitoverflowcheck(p:ptree);
procedure emitrangecheck(p:ptree;todef:pdef);
procedure firstcomplex(p : ptree);
{$endif}
procedure genentrycode(alist : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean;
stackframe:longint;
@ -350,22 +351,6 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
internalerror(7453984);
end;
{$ifdef nojmpfix}
procedure emitjmp(c : tasmcond;var l : pasmlabel);
var
ai : Paicpu;
begin
if c=C_None then
exprasmlist^.concat(new(paicpu,op_sym(A_JMP,S_NO,l)))
else
begin
ai:=new(paicpu,op_sym(A_Jcc,S_NO,l));
ai^.SetCondition(c);
ai^.is_jmp:=true;
exprasmlist^.concat(ai);
end;
end;
{$else nojmpfix}
procedure emitjmp(c : tasmcond;var l : pasmlabel);
var
ai : Paicpu;
@ -380,7 +365,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
ai^.is_jmp:=true;
exprasmlist^.concat(ai);
end;
{$endif nojmpfix}
procedure emit_flag2reg(flag:tresflags;hregister:tregister);
var
@ -1077,74 +1062,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
Emit Push Functions
*****************************************************************************}
{$ifdef CG11}
function maybe_push(needed : byte;p : tnode;isint64 : boolean) : boolean;
var
pushed : boolean;
{hregister : tregister; }
{$ifdef TEMPS_NOT_PUSH}
href : treference;
{$endif TEMPS_NOT_PUSH}
begin
if needed>usablereg32 then
begin
if (p.location.loc=LOC_REGISTER) then
begin
if isint64 then
begin
{$ifdef TEMPS_NOT_PUSH}
gettempofsizereference(href,8);
p.temp_offset:=href.offset;
href.offset:=href.offset+4;
exprasmlist^.concat(new(paicpu,op_reg(A_MOV,S_L,p.location.registerhigh,href)));
href.offset:=href.offset-4;
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p.location.registerhigh)));
{$endif TEMPS_NOT_PUSH}
ungetregister32(p^.location.registerhigh);
end
{$ifdef TEMPS_NOT_PUSH}
else
begin
gettempofsizereference(href,4);
p.temp_offset:=href.offset;
end
{$endif TEMPS_NOT_PUSH}
;
pushed:=true;
{$ifdef TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,p.location.register,href)));
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p.location.register)));
{$endif TEMPS_NOT_PUSH}
ungetregister32(p.location.register);
end
else if (p.location.loc in [LOC_MEM,LOC_REFERENCE]) and
((p.location.reference.base<>R_NO) or
(p.location.reference.index<>R_NO)
) then
begin
del_reference(p.location.reference);
getexplicitregister32(R_EDI);
emit_ref_reg(A_LEA,S_L,newreference(p^.location.reference),R_EDI);
{$ifdef TEMPS_NOT_PUSH}
gettempofsizereference(href,4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,href)));
p^.temp_offset:=href.offset;
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
{$endif TEMPS_NOT_PUSH}
ungetregister32(R_EDI);
pushed:=true;
end
else pushed:=false;
end
else pushed:=false;
maybe_push:=pushed;
end;
{$else CG11}
{$ifndef CG11}
function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean;
var
pushed : boolean;
@ -1210,7 +1128,6 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
else pushed:=false;
maybe_push:=pushed;
end;
{$endif CG11}
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : ptree;isint64 : boolean) : boolean;
@ -1263,6 +1180,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
maybe_push:=pushed;
end;
{$endif TEMPS_NOT_PUSH}
{$endif CG11}
procedure push_int(l : longint);
@ -1338,7 +1256,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end;
end;
{$ifndef CG11}
procedure pushsetelement(p : ptree);
{
copies p a set element on the stack
@ -1395,8 +1313,9 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end;
end;
end;
{$endif CG11}
{$ifndef CG11}
procedure restore(p : ptree;isint64 : boolean);
var
hregister : tregister;
@ -1443,6 +1362,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
ungetiftemp(href);
{$endif TEMPS_NOT_PUSH}
end;
{$endif CG11}
{$ifdef TEMPS_NOT_PUSH}
procedure restorefromtemp(p : ptree;isint64 : boolean);
@ -1480,6 +1400,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end;
{$endif TEMPS_NOT_PUSH}
{$ifndef CG11}
procedure push_value_para(p:ptree;inlined,is_cdecl:boolean;
para_offset:longint;alignment : longint);
var
@ -1990,7 +1911,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{$endif SUPPORT_MMX}
end;
end;
{$endif CG11}
{*****************************************************************************
@ -2075,262 +1996,6 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
Emit Functions
*****************************************************************************}
procedure maketojumpbool(p : ptree);
{
produces jumps to true respectively false labels using boolean expressions
}
var
opsize : topsize;
storepos : tfileposinfo;
begin
if p^.error then
exit;
storepos:=aktfilepos;
aktfilepos:=p^.fileinfo;
if is_boolean(p^.resulttype) then
begin
if is_constboolnode(p) then
begin
if p^.value<>0 then
emitjmp(C_None,truelabel)
else
emitjmp(C_None,falselabel);
end
else
begin
opsize:=def_opsize(p^.resulttype);
case p^.location.loc of
LOC_CREGISTER,LOC_REGISTER : begin
emit_reg_reg(A_OR,opsize,p^.location.register,
p^.location.register);
ungetregister(p^.location.register);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_MEM,LOC_REFERENCE : begin
emit_const_ref(
A_CMP,opsize,0,newreference(p^.location.reference));
del_reference(p^.location.reference);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_FLAGS : begin
emitjmp(flag_2_cond[p^.location.resflags],truelabel);
emitjmp(C_None,falselabel);
end;
end;
end;
end
else
CGMessage(type_e_mismatch);
aktfilepos:=storepos;
end;
{ produces if necessary overflowcode }
procedure emitoverflowcheck(p:ptree);
var
hl : pasmlabel;
begin
if not(cs_check_overflow in aktlocalswitches) then
exit;
getlabel(hl);
if not ((p^.resulttype^.deftype=pointerdef) or
((p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar,
bool8bit,bool16bit,bool32bit]))) then
emitjmp(C_NO,hl)
else
emitjmp(C_NB,hl);
emitcall('FPC_OVERFLOW');
emitlab(hl);
end;
{ produces range check code, while one of the operands is a 64 bit
integer }
procedure emitrangecheck64(p : ptree;todef : pdef);
begin
CGMessage(cg_w_64bit_range_check_not_supported);
{internalerror(28699);}
end;
{ produces if necessary rangecheckcode }
procedure emitrangecheck(p:ptree;todef:pdef);
{
generate range checking code for the value at location t. The
type used is the checked against todefs ranges. fromdef (p.resulttype)
is the original type used at that location, when both defs are
equal the check is also insert (needed for succ,pref,inc,dec)
}
var
neglabel,
poslabel : pasmlabel;
href : treference;
rstr : string;
hreg : tregister;
opsize : topsize;
op : tasmop;
fromdef : pdef;
lto,hto,
lfrom,hfrom : longint;
doublebound,
is_reg,
popecx : boolean;
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef^.deftype in [orddef,enumdef,arraydef]) then
exit;
{ only check when assigning to scalar, subranges are different,
when todef=fromdef then the check is always generated }
fromdef:=p^.resulttype;
if is_64bitint(fromdef) or is_64bitint(todef) then
begin
emitrangecheck64(p,todef);
exit;
end;
{we also need lto and hto when checking if we need to use doublebound!
(JM)}
getrange(todef,lto,hto);
if todef<>fromdef then
begin
getrange(p^.resulttype,lfrom,hfrom);
{ first check for not being u32bit, then if the to is bigger than
from }
if (lto<hto) and (lfrom<hfrom) and
(lto<=lfrom) and (hto>=hfrom) then
exit;
end;
{ generate the rangecheck code for the def where we are going to
store the result }
doublebound:=false;
case todef^.deftype of
orddef :
begin
porddef(todef)^.genrangecheck;
rstr:=porddef(todef)^.getrangecheckstring;
doublebound:=(porddef(todef)^.typ=u32bit) and (lto>hto);
end;
enumdef :
begin
penumdef(todef)^.genrangecheck;
rstr:=penumdef(todef)^.getrangecheckstring;
end;
arraydef :
begin
parraydef(todef)^.genrangecheck;
rstr:=parraydef(todef)^.getrangecheckstring;
doublebound:=(lto>hto);
end;
end;
{ get op and opsize }
opsize:=def2def_opsize(fromdef,u32bitdef);
if opsize in [S_B,S_W,S_L] then
op:=A_MOV
else
if is_signed(fromdef) then
op:=A_MOVSX
else
op:=A_MOVZX;
is_reg:=(p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]);
if is_reg then
hreg:=p^.location.register;
if not target_os.use_bound_instruction then
begin
{ FPC_BOUNDCHECK needs to be called with
%ecx - value
%edi - pointer to the ranges }
popecx:=false;
if not(is_reg) or
(p^.location.register<>R_ECX) then
begin
if not(R_ECX in unused) then
begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX)));
popecx:=true;
end
else exprasmlist^.concat(new(pairegalloc,alloc(R_ECX)));
if is_reg then
emit_reg_reg(op,opsize,p^.location.register,R_ECX)
else
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_ECX);
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_OR,S_L,R_ECX,R_ECX);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
getexplicitregister32(R_EDI);
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),0,R_EDI)));
emitcall('FPC_BOUNDCHECK');
ungetregister32(R_EDI);
{ u32bit needs 2 checks }
if doublebound then
begin
emitjmp(C_None,poslabel);
emitlab(neglabel);
getexplicitregister32(R_EDI);
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),8,R_EDI)));
emitcall('FPC_BOUNDCHECK');
ungetregister32(R_EDI);
emitlab(poslabel);
end;
if popecx then
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX)))
else exprasmlist^.concat(new(pairegalloc,dealloc(R_ECX)));
end
else
begin
reset_reference(href);
href.symbol:=newasmsymbol(rstr);
{ load the value in a register }
if is_reg then
begin
{ be sure that hreg is a 32 bit reg, if not load it in %edi }
if p^.location.register in [R_EAX..R_EDI] then
hreg:=p^.location.register
else
begin
getexplicitregister32(R_EDI);
emit_reg_reg(op,opsize,p^.location.register,R_EDI);
hreg:=R_EDI;
end;
end
else
begin
getexplicitregister32(R_EDI);
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_EDI);
hreg:=R_EDI;
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_TEST,S_L,hreg,hreg);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
{ u32bit needs 2 checks }
if doublebound then
begin
href.offset:=8;
emitjmp(C_None,poslabel);
emitlab(neglabel);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
emitlab(poslabel);
end;
if hreg = R_EDI then
ungetregister32(R_EDI);
end;
end;
procedure concatcopy(source,dest : treference;size : longint;delsource,loadref : boolean);
const
@ -2613,6 +2278,263 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end;
{$ifndef CG11}
procedure maketojumpbool(p : ptree);
{
produces jumps to true respectively false labels using boolean expressions
}
var
opsize : topsize;
storepos : tfileposinfo;
begin
if p^.error then
exit;
storepos:=aktfilepos;
aktfilepos:=p^.fileinfo;
if is_boolean(p^.resulttype) then
begin
if is_constboolnode(p) then
begin
if p^.value<>0 then
emitjmp(C_None,truelabel)
else
emitjmp(C_None,falselabel);
end
else
begin
opsize:=def_opsize(p^.resulttype);
case p^.location.loc of
LOC_CREGISTER,LOC_REGISTER : begin
emit_reg_reg(A_OR,opsize,p^.location.register,
p^.location.register);
ungetregister(p^.location.register);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_MEM,LOC_REFERENCE : begin
emit_const_ref(
A_CMP,opsize,0,newreference(p^.location.reference));
del_reference(p^.location.reference);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_FLAGS : begin
emitjmp(flag_2_cond[p^.location.resflags],truelabel);
emitjmp(C_None,falselabel);
end;
end;
end;
end
else
CGMessage(type_e_mismatch);
aktfilepos:=storepos;
end;
{ produces if necessary overflowcode }
procedure emitoverflowcheck(p:ptree);
var
hl : pasmlabel;
begin
if not(cs_check_overflow in aktlocalswitches) then
exit;
getlabel(hl);
if not ((p^.resulttype^.deftype=pointerdef) or
((p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar,
bool8bit,bool16bit,bool32bit]))) then
emitjmp(C_NO,hl)
else
emitjmp(C_NB,hl);
emitcall('FPC_OVERFLOW');
emitlab(hl);
end;
{ produces range check code, while one of the operands is a 64 bit
integer }
procedure emitrangecheck64(p : ptree;todef : pdef);
begin
CGMessage(cg_w_64bit_range_check_not_supported);
{internalerror(28699);}
end;
{ produces if necessary rangecheckcode }
procedure emitrangecheck(p:ptree;todef:pdef);
{
generate range checking code for the value at location t. The
type used is the checked against todefs ranges. fromdef (p.resulttype)
is the original type used at that location, when both defs are
equal the check is also insert (needed for succ,pref,inc,dec)
}
var
neglabel,
poslabel : pasmlabel;
href : treference;
rstr : string;
hreg : tregister;
opsize : topsize;
op : tasmop;
fromdef : pdef;
lto,hto,
lfrom,hfrom : longint;
doublebound,
is_reg,
popecx : boolean;
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef^.deftype in [orddef,enumdef,arraydef]) then
exit;
{ only check when assigning to scalar, subranges are different,
when todef=fromdef then the check is always generated }
fromdef:=p^.resulttype;
if is_64bitint(fromdef) or is_64bitint(todef) then
begin
emitrangecheck64(p,todef);
exit;
end;
{we also need lto and hto when checking if we need to use doublebound!
(JM)}
getrange(todef,lto,hto);
if todef<>fromdef then
begin
getrange(p^.resulttype,lfrom,hfrom);
{ first check for not being u32bit, then if the to is bigger than
from }
if (lto<hto) and (lfrom<hfrom) and
(lto<=lfrom) and (hto>=hfrom) then
exit;
end;
{ generate the rangecheck code for the def where we are going to
store the result }
doublebound:=false;
case todef^.deftype of
orddef :
begin
porddef(todef)^.genrangecheck;
rstr:=porddef(todef)^.getrangecheckstring;
doublebound:=(porddef(todef)^.typ=u32bit) and (lto>hto);
end;
enumdef :
begin
penumdef(todef)^.genrangecheck;
rstr:=penumdef(todef)^.getrangecheckstring;
end;
arraydef :
begin
parraydef(todef)^.genrangecheck;
rstr:=parraydef(todef)^.getrangecheckstring;
doublebound:=(lto>hto);
end;
end;
{ get op and opsize }
opsize:=def2def_opsize(fromdef,u32bitdef);
if opsize in [S_B,S_W,S_L] then
op:=A_MOV
else
if is_signed(fromdef) then
op:=A_MOVSX
else
op:=A_MOVZX;
is_reg:=(p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]);
if is_reg then
hreg:=p^.location.register;
if not target_os.use_bound_instruction then
begin
{ FPC_BOUNDCHECK needs to be called with
%ecx - value
%edi - pointer to the ranges }
popecx:=false;
if not(is_reg) or
(p^.location.register<>R_ECX) then
begin
if not(R_ECX in unused) then
begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX)));
popecx:=true;
end
else exprasmlist^.concat(new(pairegalloc,alloc(R_ECX)));
if is_reg then
emit_reg_reg(op,opsize,p^.location.register,R_ECX)
else
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_ECX);
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_OR,S_L,R_ECX,R_ECX);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
getexplicitregister32(R_EDI);
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),0,R_EDI)));
emitcall('FPC_BOUNDCHECK');
ungetregister32(R_EDI);
{ u32bit needs 2 checks }
if doublebound then
begin
emitjmp(C_None,poslabel);
emitlab(neglabel);
getexplicitregister32(R_EDI);
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),8,R_EDI)));
emitcall('FPC_BOUNDCHECK');
ungetregister32(R_EDI);
emitlab(poslabel);
end;
if popecx then
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX)))
else exprasmlist^.concat(new(pairegalloc,dealloc(R_ECX)));
end
else
begin
reset_reference(href);
href.symbol:=newasmsymbol(rstr);
{ load the value in a register }
if is_reg then
begin
{ be sure that hreg is a 32 bit reg, if not load it in %edi }
if p^.location.register in [R_EAX..R_EDI] then
hreg:=p^.location.register
else
begin
getexplicitregister32(R_EDI);
emit_reg_reg(op,opsize,p^.location.register,R_EDI);
hreg:=R_EDI;
end;
end
else
begin
getexplicitregister32(R_EDI);
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_EDI);
hreg:=R_EDI;
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_TEST,S_L,hreg,hreg);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
{ u32bit needs 2 checks }
if doublebound then
begin
href.offset:=8;
emitjmp(C_None,poslabel);
emitlab(neglabel);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
emitlab(poslabel);
end;
if hreg = R_EDI then
ungetregister32(R_EDI);
end;
end;
{ DO NOT RELY on the fact that the ptree is not yet swaped
because of inlining code PM }
procedure firstcomplex(p : ptree);
@ -2644,6 +2566,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{else
p^.swaped:=false; do not modify }
end;
{$endif}
{*****************************************************************************
@ -3966,7 +3889,10 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end.
{
$Log$
Revision 1.16 2000-09-30 16:08:45 peter
Revision 1.17 2000-10-01 19:48:23 peter
* lot of compile updates for cg11
Revision 1.16 2000/09/30 16:08:45 peter
* more cg11 updates
Revision 1.15 2000/09/24 15:06:12 peter
@ -4032,4 +3958,4 @@ end.
Revision 1.2 2000/07/13 11:32:37 michael
+ removed logs
}
}

968
compiler/htypechk.pas
View File

File diff suppressed because it is too large Load Diff

93
compiler/nadd.pas
View File

@ -42,8 +42,6 @@ interface
{ specific node types can be created }
caddnode : class of taddnode;
function isbinaryoverloaded(var p : tbinarynode) : boolean;
implementation
uses
@ -57,89 +55,9 @@ implementation
hcodegen,
{$endif newcg}
htypechk,pass_1,
ncal,nmat,ncnv,nld,ncon,nset,
cpubase;
function isbinaryoverloaded(var p : tbinarynode) : boolean;
var
rd,ld : pdef;
t : tnode;
optoken : ttoken;
begin
isbinaryoverloaded:=false;
{ overloaded operator ? }
{ load easier access variables }
rd:=p.right.resulttype;
ld:=p.left.resulttype;
if isbinaryoperatoroverloadable(ld,rd,voiddef,p.nodetype) then
begin
isbinaryoverloaded:=true;
{!!!!!!!!! handle paras }
case p.nodetype of
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
addn:
optoken:=_PLUS;
subn:
optoken:=_MINUS;
muln:
optoken:=_STAR;
starstarn:
optoken:=_STARSTAR;
slashn:
optoken:=_SLASH;
ltn:
optoken:=tokens._lt;
gtn:
optoken:=tokens._gt;
lten:
optoken:=_lte;
gten:
optoken:=_gte;
equaln,unequaln :
optoken:=_EQUAL;
symdifn :
optoken:=_SYMDIF;
modn :
optoken:=_OP_MOD;
orn :
optoken:=_OP_OR;
xorn :
optoken:=_OP_XOR;
andn :
optoken:=_OP_AND;
divn :
optoken:=_OP_DIV;
shln :
optoken:=_OP_SHL;
shrn :
optoken:=_OP_SHR;
else
exit;
end;
t:=gencallnode(overloaded_operators[optoken],nil);
{ we have to convert p.left and p.right into
callparanodes }
if tcallnode(t).symtableprocentry=nil then
begin
CGMessage(parser_e_operator_not_overloaded);
t.free;
end
else
begin
inc(tcallnode(t).symtableprocentry^.refs);
tcallnode(t).left:=gencallparanode(p.left,nil);
tcallnode(t).left:=gencallparanode(p.right,tcallnode(t).left);
if p.nodetype=unequaln then
t:=cnotnode.create(t);
p.left:=nil;
p.right:=nil;
firstpass(t);
p:=tbinarynode(t);
end;
end;
end;
{*****************************************************************************
TADDNODE
@ -206,8 +124,8 @@ implementation
arrayconstructor_to_set(tarrayconstructnode(right));
{ both left and right need to be valid }
left.set_varstate(true);
right.set_varstate(true);
set_varstate(left,true);
set_varstate(right,true);
{ load easier access variables }
lt:=left.nodetype;
@ -1314,7 +1232,10 @@ begin
end.
{
$Log$
Revision 1.11 2000-09-30 16:08:45 peter
Revision 1.12 2000-10-01 19:48:23 peter
* lot of compile updates for cg11
Revision 1.11 2000/09/30 16:08:45 peter
* more cg11 updates
Revision 1.10 2000/09/28 19:49:52 florian

15
compiler/ncal.pas
View File

@ -219,7 +219,7 @@ interface
begin
{ not completly proper, but avoids some warnings }
if (defcoll^.paratyp=vs_var) then
left.set_funcret_is_valid;
set_funcret_is_valid(left);
{ protected has nothing to do with read/write
if (defcoll^.paratyp=vs_var) then
@ -353,7 +353,7 @@ interface
{ Causes problems with const ansistrings if also }
{ done for vs_const (JM) }
if defcoll^.paratyp = vs_var then
left.set_unique;
set_unique(left);
make_not_regable(left);
end;
@ -363,7 +363,7 @@ interface
make_not_regable(left);
if do_count then
left.set_varstate(defcoll^.paratyp <> vs_var);
set_varstate(left,defcoll^.paratyp <> vs_var);
{ must only be done after typeconv PM }
resulttype:=defcoll^.paratype.def;
end;
@ -628,7 +628,7 @@ interface
goto errorexit;
end;
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
{ check the parameters }
pdc:=pparaitem(pprocvardef(right.resulttype)^.para^.first);
@ -1363,7 +1363,7 @@ interface
else
method_must_be_valid:=true;
firstpass(methodpointer);
methodpointer.set_varstate(method_must_be_valid);
set_varstate(methodpointer,method_must_be_valid);
{ The object is already used ven if it is called once }
if (methodpointer.nodetype=loadn) and
(tloadnode(methodpointer).symtableentry^.typ=varsym) then
@ -1472,7 +1472,10 @@ begin
end.
{
$Log$
Revision 1.7 2000-09-28 19:49:52 florian
Revision 1.8 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.7 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.6 2000/09/27 18:14:31 florian

21
compiler/ncnv.pas
View File

@ -27,7 +27,9 @@ unit ncnv;
interface
uses
node,symtable,nld;
node,
symtable,types,
nld;
type
ttypeconvnode = class(tunarynode)
@ -85,8 +87,8 @@ implementation
uses
globtype,systems,tokens,
cutils,cobjects,verbose,globals,
symconst,aasm,types,ncon,ncal,
nset,nadd,
symconst,aasm,
ncon,ncal,nset,nadd,
{$ifdef newcg}
cgbase,
{$else newcg}
@ -1094,9 +1096,9 @@ implementation
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
@ -1136,9 +1138,9 @@ implementation
begin
pass_1:=nil;
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
@ -1171,7 +1173,10 @@ begin
end.
{
$Log$
Revision 1.5 2000-09-28 19:49:52 florian
Revision 1.6 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.5 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.4 2000/09/27 18:14:31 florian

21
compiler/nflw.pas
View File

@ -236,7 +236,7 @@ implementation
{$endif newcg}
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
if not is_boolean(left.resulttype) then
@ -300,7 +300,7 @@ implementation
cleartempgen;
{$endif newcg}
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
{ Only check type if no error, we can't leave here because
the right also needs to be firstpassed }
@ -439,7 +439,7 @@ implementation
cleartempgen;
{$endif newcg}
firstpass(left);
left.set_varstate(false);
set_varstate(left,false);
{$ifdef newcg}
tg.cleartempgen;
@ -474,7 +474,7 @@ implementation
cleartempgen;
{$endif newcg}
firstpass(t2);
t2.set_varstate(true);
set_varstate(t2,true);
if codegenerror then
exit;
@ -512,7 +512,7 @@ implementation
cleartempgen;
{$endif newcg}
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if right.nodetype<>ordconstn then
begin
right:=gentypeconvnode(right,t2.resulttype);
@ -658,7 +658,7 @@ implementation
((left.resulttype^.deftype<>objectdef) or
not(pobjectdef(left.resulttype)^.is_class)) then
CGMessage(type_e_mismatch);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
{ insert needed typeconvs for addr,frame }
@ -770,7 +770,7 @@ implementation
aktexceptblock:=left;
firstpass(left);
aktexceptblock:=oldexceptblock;
left.set_varstate(true);
set_varstate(left,true);
{$ifdef newcg}
tg.cleartempgen;
{$else newcg}
@ -780,7 +780,7 @@ implementation
aktexceptblock:=right;
firstpass(right);
aktexceptblock:=oldexceptblock;
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
left_right_max;
@ -875,7 +875,10 @@ begin
end.
{
$Log$
Revision 1.4 2000-09-28 19:49:52 florian
Revision 1.5 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.4 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.3 2000/09/24 21:15:34 florian

59
compiler/ninl.pas
View File

@ -171,7 +171,7 @@ implementation
location.loc:=LOC_FPU;
resulttype:=s80floatdef;
{ redo firstpass for varstate status PM }
left.set_varstate(true);
set_varstate(left,true);
if (left.resulttype^.deftype<>floatdef) or
(pfloatdef(left.resulttype)^.typ<>s80real) then
begin
@ -404,7 +404,7 @@ implementation
in_hi_word:
begin
left.set_varstate(true);
set_varstate(left,true);
if registers32<1 then
registers32:=1;
if inlinenumber in [in_lo_word,in_hi_word] then
@ -446,7 +446,7 @@ implementation
in_sizeof_x:
begin
left.set_varstate(false);
set_varstate(left,false);
if push_high_param(left.resulttype) then
begin
getsymonlyin(tloadnode(left).symtable,'high'+pvarsym(tloadnode(left).symtableentry)^.name);
@ -466,7 +466,7 @@ implementation
in_typeof_x:
begin
left.set_varstate(false);
set_varstate(left,false);
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
@ -475,7 +475,7 @@ implementation
in_ord_x:
begin
left.set_varstate(true);
set_varstate(left,true);
if (left.nodetype=ordconstn) then
begin
hp:=genordinalconstnode(tordconstnode(left).value,s32bitdef);
@ -545,7 +545,7 @@ implementation
in_chr_byte:
begin
left.set_varstate(true);
set_varstate(left,true);
hp:=gentypeconvnode(left,cchardef);
left:=nil;
include(hp.flags,nf_explizit);
@ -555,7 +555,7 @@ implementation
in_length_string:
begin
left.set_varstate(true);
set_varstate(left,true);
if is_ansistring(left.resulttype) then
resulttype:=s32bitdef
else
@ -600,14 +600,14 @@ implementation
in_assigned_x:
begin
left.set_varstate(true);
set_varstate(left,true);
resulttype:=booldef;
location.loc:=LOC_FLAGS;
end;
in_ofs_x,
in_seg_x :
left.set_varstate(false);
set_varstate(left,false);
in_pred_x,
in_succ_x:
begin
@ -623,7 +623,7 @@ implementation
registers32:=1;
end;
location.loc:=LOC_REGISTER;
left.set_varstate(true);
set_varstate(left,true);
if not is_ordinal(resulttype) then
CGMessage(type_e_ordinal_expr_expected)
else
@ -651,7 +651,7 @@ implementation
if assigned(left) then
begin
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
{ first param must be var }
@ -708,7 +708,7 @@ implementation
begin
dowrite:=(inlinenumber in [in_write_x,in_writeln_x]);
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(dowrite);
set_varstate(left,dowrite);
{ now we can check }
hp:=left;
while assigned(tcallparanode(hp).right) do
@ -877,7 +877,7 @@ implementation
if codegenerror then
exit;
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true);
set_varstate(left,true);
{ calc registers }
left_max;
if extra_register then
@ -909,7 +909,7 @@ implementation
begin
procinfo^.flags:=procinfo^.flags or pi_do_call;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
resulttype:=voiddef;
end;
@ -928,12 +928,12 @@ implementation
hp:=tcallparanode(left).right;
tcallparanode(left).right:=nil;
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(false);
set_varstate(left,false);
{ remove warning when result is passed }
tcallparanode(left).left.set_funcret_is_valid;
set_funcret_is_valid(tcallparanode(left).left);
tcallparanode(left).right:=hp;
tcallparanode(tcallparanode(left).right).firstcallparan(nil,true);
tcallparanode(left).right.set_varstate(true);
set_varstate(tcallparanode(left).right,true);
hp:=left;
{ valid string ? }
if not assigned(hp) or
@ -986,7 +986,7 @@ implementation
if assigned(hpp) and (nf_is_colon_para in hpp.flags) then
begin
firstpass(tcallparanode(hpp).left);
tcallparanode(hpp).left.set_varstate(true);
set_varstate(tcallparanode(hpp).left,true);
if (not is_integer(tcallparanode(hpp).left.resulttype)) then
CGMessage1(type_e_integer_expr_expected,tcallparanode(hpp).left.resulttype^.typename)
else
@ -1001,7 +1001,7 @@ implementation
else
begin
firstpass(tcallparanode(hpp).left);
tcallparanode(hpp).left.set_varstate(true);
set_varstate(tcallparanode(hpp).left,true);
tcallparanode(hpp).left:=gentypeconvnode(tcallparanode(hpp).left,s32bitdef);
end;
end
@ -1037,7 +1037,7 @@ implementation
tcallparanode(left).right := nil;
make_not_regable(tcallparanode(left).left);
tcallparanode(left).firstcallparan(nil,true);
tcallparanode(left).set_varstate(false);
set_varstate(left,false);
if codegenerror then exit;
tcallparanode(left).right := hp;
{code has to be a var parameter}
@ -1058,12 +1058,12 @@ implementation
{hpp = destination}
make_not_regable(tcallparanode(hpp).left);
tcallparanode(hpp).firstcallparan(nil,true);
hpp.set_varstate(false);
set_varstate(hpp,false);
if codegenerror then
exit;
{ remove warning when result is passed }
tcallparanode(hpp).left.set_funcret_is_valid;
set_funcret_is_valid(tcallparanode(hpp).left);
tcallparanode(hpp).right := hp;
if valid_for_assign(tcallparanode(hpp).left,false) then
begin
@ -1077,7 +1077,7 @@ implementation
{hp = source (String)}
{ count_ref := false; WHY ?? }
tcallparanode(hp).firstcallparan(nil,true);
hp.set_varstate(true);
set_varstate(hp,true);
if codegenerror then
exit;
{ if not a stringdef then insert a type conv which
@ -1105,14 +1105,14 @@ implementation
if assigned(left) then
begin
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true);
set_varstate(left,true);
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
{ remove warning when result is passed }
tcallparanode(left).left.set_funcret_is_valid;
set_funcret_is_valid(tcallparanode(left).left);
{ first param must be var }
valid_for_assign(tcallparanode(left).left,false);
{ check type }
@ -1144,7 +1144,7 @@ implementation
in_low_x,
in_high_x:
begin
left.set_varstate(false);
set_varstate(left,false);
{ this fixes tests\webtbs\tbug879.pp (FK)
if left.nodetype in [typen,loadn,subscriptn] then
begin
@ -1319,7 +1319,7 @@ implementation
if assigned(left) then
begin
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true);
set_varstate(left,true);
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
@ -1366,7 +1366,10 @@ begin
end.
{
$Log$
Revision 1.5 2000-09-28 19:49:52 florian
Revision 1.6 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.5 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.4 2000/09/28 16:34:47 florian

19
compiler/nld.pas
View File

@ -391,14 +391,14 @@ implementation
{ must be made unique }
if assigned(left) then
begin
left.set_unique;
set_unique(left);
{ set we the function result? }
left.set_funcret_is_valid;
set_funcret_is_valid(left);
end;
firstpass(left);
left.set_varstate(false);
set_varstate(left,false);
if codegenerror then
exit;
@ -436,7 +436,7 @@ implementation
end;
{$endif i386}
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
@ -558,9 +558,9 @@ implementation
function tarrayconstructorrangenode.pass_1 : tnode;
begin
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
calcregisters(self,0,0,0);
resulttype:=left.resulttype;
end;
@ -640,7 +640,7 @@ implementation
while assigned(hp) do
begin
firstpass(hp.left);
hp.left.set_varstate(true);
set_varstate(hp.left,true);
if (not get_para_resulttype) and
(not(nf_novariaallowed in flags)) then
begin
@ -769,7 +769,10 @@ begin
end.
{
$Log$
Revision 1.4 2000-09-28 19:49:52 florian
Revision 1.5 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.4 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.3 2000/09/27 18:14:31 florian

17
compiler/nmat.pas
View File

@ -82,9 +82,9 @@ interface
begin
pass_1:=nil;
firstpass(left);
right.set_varstate(true);
set_varstate(right,true);
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
@ -217,9 +217,9 @@ interface
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
@ -286,7 +286,7 @@ interface
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
@ -417,7 +417,7 @@ interface
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
@ -528,7 +528,10 @@ begin
end.
{
$Log$
Revision 1.6 2000-09-27 21:33:22 florian
Revision 1.7 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.6 2000/09/27 21:33:22 florian
* finally nadd.pas compiles
Revision 1.5 2000/09/27 20:25:44 florian

15
compiler/nmem.pas
View File

@ -483,7 +483,7 @@ implementation
firstpass(left);
{ this is like the function addr }
inc(parsing_para_level);
left.set_varstate(false);
set_varstate(left,false);
dec(parsing_para_level);
if codegenerror then
exit;
@ -532,7 +532,7 @@ implementation
make_not_regable(left);
firstpass(left);
inc(parsing_para_level);
left.set_varstate(false);
set_varstate(left,false);
dec(parsing_para_level);
if resulttype=nil then
resulttype:=voidpointerdef;
@ -570,7 +570,7 @@ implementation
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
begin
resulttype:=generrordef;
@ -853,8 +853,8 @@ implementation
if assigned(left) and assigned(right) then
begin
firstpass(left);
left.unset_varstate;
left.set_varstate(true);
unset_varstate(left);
set_varstate(left,true);
if codegenerror then
exit;
symtable:=withsymtable;
@ -884,7 +884,10 @@ implementation
end.
{
$Log$
Revision 1.4 2000-09-28 19:49:52 florian
Revision 1.5 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.4 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.3 2000/09/25 15:37:14 florian

257
compiler/node.inc
View File

@ -230,173 +230,6 @@
fileinfo:=filepos;
end;
procedure tnode.unset_varstate;
begin
internalerror(220920002);
end;
procedure tnode.set_varstate(must_be_valid : boolean);
begin
internalerror(220920001);
end;
procedure tnode.set_unique;
begin
case nodetype of
vecn:
include(flags,nf_callunique);
typeconvn,subscriptn,derefn:
if assigned(tunarynode(self).left) then
tunarynode(self).left.set_unique;
end;
end;
procedure tnode.set_funcret_is_valid;
begin
case nodetype of
funcretn:
if nf_is_first_funcret in flags then
pprocinfo(tfuncretnode(self).funcretprocinfo)^.funcret_state:=vs_assigned;
vecn,typeconvn,subscriptn{,derefn}:
if assigned(tunarynode(self).left) then
tunarynode(self).left.set_funcret_is_valid;
end;
end;
{$warning FIX ME !!!!!}
{$ifdef dummy}
procedure unset_varstate(p : ptree);
begin
while assigned(p) do
begin
p^.varstateset:=false;
case p^.treetype of
typeconvn,
subscriptn,
vecn :
p:=p^.left;
else
break;
end;
end;
end;
procedure set_varstate(p : ptree;must_be_valid : boolean);
begin
if not assigned(p) then
exit
else
begin
if p^.varstateset then
exit;
case p^.treetype of
typeconvn :
if p^.convtyp in
[
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_array_2_pointer
] then
set_varstate(p^.left,false)
else if p^.convtyp in
[
tc_pchar_2_string,
tc_pointer_2_array
] then
set_varstate(p^.left,true)
else
set_varstate(p^.left,must_be_valid);
subscriptn :
set_varstate(p^.left,must_be_valid);
vecn:
begin
if (p^.left^.resulttype^.deftype in [stringdef,arraydef]) then
set_varstate(p^.left,must_be_valid)
else
set_varstate(p^.left,true);
set_varstate(p^.right,true);
end;
{ do not parse calln }
calln : ;
callparan:
begin
set_varstate(p^.left,must_be_valid);
set_varstate(p^.right,must_be_valid);
end;
loadn :
if (p^.symtableentry^.typ=varsym) then
begin
if must_be_valid and p^.is_first then
begin
if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) or
(pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed) then
if (assigned(pvarsym(p^.symtableentry)^.owner) and
assigned(aktprocsym) and
(pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
begin
if p^.symtable^.symtabletype=localsymtable then
CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name)
else
CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name);
end;
end;
if (p^.is_first) then
begin
if pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found then
{ this can only happen at left of an assignment, no ? PM }
if (parsing_para_level=0) and not must_be_valid then
pvarsym(p^.symtableentry)^.varstate:=vs_assigned
else
pvarsym(p^.symtableentry)^.varstate:=vs_used;
if pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed then
pvarsym(p^.symtableentry)^.varstate:=vs_used;
p^.is_first:=false;
end
else
begin
if (pvarsym(p^.symtableentry)^.varstate=vs_assigned) and
(must_be_valid or (parsing_para_level>0) or
(p^.resulttype^.deftype=procvardef)) then
pvarsym(p^.symtableentry)^.varstate:=vs_used;
if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) and
(must_be_valid or (parsing_para_level>0) or
(p^.resulttype^.deftype=procvardef)) then
pvarsym(p^.symtableentry)^.varstate:=vs_set_but_first_not_passed;
end;
end;
funcretn:
begin
{ no claim if setting higher return value_str }
if must_be_valid and
(procinfo=pprocinfo(p^.funcretprocinfo)) and
((procinfo^.funcret_state=vs_declared) or
((p^.is_first_funcret) and
(procinfo^.funcret_state=vs_declared_and_first_found))) then
begin
CGMessage(sym_w_function_result_not_set);
{ avoid multiple warnings }
procinfo^.funcret_state:=vs_assigned;
end;
if p^.is_first_funcret and not must_be_valid then
pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
end;
else
begin
{internalerror(565656);}
end;
end;{case }
p^.varstateset:=true;
end;
end;
{$endif}
{****************************************************************************
TUNARYNODE
@ -536,86 +369,6 @@
getcopy:=p;
end;
function tbinarynode.isbinaryoverloaded(var t : tnode) : boolean;
var
rd,ld : pdef;
optoken : ttoken;
begin
t:=nil;
isbinaryoverloaded:=false;
{ overloaded operator ? }
{ load easier access variables }
rd:=right.resulttype;
ld:=left.resulttype;
if isbinaryoperatoroverloadable(ld,rd,voiddef,nodetype) then
begin
isbinaryoverloaded:=true;
{!!!!!!!!! handle paras }
case nodetype of
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
addn:
optoken:=_PLUS;
subn:
optoken:=_MINUS;
muln:
optoken:=_STAR;
starstarn:
optoken:=_STARSTAR;
slashn:
optoken:=_SLASH;
ltn:
optoken:=tokens._lt;
gtn:
optoken:=tokens._gt;
lten:
optoken:=_lte;
gten:
optoken:=_gte;
equaln,unequaln :
optoken:=_EQUAL;
symdifn :
optoken:=_SYMDIF;
modn :
optoken:=_OP_MOD;
orn :
optoken:=_OP_OR;
xorn :
optoken:=_OP_XOR;
andn :
optoken:=_OP_AND;
divn :
optoken:=_OP_DIV;
shln :
optoken:=_OP_SHL;
shrn :
optoken:=_OP_SHR;
else
exit;
end;
t:=gencallnode(overloaded_operators[optoken],nil);
{ we have to convert p^.left and p^.right into
callparanodes }
if tcallnode(t).symtableprocentry=nil then
begin
CGMessage(parser_e_operator_not_overloaded);
t.free;
t:=nil;
end
else
begin
inc(tcallnode(t).symtableprocentry^.refs);
tcallnode(t).left:=gencallparanode(left,nil);
tcallnode(t).left:=gencallparanode(right,tcallnode(t).left);
if nodetype=unequaln then
t:=cnotnode.create(t);
firstpass(t);
end;
end;
end;
procedure tbinarynode.swapleftright;
@ -625,7 +378,8 @@
begin
swapp:=right;
right:=left;
left:=swapp;
left:=
swapp;
if nf_swaped in flags then
exclude(flags,nf_swaped)
else
@ -675,7 +429,10 @@
end;
{
$Log$
Revision 1.7 2000-09-29 15:45:23 florian
Revision 1.8 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.7 2000/09/29 15:45:23 florian
* make cycle fixed
Revision 1.6 2000/09/28 19:49:52 florian
@ -696,4 +453,4 @@
Revision 1.1 2000/08/26 12:27:17 florian
* createial release
}
}

17
compiler/node.pas
View File

@ -27,23 +27,30 @@ unit node;
interface
uses
globtype,globals,cobjects,aasm,cpubase,symtable,
tokens;
cobjects,
globtype,
cpubase,
aasm,
symtable;
{$I nodeh.inc}
implementation
uses
htypechk,hcodegen,verbose,
pass_1,symconst,cutils;
cutils,
globals,
symconst;
{$I node.inc}
end.
{
$Log$
Revision 1.7 2000-09-30 16:08:45 peter
Revision 1.8 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.7 2000/09/30 16:08:45 peter
* more cg11 updates
Revision 1.6 2000/09/28 19:49:52 florian

60
compiler/nodeh.inc
View File

@ -109,53 +109,6 @@
loadvmtn
);
tconverttype = (
tc_equal,
tc_not_possible,
tc_string_2_string,
tc_char_2_string,
tc_pchar_2_string,
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_ansistring_2_pchar,
tc_string_2_chararray,
tc_chararray_2_string,
tc_array_2_pointer,
tc_pointer_2_array,
tc_int_2_int,
tc_int_2_bool,
tc_bool_2_bool,
tc_bool_2_int,
tc_real_2_real,
tc_int_2_real,
tc_int_2_fix,
tc_real_2_fix,
tc_fix_2_real,
tc_proc_2_procvar,
tc_arrayconstructor_2_set,
tc_load_smallset,
tc_cord_2_pointer
);
pcaserecord = ^tcaserecord;
tcaserecord = record
{ range }
_low,_high : longint;
{ only used by gentreejmp }
_at : pasmlabel;
{ label of instruction }
statement : pasmlabel;
{ is this the first of an case entry, needed to release statement
label (PFV) }
firstlabel : boolean;
{ left and right tree node }
less,greater : pcaserecord;
end;
{ all boolean field of ttree are now collected in flags }
tnodeflags = (
nf_needs_truefalselabel,
@ -272,14 +225,7 @@
function docompare(p : tnode) : boolean;virtual;
{ gets a copy of the node }
function getcopy : tnode;virtual;
procedure unset_varstate;virtual;
procedure set_varstate(must_be_valid : boolean);virtual;
{ it would be cleaner to make the following virtual methods }
{ but this would require an extra vmt entry }
{ so we do some hacking instead .... }
procedure set_unique;
procedure set_funcret_is_valid;
{$ifdef EXTDEBUG}
{ writes a node for debugging purpose, shouldn't be called }
{ direct, because there is no test for nil, use writenode }
@ -325,7 +271,6 @@
procedure det_temp;override;
function docompare(p : tnode) : boolean;override;
procedure swapleftright;
function isbinaryoverloaded(var t : tnode) : boolean;
function getcopy : tnode;override;
procedure left_right_max;
end;
@ -338,7 +283,10 @@
{
$Log$
Revision 1.10 2000-09-28 19:49:52 florian
Revision 1.11 2000-10-01 19:48:24 peter
* lot of compile updates for cg11
Revision 1.10 2000/09/28 19:49:52 florian
*** empty log message ***
Revision 1.9 2000/09/27 18:14:31 florian

17
compiler/nset.pas
View File

@ -135,7 +135,7 @@ implementation
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
@ -203,7 +203,7 @@ implementation
resulttype:=booldef;
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
@ -237,7 +237,7 @@ implementation
end;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
@ -297,9 +297,9 @@ implementation
begin
pass_1:=nil;
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
firstpass(right);
right.set_varstate(true);
set_varstate(right,true);
if codegenerror then
exit;
{ both types must be compatible }
@ -425,7 +425,7 @@ implementation
cleartempgen;
{$endif newcg}
firstpass(left);
left.set_varstate(true);
set_varstate(left,true);
if codegenerror then
exit;
registers32:=left.registers32;
@ -516,7 +516,10 @@ begin
end.
{
$Log$
Revision 1.3 2000-09-27 18:14:31 florian
Revision 1.4 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.3 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.2 2000/09/24 20:17:44 florian

30
compiler/og386.pas
View File

@ -62,7 +62,8 @@ interface
pobjectoutput = ^tobjectoutput;
tobjectoutput = object
smarthcount : longint;
SmartFilesCount,
SmartHeaderCount : longint;
objsmart : boolean;
writer : pobjectwriter;
path : pathstr;
@ -96,8 +97,7 @@ interface
uses
comphook,
cutils,globtype,globals,verbose,fmodule,
assemble;
cutils,globtype,globals,verbose,fmodule;
{****************************************************************************
@ -160,7 +160,8 @@ interface
constructor tobjectoutput.init(smart:boolean);
begin
smarthcount:=0;
SmartFilesCount:=0;
SmartHeaderCount:=0;
objsmart:=smart;
objfile:=current_module^.objfilename^;
{ Which path will be used ? }
@ -195,8 +196,8 @@ interface
var
s : string;
begin
inc(SmartLinkFilesCnt);
if SmartLinkFilesCnt>999999 then
inc(SmartFilesCount);
if SmartFilesCount>999999 then
Message(asmw_f_too_many_asm_files);
if (cs_asm_leave in aktglobalswitches) then
s:=current_module^.asmprefix^
@ -205,15 +206,15 @@ interface
case place of
cut_begin :
begin
inc(smarthcount);
s:=s+tostr(smarthcount)+'h';
inc(SmartHeaderCount);
s:=s+tostr(SmartHeaderCount)+'h';
end;
cut_normal :
s:=s+tostr(smarthcount)+'s';
s:=s+tostr(SmartHeaderCount)+'s';
cut_end :
s:=s+tostr(smarthcount)+'t';
s:=s+tostr(SmartHeaderCount)+'t';
end;
ObjFile:=FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.objext);
ObjFile:=FixFileName(s+tostr(SmartFilesCount)+target_info.objext);
end;
@ -284,7 +285,10 @@ interface
end.
{
$Log$
Revision 1.6 2000-09-24 15:06:19 peter
Revision 1.7 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.6 2000/09/24 15:06:19 peter
* use defines.inc
Revision 1.5 2000/08/27 16:11:51 peter
@ -300,4 +304,4 @@ end.
Revision 1.2 2000/07/13 11:32:43 michael
+ removed logs
}
}

6
compiler/parser.pas
View File

@ -74,6 +74,7 @@ implementation
current_module:=nil;
compiled_module:=nil;
procinfo:=nil;
loaded_units.init;
@ -593,7 +594,10 @@ implementation
end.
{
$Log$
Revision 1.5 2000-09-24 15:06:20 peter
Revision 1.6 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.5 2000/09/24 15:06:20 peter
* use defines.inc
Revision 1.4 2000/08/27 16:11:51 peter

18
compiler/pass_1.pas
View File

@ -373,7 +373,7 @@ implementation
end.
{$else cg11}
{$else tnode}
unit pass_1;
{$i defines.inc}
@ -426,18 +426,19 @@ implementation
cutils,cobjects,verbose,globals,
aasm,symtable,types,
htypechk,
cpubase,cpuasm
cpubase,cpuasm,
nflw
{$ifdef newcg}
,cgbase
,tgcpu
{$else newcg}
,hcodegen
{$ifdef i386}
{$ifdef i386}
,tgeni386
{$endif}
{$ifdef m68k}
{$endif}
{$ifdef m68k}
,tgen68k
{$endif}
{$endif}
{$endif}
;
@ -741,7 +742,10 @@ end.
{$endif cg11}
{
$Log$
Revision 1.7 2000-09-30 16:08:45 peter
Revision 1.8 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.7 2000/09/30 16:08:45 peter
* more cg11 updates
Revision 1.6 2000/09/28 19:49:52 florian

7
compiler/pexpr.pas
View File

@ -2224,7 +2224,10 @@ _LECKKLAMMER : begin
end.
{
$Log$
Revision 1.9 2000-09-24 21:19:50 peter
Revision 1.10 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.9 2000/09/24 21:19:50 peter
* delphi compile fixes
Revision 1.8 2000/09/24 15:06:22 peter
@ -2250,4 +2253,4 @@ end.
Revision 1.2 2000/07/13 11:32:44 michael
+ removed logs
}
}

6
compiler/pstatmnt.pas
View File

@ -40,6 +40,7 @@ interface
globtype,systems,tokens,
cutils,cobjects,globals,fmodule,verbose,cpuinfo,
symconst,symtable,aasm,pass_1,types,scanner,
htypechk,
{$ifdef newcg}
cgbase,
{$else}
@ -1375,7 +1376,10 @@ interface
end.
{
$Log$
Revision 1.8 2000-09-24 21:19:50 peter
Revision 1.9 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.8 2000/09/24 21:19:50 peter
* delphi compile fixes
Revision 1.7 2000/09/24 15:06:24 peter

312
compiler/regvars.pas
View File

@ -28,10 +28,20 @@ interface
uses
aasm,
tree;
{$ifdef CG11}
node
{$else CG11}
tree
{$endif CG11}
;
procedure assign_regvars(var p: ptree);
{$ifdef CG11}
procedure assign_regvars(p: tnode);
procedure load_regvars(asml: paasmoutput; p: tnode);
{$else CG11}
procedure assign_regvars(p: ptree);
procedure load_regvars(asml: paasmoutput; p: ptree);
{$endif CG11}
procedure cleanup_regvars(asml: paasmoutput);
implementation
@ -167,7 +177,296 @@ implementation
end;
{$endif i386}
procedure assign_regvars(var p: ptree);
{$ifdef CG11}
procedure assign_regvars(p: tnode);
{ register variables }
var
regvarinfo: pregvarinfo;
i: longint;
begin
{ max. optimizations }
{ only if no asm is used }
{ and no try statement }
if (cs_regalloc in aktglobalswitches) and
((procinfo^.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
begin
new(regvarinfo);
fillchar(regvarinfo^,sizeof(regvarinfo^),0);
aktprocsym^.definition^.regvarinfo := regvarinfo;
if (p.registers32<4) then
begin
parasym:=false;
symtablestack^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
{ copy parameter into a register ? }
parasym:=true;
symtablestack^.next^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
{ hold needed registers free }
for i:=maxvarregs downto maxvarregs-p.registers32+1 do
begin
regvarinfo^.regvars[i]:=nil;
regvarinfo^.regvars_para[i] := false;
end;
{ now assign register }
for i:=1 to maxvarregs-p.registers32 do
begin
if assigned(regvarinfo^.regvars[i]) and
(reg_pushes[varregs[i]] < regvarinfo^.regvars[i]^.refs) then
begin
{ register is no longer available for }
{ expressions }
{ search the register which is the most }
{ unused }
usableregs:=usableregs-[varregs[i]];
is_reg_var[varregs[i]]:=true;
dec(c_usableregs);
{ possibly no 32 bit register are needed }
{ call by reference/const ? }
if (regvarinfo^.regvars[i]^.varspez=vs_var) or
((regvarinfo^.regvars[i]^.varspez=vs_const) and
push_addr_param(regvarinfo^.regvars[i]^.vartype.def)) then
begin
regvarinfo^.regvars[i]^.reg:=varregs[i];
end
else
if (regvarinfo^.regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and
(porddef(regvarinfo^.regvars[i]^.vartype.def)^.size=1) then
begin
{$ifdef i386}
regvarinfo^.regvars[i]^.reg:=reg32toreg8(varregs[i]);
{$endif}
end
else
if (regvarinfo^.regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and
(porddef(regvarinfo^.regvars[i]^.vartype.def)^.size=2) then
begin
{$ifdef i386}
regvarinfo^.regvars[i]^.reg:=reg32toreg16(varregs[i]);
{$endif}
end
else
begin
regvarinfo^.regvars[i]^.reg:=varregs[i];
end;
if regvarinfo^.regvars_para[i] then
unused:=unused - [regvarinfo^.regvars[i]^.reg];
{ procedure uses this register }
{$ifdef i386}
usedinproc:=usedinproc or ($80 shr byte(varregs[i]));
{$endif i386}
{$ifdef m68k}
usedinproc:=usedinproc or ($800 shr word(varregs[i]));
{$endif m68k}
end
else
begin
regvarinfo^.regvars[i] := nil;
regvarinfo^.regvars_para[i] := false;
end;
end;
end;
if ((p.registersfpu+1)<maxfpuvarregs) then
begin
parasym:=false;
symtablestack^.foreach({$ifdef FPCPROCVAR}@{$endif}searchfpuregvars);
{$ifdef dummy}
{ copy parameter into a register ? }
parasym:=true;
symtablestack^.next^.foreach({$ifdef FPCPROCVAR}@{$endif}searchregvars);
{$endif dummy}
{ hold needed registers free }
{ in non leaf procedures we must be very careful }
{ with assigning registers }
if aktmaxfpuregisters=-1 then
begin
if (procinfo^.flags and pi_do_call)<>0 then
begin
for i:=maxfpuvarregs downto 2 do
regvarinfo^.fpuregvars[i]:=nil;
end
else
begin
for i:=maxfpuvarregs downto maxfpuvarregs-p.registersfpu do
regvarinfo^.fpuregvars[i]:=nil;
end;
end
else
begin
for i:=aktmaxfpuregisters+1 to maxfpuvarregs do
regvarinfo^.fpuregvars[i]:=nil;
end;
{ now assign register }
for i:=1 to maxfpuvarregs do
begin
if assigned(regvarinfo^.fpuregvars[i]) then
begin
{$ifdef i386}
{ reserve place on the FPU stack }
regvarinfo^.fpuregvars[i]^.reg:=correct_fpuregister(R_ST0,i-1);
{$endif i386}
{$ifdef m68k}
regvarinfo^.fpuregvars[i]^.reg:=fpuvarregs[i];
{$endif m68k}
end;
end;
end;
end;
end;
procedure load_regvars(asml: paasmoutput; p: tnode);
var
i: longint;
hr : preference;
regvarinfo: pregvarinfo;
{$ifdef i386}
opsize: topsize;
opcode: tasmop;
signed: boolean;
{$endif i386}
begin
if (cs_regalloc in aktglobalswitches) and
((procinfo^.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
begin
regvarinfo := pregvarinfo(aktprocsym^.definition^.regvarinfo);
{ can happen when inlining assembler procedures (JM) }
if not assigned(regvarinfo) then
exit;
for i:=1 to maxvarregs do
begin
{ parameter must be load }
if regvarinfo^.regvars_para[i] then
begin
{$ifdef i386}
asml^.concat(new(pairegalloc,alloc(reg32(regvarinfo^.regvars[i]^.reg))));
{$endif i386}
{ procinfo is there actual, }
{ because we can't never be in a }
{ nested procedure }
{ when loading parameter to reg }
new(hr);
reset_reference(hr^);
hr^.offset:=pvarsym(regvarinfo^.regvars[i])^.address+procinfo^.para_offset;
hr^.base:=procinfo^.framepointer;
{$ifdef i386}
{ zero the regvars because the upper 48bits must be clear }
{ for 8bits vars when using them with btrl (JM) }
signed :=
(pvarsym(regvarinfo^.regvars[i])^.vartype.def^.deftype =
orddef) and
is_signed(pvarsym(regvarinfo^.regvars[i])^.vartype.def);
case regsize(regvarinfo^.regvars[i]^.reg) of
S_L:
begin
opsize := S_L;
opcode := A_MOV;
end;
S_W:
begin
opsize := S_WL;
if signed then
opcode := A_MOVSX
else opcode := A_MOVZX;
end;
S_B:
begin
opsize := S_BL;
if signed then
opcode := A_MOVSX
else opcode := A_MOVZX;
end;
end;
asml^.concat(new(paicpu,op_ref_reg(opcode,opsize,
hr,reg32(regvarinfo^.regvars[i]^.reg))));
{$endif i386}
{$ifdef m68k}
asml^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize(regvarinfo^.regvars[i]^.reg),
hr,regvarinfo^.regvars[i]^.reg)));
{$endif m68k}
end
end;
for i:=1 to maxvarregs do
begin
if assigned(regvarinfo^.regvars[i]) then
begin
{$ifdef i386}
if not(regvarinfo^.regvars_para[i]) then
begin
asml^.concat(new(pairegalloc,alloc(reg32(regvarinfo^.regvars[i]^.reg))));
{ zero the regvars because the upper 48bits must be clear }
{ for 8bits vars when using them with btrl (JM) }
if (regsize(regvarinfo^.regvars[i]^.reg) in [S_B,S_W]) then
asml^.concat(new(paicpu,op_reg_reg(A_XOR,S_L,
reg32(regvarinfo^.regvars[i]^.reg),
reg32(regvarinfo^.regvars[i]^.reg))));
end;
{$endif i386}
if cs_asm_source in aktglobalswitches then
asml^.insert(new(pai_asm_comment,init(strpnew(regvarinfo^.regvars[i]^.name+
' with weight '+tostr(regvarinfo^.regvars[i]^.refs)+' assigned to register '+
reg2str(regvarinfo^.regvars[i]^.reg)))));
if (status.verbosity and v_debug)=v_debug then
Message3(cg_d_register_weight,reg2str(regvarinfo^.regvars[i]^.reg),
tostr(regvarinfo^.regvars[i]^.refs),regvarinfo^.regvars[i]^.name);
end;
end;
for i:=1 to maxfpuvarregs do
begin
if assigned(regvarinfo^.fpuregvars[i]) then
begin
{$ifdef i386}
{ reserve place on the FPU stack }
regvarinfo^.fpuregvars[i]^.reg:=correct_fpuregister(R_ST0,i-1);
asml^.concat(new(paicpu,op_none(A_FLDZ,S_NO)));
{$endif i386}
{$ifdef dummy}
{ parameter must be load }
if regvarinfo^.fpuregvars_para[i] then
begin
{ procinfo is there actual, }
{ because we can't never be in a }
{ nested procedure }
{ when loading parameter to reg }
new(hr);
reset_reference(hr^);
hr^.offset:=pvarsym(regvarinfo^.regvars[i])^.address+procinfo^.para_offset;
hr^.base:=procinfo^.framepointer;
{$ifdef i386}
asml^.concat(new(paicpu,op_ref_reg(A_MOV,regsize(regvarinfo^.regvars[i]^.reg),
hr,regvarinfo^.regvars[i]^.reg)));
{$endif i386}
{$ifdef m68k}
asml^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize(regvarinfo^.regvars[i]^.reg),
hr,regvarinfo^.regvars[i]^.reg)));
{$endif m68k}
end;
{$endif dummy}
end;
end;
if assigned(p) then
if cs_asm_source in aktglobalswitches then
asml^.insert(new(pai_asm_comment,init(strpnew(tostr(p.registersfpu)+
' registers on FPU stack used by temp. expressions'))));
for i:=1 to maxfpuvarregs do
begin
if assigned(regvarinfo^.fpuregvars[i]) then
begin
if cs_asm_source in aktglobalswitches then
asml^.insert(new(pai_asm_comment,init(strpnew(regvarinfo^.fpuregvars[i]^.name+
' with weight '+tostr(regvarinfo^.fpuregvars[i]^.refs)+' assigned to register '+
reg2str(regvarinfo^.fpuregvars[i]^.reg)))));
if (status.verbosity and v_debug)=v_debug then
Message3(cg_d_register_weight,reg2str(regvarinfo^.fpuregvars[i]^.reg),
tostr(regvarinfo^.fpuregvars[i]^.refs),regvarinfo^.fpuregvars[i]^.name);
end;
end;
if cs_asm_source in aktglobalswitches then
asml^.insert(new(pai_asm_comment,init(strpnew('Register variable assignment:'))));
end;
end;
{$else CG11}
procedure assign_regvars(p: ptree);
{ register variables }
var
regvarinfo: pregvarinfo;
@ -303,7 +602,6 @@ implementation
end;
end;
procedure load_regvars(asml: paasmoutput; p: ptree);
var
i: longint;
@ -454,6 +752,7 @@ implementation
asml^.insert(new(pai_asm_comment,init(strpnew('Register variable assignment:'))));
end;
end;
{$endif CG11}
procedure cleanup_regvars(asml: paasmoutput);
@ -483,7 +782,10 @@ end.
{
$Log$
Revision 1.8 2000-09-30 16:08:45 peter
Revision 1.9 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.8 2000/09/30 16:08:45 peter
* more cg11 updates
Revision 1.7 2000/09/30 13:08:16 jonas

12
compiler/symdef.inc
View File

@ -2869,8 +2869,13 @@ Const local_symtable_index : longint = $8001;
dispose(parast,done);
if assigned(localst) and (localst^.symtabletype<>staticsymtable) then
dispose(localst,done);
{$ifdef CG11}
if (pocall_inline in proccalloptions) and assigned(code) then
tnode(code).free;
{$else}
if (pocall_inline in proccalloptions) and assigned(code) then
disposetree(ptree(code));
{$endif}
if assigned(regvarinfo) then
dispose(pregvarinfo(regvarinfo));
if (po_msgstr in procoptions) then
@ -4311,7 +4316,10 @@ Const local_symtable_index : longint = $8001;
{
$Log$
Revision 1.19 2000-09-24 21:19:52 peter
Revision 1.20 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.19 2000/09/24 21:19:52 peter
* delphi compile fixes
Revision 1.18 2000/09/24 15:06:28 peter
@ -4378,4 +4386,4 @@ Const local_symtable_index : longint = $8001;
Revision 1.2 2000/07/13 11:32:49 michael
+ removed logs
}
}

11
compiler/symtable.pas
View File

@ -473,7 +473,11 @@ implementation
version,verbose,
types,ppu,
gendef,fmodule,finput
{$ifdef CG11}
,node
{$else CG11}
,tree
{$endif CG11}
,cresstr
{$ifdef newcg}
,cgbase
@ -2878,7 +2882,10 @@ implementation
end.
{
$Log$
Revision 1.8 2000-09-24 15:06:29 peter
Revision 1.9 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.8 2000/09/24 15:06:29 peter
* use defines.inc
Revision 1.7 2000/08/27 16:11:54 peter
@ -2903,4 +2910,4 @@ end.
Revision 1.2 2000/07/13 11:32:50 michael
+ removed logs
}
}

175
compiler/tree.pas
View File

@ -332,22 +332,11 @@ unit tree;
maxfirstpasscount : longint = 0;
{$endif extdebug}
{ sets the callunique flag, if the node is a vecn, }
{ takes care of type casts etc. }
procedure set_unique(p : ptree);
{ sets funcret_is_valid to true, if p contains a funcref node }
procedure set_funcret_is_valid(p : ptree);
{
type
tvarstaterequire = (vsr_can_be_undefined,vsr_must_be_valid,
vsr_is_used_after,vsr_must_be_valid_and_is_used_after); }
{ sets varsym varstate field correctly }
procedure unset_varstate(p : ptree);
procedure set_varstate(p : ptree;must_be_valid : boolean);
{ returns the ordinal value of the node, if it hasn't a ord. }
{ value an error is generated }
function get_ordinal_value(p : ptree) : longint;
@ -1840,163 +1829,6 @@ unit tree;
end;
{$endif newoptimizations2}
procedure set_unique(p : ptree);
begin
if assigned(p) then
begin
case p^.treetype of
vecn:
p^.callunique:=true;
typeconvn,subscriptn,derefn:
set_unique(p^.left);
end;
end;
end;
procedure set_funcret_is_valid(p : ptree);
begin
if assigned(p) then
begin
case p^.treetype of
funcretn:
begin
if p^.is_first_funcret then
pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
end;
vecn,typeconvn,subscriptn{,derefn}:
set_funcret_is_valid(p^.left);
end;
end;
end;
procedure unset_varstate(p : ptree);
begin
while assigned(p) do
begin
p^.varstateset:=false;
case p^.treetype of
typeconvn,
subscriptn,
vecn :
p:=p^.left;
else
break;
end;
end;
end;
procedure set_varstate(p : ptree;must_be_valid : boolean);
begin
if not assigned(p) then
exit
else
begin
if p^.varstateset then
exit;
case p^.treetype of
typeconvn :
if p^.convtyp in
[
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_array_2_pointer
] then
set_varstate(p^.left,false)
else if p^.convtyp in
[
tc_pchar_2_string,
tc_pointer_2_array
] then
set_varstate(p^.left,true)
else
set_varstate(p^.left,must_be_valid);
subscriptn :
set_varstate(p^.left,must_be_valid);
vecn:
begin
if (p^.left^.resulttype^.deftype in [stringdef,arraydef]) then
set_varstate(p^.left,must_be_valid)
else
set_varstate(p^.left,true);
set_varstate(p^.right,true);
end;
{ do not parse calln }
calln : ;
callparan:
begin
set_varstate(p^.left,must_be_valid);
set_varstate(p^.right,must_be_valid);
end;
loadn :
if (p^.symtableentry^.typ=varsym) then
begin
if must_be_valid and p^.is_first then
begin
if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) or
(pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed) then
if (assigned(pvarsym(p^.symtableentry)^.owner) and
assigned(aktprocsym) and
(pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
begin
if p^.symtable^.symtabletype=localsymtable then
CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name)
else
CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name);
end;
end;
if (p^.is_first) then
begin
if pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found then
{ this can only happen at left of an assignment, no ? PM }
if (parsing_para_level=0) and not must_be_valid then
pvarsym(p^.symtableentry)^.varstate:=vs_assigned
else
pvarsym(p^.symtableentry)^.varstate:=vs_used;
if pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed then
pvarsym(p^.symtableentry)^.varstate:=vs_used;
p^.is_first:=false;
end
else
begin
if (pvarsym(p^.symtableentry)^.varstate=vs_assigned) and
(must_be_valid or (parsing_para_level>0) or
(p^.resulttype^.deftype=procvardef)) then
pvarsym(p^.symtableentry)^.varstate:=vs_used;
if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) and
(must_be_valid or (parsing_para_level>0) or
(p^.resulttype^.deftype=procvardef)) then
pvarsym(p^.symtableentry)^.varstate:=vs_set_but_first_not_passed;
end;
end;
funcretn:
begin
{ no claim if setting higher return value_str }
if must_be_valid and
(procinfo=pprocinfo(p^.funcretprocinfo)) and
((procinfo^.funcret_state=vs_declared) or
((p^.is_first_funcret) and
(procinfo^.funcret_state=vs_declared_and_first_found))) then
begin
CGMessage(sym_w_function_result_not_set);
{ avoid multiple warnings }
procinfo^.funcret_state:=vs_assigned;
end;
if p^.is_first_funcret and not must_be_valid then
pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned;
end;
else
begin
{internalerror(565656);}
end;
end;{case }
p^.varstateset:=true;
end;
end;
procedure clear_location(var loc : tlocation);
@ -2149,7 +1981,10 @@ unit tree;
end.
{
$Log$
Revision 1.10 2000-09-27 18:14:31 florian
Revision 1.11 2000-10-01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.10 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.9 2000/09/24 15:06:32 peter
@ -2176,4 +2011,4 @@ end.
Revision 1.2 2000/07/13 11:32:52 michael
+ removed logs
}
}

553
compiler/types.pas
View File

@ -27,10 +27,12 @@ unit types;
interface
uses
cobjects,symtable,cpuinfo
{$IFDEF NEWST}
,defs
{$ENDIF NEWST};
cobjects,
cpuinfo,
{$ifdef CG11}
node,
{$endif}
symtable;
type
tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
@ -145,6 +147,47 @@ interface
{ to use on other types }
function is_subequal(def1, def2: pdef): boolean;
{$ifdef CG11}
type
tconverttype = (
tc_equal,
tc_not_possible,
tc_string_2_string,
tc_char_2_string,
tc_pchar_2_string,
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_ansistring_2_pchar,
tc_string_2_chararray,
tc_chararray_2_string,
tc_array_2_pointer,
tc_pointer_2_array,
tc_int_2_int,
tc_int_2_bool,
tc_bool_2_bool,
tc_bool_2_int,
tc_real_2_real,
tc_int_2_real,
tc_int_2_fix,
tc_real_2_fix,
tc_fix_2_real,
tc_proc_2_procvar,
tc_arrayconstructor_2_set,
tc_load_smallset,
tc_cord_2_pointer
);
function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
{ Returns:
0 - Not convertable
1 - Convertable
2 - Convertable, but not first choice }
function isconvertable(def_from,def_to : pdef;
var doconv : tconverttype;fromtreetype : tnodetype;
explicit : boolean) : byte;
{$endif CG11}
{ same as is_equal, but with error message if failed }
function CheckTypes(def1,def2 : pdef) : boolean;
@ -191,13 +234,12 @@ interface
implementation
uses
globtype,globals,htypechk,
{$ifdef CG11}
node,
{$else}
globtype,globals,
{$ifndef CG11}
htypechk,
tree,
{$endif}
verbose,symconst;
verbose,symconst,tokens;
var
b_needs_init_final : boolean;
@ -1119,6 +1161,494 @@ implementation
end; { endif assigned ... }
end;
{$ifdef CG11}
function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
var
passproc : pprocdef;
convtyp : tconverttype;
begin
assignment_overloaded:=nil;
if assigned(overloaded_operators[_ASSIGNMENT]) then
passproc:=overloaded_operators[_ASSIGNMENT]^.definition
else
exit;
while passproc<>nil do
begin
if is_equal(passproc^.rettype.def,to_def) and
(is_equal(pparaitem(passproc^.para^.first)^.paratype.def,from_def) or
(isconvertable(from_def,pparaitem(passproc^.para^.first)^.paratype.def,convtyp,ordconstn,false)=1)) then
begin
assignment_overloaded:=passproc;
break;
end;
passproc:=passproc^.nextoverloaded;
end;
end;
{ Returns:
0 - Not convertable
1 - Convertable
2 - Convertable, but not first choice }
function isconvertable(def_from,def_to : pdef;
var doconv : tconverttype;fromtreetype : tnodetype;
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,bchar);
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;
hct : tconverttype;
begin
{ safety check }
if not(assigned(def_from) and assigned(def_to)) then
begin
isconvertable:=0;
exit;
end;
{ tp7 procvar def support, in tp7 a procvar is always called, if the
procvar is passed explicit a addrn would be there }
if (m_tp_procvar in aktmodeswitches) and
(def_from^.deftype=procvardef) and
(fromtreetype=loadn) then
begin
def_from:=pprocvardef(def_from)^.rettype.def;
end;
{ we walk the wanted (def_to) types and check then the def_from
types if there is a conversion possible }
b:=0;
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
{ needed for char(enum) }
if explicit then
begin
doconv:=tc_int_2_int;
b:=1;
end;
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
{ 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,
but not in tp7 compatible mode }
if is_pchar(def_from) and not(m_tp7 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
hd1:=def_from;
while assigned(penumdef(hd1)^.basedef) do
hd1:=penumdef(hd1)^.basedef;
hd2:=def_to;
while assigned(penumdef(hd2)^.basedef) do
hd2:=penumdef(hd2)^.basedef;
if (hd1=hd2) then
begin
b:=1;
{ because of packenum they can have different sizes! (JM) }
doconv:=tc_int_2_int;
end;
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)^.elementtype.def,def_from) then
begin
doconv:=tc_equal;
b:=1;
end
else
begin
case def_from^.deftype of
arraydef :
begin
{ array constructor -> open array }
if is_open_array(def_to) and
is_array_constructor(def_from) then
begin
if is_void(parraydef(def_from)^.elementtype.def) or
is_equal(parraydef(def_to)^.elementtype.def,parraydef(def_from)^.elementtype.def) then
begin
doconv:=tc_equal;
b:=1;
end
else
if isconvertable(parraydef(def_from)^.elementtype.def,
parraydef(def_to)^.elementtype.def,hct,arrayconstructn,false)<>0 then
begin
doconv:=hct;
b:=2;
end;
end;
end;
pointerdef :
begin
if is_zero_based_array(def_to) and
is_equal(ppointerdef(def_from)^.pointertype.def,parraydef(def_to)^.elementtype.def) 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)^.elementtype.def,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 (which can be part of array constructor)
to zero terminated string constant }
if (fromtreetype in [arrayconstructn,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) then
begin
if is_equal(def_from,cchardef) and
is_pchar(def_to) then
begin
doconv:=tc_cchar_2_pchar;
b:=1;
end
else
if is_integer(def_from) then
begin
doconv:=tc_cord_2_pointer;
b:=1;
end;
end;
end;
arraydef :
begin
{ chararray to pointer }
if is_zero_based_array(def_from) and
is_equal(parraydef(def_from)^.elementtype.def,ppointerdef(def_to)^.pointertype.def) 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)^.pointertype.def^.deftype=objectdef) and
(ppointerdef(def_to)^.pointertype.def^.deftype=objectdef) and
pobjectdef(ppointerdef(def_from)^.pointertype.def)^.is_related(
pobjectdef(ppointerdef(def_to)^.pointertype.def))
) or
{ all pointers can be assigned to void-pointer }
is_equal(ppointerdef(def_to)^.pointertype.def,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)^.pointertype.def,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)^.pointertype.def^.deftype=orddef) and
(porddef(ppointerdef(def_to)^.pointertype.def)^.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)^.is_class) or
(def_from^.deftype=classrefdef)
) and
(ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
(porddef(ppointerdef(def_to)^.pointertype.def)^.typ=uvoid) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
end;
end;
setdef :
begin
{ automatic arrayconstructor -> set conversion }
if is_array_constructor(def_from) then
begin
doconv:=tc_arrayconstructor_2_set;
b:=1;
end;
end;
procvardef :
begin
{ proc -> procvar }
if (def_from^.deftype=procdef) then
begin
doconv:=tc_proc_2_procvar;
if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
b:=1;
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)^.pointertype.def^.deftype=orddef) and
(porddef(ppointerdef(def_from)^.pointertype.def)^.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)^.is_related(pobjectdef(def_to)) then
b:=1;
end
else
{ Class specific }
if (pobjectdef(def_to)^.is_class) then
begin
{ void pointer also for delphi mode }
if (m_delphi in aktmodeswitches) and
is_voidpointer(def_from) then
begin
doconv:=tc_equal;
b:=1;
end
else
{ nil is compatible with class instances }
if (fromtreetype=niln) and (pobjectdef(def_to)^.is_class) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
end;
classrefdef :
begin
{ class reference types }
if (def_from^.deftype=classrefdef) then
begin
doconv:=tc_equal;
if pobjectdef(pclassrefdef(def_from)^.pointertype.def)^.is_related(
pobjectdef(pclassrefdef(def_to)^.pointertype.def)) 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)^.filetyp = ft_typed) and
(pfiledef(def_to)^.filetyp = ft_typed) and
(
(pfiledef(def_from)^.typedfiletype.def = pdef(voiddef)) or
(pfiledef(def_to)^.typedfiletype.def = pdef(voiddef))
)
) or
(
(
(pfiledef(def_from)^.filetyp = ft_untyped) and
(pfiledef(def_to)^.filetyp = ft_typed)
) or
(
(pfiledef(def_from)^.filetyp = ft_typed) and
(pfiledef(def_to)^.filetyp = ft_untyped)
)
)
) then
begin
doconv:=tc_equal;
b:=1;
end
end;
else
begin
{ assignment overwritten ?? }
if assignment_overloaded(def_from,def_to)<>nil then
b:=2;
end;
end;
isconvertable:=b;
end;
{$endif CG11}
function CheckTypes(def1,def2 : pdef) : boolean;
var
@ -1148,7 +1678,10 @@ implementation
end.
{
$Log$
Revision 1.12 2000-09-30 16:08:46 peter
Revision 1.13 2000-10-01 19:48:26 peter
* lot of compile updates for cg11
Revision 1.12 2000/09/30 16:08:46 peter
* more cg11 updates
Revision 1.11 2000/09/24 15:06:32 peter