paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-24 07:19:28 +01:00
Code Issues Packages Projects Releases Wiki Activity

* hmm, still a lot of work to get things compilable

Browse Source
This commit is contained in:
florian 2000-09-26 20:06:13 +00:00
parent 531bb2a6ad
commit a32e181d77
5 changed files with 316 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
compiler/cpubase.pas
View File

@ -673,6 +673,10 @@ const
function is_calljmp(o:tasmop):boolean; function is_calljmp(o:tasmop):boolean;
procedure clear_location(var loc : tlocation);
procedure set_location(var destloc,sourceloc : tlocation);
procedure swap_location(var destloc,sourceloc : tlocation);
implementation implementation
@ -842,6 +846,31 @@ begin
new_reference:=r; new_reference:=r;
end; end;
procedure clear_location(var loc : tlocation);
begin
loc.loc:=LOC_INVALID;
end;
{This is needed if you want to be able to delete the string with the nodes !!}
procedure set_location(var destloc,sourceloc : tlocation);
begin
destloc:= sourceloc;
end;
procedure swap_location(var destloc,sourceloc : tlocation);
var
swapl : tlocation;
begin
swapl := destloc;
destloc := sourceloc;
sourceloc := swapl;
end;
{***************************************************************************** {*****************************************************************************
Instruction table Instruction table
*****************************************************************************} *****************************************************************************}
@ -887,7 +916,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.6 2000-09-24 15:06:14 peter Revision 1.7 2000-09-26 20:06:13 florian
* hmm, still a lot of work to get things compilable
Revision 1.6 2000/09/24 15:06:14 peter
* use defines.inc * use defines.inc
Revision 1.5 2000/08/27 16:11:50 peter Revision 1.5 2000/08/27 16:11:50 peter

6
compiler/htypechk.pas
View File

@ -1135,7 +1135,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.6 2000-09-24 15:06:17 peter Revision 1.7 2000-09-26 20:06:13 florian
* hmm, still a lot of work to get things compilable
Revision 1.6 2000/09/24 15:06:17 peter
* use defines.inc * use defines.inc
Revision 1.5 2000/08/27 16:11:51 peter Revision 1.5 2000/08/27 16:11:51 peter
@ -1155,5 +1158,4 @@ end.
Revision 1.2 2000/07/13 11:32:41 michael Revision 1.2 2000/07/13 11:32:41 michael
+ removed logs + removed logs
} }

422
compiler/ncnv.pas
View File

