paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-03 10:18:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
florian 2000-09-28 19:49:51 +00:00
parent 95c8173a7b
commit 57a566e53d
13 changed files with 440 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
compiler/htypechk.pas
View File

@ -108,7 +108,7 @@ interface
{ Register Allocation }
procedure make_not_regable(p : tnode);
procedure calcregisters(p : tnode;r32,fpu,mmx : word);
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
{ subroutine handling }
procedure test_protected_sym(sym : psym);
@ -161,7 +161,8 @@ implementation
globtype,systems,
cutils,cobjects,verbose,globals,
symconst,
types,pass_1,cpubase,
types,pass_1,cpubase,ncnv,nld,
nmem,ncal,
{$ifdef newcg}
cgbase
{$else}
@ -796,21 +797,21 @@ implementation
{ marks an lvalue as "unregable" }
procedure make_not_regable(p : tnode);
begin
case p.treetype of
case p.nodetype of
typeconvn :
make_not_regable(p.left);
make_not_regable(ttypeconvnode(p).left);
loadn :
if p.symtableentry^.typ=varsym then
pvarsym(p.symtableentry)^.varoptions:=pvarsym(p.symtableentry)^.varoptions-[vo_regable,vo_fpuregable];
if tloadnode(p).symtableentry^.typ=varsym then
pvarsym(tloadnode(p).symtableentry)^.varoptions:=pvarsym(tloadnode(p).symtableentry)^.varoptions-[vo_regable,vo_fpuregable];
end;
end;
{ calculates the needed registers for a binary operator }
procedure calcregisters(p : tnode;r32,fpu,mmx : word);
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
begin
left_right_max(p);
p.left_right_max;
{ Only when the difference between the left and right registers < the
wanted registers allocate the amount of registers }
@ -819,12 +820,12 @@ implementation
begin
if assigned(p.right) then
begin
if (abs(p.left^.registers32-p.right^.registers32)<r32) then
if (abs(p.left.registers32-p.right.registers32)<r32) then
inc(p.registers32,r32);
if (abs(p.left^.registersfpu-p.right^.registersfpu)<fpu) then
if (abs(p.left.registersfpu-p.right.registersfpu)<fpu) then
inc(p.registersfpu,fpu);
{$ifdef SUPPORT_MMX}
if (abs(p.left^.registersmmx-p.right^.registersmmx)<mmx) then
if (abs(p.left.registersmmx-p.right.registersmmx)<mmx) then
inc(p.registersmmx,mmx);
{$endif SUPPORT_MMX}
{ the following is a little bit guessing but I think }
@ -833,21 +834,21 @@ implementation
{ and return a mem location, but the current node }
{ doesn't use an integer register we get probably }
{ trouble when restoring a node }
if (p.left^.registers32=p.right^.registers32) and
(p.registers32=p.left^.registers32) and
if (p.left.registers32=p.right.registers32) and
(p.registers32=p.left.registers32) and
(p.registers32>0) and
(p.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and
(p.right^.location.loc in [LOC_REFERENCE,LOC_MEM]) then
(p.left.location.loc in [LOC_REFERENCE,LOC_MEM]) and
(p.right.location.loc in [LOC_REFERENCE,LOC_MEM]) then
inc(p.registers32);
end
else
begin
if (p.left^.registers32<r32) then
if (p.left.registers32<r32) then
inc(p.registers32,r32);
if (p.left^.registersfpu<fpu) then
if (p.left.registersfpu<fpu) then
inc(p.registersfpu,fpu);
{$ifdef SUPPORT_MMX}
if (p.left^.registersmmx<mmx) then
if (p.left.registersmmx<mmx) then
inc(p.registersmmx,mmx);
{$endif SUPPORT_MMX}
end;
@ -883,15 +884,15 @@ implementation
procedure test_protected(p : tnode);
begin
case p.treetype of
loadn : test_protected_sym(p.symtableentry);
typeconvn : test_protected(p.left);
derefn : test_protected(p.left);
case p.nodetype of
loadn : test_protected_sym(tloadnode(p).symtableentry);
typeconvn : test_protected(ttypeconvnode(p).left);
derefn : test_protected(tderefnode(p).left);
subscriptn : begin
{ test_protected(p.left);
Is a field of a protected var
also protected ??? PM }
test_protected_sym(p.vs);
test_protected_sym(tsubscriptnode(p).vs);
end;
end;
end;
@ -900,11 +901,11 @@ implementation
var
v : boolean;
begin
case p.treetype of
case p.nodetype of
loadn :
v:=(p.symtableentry^.typ in [typedconstsym,varsym]);
v:=(tloadnode(p).symtableentry^.typ in [typedconstsym,varsym]);
typeconvn :
v:=valid_for_formal_var(p.left);
v:=valid_for_formal_var(ttypeconvnode(p).left);
derefn,
subscriptn,
vecn,
@ -912,12 +913,12 @@ implementation
selfn :
v:=true;
calln : { procvars are callnodes first }
v:=assigned(p.right) and not assigned(p.left);
v:=assigned(tcallnode(p).right) and not assigned(tcallnode(p).left);
addrn :
begin
{ addrn is not allowed as this generate a constant value,
but a tp procvar are allowed (PFV) }
if p.procvarload then
if nf_procvarload in p.flags then
v:=true
else
v:=false;
@ -928,20 +929,20 @@ implementation
valid_for_formal_var:=v;
end;
function valid_for_formal_const(p : ptree) : boolean;
function valid_for_formal_const(p : tnode) : boolean;
var
v : boolean;
begin
{ p must have been firstpass'd before }
{ accept about anything but not a statement ! }
case p.treetype of
case p.nodetype of
calln,
statementn,
addrn :
begin
{ addrn is not allowed as this generate a constant value,
but a tp procvar are allowed (PFV) }
if p.procvarload then
if nf_procvarload in p.flags then
v:=true
else
v:=false;
@ -952,20 +953,20 @@ implementation
valid_for_formal_const:=v;
end;
function is_procsym_load(p:Ptree):boolean;
function is_procsym_load(p:tnode):boolean;
begin
is_procsym_load:=((p.treetype=loadn) and (p.symtableentry^.typ=procsym)) or
((p.treetype=addrn) and (p.left^.treetype=loadn)
and (p.left^.symtableentry^.typ=procsym)) ;
is_procsym_load:=((p.nodetype=loadn) and (tloadnode(p).symtableentry^.typ=procsym)) or
((p.nodetype=addrn) and (taddrnode(p).left.nodetype=loadn)
and (tloadnode(taddrnode(p).left).symtableentry^.typ=procsym)) ;
end;
{ change a proc call to a procload for assignment to a procvar }
{ this can only happen for proc/function without arguments }
function is_procsym_call(p:Ptree):boolean;
function is_procsym_call(p:tnode):boolean;
begin
is_procsym_call:=(p.treetype=calln) and (p.left=nil) and
(((p.symtableprocentry^.typ=procsym) and (p.right=nil)) or
((p.right<>nil) and (p.right^.symtableprocentry^.typ=varsym)));
is_procsym_call:=(p.nodetype=calln) and (tcallnode(p).left=nil) and
(((tcallnode(p).symtableprocentry^.typ=procsym) and (tcallnode(p).right=nil)) or
(assigned(tcallnode(p).right) and (tcallnode(tcallnode(p).right).symtableprocentry^.typ=varsym)));
end;
@ -1021,17 +1022,17 @@ implementation
begin
{ property allowed? calln has a property check itself }
if (not allowprop) and
(hp.isproperty) and
(hp.treetype<>calln) then
(nf_isproperty in hp.flags) and
(hp.nodetype<>calln) then
begin
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
exit;
end;
case hp.treetype of
case hp.nodetype of
derefn :
begin
gotderef:=true;
hp:=hp.left;
hp:=tderefnode(hp).left;
end;
typeconvn :
begin
@ -1046,19 +1047,19 @@ implementation
begin
{ pointer -> array conversion is done then we need to see it
as a deref, because a ^ is then not required anymore }
if (hp.left^.resulttype^.deftype=pointerdef) then
if (ttypeconvnode(hp).left.resulttype^.deftype=pointerdef) then
gotderef:=true;
end;
end;
hp:=hp.left;
hp:=ttypeconvnode(hp).left;
end;
vecn,
asn :
hp:=hp.left;
hp:=tunarynode(hp).left;
subscriptn :
begin
gotsubscript:=true;
hp:=hp.left;
hp:=tsubscriptnode(hp).left;
end;
subn,
addn :
@ -1075,7 +1076,7 @@ implementation
addrn :
begin
if not(gotderef) and
not(hp.procvarload) then
not(nf_procvarload in hp.flags) then
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
exit;
end;
@ -1102,7 +1103,7 @@ implementation
3. property is allowed }
if (gotpointer and gotderef) or
(gotclass and (gotsubscript or gotwith)) or
(hp.isproperty and allowprop) then
((nf_isproperty in hp.flags) and allowprop) then
valid_for_assign:=true
else
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
@ -1110,32 +1111,32 @@ implementation
end;
loadn :
begin
case hp.symtableentry^.typ of
case tloadnode(hp).symtableentry^.typ of
absolutesym,
varsym :
begin
if (pvarsym(hp.symtableentry)^.varspez=vs_const) then
if (pvarsym(tloadnode(hp).symtableentry)^.varspez=vs_const) then
begin
{ allow p^:= constructions with p is const parameter }
if gotderef then
valid_for_assign:=true
else
CGMessagePos(hp.fileinfo,type_e_no_assign_to_const);
CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
exit;
end;
{ Are we at a with symtable, then we need to process the
withrefnode also to check for maybe a const load }
if (hp.symtable^.symtabletype=withsymtable) then
if (tloadnode(hp).symtable^.symtabletype=withsymtable) then
begin
{ continue with processing the withref node }
hp:=ptree(pwithsymtable(hp.symtable)^.withrefnode);
hp:=tnode(pwithsymtable(tloadnode(hp).symtable)^.withrefnode);
gotwith:=true;
end
else
begin
{ set the assigned flag for varsyms }
if (pvarsym(hp.symtableentry)^.varstate=vs_declared) then
pvarsym(hp.symtableentry)^.varstate:=vs_assigned;
if (pvarsym(tloadnode(hp).symtableentry)^.varstate=vs_declared) then
pvarsym(tloadnode(hp).symtableentry)^.varstate:=vs_assigned;
valid_for_assign:=true;
exit;
end;
@ -2172,7 +2173,10 @@ implementation
end.
{
$Log$
Revision 1.8 2000-09-27 18:14:31 florian
Revision 1.9 2000-09-28 19:49:51 florian
*** empty log message ***
Revision 1.8 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.7 2000/09/26 20:06:13 florian

13
compiler/nadd.pas
View File

@ -157,7 +157,7 @@ implementation
if porddef(left.resulttype)^.typ>porddef(right.resulttype)^.typ then
begin
right:=gentypeconvnode(right,porddef(left.resulttype));
ttypeconvnode(right).convtyp:=tc_bool_2_int;
ttypeconvnode(right).convtype:=tc_bool_2_int;
include(right.flags,nf_explizit);
firstpass(right);
end
@ -165,7 +165,7 @@ implementation
if porddef(left.resulttype)^.typ<porddef(right.resulttype)^.typ then
begin
left:=gentypeconvnode(left,porddef(right.resulttype));
ttypeconvnode(left).convtyp:=tc_bool_2_int;
ttypeconvnode(left).convtype:=tc_bool_2_int;
include(left.flags,nf_explizit);
firstpass(left);
end;
@ -488,14 +488,14 @@ implementation
if left.location.loc=LOC_FLAGS then
begin
left:=gentypeconvnode(left,porddef(left.resulttype));
left.convtyp:=tc_bool_2_int;
left.convtype:=tc_bool_2_int;
left.explizit:=true;
firstpass(left);
end;
if right.location.loc=LOC_FLAGS then
begin
right:=gentypeconvnode(right,porddef(right.resulttype));
right.convtyp:=tc_bool_2_int;
right.convtype:=tc_bool_2_int;
right.explizit:=true;
firstpass(right);
end;
@ -1316,7 +1316,10 @@ begin
end.
{
$Log$
Revision 1.9 2000-09-27 21:33:22 florian
Revision 1.10 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.9 2000/09/27 21:33:22 florian
* finally nadd.pas compiles
Revision 1.8 2000/09/27 20:25:44 florian

150
compiler/ncal.pas
View File

@ -51,7 +51,6 @@ interface
{ constructor }
constructor create(expr,next : tnode);virtual;
destructor destroy;override;
function pass_1 : tnode;override;
procedure gen_high_tree(openstring:boolean);
{ tcallparanode doesn't use pass_1 }
{ tcallnode takes care of this }
@ -150,7 +149,6 @@ interface
{$endif def extdebug}
{convtyp : tconverttype;}
begin
firstcallparan:=nil;
inc(parsing_para_level);
{$ifdef extdebug}
if do_count then
@ -162,9 +160,9 @@ interface
if assigned(right) then
begin
if defcoll=nil then
right.firstcallparan(nil,do_count)
tcallparanode(right).firstcallparan(nil,do_count)
else
right.firstcallparan(pparaitem(defcoll^.next),do_count);
tcallparanode(right).firstcallparan(pparaitem(defcoll^.next),do_count);
registers32:=right.registers32;
registersfpu:=right.registersfpu;
{$ifdef SUPPORT_MMX}
@ -206,14 +204,14 @@ interface
if assigned(aktcallprocsym) and
(pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
(po_external in aktcallprocsym^.definition^.procoptions) then
left.cargs:=true;
include(left.flags,nf_cargs);
{ force variant array }
left.forcevaria:=true;
include(left.flags,nf_forcevaria);
end
else
begin
left.novariaallowed:=true;
left.constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
include(left.flags,nf_novariaallowed);
tarrayconstructnode(left).constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
end;
end;
@ -221,7 +219,7 @@ interface
begin
{ not completly proper, but avoids some warnings }
if (defcoll^.paratyp=vs_var) then
set_funcret_is_valid(left);
left.set_funcret_is_valid;
{ protected has nothing to do with read/write
if (defcoll^.paratyp=vs_var) then
@ -252,7 +250,7 @@ interface
CGMessagePos(left.fileinfo,type_e_argument_cant_be_assigned);
{ generate the high() value tree }
if push_high_param(defcoll^.paratype.def) then
gen_high_tree(p,is_open_string(defcoll^.paratype.def));
gen_high_tree(is_open_string(defcoll^.paratype.def));
if not(is_shortstring(left.resulttype) and
is_shortstring(defcoll^.paratype.def)) and
(defcoll^.paratype.def^.deftype<>formaldef) then
@ -355,7 +353,7 @@ interface
{ Causes problems with const ansistrings if also }
{ done for vs_const (JM) }
if defcoll^.paratyp = vs_var then
set_unique(left);
left.set_unique;
make_not_regable(left);
end;
@ -437,7 +435,7 @@ interface
end
else
begin
hightree:=gennode(subn,geninlinenode(in_length_string,false,getcopy(left)),
hightree:=caddnode.create(subn,geninlinenode(in_length_string,false,left.getcopy),
genordinalconstnode(1,s32bitdef));
firstpass(hightree);
hightree:=gentypeconvnode(hightree,s32bitdef);
@ -526,11 +524,11 @@ interface
the specified value matches the range }
or
(
(left.treetype=ordconstn) and
(left.nodetype=ordconstn) and
is_integer(resulttype) and
is_integer(def) and
(left.value>=porddef(def)^.low) and
(left.value<=porddef(def)^.high)
(tordconstnode(left).value>=porddef(def)^.low) and
(tordconstnode(left).value<=porddef(def)^.high)
)
{ to support ansi/long/wide strings in a proper way }
{ string and string[10] are assumed as equal }
@ -542,12 +540,12 @@ interface
)
or
(
(left.treetype=stringconstn) and
(left.nodetype=stringconstn) and
(is_ansistring(resulttype) and is_pchar(def))
)
or
(
(left.treetype=ordconstn) and
(left.nodetype=ordconstn) and
(is_char(resulttype) and (is_shortstring(def) or is_ansistring(def)))
)
{ set can also be a not yet converted array constructor }
@ -560,8 +558,8 @@ interface
or
(
(m_tp_procvar in aktmodeswitches) and
(def^.deftype=procvardef) and (left.treetype=calln) and
(proc_to_procvar_equal(pprocdef(left.procdefinition),pprocvardef(def)))
(def^.deftype=procvardef) and (left.nodetype=calln) and
(proc_to_procvar_equal(pprocdef(tcallnode(left).procdefinition),pprocvardef(def)))
)
;
end;
@ -625,19 +623,19 @@ interface
{ calculate the type of the parameters }
if assigned(left) then
begin
firstcallparan(left,nil,false);
tcallparanode(left).firstcallparan(nil,false);
if codegenerror then
goto errorexit;
end;
firstpass(right);
set_varstate(right,true);
right.set_varstate(true);
{ check the parameters }
pdc:=pparaitem(pprocvardef(right.resulttype)^.para^.first);
pt:=left;
while assigned(pdc) and assigned(pt) do
begin
pt:=pt.right;
pt:=tcallparanode(pt).right;
pdc:=pparaitem(pdc^.next);
end;
if assigned(pt) or assigned(pdc) then
@ -649,7 +647,7 @@ interface
{ insert type conversions }
if assigned(left) then
begin
firstcallparan(left,pparaitem(pprocvardef(right.resulttype)^.para^.first),true);
tcallparanode(left).firstcallparan(pparaitem(pprocvardef(right.resulttype)^.para^.first),true);
if codegenerror then
goto errorexit;
end;
@ -665,7 +663,7 @@ interface
{ determine the type of the parameters }
if assigned(left) then
begin
firstcallparan(left,nil,false);
tcallparanode(left).firstcallparan(nil,false);
if codegenerror then
goto errorexit;
end;
@ -705,7 +703,7 @@ interface
while assigned(pt) do
begin
inc(paralength);
pt:=pt.right;
pt:=tcallparanode(pt).right;
end;
{ link all procedures which have the same # of parameters }
@ -742,7 +740,7 @@ interface
if (symtableprocentry^.owner^.symtabletype=objectsymtable) and
(pobjectdef(symtableprocentry^.owner^.defowner)^.is_class) then
hpt:=genloadmethodcallnode(pprocsym(symtableprocentry),symtableproc,
getcopy(methodpointer))
methodpointer.getcopy)
else
hpt:=genloadcallnode(pprocsym(symtableprocentry),symtableproc);
firstpass(hpt);
@ -783,7 +781,7 @@ interface
begin
if hp^.nextpara^.paratype.def=pt.resulttype then
begin
pt.exact_match_found:=true;
include(pt.flags,nf_exact_match_found);
hp^.nextpara^.argconvtyp:=act_exact;
end
else
@ -794,10 +792,10 @@ interface
begin
hp^.nextpara^.argconvtyp:=act_convertable;
hp^.nextpara^.convertlevel:=isconvertable(pt.resulttype,hp^.nextpara^.paratype.def,
hcvt,pt.left.treetype,false);
hcvt,tcallparanode(pt).left.nodetype,false);
case hp^.nextpara^.convertlevel of
1 : pt.convlevel1found:=true;
2 : pt.convlevel2found:=true;
1 : include(pt.flags,nf_convlevel1found);
2 : include(pt.flags,nf_convlevel2found);
end;
end;
@ -856,7 +854,7 @@ interface
end;
{ load next parameter or quit loop if no procs left }
if assigned(procs) then
pt:=pt.right
pt:=tcallparanode(pt).right
else
break;
end;
@ -965,7 +963,7 @@ interface
hp^.nextpara:=pparaitem(hp^.nextpara^.next);
hp:=hp^.next;
end;
pt:=pt.right;
pt:=tcallparanode(pt).right;
end;
end;
@ -984,7 +982,7 @@ interface
pt:=left;
while assigned(pt) do
begin
if pt.exact_match_found then
if nf_exact_match_found in pt.flags then
begin
hp:=procs;
procs:=nil;
@ -1009,7 +1007,7 @@ interface
hp^.nextpara:=pparaitem(hp^.nextpara^.next);
hp:=hp^.next;
end;
pt:=pt.right;
pt:=tcallparanode(pt).right;
end;
end;
@ -1031,7 +1029,7 @@ interface
while assigned(pt) do
begin
bestord:=nil;
if (pt.left.treetype=ordconstn) and
if (tcallparanode(pt).left.nodetype=ordconstn) and
is_integer(pt.resulttype) then
begin
hp:=procs;
@ -1078,7 +1076,7 @@ interface
hp^.nextpara:=pparaitem(hp^.nextpara^.next);
hp:=hp^.next;
end;
pt:=pt.right;
pt:=tcallparanode(pt).right;
end;
end;
@ -1100,7 +1098,8 @@ interface
pt:=left;
while assigned(pt) do
begin
if pt.convlevel1found and pt.convlevel2found then
if (nf_convlevel1found in pt.flags) and
(nf_convlevel2found in pt.flags) then
begin
hp:=procs;
procs:=nil;
@ -1126,7 +1125,7 @@ interface
hp^.nextpara:=pparaitem(hp^.nextpara^.next);
hp:=hp^.next;
end;
pt:=pt.right;
pt:=tcallparanode(pt).right;
end;
end;
@ -1168,7 +1167,7 @@ interface
(procdefinition^._class=nil) then
begin
{ not ok for extended }
case methodpointer^.treetype of
case methodpointer^.nodetype of
typen,hnewn : fatalerror(no_para_match);
end;
methodpointer.free;
@ -1179,19 +1178,20 @@ interface
is_const:=(pocall_internconst in procdefinition^.proccalloptions) and
((block_type=bt_const) or
(assigned(left) and (left.left.treetype in [realconstn,ordconstn])));
(assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
{ handle predefined procedures }
if (pocall_internproc in procdefinition^.proccalloptions) or is_const then
begin
if assigned(left) then
begin
{ settextbuf needs two args }
if assigned(left.right) then
if assigned(tcallparanode(left).right) then
pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,left)
else
begin
pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,left.left);
left.left:=nil;
pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,
tcallparanode(left).left);
tcallparanode(left).left:=nil;
left.free;
end;
end
@ -1211,13 +1211,13 @@ interface
begin
if assigned(methodpointer) then
CGMessage(cg_e_unable_inline_object_methods);
if assigned(right) and (right.treetype<>procinlinen) then
if assigned(right) and (right.nodetype<>procinlinen) then
CGMessage(cg_e_unable_inline_procvar);
{ treetype:=procinlinen; }
{ nodetype:=procinlinen; }
if not assigned(right) then
begin
if assigned(pprocdef(procdefinition)^.code) then
inlinecode:=genprocinlinenode(p,ptree(pprocdef(procdefinition)^.code))
inlinecode:=genprocinlinenode(self,tnode(pprocdef(procdefinition)^.code))
else
CGMessage(cg_e_no_code_for_inline_stored);
if assigned(inlinecode) then
@ -1256,9 +1256,7 @@ interface
{ work trough all parameters to insert the type conversions }
if assigned(left) then
begin
firstcallparan(left,pparaitem(procdefinition^.para^.first),true);
end;
tcallparanode(left).firstcallparan(pparaitem(procdefinition^.para^.first),true);
{$ifndef newcg}
{$ifdef i386}
incrementregisterpushed(pprocdef(procdefinition)^.usedregisters);
@ -1281,13 +1279,13 @@ interface
begin
{ extra handling of classes }
{ methodpointer should be assigned! }
if assigned(methodpointer) and assigned(methodpointer^.resulttype) and
(methodpointer^.resulttype^.deftype=classrefdef) then
if assigned(methodpointer) and assigned(methodpointer.resulttype) and
(methodpointer.resulttype^.deftype=classrefdef) then
begin
location.loc:=LOC_REGISTER;
registers32:=1;
{ the result type depends on the classref }
resulttype:=pclassrefdef(methodpointer^.resulttype)^.pointertype.def;
resulttype:=pclassrefdef(methodpointer.resulttype)^.pointertype.def;
end
{ a object constructor returns the result with the flags }
else
@ -1339,7 +1337,7 @@ interface
{ if this is a call to a method calc the registers }
if (methodpointer<>nil) then
begin
case methodpointer^.treetype of
case methodpointer.nodetype of
{ but only, if this is not a supporting node }
typen: ;
{ we need one register for new return value PM }
@ -1348,8 +1346,8 @@ interface
else
begin
if (procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
assigned(symtable) and (symtable^.symtabletype=withsymtable) and
not pwithsymtable(symtable)^.direct_with then
assigned(symtableproc) and (symtableproc^.symtabletype=withsymtable) and
not pwithsymtable(symtableproc)^.direct_with then
begin
CGmessage(cg_e_cannot_call_cons_dest_inside_with);
end; { Is accepted by Delphi !! }
@ -1359,22 +1357,22 @@ interface
{ R.Assign is not a constructor !!! }
{ but for R^.Assign, R must be valid !! }
if (procdefinition^.proctypeoption=potype_constructor) or
((methodpointer^.treetype=loadn) and
(not(oo_has_virtual in pobjectdef(methodpointer^.resulttype)^.objectoptions))) then
((methodpointer.nodetype=loadn) and
(not(oo_has_virtual in pobjectdef(methodpointer.resulttype)^.objectoptions))) then
method_must_be_valid:=false
else
method_must_be_valid:=true;
firstpass(methodpointer);
set_varstate(methodpointer,method_must_be_valid);
methodpointer.set_varstate(method_must_be_valid);
{ The object is already used ven if it is called once }
if (methodpointer^.treetype=loadn) and
(methodpointer^.symtableentry^.typ=varsym) then
pvarsym(methodpointer^.symtableentry)^.varstate:=vs_used;
if (methodpointer.nodetype=loadn) and
(tloadnode(methodpointer).symtableentry^.typ=varsym) then
pvarsym(tloadnode(methodpointer).symtableentry)^.varstate:=vs_used;
registersfpu:=max(methodpointer^.registersfpu,registersfpu);
registers32:=max(methodpointer^.registers32,registers32);
registersfpu:=max(methodpointer.registersfpu,registersfpu);
registers32:=max(methodpointer.registers32,registers32);
{$ifdef SUPPORT_MMX}
registersmmx:=max(methodpointer^.registersmmx,registersmmx);
registersmmx:=max(methodpointer.registersmmx,registersmmx);
{$endif SUPPORT_MMX}
end;
end;
@ -1414,11 +1412,11 @@ interface
TPROCINLINENODE
****************************************************************************}
constructor tprocinlinenode.create(callp,code : tnode) : tnode;
constructor tprocinlinenode.create(callp,code : tnode);
begin
inherited create(procinlinen);
inlineprocsym:=callp.symtableprocentry;
inlineprocsym:=tcallnode(callp).symtableprocentry;
retoffset:=-4; { less dangerous as zero (PM) }
para_offset:=0;
{$IFDEF NEWST}
@ -1443,6 +1441,21 @@ interface
{$ENDIF NEWST}
end;
function tprocinlinenode.getcopy : tnode;
var
n : tprocinlinenode;
begin
n:=tprocinlinenode(inherited getcopy);
n.inlinetree:=inlinetree.getcopy;
n.inlineprocsym:=inlineprocsym;
n.retoffset:=retoffset;
n.para_offset:=para_offset;
n.para_size:=para_size;
getcopy:=n;
end;
function tprocinlinenode.pass_1 : tnode;
begin
pass_1:=nil;
@ -1459,7 +1472,10 @@ begin
end.
{
$Log$
Revision 1.6 2000-09-27 18:14:31 florian
Revision 1.7 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.6 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.5 2000/09/24 21:15:34 florian

70
compiler/ncnv.pas
View File

@ -31,7 +31,7 @@ interface
type
ttypeconvnode = class(tunarynode)
convtyp : tconverttype;
convtype : tconverttype;
constructor create(node : tnode;t : pdef);virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
@ -77,7 +77,7 @@ interface
casnode : class of tasnode;
cisnode : class of tisnode;
function gentypeconvnode(node : tnode;t : pdef) : tnode;
function gentypeconvnode(node : tnode;t : pdef) : ttypeconvnode;
procedure arrayconstructor_to_set(var p : tarrayconstructnode);
implementation
@ -95,6 +95,12 @@ implementation
htypechk,pass_1,cpubase;
function gentypeconvnode(node : tnode;t : pdef) : ttypeconvnode;
begin
gentypeconvnode:=ctypeconvnode.create(node,t);
end;
{*****************************************************************************
Array constructor to Set Conversion
*****************************************************************************}
@ -305,7 +311,7 @@ implementation
buildp:=caddnode.create(addn,buildp,p4);
{ load next and dispose current node }
p2:=p;
p:=tarrayconstrucnode(p.right);
p:=tarrayconstructnode(p.right);
tarrayconstructnode(p2).right:=nil;
p2.free;
end;
@ -331,6 +337,29 @@ implementation
TTYPECONVNODE
*****************************************************************************}
constructor ttypeconvnode.create(node : tnode;t : pdef);
begin
inherited create(typeconvn,node);
convtype:=tc_not_possible;
resulttype:=t;
set_file_line(node);
end;
function ttypeconvnode.getcopy : tnode;
var
n : ttypeconvnode;
begin
n:=ttypeconvnode(inherited getcopy);
n.convtype:=convtype;
getcopy:=n;
end;
function ttypeconvnode.first_int_to_int : tnode;
begin
first_int_to_int:=nil;
@ -777,7 +806,7 @@ implementation
psetdef(resulttype)^.settype:=normset
end
else
convtyp:=tc_load_smallset;
convtype:=tc_load_smallset;
exit;
end
else
@ -802,7 +831,7 @@ implementation
exit;
end;
if isconvertable(left.resulttype,resulttype,convtyp,left.nodetype,nf_explizit in flags)=0 then
if isconvertable(left.resulttype,resulttype,convtype,left.nodetype,nf_explizit in flags)=0 then
begin
{Procedures have a resulttype of voiddef and functions of their
own resulttype. They will therefore always be incompatible with
@ -860,14 +889,14 @@ implementation
if (left.nodetype<>addrn) then
aprocdef:=pprocsym(tloadnode(left).symtableentry)^.definition;
end;
convtyp:=tc_proc_2_procvar;
convtype:=tc_proc_2_procvar;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if assigned(aprocdef) then
begin
if not proc_to_procvar_equal(aprocdef,pprocvardef(resulttype)) then
CGMessage2(type_e_incompatible_types,aprocdef^.typename,resulttype^.typename);
pass_1:=call_helper(convtyp);
pass_1:=call_helper(convtype);
end
else
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
@ -886,20 +915,20 @@ implementation
if is_integer(resulttype) and
is_boolean(left.resulttype) then
begin
convtyp:=tc_bool_2_int;
pass_1:=call_helper(convtyp);
convtype:=tc_bool_2_int;
pass_1:=call_helper(convtype);
exit;
end;
{ ansistring to pchar }
if is_pchar(resulttype) and
is_ansistring(left.resulttype) then
begin
convtyp:=tc_ansistring_2_pchar;
pass_1:=call_helper(convtyp);
convtype:=tc_ansistring_2_pchar;
pass_1:=call_helper(convtype);
exit;
end;
{ do common tc_equal cast }
convtyp:=tc_equal;
convtype:=tc_equal;
{ enum to ordinal will always be s32bit }
if (left.resulttype^.deftype=enumdef) and
@ -914,7 +943,7 @@ implementation
end
else
begin
if isconvertable(s32bitdef,resulttype,convtyp,ordconstn,false)=0 then
if isconvertable(s32bitdef,resulttype,convtype,ordconstn,false)=0 then
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end;
end
@ -933,7 +962,7 @@ implementation
end
else
begin
if IsConvertable(left.resulttype,s32bitdef,convtyp,ordconstn,false)=0 then
if IsConvertable(left.resulttype,s32bitdef,convtype,ordconstn,false)=0 then
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end;
end
@ -962,7 +991,7 @@ implementation
end
else
begin
if IsConvertable(left.resulttype,u8bitdef,convtyp,ordconstn,false)=0 then
if IsConvertable(left.resulttype,u8bitdef,convtype,ordconstn,false)=0 then
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end;
end
@ -981,7 +1010,7 @@ implementation
end
else
begin
if IsConvertable(u8bitdef,resulttype,convtyp,ordconstn,false)=0 then
if IsConvertable(u8bitdef,resulttype,convtype,ordconstn,false)=0 then
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end;
end
@ -1046,8 +1075,8 @@ implementation
pass_1:=hp;
exit;
end;
if convtyp<>tc_equal then
pass_1:=call_helper(convtyp);
if convtype<>tc_equal then
pass_1:=call_helper(convtype);
end;
@ -1142,7 +1171,10 @@ begin
end.
{
$Log$
Revision 1.4 2000-09-27 18:14:31 florian
Revision 1.5 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.4 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.3 2000/09/26 20:06:13 florian

62
compiler/ncon.pas
View File

@ -119,6 +119,7 @@ interface
function is_constresourcestringnode(p : tnode) : boolean;
function str_length(p : tnode) : longint;
function is_emptyset(p : tnode):boolean;
function genconstsymtree(p : pconstsym) : tnode;
implementation
@ -131,6 +132,7 @@ implementation
genordinalconstnode:=cordconstnode.create(v,def);
end;
function genintconstnode(v : TConstExprInt) : tordconstnode;
var
@ -145,36 +147,43 @@ implementation
genintconstnode:=genordinalconstnode(v,cs64bitdef);
end;
function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
begin
genpointerconstnode:=cpointerconstnode.create(v,def);
end;
function genenumnode(v : penumsym) : tordconstnode;
begin
genenumnode:=cordconstnode.create(v^.value,v^.definition);
end;
function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;
begin
gensetconstnode:=csetconstnode.create(s,settype);
end;
function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
begin
genrealconstnode:=crealconstnode.create(v,def);
end;
function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
begin
genfixconstnode:=cfixconstnode.create(v,def);
end;
function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
begin
genstringconstnode:=cstringconstnode.createstr(s,st);
end;
function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
begin
genpcharconstnode:=cstringconstnode.createpchar(s,length);
@ -210,12 +219,14 @@ implementation
is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype);
end;
function is_constrealnode(p : tnode) : boolean;
begin
is_constrealnode:=(p.nodetype=realconstn);
end;
function is_constboolnode(p : tnode) : boolean;
begin
@ -234,9 +245,10 @@ implementation
function str_length(p : tnode) : longint;
begin
str_length:=tstrconstnode(p).length;
str_length:=tstringconstnode(p).len;
end;
function is_emptyset(p : tnode):boolean;
var
@ -252,6 +264,49 @@ implementation
end;
function genconstsymtree(p : pconstsym) : tnode;
var
p1 : tnode;
len : longint;
pc : pchar;
begin
p1:=nil;
case p^.consttyp of
constint :
p1:=genordinalconstnode(p^.value,s32bitdef);
conststring :
begin
len:=p^.len;
if not(cs_ansistrings in aktlocalswitches) and (len>255) then
len:=255;
getmem(pc,len+1);
move(pchar(tpointerord(p^.value))^,pc^,len);
pc[len]:=#0;
p1:=genpcharconstnode(pc,len);
end;
constchar :
p1:=genordinalconstnode(p^.value,cchardef);
constreal :
p1:=genrealconstnode(pbestreal(tpointerord(p^.value))^,bestrealdef^);
constbool :
p1:=genordinalconstnode(p^.value,booldef);
constset :
p1:=gensetconstnode(pconstset(tpointerord(p^.value)),psetdef(p^.consttype.def));
constord :
p1:=genordinalconstnode(p^.value,p^.consttype.def);
constpointer :
p1:=genpointerconstnode(p^.value,p^.consttype.def);
constnil :
p1:=cnilnode.create;
constresourcestring:
begin
p1:=genloadnode(pvarsym(p),pvarsym(p)^.owner);
p1.resulttype:=cansistringdef;
end;
end;
genconstsymtree:=p1;
end;
{*****************************************************************************
TREALCONSTNODE
*****************************************************************************}
@ -561,7 +616,10 @@ begin
end.
{
$Log$
Revision 1.6 2000-09-27 20:25:44 florian
Revision 1.7 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.6 2000/09/27 20:25:44 florian
* more stuff fixed
Revision 1.5 2000/09/27 18:14:31 florian

92
compiler/nflw.pas
View File

@ -38,7 +38,7 @@ interface
function getcopy : tnode;override;
end;
tlabelednode = class(tnode)
tlabelednode = class(tunarynode)
labelnr : pasmlabel;
exceptionblock : tnode;
labsym : plabelsym;
@ -76,7 +76,9 @@ interface
end;
traisenode = class(tbinarynode)
frametree : tnode;
constructor create;virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override;
end;
@ -95,7 +97,6 @@ interface
excepttype : pobjectdef;
constructor create;virtual;
function pass_1 : tnode;override;
destructor destroy;override;
function getcopy : tnode;override;
end;
@ -122,7 +123,8 @@ implementation
uses
globtype,systems,
cutils,cobjects,verbose,globals,
symconst,types,htypechk,pass_1,ncon,nmem
symconst,types,htypechk,pass_1,
ncon,nmem,nld,ncnv
{$ifdef newcg}
,tgobj
,tgcpu
@ -482,26 +484,26 @@ implementation
hp:=tsubscriptnode(hp).left;
{ we need a simple loadn, but the load must be in a global symtable or
in the same lexlevel }
if (hp.treetype=funcretn) or
((hp.treetype=loadn) and
((hp.symtable^.symtablelevel<=1) or
(hp.symtable^.symtablelevel=lexlevel))) then
if (hp.nodetype=funcretn) or
((hp.nodetype=loadn) and
((tloadnode(hp).symtable^.symtablelevel<=1) or
(tloadnode(hp).symtable^.symtablelevel=lexlevel))) then
begin
if hp.symtableentry^.typ=varsym then
pvarsym(hp.symtableentry)^.varstate:=vs_used;
if (not(is_ordinal(t2^.resulttype)) or is_64bitint(t2^.resulttype)) then
if tloadnode(hp).symtableentry^.typ=varsym then
pvarsym(tloadnode(hp).symtableentry)^.varstate:=vs_used;
if (not(is_ordinal(t2.resulttype)) or is_64bitint(t2.resulttype)) then
CGMessagePos(hp.fileinfo,type_e_ordinal_expr_expected);
end
else
CGMessagePos(hp.fileinfo,cg_e_illegal_count_var);
if t2^.registers32>registers32 then
registers32:=t2^.registers32;
if t2^.registersfpu>registersfpu then
registersfpu:=t2^.registersfpu;
if t2.registers32>registers32 then
registers32:=t2.registers32;
if t2.registersfpu>registersfpu then
registersfpu:=t2.registersfpu;
{$ifdef SUPPORT_MMX}
if t2^.registersmmx>registersmmx then
registersmmx:=t2^.registersmmx;
if t2.registersmmx>registersmmx then
registersmmx:=t2.registersmmx;
{$endif SUPPORT_MMX}
{$ifdef newcg}
@ -511,9 +513,9 @@ implementation
{$endif newcg}
firstpass(right);
right.set_varstate(true);
if right.treetype<>ordconstn then
if right.nodetype<>ordconstn then
begin
right:=gentypeconvnode(right,t2^.resulttype);
right:=gentypeconvnode(right,t2.resulttype);
{$ifdef newcg}
tg.cleartempgen;
{$else newcg}
@ -548,7 +550,7 @@ implementation
function texitnode.pass_1 : tnode;
var
pt : tnode;
pt : tfuncretnode;
begin
pass_1:=nil;
resulttype:=voiddef;
@ -563,10 +565,10 @@ implementation
firstpass(left);
if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then
begin
pt:=genzeronode(funcretn);
pt^.rettype.setdef(procinfo^.returntype.def);
pt^.funcretprocinfo:=procinfo;
left:=gennode(assignn,pt,left);
pt:=cfuncretnode.create;
pt.rettype.setdef(procinfo^.returntype.def);
pt.funcretprocinfo:=procinfo;
left:=cassignmentnode.create(pt,left);
firstpass(left);
end;
registers32:=left.registers32;
@ -629,6 +631,19 @@ implementation
constructor traisenode.create;
begin
inherited create(raisen,nil,nil);
frametree:=nil;
end;
function traisenode.getcopy : tnode;
var
n : traisenode;
begin
n:=traisenode(inherited getcopy);
n.frametree:=frametree;
getcopy:=n;
end;
function traisenode.pass_1 : tnode;
@ -643,7 +658,7 @@ implementation
((left.resulttype^.deftype<>objectdef) or
not(pobjectdef(left.resulttype)^.is_class)) then
CGMessage(type_e_mismatch);
left.set_varstate(left);
left.set_varstate(true);
if codegenerror then
exit;
{ insert needed typeconvs for addr,frame }
@ -665,7 +680,7 @@ implementation
exit;
end;
end;
left_right_max(p);
left_right_max;
end;
end;
@ -720,10 +735,10 @@ implementation
aktexceptblock:=t1;
firstpass(t1);
aktexceptblock:=oldexceptblock;
registers32:=max(registers32,t1^.registers32);
registersfpu:=max(registersfpu,t1^.registersfpu);
registers32:=max(registers32,t1.registers32);
registersfpu:=max(registersfpu,t1.registersfpu);
{$ifdef SUPPORT_MMX}
registersmmx:=max(registersmmx,t1^.registersmmx);
registersmmx:=max(registersmmx,t1.registersmmx);
{$endif SUPPORT_MMX}
end;
end;
@ -768,7 +783,7 @@ implementation
right.set_varstate(true);
if codegenerror then
exit;
left_right_max(p);
left_right_max;
end;
@ -779,6 +794,20 @@ implementation
constructor tonnode.create;
begin
inherited create(onn,nil,nil);
exceptsymtable:=nil;
excepttype:=nil;
end;
function tonnode.getcopy : tnode;
var
n : tonnode;
begin
n:=tonnode(inherited getcopy);
n.exceptsymtable:=exceptsymtable;
n.excepttype:=excepttype;
end;
function tonnode.pass_1 : tnode;
@ -846,7 +875,10 @@ begin
end.
{
$Log$
Revision 1.3 2000-09-24 21:15:34 florian
Revision 1.4 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.3 2000/09/24 21:15:34 florian
* some errors fix to get more stuff compilable
Revision 1.2 2000/09/24 15:06:19 peter

41
compiler/ninl.pas
View File

@ -27,7 +27,7 @@ unit ninl;
interface
uses
node;
node,htypechk;
{$i innr.inc}
@ -50,7 +50,7 @@ implementation
cobjects,verbose,globals,systems,
globtype,
symconst,symtable,aasm,types,
pass_1,htypechk,
pass_1,
ncal,ncon,ncnv,nadd,nld,
cpubase
{$ifdef newcg}
@ -110,7 +110,7 @@ implementation
dowrite,
file_is_typed : boolean;
procedure do_lowhigh(adef : pdef);
function do_lowhigh(adef : pdef) : tnode;
var
v : longint;
@ -126,7 +126,7 @@ implementation
v:=porddef(adef)^.high;
hp:=genordinalconstnode(v,adef);
firstpass(hp);
pass_1:=hp;
do_lowhigh:=hp;
end;
enumdef:
begin
@ -135,7 +135,7 @@ implementation
while enum^.nextenum<>nil do
enum:=enum^.nextenum;
hp:=genenumnode(enum);
pass_1:=hp;
do_lowhigh:=hp;
end;
else
internalerror(87);
@ -193,7 +193,7 @@ implementation
tcallparanode(left).firstcallparan(nil,false)
else
firstpass(left);
left_right_max(self);
left_max;
set_location(location,left.location);
end;
inc(parsing_para_level);
@ -511,7 +511,7 @@ implementation
begin
hp:=gentypeconvnode(left,u8bitdef);
left:=nil;
ttypeconvnode(hp).convtyp:=tc_bool_2_int;
ttypeconvnode(hp).convtype:=tc_bool_2_int;
include(hp.flags,nf_explizit);
firstpass(hp);
pass_1:=hp;
@ -879,7 +879,7 @@ implementation
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true);
{ calc registers }
left_right_max(self);
left_max;
if extra_register then
inc(registers32);
end;
@ -930,7 +930,7 @@ implementation
tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(false);
{ remove warning when result is passed }
set_funcret_is_valid(tcallparanode(left).left);
tcallparanode(left).left.set_funcret_is_valid;
tcallparanode(left).right:=hp;
tcallparanode(tcallparanode(left).right).firstcallparan(nil,true);
tcallparanode(left).right.set_varstate(true);
@ -1015,7 +1015,7 @@ implementation
exit;
tcallparanode(left).firstcallparan(nil,true);
{ calc registers }
left_right_max(self);
left_max;
end;
in_val_x :
@ -1063,7 +1063,7 @@ implementation
if codegenerror then
exit;
{ remove warning when result is passed }
set_funcret_is_valid(tcallparanode(hpp).left);
tcallparanode(hpp).left.set_funcret_is_valid;
tcallparanode(hpp).right := hp;
if valid_for_assign(tcallparanode(hpp).left,false) then
begin
@ -1088,7 +1088,7 @@ implementation
firstpass(hp);
end;
{ calc registers }
left_right_max(self);
left_max;
{ val doesn't calculate the registers really }
{ correct, we need one register extra (FK) }
@ -1112,7 +1112,7 @@ implementation
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
{ remove warning when result is passed }
set_funcret_is_valid(tcallparanode(left).left);
tcallparanode(left).left.set_funcret_is_valid;
{ first param must be var }
valid_for_assign(tcallparanode(left).left,false);
{ check type }
@ -1152,13 +1152,15 @@ implementation
case left.resulttype^.deftype of
orddef,enumdef:
begin
do_lowhigh(left.resulttype);
firstpass(p);
hp:=do_lowhigh(left.resulttype);
firstpass(hp);
pass_1:=hp;
end;
setdef:
begin
do_lowhigh(Psetdef(left.resulttype)^.elementtype.def);
firstpass(p);
hp:=do_lowhigh(Psetdef(left.resulttype)^.elementtype.def);
firstpass(hp);
pass_1:=hp;
end;
arraydef:
begin
@ -1364,7 +1366,10 @@ begin
end.
{
$Log$
Revision 1.4 2000-09-28 16:34:47 florian
Revision 1.5 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.4 2000/09/28 16:34:47 florian
*** empty log message ***
Revision 1.3 2000/09/27 21:33:22 florian

7
compiler/nld.pas
View File

@ -599,7 +599,7 @@ implementation
procedure postprocess(t : tnode);
begin
calcregisters(t,0,0,0);
calcregisters(tbinarynode(t),0,0,0);
{ looks a little bit dangerous to me }
{ len-1 gives problems with is_open_array if len=0, }
{ is_open_array checks now for isconstructor (FK) }
@ -769,7 +769,10 @@ begin
end.
{
$Log$
Revision 1.3 2000-09-27 18:14:31 florian
Revision 1.4 2000-09-28 19:49:52 florian
*** empty log message ***
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/25 15:37:14 florian

53
compiler/nmem.pas
View File

@ -130,7 +130,7 @@ implementation
globtype,systems,
cutils,cobjects,verbose,globals,
symconst,aasm,types,
htypechk,pass_1,ncal,nld
htypechk,pass_1,ncal,nld,ncon,ncnv
{$ifdef newcg}
,cgbase
{$else newcg}
@ -157,7 +157,7 @@ implementation
!!!!!!!!! fixme
p:=getnode;
disposetyp:=dt_with;
treetype:=withn;
nodetype:=withn;
left:=l;
right:=r;
registers32:=0;
@ -443,16 +443,16 @@ implementation
{ we need to process the parameters reverse so they are inserted
in the correct right2left order (PFV) }
hp2:=pparaitem(hp3^.para^.last);
while assigned(hp2^.) do
while assigned(hp2) do
begin
pprocvardef(resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp,hp2^.defaultvalue);
hp2^.:=pparaitem(hp2^.previous);
hp2:=pparaitem(hp2^.previous);
end;
end
else
resulttype:=voidpointerdef;
disposetree(left);
left.free;
left:=hp;
end
else
@ -460,11 +460,11 @@ implementation
firstpass(left);
{ what are we getting the address from an absolute sym? }
hp:=left;
while assigned(hp) and (hp.treetype in [vecn,derefn,subscriptn]) do
hp:=hp.left;
if assigned(hp) and (hp.treetype=loadn) and
((hp.symtableentry^.typ=absolutesym) and
pabsolutesym(hp.symtableentry)^.absseg) then
while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
hp:=tunarynode(hp).left;
if assigned(hp) and (hp.nodetype=loadn) and
((tloadnode(hp).symtableentry^.typ=absolutesym) and
pabsolutesym(tloadnode(hp).symtableentry)^.absseg) then
begin
if not(cs_typed_addresses in aktlocalswitches) then
resulttype:=voidfarpointerdef
@ -483,7 +483,7 @@ implementation
firstpass(left);
{ this is like the function addr }
inc(parsing_para_level);
set_varstate(left,false);
left.set_varstate(false);
dec(parsing_para_level);
if codegenerror then
exit;
@ -532,7 +532,7 @@ implementation
make_not_regable(left);
firstpass(left);
inc(parsing_para_level);
set_varstate(left,false);
left.set_varstate(false);
dec(parsing_para_level);
if resulttype=nil then
resulttype:=voidpointerdef;
@ -570,7 +570,7 @@ implementation
begin
pass_1:=nil;
firstpass(left);
set_varstate(left,true);
left.set_varstate(true);
if codegenerror then
begin
resulttype:=generrordef;
@ -595,11 +595,12 @@ implementation
TSUBSCRIPTNODE
*****************************************************************************}
constructor tsubscriptnode.create(varsym : pvarsym;l : tnode);
constructor tsubscriptnode.create(varsym : psym;l : tnode);
begin
inherited create(subscriptn,l);
vs:=varsym;
{ vs should be changed to psym! }
vs:=pvarsym(varsym);
end;
function tsubscriptnode.getcopy : tnode;
@ -728,11 +729,11 @@ implementation
CGMessage(type_e_array_required);
{ the register calculation is easy if a const index is used }
if right.treetype=ordconstn then
if right.nodetype=ordconstn then
begin
{$ifdef consteval}
{ constant evaluation }
if (left.treetype=loadn) and
if (left.nodetype=loadn) and
(left.symtableentry^.typ=typedconstsym) then
begin
tcsym:=ptypedconstsym(left.symtableentry);
@ -839,7 +840,7 @@ implementation
begin
p:=twithnode(inherited getcopy);
p.withsymtable:=withsymtable;
p.tablecount:=count;
p.tablecount:=tablecount;
p.withreference:=withreference;
end;
@ -859,24 +860,23 @@ implementation
symtable:=withsymtable;
for i:=1 to tablecount do
begin
if (left.treetype=loadn) and
(left.symtable=aktprocsym^.definition^.localst) then
if (left.nodetype=loadn) and
(tloadnode(left).symtable=aktprocsym^.definition^.localst) then
symtable^.direct_with:=true;
symtable^.withnode:=p;
symtable^.withnode:=self;
symtable:=pwithsymtable(symtable^.next);
end;
firstpass(right);
if codegenerror then
exit;
left_right_max(p);
left_right_max;
resulttype:=voiddef;
end
else
begin
{ optimization }
disposetree(p);
p:=nil;
pass_1:=nil;
end;
end;
@ -884,7 +884,10 @@ implementation
end.
{
$Log$
Revision 1.3 2000-09-25 15:37:14 florian
Revision 1.4 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.3 2000/09/25 15:37:14 florian
* more fixes
Revision 1.2 2000/09/25 15:05:25 florian

34
compiler/node.inc
View File

@ -36,7 +36,7 @@
fileinfo:=aktfilepos;
localswitches:=aktlocalswitches;
resulttype:=nil;
registersint:=0;
registers32:=0;
registersfpu:=0;
{$ifdef SUPPORT_MMX}
registersmmx:=0;
@ -196,17 +196,16 @@
begin
{ this is quite tricky because we need a node of the current }
{ node type and not one of tnode! }
p:=classtype.createforcopy;
p:=tnode(classtype).createforcopy;
p.nodetype:=nodetype;
p.location:=location;
p.varstateset:=varstateset;
p.parent:=parent;
p.flags:=flags;
p.registers32:=registers32
p.registers32:=registers32;
p.registersfpu:=registersfpu;
{$ifdef SUPPORT_MMX}
p.registersmmx:=registersmmx;
p.registerskni:=registerskni
p.registerskni:=registerskni;
{$endif SUPPORT_MMX}
p.resulttype:=resulttype;
p.fileinfo:=fileinfo;
@ -260,7 +259,7 @@
begin
case nodetype of
funcretn:
if is_first_funcret in flags) then
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
@ -417,7 +416,7 @@
left.isequal(tunarynode(p).left);
end;
function.tunarynode.getcopy : tnode;
function tunarynode.getcopy : tnode;
var
p : tunarynode;
@ -439,6 +438,16 @@
end;
{$endif}
procedure tunarynode.left_max;
begin
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
end;
procedure tunarynode.concattolist(l : plinkedlist);
begin
@ -515,7 +524,7 @@
right.isequal(tbinarynode(p).right);
end;
function.tbinarynode.getcopy : tnode;
function tbinarynode.getcopy : tnode;
var
p : tbinarynode;
@ -591,6 +600,7 @@
begin
CGMessage(parser_e_operator_not_overloaded);
t.free;
t:=nil;
end
else
begin
@ -601,9 +611,6 @@
t:=cnotnode.create(t);
firstpass(t);
putnode(p);
p:=t;
end;
end;
end;
@ -666,7 +673,10 @@
end;
{
$Log$
Revision 1.5 2000-09-27 18:14:31 florian
Revision 1.6 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.5 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.4 2000/09/26 20:06:13 florian

8
compiler/node.pas
View File

@ -35,14 +35,18 @@ interface
implementation
uses
htypechk,ncal,hcodegen,verbose,nmat,pass_1,nld;
htypechk,ncal,hcodegen,verbose,nmat,
pass_1,nld,symconst,cutils;
{$I node.inc}
end.
{
$Log$
Revision 1.5 2000-09-27 18:14:31 florian
Revision 1.6 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.5 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.4 2000/09/24 15:06:19 peter

9
compiler/nodeh.inc
View File

@ -213,7 +213,8 @@
nf_inlineconst,
{ general }
nf_isproperty { 30th }
nf_isproperty, { 30th }
nf_varstateset
);
tnodeflagset = set of tnodeflags;
@ -311,6 +312,7 @@
procedure det_temp;override;
function docompare(p : tnode) : boolean;override;
function getcopy : tnode;override;
procedure left_max;
end;
pbinarynode = ^tbinarynode;
@ -336,7 +338,10 @@
{
$Log$
Revision 1.9 2000-09-27 18:14:31 florian
Revision 1.10 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.9 2000/09/27 18:14:31 florian
* fixed a lot of syntax errors in the n*.pas stuff
Revision 1.8 2000/09/26 20:06:13 florian

38
compiler/pass_1.pas
View File

@ -561,24 +561,24 @@ implementation
{ !!!! this tbinarynode should be tassignmentnode }
(tbinarynode(hp.right).left.nodetype=funcretn) then
begin
if assigned(texitnode(tstatmentnode(hp.left).right).left) then
if assigned(texitnode(tstatementnode(hp.left).right).left) then
CGMessage(cg_n_inefficient_code)
else
begin
hp.left.right.left:=hp.right.right;
hp.right.right:=nil;
texitnode(tstatementnode(hp.left).right).left:=tstatementnode(hp.right).right;
tstatementnode(hp.right).right:=nil;
hp.right.free;
hp.right:=nil;
end;
end
{ warning if unreachable code occurs and elimate this }
else if (hp.right.treetype in
else if (hp.right.nodetype in
[exitn,breakn,continuen,goton]) and
{ statement node (JM) }
assigned(hp.left) and
{ kind of statement! (JM) }
assigned(hp.left.right) and
(hp.left.right.treetype<>labeln) then
assigned(tstatementnode(hp.left).right) and
(tstatementnode(hp.left).right.nodetype<>labeln) then
begin
{ use correct line number }
aktfilepos:=hp.left.fileinfo;
@ -613,7 +613,7 @@ implementation
else
hp.registers32:=0;
if hp.registers32>p^.registers32 then
if hp.registers32>registers32 then
registers32:=hp.registers32;
if hp.registersfpu>registersfpu then
registersfpu:=hp.registersfpu;
@ -622,7 +622,7 @@ implementation
registersmmx:=hp.registersmmx;
{$endif}
inc(count);
hp:=hp.left;
hp:=tstatementnode(hp.left);
end;
end;
@ -631,6 +631,13 @@ implementation
TASMNODE
*****************************************************************************}
constructor tasmnode.create;
begin
inherited create(asmn);
end;
function tasmnode.pass_1 : tnode;
begin
pass_1:=nil;
@ -641,7 +648,7 @@ implementation
Global procedures
*****************************************************************************}
procedure firstpass(var p : pnode);
procedure firstpass(var p : tnode);
var
oldcodegenerror : boolean;
@ -656,14 +663,14 @@ implementation
begin
{$ifdef extdebug}
inc(total_of_firstpass);
if (p^.firstpasscount>0) and only_one_pass then
if (p.firstpasscount>0) and only_one_pass then
exit;
{$endif extdebug}
oldcodegenerror:=codegenerror;
oldpos:=aktfilepos;
oldlocalswitches:=aktlocalswitches;
{$ifdef extdebug}
if p^.firstpasscount>0 then
if p.firstpasscount>0 then
begin
move(p^,str1[1],sizeof(ttree));
str1[0]:=char(sizeof(ttree));
@ -705,13 +712,13 @@ implementation
if str1<>str2 then
begin
comment(v_debug,'tree changed after first counting pass '
+tostr(longint(p^.treetype)));
+tostr(longint(p.treetype)));
compare_trees(oldp,p);
end;
dispose(oldp);
end;
if count_ref then
inc(p^.firstpasscount);
inc(p.firstpasscount);
{$endif extdebug}
end;
@ -734,7 +741,10 @@ end.
{$endif cg11}
{
$Log$
Revision 1.5 2000-09-24 21:15:34 florian
Revision 1.6 2000-09-28 19:49:52 florian
*** empty log message ***
Revision 1.5 2000/09/24 21:15:34 florian
* some errors fix to get more stuff compilable
Revision 1.4 2000/09/24 15:06:21 peter