@ -35,6 +35,31 @@ interface
constructor create(node : tnode;t : pdef);virtual; constructor create(node : tnode;t : pdef);virtual;
function getcopy : tnode;override; function getcopy : tnode;override;
function pass_1 : tnode;override; function pass_1 : tnode;override;
function first_int_to_int : tnode;virtual;
function first_cstring_to_pchar : tnode;virtual;
function first_string_to_chararray : tnode;virtual;
function first_string_to_string : tnode;virtual;
function first_char_to_string : tnode;virtual;
function first_nothing : tnode;virtual;
function first_array_to_pointer : tnode;virtual;
function first_int_to_real : tnode;virtual;
function first_int_to_fix : tnode;virtual;
function first_real_to_fix : tnode;virtual;
function first_fix_to_real : tnode;virtual;
function first_real_to_real : tnode;virtual;
function first_pointer_to_array : tnode;virtual;
function first_chararray_to_string : tnode;virtual;
function first_cchar_to_pchar : tnode;virtual;
function first_bool_to_int : tnode;virtual;
function first_int_to_bool : tnode;virtual;
function first_bool_to_bool : tnode;virtual;
function first_proc_to_procvar : tnode;virtual;
function first_load_smallset : tnode;virtual;
function first_cord_to_pointer : tnode;virtual;
function first_pchar_to_string : tnode;virtual;
function first_ansistring_to_pchar : tnode;virtual;
function first_arrayconstructor_to_set : tnode;virtual;
function call_helper(c : tconverttype) : tnode;
end; end;
tasnode = class(tbinarynode) tasnode = class(tbinarynode)
@ -54,14 +79,12 @@ interface
function gentypeconvnode(node : tnode;t : pdef) : tnode; function gentypeconvnode(node : tnode;t : pdef) : tnode;
procedure arrayconstructor_to_set(var p:ptree);
implementation implementation
uses uses
globtype,systems,tokens, globtype,systems,tokens,
cutils,cobjects,verbose,globals, cutils,cobjects,verbose,globals,
symconst,aasm,types, symconst,aasm,types,ncon,ncal,nld,
{$ifdef newcg} {$ifdef newcg}
cgbase, cgbase,
{$else newcg} {$else newcg}
@ -74,11 +97,17 @@ implementation
Array constructor to Set Conversion Array constructor to Set Conversion
*****************************************************************************} *****************************************************************************}
procedure arrayconstructor_to_set(var p:ptree); function arrayconstructor_to_set : tnode;
begin
{$warning FIX ME !!!!!!!}
internalerror(2609000);
end;
{$ifdef dummy}
var var
constp, constp : tsetconstnode;
buildp, buildp,
p2,p3,p4 : ptree; p2,p3,p4 : tnode;
pd : pdef; pd : pdef;
constset : pconstset; constset : pconstset;
constsetlo, constsetlo,
@ -138,7 +167,7 @@ implementation
pd:=nil; pd:=nil;
constsetlo:=0; constsetlo:=0;
constsethi:=0; constsethi:=0;
constp:=gensinglenode(setconstn,nil); constp:=csetconstnode.create(nil);
constvalue_set:=constset; constvalue_set:=constset;
buildp:=constp; buildp:=constp;
if assigned(left) then if assigned(left) then
@ -147,7 +176,7 @@ implementation
begin begin
p4:=nil; { will contain the tree to create the set } p4:=nil; { will contain the tree to create the set }
{ split a range into p2 and p3 } { split a range into p2 and p3 }
if left.treetype=arrayconstructrangen then if left.nodetype=arrayconstructrangen then
begin begin
p2:=left.left; p2:=left.left;
p3:=left.right; p3:=left.right;
@ -190,7 +219,7 @@ implementation
end end
else else
begin begin
if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then if (p2^.nodetype=ordconstn) and (p3^.nodetype=ordconstn) then
begin begin
if not(is_integer(p3^.resulttype)) then if not(is_integer(p3^.resulttype)) then
pd:=p3^.resulttype pd:=p3^.resulttype
@ -230,7 +259,7 @@ implementation
else else
begin begin
{ Single value } { Single value }
if p2^.treetype=ordconstn then if p2^.nodetype=ordconstn then
begin begin
if not(is_integer(p2^.resulttype)) then if not(is_integer(p2^.resulttype)) then
update_constsethi(p2^.resulttype) update_constsethi(p2^.resulttype)
@ -298,16 +327,15 @@ implementation
p:=buildp; p:=buildp;
end; end;
{$endif dummy}
{***************************************************************************** {*****************************************************************************
TTYPECONVNODE TTYPECONVNODE
*****************************************************************************} *****************************************************************************}
type function ttypeconvnode.first_int_to_int : tnode;
tfirstconvproc = procedure of object;
procedure first_int_to_int(var p : ptree);
begin begin
first_int_to_int:=nil;
if (left.location.loc<>LOC_REGISTER) and if (left.location.loc<>LOC_REGISTER) and
(resulttype^.size>left.resulttype^.size) then (resulttype^.size>left.resulttype^.size) then
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
@ -318,35 +346,37 @@ implementation
end; end;
procedure first_cstring_to_pchar(var p : ptree); function ttypeconvnode.first_cstring_to_pchar : tnode;
begin begin
first_cstring_to_pchar:=nil;
registers32:=1; registers32:=1;
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
end; end;
procedure first_string_to_chararray(var p : ptree); function ttypeconvnode.first_string_to_chararray : tnode;
begin begin
first_string_to_chararray:=nil;
registers32:=1; registers32:=1;
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
end; end;
procedure first_string_to_string(var p : ptree); function ttypeconvnode.first_string_to_string : tnode;
var var
hp : ptree; t : tnode;
begin begin
first_string_to_string:=nil;
if pstringdef(resulttype)^.string_typ<> if pstringdef(resulttype)^.string_typ<>
pstringdef(left.resulttype)^.string_typ then pstringdef(left.resulttype)^.string_typ then
begin begin
if left.treetype=stringconstn then if left.nodetype=stringconstn then
begin begin
left.stringtype:=pstringdef(resulttype)^.string_typ; tstringconstnode(left).stringtype:=pstringdef(resulttype)^.string_typ;
left.resulttype:=resulttype; tstringconstnode(left).resulttype:=resulttype;
{ remove typeconv node } { remove typeconv node }
hp:=p; first_string_to_string:=left;
p:=left; left:=nil;
putnode(hp);
exit; exit;
end end
else else
@ -361,47 +391,49 @@ implementation
end; end;
procedure first_char_to_string(var p : ptree); function ttypeconvnode.first_char_to_string : tnode;
var var
hp : ptree; hp : tstringconstnode;
begin begin
if left.treetype=ordconstn then first_char_to_string:=nil;
if left.nodetype=ordconstn then
begin begin
hp:=genstringconstnode(chr(left.value),st_default); hp:=genstringconstnode(chr(tordconstnode(left).value),st_default);
hp.stringtype:=pstringdef(resulttype)^.string_typ; hp.stringtype:=pstringdef(resulttype)^.string_typ;
firstpass(hp); firstpass(hp);
disposetree(p); first_char_to_string:=hp;
p:=hp;
end end
else else
location.loc:=LOC_MEM; location.loc:=LOC_MEM;
end; end;
procedure first_nothing(var p : ptree); function ttypeconvnode.first_nothing : tnode;
begin begin
first_nothing:=nil;
location.loc:=LOC_MEM; location.loc:=LOC_MEM;
end; end;
procedure first_array_to_pointer(var p : ptree); function ttypeconvnode.first_array_to_pointer : tnode;
begin begin
first_array_to_pointer:=nil;
if registers32<1 then if registers32<1 then
registers32:=1; registers32:=1;
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
end; end;
procedure first_int_to_real(var p : ptree); function ttypeconvnode.first_int_to_real : tnode;
var var
t : ptree; t : trealconstnode;
begin begin
if left.treetype=ordconstn then first_int_to_real:=nil;
if left.nodetype=ordconstn then
begin begin
t:=genrealconstnode(left.value,pfloatdef(resulttype)); t:=genrealconstnode(tordconstnode(left).value,pfloatdef(resulttype));
firstpass(t); firstpass(t);
disposetree(p); first_int_to_real:=t;
p:=t;
exit; exit;
end; end;
if registersfpu<1 then if registersfpu<1 then
@ -410,16 +442,16 @@ implementation
end; end;
procedure first_int_to_fix(var p : ptree); function ttypeconvnode.first_int_to_fix : tnode;
var var
t : ptree; t : tnode;
begin begin
if left.treetype=ordconstn then first_int_to_fix:=nil;
if left.nodetype=ordconstn then
begin begin
t:=genfixconstnode(left.value shl 16,resulttype); t:=genfixconstnode(tordconstnode(left).value shl 16,resulttype);
firstpass(t); firstpass(t);
disposetree(p); first_int_to_fix:=t;
p:=t;
exit; exit;
end; end;
if registers32<1 then if registers32<1 then
@ -428,16 +460,16 @@ implementation
end; end;
procedure first_real_to_fix(var p : ptree); function ttypeconvnode.first_real_to_fix : tnode;
var var
t : ptree; t : tnode;
begin begin
if left.treetype=fixconstn then first_real_to_fix:=nil;
if left.nodetype=realconstn then
begin begin
t:=genfixconstnode(round(left.value_real*65536),resulttype); t:=genfixconstnode(round(trealconstnode(left).value_real*65536),resulttype);
firstpass(t); firstpass(t);
disposetree(p); first_real_to_fix:=t;
p:=t;
exit; exit;
end; end;
{ at least one fpu and int register needed } { at least one fpu and int register needed }
@ -449,16 +481,16 @@ implementation
end; end;
procedure first_fix_to_real(var p : ptree); function ttypeconvnode.first_fix_to_real : tnode;
var var
t : ptree; t : tnode;
begin begin
if left.treetype=fixconstn then first_fix_to_real:=nil;
if left.nodetype=fixconstn then
begin begin
t:=genrealconstnode(round(left.value_fix/65536.0),resulttype); t:=genrealconstnode(round(tfixconstnode(left).value_fix/65536.0),resulttype);
firstpass(t); firstpass(t);
disposetree(p); first_fix_to_real:=t;
p:=t;
exit; exit;
end; end;
if registersfpu<1 then if registersfpu<1 then
@ -467,23 +499,23 @@ implementation
end; end;
procedure first_real_to_real(var p : ptree); function ttypeconvnode.first_real_to_real : tnode;
var var
t : ptree; t : tnode;
begin begin
if left.treetype=realconstn then first_real_to_real:=nil;
if left.nodetype=realconstn then
begin begin
t:=genrealconstnode(left.value_real,resulttype); t:=genrealconstnode(trealconstnode(left).value_real,resulttype);
firstpass(t); firstpass(t);
disposetree(p); first_real_to_real:=t;
p:=t;
exit; exit;
end; end;
{ comp isn't a floating type } { comp isn't a floating type }
{$ifdef i386} {$ifdef i386}
if (pfloatdef(resulttype)^.typ=s64comp) and if (pfloatdef(resulttype)^.typ=s64comp) and
(pfloatdef(left.resulttype)^.typ<>s64comp) and (pfloatdef(left.resulttype)^.typ<>s64comp) and
not (explizit) then not (nf_explizit in flags) then
CGMessage(type_w_convert_real_2_comp); CGMessage(type_w_convert_real_2_comp);
{$endif} {$endif}
if registersfpu<1 then if registersfpu<1 then
@ -492,16 +524,18 @@ implementation
end; end;
procedure first_pointer_to_array(var p : ptree); function ttypeconvnode.first_pointer_to_array : tnode;
begin begin
first_pointer_to_array:=nil;
if registers32<1 then if registers32<1 then
registers32:=1; registers32:=1;
location.loc:=LOC_REFERENCE; location.loc:=LOC_REFERENCE;
end; end;
procedure first_chararray_to_string(var p : ptree); function ttypeconvnode.first_chararray_to_string : tnode;
begin begin
first_chararray_to_string:=nil;
{ the only important information is the location of the } { the only important information is the location of the }
{ result } { result }
{ other stuff is done by firsttypeconv } { other stuff is done by firsttypeconv }
@ -509,21 +543,23 @@ implementation
end; end;
procedure first_cchar_to_pchar(var p : ptree); function ttypeconvnode.first_cchar_to_pchar : tnode;
begin begin
first_cchar_to_pchar:=nil;
left:=gentypeconvnode(left,cshortstringdef); left:=gentypeconvnode(left,cshortstringdef);
{ convert constant char to constant string } { convert constant char to constant string }
firstpass(left); firstpass(left);
{ evalute tree } { evalute tree }
firstpass(p); first_cchar_to_pchar:=pass_1;
end; end;
procedure first_bool_to_int(var p : ptree); function ttypeconvnode.first_bool_to_int : tnode;
begin begin
first_bool_to_int:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must { byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters } be accepted for var parameters }
if (explizit) and if (nf_explizit in flags) and
(left.resulttype^.size=resulttype^.size) and (left.resulttype^.size=resulttype^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit; exit;
@ -533,11 +569,12 @@ implementation
end; end;
procedure first_int_to_bool(var p : ptree); function ttypeconvnode.first_int_to_bool : tnode;
begin begin
first_int_to_bool:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must { byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters } be accepted for var parameters }
if (explizit) and if (nf_explizit in flags) and
(left.resulttype^.size=resulttype^.size) and (left.resulttype^.size=resulttype^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit; exit;
@ -552,16 +589,18 @@ implementation
end; end;
procedure first_bool_to_bool(var p : ptree); function ttypeconvnode.first_bool_to_bool : tnode;
begin begin
first_bool_to_bool:=nil;
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
if registers32<1 then if registers32<1 then
registers32:=1; registers32:=1;
end; end;
procedure first_proc_to_procvar(var p : ptree); function ttypeconvnode.first_proc_to_procvar : tnode;
begin begin
first_proc_to_procvar:=nil;
{ hmmm, I'am not sure if that is necessary (FK) } { hmmm, I'am not sure if that is necessary (FK) }
firstpass(left); firstpass(left);
if codegenerror then if codegenerror then
@ -577,21 +616,22 @@ implementation
end; end;
procedure first_load_smallset(var p : ptree); function ttypeconvnode.first_load_smallset : tnode;
begin begin
first_load_smallset:=nil;
end; end;
procedure first_cord_to_pointer(var p : ptree); function ttypeconvnode.first_cord_to_pointer : tnode;
var var
t : ptree; t : tnode;
begin begin
if left.treetype=ordconstn then first_cord_to_pointer:=nil;
if left.nodetype=ordconstn then
begin begin
t:=genpointerconstnode(left.value,resulttype); t:=genpointerconstnode(tordconstnode(left).value,resulttype);
firstpass(t); firstpass(t);
disposetree(p); first_cord_to_pointer:=t;
p:=t;
exit; exit;
end end
else else
@ -599,75 +639,104 @@ implementation
end; end;
procedure first_pchar_to_string(var p : ptree); function ttypeconvnode.first_pchar_to_string : tnode;
begin begin
first_pchar_to_string:=nil;
location.loc:=LOC_REFERENCE; location.loc:=LOC_REFERENCE;
end; end;
procedure first_ansistring_to_pchar(var p : ptree); function ttypeconvnode.first_ansistring_to_pchar : tnode;
begin begin
first_ansistring_to_pchar:=nil;
location.loc:=LOC_REGISTER; location.loc:=LOC_REGISTER;
if registers32<1 then if registers32<1 then
registers32:=1; registers32:=1;
end; end;
procedure first_arrayconstructor_to_set(var p:ptree); function ttypeconvnode.first_arrayconstructor_to_set : tnode;
var var
hp : ptree; hp : tnode;
begin begin
if left.treetype<>arrayconstructn then first_arrayconstructor_to_set:=nil;
if left.nodetype<>arrayconstructn then
internalerror(5546); internalerror(5546);
{ remove typeconv node } { remove typeconv node }
hp:=p; hp:=left;
p:=left; left:=nil;
putnode(hp);
{ create a set constructor tree } { create a set constructor tree }
arrayconstructor_to_set(p); // !!!!!!!arrayconstructor_to_set(hp);
internalerror(2609001);
{$warning FIX ME !!!!!!!!}
{ now firstpass the set } { now firstpass the set }
firstpass(p); firstpass(hp);
first_arrayconstructor_to_set:=hp;
end; end;
function ttypeconvnode.call_helper(c : tconverttype) : tnode;
procedure firsttypeconv(var p : ptree); {$warning FIX ME !!!!!!!!!}
{
const
firstconvert : array[tconverttype] of pointer = (
@ttypeconvnode.first_nothing), {equal}
@ttypeconvnode.first_nothing, {not_possible}
@ttypeconvnode.first_string_to_string,
@ttypeconvnode.first_char_to_string,
@ttypeconvnode.first_pchar_to_string,
@ttypeconvnode.first_cchar_to_pchar,
@ttypeconvnode.first_cstring_to_pchar,
@ttypeconvnode.first_ansistring_to_pchar,
@ttypeconvnode.first_string_to_chararray,
@ttypeconvnode.first_chararray_to_string,
@ttypeconvnode.first_array_to_pointer,
@ttypeconvnode.first_pointer_to_array,
@ttypeconvnode.first_int_to_int,
@ttypeconvnode.first_int_to_bool,
@ttypeconvnode.first_bool_to_bool,
@ttypeconvnode.first_bool_to_int,
@ttypeconvnode.first_real_to_real,
@ttypeconvnode.first_int_to_real,
@ttypeconvnode.first_int_to_fix,
@ttypeconvnode.first_real_to_fix,
@ttypeconvnode.first_fix_to_real,
@ttypeconvnode.first_proc_to_procvar,
@ttypeconvnode.first_arrayconstructor_to_set,
@ttypeconvnode.first_load_smallset,
@ttypeconvnode.first_cord_to_pointer
);
}
type
tprocedureofobject = function : tnode of object;
var
r : packed record
proc : pointer;
obj : pointer;
end;
begin
{ this is a little bit dirty but it works }
{ and should be quite portable too }
// !!!! r.proc:=firstconvert[c];
{$warning FIX ME !!!!!}
internalerror(2609002);
r.obj:=self;
call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
end;
function ttypeconvnode.pass_1 : tnode;
var var
hp : ptree; hp : tnode;
aprocdef : pprocdef; aprocdef : pprocdef;
const
firstconvert : array[tconverttype] of tfirstconvproc = (
first_nothing, {equal}
first_nothing, {not_possible}
first_string_to_string,
first_char_to_string,
first_pchar_to_string,
first_cchar_to_pchar,
first_cstring_to_pchar,
first_ansistring_to_pchar,
first_string_to_chararray,
first_chararray_to_string,
first_array_to_pointer,
first_pointer_to_array,
first_int_to_int,
first_int_to_bool,
first_bool_to_bool,
first_bool_to_int,
first_real_to_real,
first_int_to_real,
first_int_to_fix,
first_real_to_fix,
first_fix_to_real,
first_proc_to_procvar,
first_arrayconstructor_to_set,
first_load_smallset,
first_cord_to_pointer
);
begin begin
pass_1:=nil;
aprocdef:=nil; aprocdef:=nil;
{ if explicite type cast, then run firstpass } { if explicite type cast, then run firstpass }
if (explizit) or not assigned(left.resulttype) then if (nf_explizit in flags) or not assigned(left.resulttype) then
firstpass(left); firstpass(left);
if (left.treetype=typen) and (left.resulttype=generrordef) then if (left.nodetype=typen) and (left.resulttype=generrordef) then
begin begin
codegenerror:=true; codegenerror:=true;
Message(parser_e_no_type_not_allowed_here); Message(parser_e_no_type_not_allowed_here);
@ -704,7 +773,7 @@ implementation
(psetdef(left.resulttype)^.settype=smallset) then (psetdef(left.resulttype)^.settype=smallset) then
begin begin
{ try to define the set as a normalset if it's a constant set } { try to define the set as a normalset if it's a constant set }
if left.treetype=setconstn then if left.nodetype=setconstn then
begin begin
resulttype:=left.resulttype; resulttype:=left.resulttype;
psetdef(resulttype)^.settype:=normset psetdef(resulttype)^.settype:=normset
@ -715,10 +784,9 @@ implementation
end end
else else
begin begin
hp:=p; pass_1:=left;
p:=left; left.resulttype:=resulttype;
resulttype:=hp.resulttype; left:=nil;
putnode(hp);
exit; exit;
end; end;
end; end;
@ -728,15 +796,15 @@ implementation
procinfo^.flags:=procinfo^.flags or pi_do_call; procinfo^.flags:=procinfo^.flags or pi_do_call;
hp:=gencallnode(overloaded_operators[_assignment],nil); hp:=gencallnode(overloaded_operators[_assignment],nil);
{ tell explicitly which def we must use !! (PM) } { tell explicitly which def we must use !! (PM) }
hp.procdefinition:=aprocdef; tcallnode(hp).procdefinition:=aprocdef;
hp.left:=gencallparanode(left,nil); tcallnode(hp).left:=gencallparanode(left,nil);
putnode(p); left:=nil;
p:=hp; firstpass(hp);
firstpass(p); pass_1:=hp;
exit; exit;
end; end;
if isconvertable(left.resulttype,resulttype,convtyp,left.treetype,explizit)=0 then if isconvertable(left.resulttype,resulttype,convtyp,left.nodetype,nf_explizit in flags)=0 then
begin begin
{Procedures have a resulttype of voiddef and functions of their {Procedures have a resulttype of voiddef and functions of their
own resulttype. They will therefore always be incompatible with own resulttype. They will therefore always be incompatible with
@ -751,20 +819,22 @@ implementation
begin begin
{if left.right=nil then {if left.right=nil then
begin} begin}
if (left.symtableprocentry^.owner^.symtabletype=objectsymtable){ and if (tcallnode(left).symtableprocentry^.owner^.symtabletype=objectsymtable){ and
(pobjectdef(left.symtableprocentry^.owner^.defowner)^.is_class) }then (pobjectdef(left.symtableprocentry^.owner^.defowner)^.is_class) }then
hp:=genloadmethodcallnode(pprocsym(left.symtableprocentry),left.symtableproc, hp:=genloadmethodcallnode(pprocsym(tcallnode(left).symtableprocentry),
getcopy(left.methodpointer)) tcallnode(left).symtableproc,
tcallnode(left).methodpointer.getcopy)
else else
hp:=genloadcallnode(pprocsym(left.symtableprocentry),left.symtableproc); hp:=genloadcallnode(pprocsym(tcallnode(left).symtableprocentry),
disposetree(left); tcallnode(left).symtableproc);
left.free;
firstpass(hp); firstpass(hp);
left:=hp; left:=hp;
aprocdef:=pprocdef(left.resulttype); aprocdef:=pprocdef(left.resulttype);
(* end (* end
else else
begin begin
left.right.treetype:=loadn; left.right.nodetype:=loadn;
left.right.symtableentry:=left.right.symtableentry; left.right.symtableentry:=left.right.symtableentry;
left.right.resulttype:=pvarsym(left.symtableentry)^.definition; left.right.resulttype:=pvarsym(left.symtableentry)^.definition;
hp:=left.right; hp:=left.right;
@ -789,8 +859,8 @@ implementation
end end
else else
begin begin
if (left.treetype<>addrn) then if (left.nodetype<>addrn) then
aprocdef:=pprocsym(left.symtableentry)^.definition; aprocdef:=pprocsym(tloadnode(left).symtableentry)^.definition;
end; end;
convtyp:=tc_proc_2_procvar; convtyp:=tc_proc_2_procvar;
{ Now check if the procedure we are going to assign to { Now check if the procedure we are going to assign to
@ -799,14 +869,14 @@ implementation
begin begin
if not proc_to_procvar_equal(aprocdef,pprocvardef(resulttype)) then if not proc_to_procvar_equal(aprocdef,pprocvardef(resulttype)) then
CGMessage2(type_e_incompatible_types,aprocdef^.typename,resulttype^.typename); CGMessage2(type_e_incompatible_types,aprocdef^.typename,resulttype^.typename);
firstconvert[convtyp](p); pass_1:=call_helper(convtyp);
end end
else else
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
exit; exit;
end; end;
end; end;
if explizit then if nf_explizit in flags then
begin begin
{ check if the result could be in a register } { check if the result could be in a register }
if not(resulttype^.is_intregable) and if not(resulttype^.is_intregable) and
@ -819,7 +889,7 @@ implementation
is_boolean(left.resulttype) then is_boolean(left.resulttype) then
begin begin
convtyp:=tc_bool_2_int; convtyp:=tc_bool_2_int;
firstconvert[convtyp](p); pass_1:=call_helper(convtyp);
exit; exit;
end; end;
{ ansistring to pchar } { ansistring to pchar }
@ -827,7 +897,7 @@ implementation
is_ansistring(left.resulttype) then is_ansistring(left.resulttype) then
begin begin
convtyp:=tc_ansistring_2_pchar; convtyp:=tc_ansistring_2_pchar;
firstconvert[convtyp](p); pass_1:=call_helper(convtyp);
exit; exit;
end; end;
{ do common tc_equal cast } { do common tc_equal cast }
@ -837,12 +907,11 @@ implementation
if (left.resulttype^.deftype=enumdef) and if (left.resulttype^.deftype=enumdef) and
is_ordinal(resulttype) then is_ordinal(resulttype) then
begin begin
if left.treetype=ordconstn then if left.nodetype=ordconstn then
begin begin
hp:=genordinalconstnode(left.value,resulttype); hp:=genordinalconstnode(tordconstnode(left).value,resulttype);
disposetree(p);
firstpass(hp); firstpass(hp);
p:=hp; pass_1:=hp;
exit; exit;
end end
else else
@ -857,12 +926,11 @@ implementation
if (resulttype^.deftype=enumdef) and if (resulttype^.deftype=enumdef) and
is_ordinal(left.resulttype) then is_ordinal(left.resulttype) then
begin begin
if left.treetype=ordconstn then if left.nodetype=ordconstn then
begin begin
hp:=genordinalconstnode(left.value,resulttype); hp:=genordinalconstnode(tordconstnode(left).value,resulttype);
disposetree(p);
firstpass(hp); firstpass(hp);
p:=hp; pass_1:=hp;
exit; exit;
end end
else else
@ -874,12 +942,11 @@ implementation
{ nil to ordinal node } { nil to ordinal node }
else if is_ordinal(resulttype) and else if is_ordinal(resulttype) and
(left.treetype=niln) then (left.nodetype=niln) then
begin begin
hp:=genordinalconstnode(0,resulttype); hp:=genordinalconstnode(0,resulttype);
firstpass(hp); firstpass(hp);
disposetree(p); pass_1:=hp;
p:=hp;
exit; exit;
end end
@ -888,12 +955,11 @@ implementation
if is_char(resulttype) and if is_char(resulttype) and
is_ordinal(left.resulttype) then is_ordinal(left.resulttype) then
begin begin
if left.treetype=ordconstn then if left.nodetype=ordconstn then
begin begin
hp:=genordinalconstnode(left.value,resulttype); hp:=genordinalconstnode(tordconstnode(left).value,resulttype);
firstpass(hp); firstpass(hp);
disposetree(p); pass_1:=hp;
p:=hp;
exit; exit;
end end
else else
@ -908,12 +974,11 @@ implementation
if is_char(left.resulttype) and if is_char(left.resulttype) and
is_ordinal(resulttype) then is_ordinal(resulttype) then
begin begin
if left.treetype=ordconstn then if left.nodetype=ordconstn then
begin begin
hp:=genordinalconstnode(left.value,resulttype); hp:=genordinalconstnode(tordconstnode(left).value,resulttype);
firstpass(hp); firstpass(hp);
disposetree(p); pass_1:=hp;
p:=hp;
exit; exit;
end end
else else
@ -931,7 +996,7 @@ implementation
(left.resulttype^.deftype=formaldef) or (left.resulttype^.deftype=formaldef) or
(left.resulttype^.size=resulttype^.size) or (left.resulttype^.size=resulttype^.size) or
(is_equal(left.resulttype,voiddef) and (is_equal(left.resulttype,voiddef) and
(left.treetype=derefn)) (left.nodetype=derefn))
) then ) then
CGMessage(cg_e_illegal_type_conversion); CGMessage(cg_e_illegal_type_conversion);
if ((left.resulttype^.deftype=orddef) and if ((left.resulttype^.deftype=orddef) and
@ -963,10 +1028,10 @@ implementation
if (m_tp_procvar in aktmodeswitches) and if (m_tp_procvar in aktmodeswitches) and
(resulttype^.deftype<>procvardef) and (resulttype^.deftype<>procvardef) and
(left.resulttype^.deftype=procvardef) and (left.resulttype^.deftype=procvardef) and
(left.treetype=loadn) then (left.nodetype=loadn) then
begin begin
hp:=gencallnode(nil,nil); hp:=gencallnode(nil,nil);
hp.right:=left; tcallnode(hp).right:=left;
firstpass(hp); firstpass(hp);
left:=hp; left:=hp;
end; end;
@ -974,18 +1039,17 @@ implementation
{ ordinal contants can be directly converted } { ordinal contants can be directly converted }
{ but not int64/qword } { but not int64/qword }
if (left.treetype=ordconstn) and is_ordinal(resulttype) and if (left.nodetype=ordconstn) and is_ordinal(resulttype) and
not(is_64bitint(resulttype)) then not(is_64bitint(resulttype)) then
begin begin
{ range checking is done in genordinalconstnode (PFV) } { range checking is done in genordinalconstnode (PFV) }
hp:=genordinalconstnode(left.value,resulttype); hp:=genordinalconstnode(tordconstnode(left).value,resulttype);
disposetree(p);
firstpass(hp); firstpass(hp);
p:=hp; pass_1:=hp;
exit; exit;
end; end;
if convtyp<>tc_equal then if convtyp<>tc_equal then
firstconvert[convtyp](p); pass_1:=call_helper(convtyp);
end; end;
@ -1003,16 +1067,16 @@ implementation
begin begin
pass_1:=nil; pass_1:=nil;
firstpass(left); firstpass(left);
set_varstate(left,true); left.set_varstate(true);
firstpass(right); firstpass(right);
set_varstate(right,true); right.set_varstate(true);
if codegenerror then if codegenerror then
exit; exit;
if (right.resulttype^.deftype<>classrefdef) then if (right.resulttype^.deftype<>classrefdef) then
CGMessage(type_e_mismatch); CGMessage(type_e_mismatch);
left_right_max(p); left_right_max;
{ left must be a class } { left must be a class }
if (left.resulttype^.deftype<>objectdef) or if (left.resulttype^.deftype<>objectdef) or
@ -1054,7 +1118,7 @@ implementation
if (right.resulttype^.deftype<>classrefdef) then if (right.resulttype^.deftype<>classrefdef) then
CGMessage(type_e_mismatch); CGMessage(type_e_mismatch);
left_right_max(p); left_right_max;
{ left must be a class } { left must be a class }
if (left.resulttype^.deftype<>objectdef) or if (left.resulttype^.deftype<>objectdef) or
@ -1080,10 +1144,12 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.2 2000-09-26 14:59:34 florian Revision 1.3 2000-09-26 20:06:13 florian
* hmm, still a lot of work to get things compilable
Revision 1.2 2000/09/26 14:59:34 florian
* more conversion work done * more conversion work done
Revision 1.1 2000/09/25 15:37:14 florian Revision 1.1 2000/09/25 15:37:14 florian
* more fixes * more fixes
} }

30
compiler/node.inc
View File

@ -1,4 +1,4 @@
7{ {
$Id$ $Id$
Copyright (c) 1999-2000 by Florian Klaempfl Copyright (c) 1999-2000 by Florian Klaempfl
@ -597,6 +597,29 @@
include(flags,nf_swaped); include(flags,nf_swaped);
end; end;
procedure tbinarynode.left_right_max;
begin
if assigned(left) then
begin
if assigned(right) then
begin
registers32:=max(left.registers32,right.registers32);
registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
registersmmx:=max(left.registersmmx,right.registersmmx);
{$endif SUPPORT_MMX}
end
else
begin
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
end;
end;
end;
{**************************************************************************** {****************************************************************************
TBINOPYNODE TBINOPYNODE
****************************************************************************} ****************************************************************************}
@ -617,7 +640,10 @@
end; end;
{ {
$Log$ $Log$
Revision 1.3 2000-09-22 21:45:36 florian Revision 1.4 2000-09-26 20:06:13 florian
* hmm, still a lot of work to get things compilable
Revision 1.3 2000/09/22 21:45:36 florian
* some updates e.g. getcopy added * some updates e.g. getcopy added
Revision 1.2 2000/09/20 21:52:38 florian Revision 1.2 2000/09/20 21:52:38 florian

6
compiler/nodeh.inc
View File

@ -316,6 +316,7 @@
procedure swapleftright; procedure swapleftright;
function isbinaryoverloaded(var t : tnode) : boolean; function isbinaryoverloaded(var t : tnode) : boolean;
function getcopy : tnode;override; function getcopy : tnode;override;
procedure left_right_max;
end; end;
pbinopnode = ^tbinopnode; pbinopnode = ^tbinopnode;
@ -326,7 +327,10 @@
{ {
$Log$ $Log$
Revision 1.7 2000-09-26 14:59:34 florian Revision 1.8 2000-09-26 20:06:13 florian
* hmm, still a lot of work to get things compilable
Revision 1.7 2000/09/26 14:59:34 florian
* more conversion work done * more conversion work done
Revision 1.6 2000/09/25 15:37:14 florian Revision 1.6 2000/09/25 15:37:14 florian