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

150
compiler/ncal.pas
View File

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

70
compiler/ncnv.pas
View File

@ -31,7 +31,7 @@ interface
type type
ttypeconvnode = class(tunarynode) ttypeconvnode = class(tunarynode)
convtyp : tconverttype; convtype : tconverttype;
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;
@ -77,7 +77,7 @@ interface
casnode : class of tasnode; casnode : class of tasnode;
cisnode : class of tisnode; 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); procedure arrayconstructor_to_set(var p : tarrayconstructnode);
implementation implementation
@ -95,6 +95,12 @@ implementation
htypechk,pass_1,cpubase; htypechk,pass_1,cpubase;
function gentypeconvnode(node : tnode;t : pdef) : ttypeconvnode;
begin
gentypeconvnode:=ctypeconvnode.create(node,t);
end;
{***************************************************************************** {*****************************************************************************
Array constructor to Set Conversion Array constructor to Set Conversion
*****************************************************************************} *****************************************************************************}
@ -305,7 +311,7 @@ implementation
buildp:=caddnode.create(addn,buildp,p4); buildp:=caddnode.create(addn,buildp,p4);
{ load next and dispose current node } { load next and dispose current node }
p2:=p; p2:=p;
p:=tarrayconstrucnode(p.right); p:=tarrayconstructnode(p.right);
tarrayconstructnode(p2).right:=nil; tarrayconstructnode(p2).right:=nil;
p2.free; p2.free;
end; end;
@ -331,6 +337,29 @@ implementation
TTYPECONVNODE 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; function ttypeconvnode.first_int_to_int : tnode;
begin begin
first_int_to_int:=nil; first_int_to_int:=nil;
@ -777,7 +806,7 @@ implementation
psetdef(resulttype)^.settype:=normset psetdef(resulttype)^.settype:=normset
end end
else else
convtyp:=tc_load_smallset; convtype:=tc_load_smallset;
exit; exit;
end end
else else
@ -802,7 +831,7 @@ implementation
exit; exit;
end; 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 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
@ -860,14 +889,14 @@ implementation
if (left.nodetype<>addrn) then if (left.nodetype<>addrn) then
aprocdef:=pprocsym(tloadnode(left).symtableentry)^.definition; aprocdef:=pprocsym(tloadnode(left).symtableentry)^.definition;
end; end;
convtyp:=tc_proc_2_procvar; convtype:=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
the procvar, is compatible with the procvar's type } the procvar, is compatible with the procvar's type }
if assigned(aprocdef) then if assigned(aprocdef) then
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);
pass_1:=call_helper(convtyp); pass_1:=call_helper(convtype);
end end
else else
CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
@ -886,20 +915,20 @@ implementation
if is_integer(resulttype) and if is_integer(resulttype) and
is_boolean(left.resulttype) then is_boolean(left.resulttype) then
begin begin
convtyp:=tc_bool_2_int; convtype:=tc_bool_2_int;
pass_1:=call_helper(convtyp); pass_1:=call_helper(convtype);
exit; exit;
end; end;
{ ansistring to pchar } { ansistring to pchar }
if is_pchar(resulttype) and if is_pchar(resulttype) and
is_ansistring(left.resulttype) then is_ansistring(left.resulttype) then
begin begin
convtyp:=tc_ansistring_2_pchar; convtype:=tc_ansistring_2_pchar;
pass_1:=call_helper(convtyp); pass_1:=call_helper(convtype);
exit; exit;
end; end;
{ do common tc_equal cast } { do common tc_equal cast }
convtyp:=tc_equal; convtype:=tc_equal;
{ enum to ordinal will always be s32bit } { enum to ordinal will always be s32bit }
if (left.resulttype^.deftype=enumdef) and if (left.resulttype^.deftype=enumdef) and
@ -914,7 +943,7 @@ implementation
end end
else else
begin 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); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end; end;
end end
@ -933,7 +962,7 @@ implementation
end end
else else
begin 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); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end; end;
end end
@ -962,7 +991,7 @@ implementation
end end
else else
begin 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); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end; end;
end end
@ -981,7 +1010,7 @@ implementation
end end
else else
begin 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); CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
end; end;
end end
@ -1046,8 +1075,8 @@ implementation
pass_1:=hp; pass_1:=hp;
exit; exit;
end; end;
if convtyp<>tc_equal then if convtype<>tc_equal then
pass_1:=call_helper(convtyp); pass_1:=call_helper(convtype);
end; end;
@ -1142,7 +1171,10 @@ begin
end. end.
{ {
$Log$ $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 * fixed a lot of syntax errors in the n*.pas stuff
Revision 1.3 2000/09/26 20:06:13 florian 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 is_constresourcestringnode(p : tnode) : boolean;
function str_length(p : tnode) : longint; function str_length(p : tnode) : longint;
function is_emptyset(p : tnode):boolean; function is_emptyset(p : tnode):boolean;
function genconstsymtree(p : pconstsym) : tnode;
implementation implementation
@ -131,6 +132,7 @@ implementation
genordinalconstnode:=cordconstnode.create(v,def); genordinalconstnode:=cordconstnode.create(v,def);
end; end;
function genintconstnode(v : TConstExprInt) : tordconstnode; function genintconstnode(v : TConstExprInt) : tordconstnode;
var var
@ -145,36 +147,43 @@ implementation
genintconstnode:=genordinalconstnode(v,cs64bitdef); genintconstnode:=genordinalconstnode(v,cs64bitdef);
end; end;
function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode; function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode;
begin begin
genpointerconstnode:=cpointerconstnode.create(v,def); genpointerconstnode:=cpointerconstnode.create(v,def);
end; end;
function genenumnode(v : penumsym) : tordconstnode; function genenumnode(v : penumsym) : tordconstnode;
begin begin
genenumnode:=cordconstnode.create(v^.value,v^.definition); genenumnode:=cordconstnode.create(v^.value,v^.definition);
end; end;
function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode; function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode;
begin begin
gensetconstnode:=csetconstnode.create(s,settype); gensetconstnode:=csetconstnode.create(s,settype);
end; end;
function genrealconstnode(v : bestreal;def : pdef) : trealconstnode; function genrealconstnode(v : bestreal;def : pdef) : trealconstnode;
begin begin
genrealconstnode:=crealconstnode.create(v,def); genrealconstnode:=crealconstnode.create(v,def);
end; end;
function genfixconstnode(v : longint;def : pdef) : tfixconstnode; function genfixconstnode(v : longint;def : pdef) : tfixconstnode;
begin begin
genfixconstnode:=cfixconstnode.create(v,def); genfixconstnode:=cfixconstnode.create(v,def);
end; end;
function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode; function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode;
begin begin
genstringconstnode:=cstringconstnode.createstr(s,st); genstringconstnode:=cstringconstnode.createstr(s,st);
end; end;
function genpcharconstnode(s : pchar;length : longint) : tstringconstnode; function genpcharconstnode(s : pchar;length : longint) : tstringconstnode;
begin begin
genpcharconstnode:=cstringconstnode.createpchar(s,length); genpcharconstnode:=cstringconstnode.createpchar(s,length);
@ -210,12 +219,14 @@ implementation
is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype); is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype);
end; end;
function is_constrealnode(p : tnode) : boolean; function is_constrealnode(p : tnode) : boolean;
begin begin
is_constrealnode:=(p.nodetype=realconstn); is_constrealnode:=(p.nodetype=realconstn);
end; end;
function is_constboolnode(p : tnode) : boolean; function is_constboolnode(p : tnode) : boolean;
begin begin
@ -234,9 +245,10 @@ implementation
function str_length(p : tnode) : longint; function str_length(p : tnode) : longint;
begin begin
str_length:=tstrconstnode(p).length; str_length:=tstringconstnode(p).len;
end; end;
function is_emptyset(p : tnode):boolean; function is_emptyset(p : tnode):boolean;
var var
@ -252,6 +264,49 @@ implementation
end; 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 TREALCONSTNODE
*****************************************************************************} *****************************************************************************}
@ -561,7 +616,10 @@ begin
end. end.
{ {
$Log$ $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 * more stuff fixed
Revision 1.5 2000/09/27 18:14:31 florian 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; function getcopy : tnode;override;
end; end;
tlabelednode = class(tnode) tlabelednode = class(tunarynode)
labelnr : pasmlabel; labelnr : pasmlabel;
exceptionblock : tnode; exceptionblock : tnode;
labsym : plabelsym; labsym : plabelsym;
@ -76,7 +76,9 @@ interface
end; end;
traisenode = class(tbinarynode) traisenode = class(tbinarynode)
frametree : tnode;
constructor create;virtual; constructor create;virtual;
function getcopy : tnode;override;
function pass_1 : tnode;override; function pass_1 : tnode;override;
end; end;
@ -95,7 +97,6 @@ interface
excepttype : pobjectdef; excepttype : pobjectdef;
constructor create;virtual; constructor create;virtual;
function pass_1 : tnode;override; function pass_1 : tnode;override;
destructor destroy;override;
function getcopy : tnode;override; function getcopy : tnode;override;
end; end;
@ -122,7 +123,8 @@ implementation
uses uses
globtype,systems, globtype,systems,
cutils,cobjects,verbose,globals, cutils,cobjects,verbose,globals,
symconst,types,htypechk,pass_1,ncon,nmem symconst,types,htypechk,pass_1,
ncon,nmem,nld,ncnv
{$ifdef newcg} {$ifdef newcg}
,tgobj ,tgobj
,tgcpu ,tgcpu
@ -482,26 +484,26 @@ implementation
hp:=tsubscriptnode(hp).left; hp:=tsubscriptnode(hp).left;
{ we need a simple loadn, but the load must be in a global symtable or { we need a simple loadn, but the load must be in a global symtable or
in the same lexlevel } in the same lexlevel }
if (hp.treetype=funcretn) or if (hp.nodetype=funcretn) or
((hp.treetype=loadn) and ((hp.nodetype=loadn) and
((hp.symtable^.symtablelevel<=1) or ((tloadnode(hp).symtable^.symtablelevel<=1) or
(hp.symtable^.symtablelevel=lexlevel))) then (tloadnode(hp).symtable^.symtablelevel=lexlevel))) then
begin begin
if hp.symtableentry^.typ=varsym then if tloadnode(hp).symtableentry^.typ=varsym then
pvarsym(hp.symtableentry)^.varstate:=vs_used; pvarsym(tloadnode(hp).symtableentry)^.varstate:=vs_used;
if (not(is_ordinal(t2^.resulttype)) or is_64bitint(t2^.resulttype)) then if (not(is_ordinal(t2.resulttype)) or is_64bitint(t2.resulttype)) then
CGMessagePos(hp.fileinfo,type_e_ordinal_expr_expected); CGMessagePos(hp.fileinfo,type_e_ordinal_expr_expected);
end end
else else
CGMessagePos(hp.fileinfo,cg_e_illegal_count_var); CGMessagePos(hp.fileinfo,cg_e_illegal_count_var);
if t2^.registers32>registers32 then if t2.registers32>registers32 then
registers32:=t2^.registers32; registers32:=t2.registers32;
if t2^.registersfpu>registersfpu then if t2.registersfpu>registersfpu then
registersfpu:=t2^.registersfpu; registersfpu:=t2.registersfpu;
{$ifdef SUPPORT_MMX} {$ifdef SUPPORT_MMX}
if t2^.registersmmx>registersmmx then if t2.registersmmx>registersmmx then
registersmmx:=t2^.registersmmx; registersmmx:=t2.registersmmx;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
{$ifdef newcg} {$ifdef newcg}
@ -511,9 +513,9 @@ implementation
{$endif newcg} {$endif newcg}
firstpass(right); firstpass(right);
right.set_varstate(true); right.set_varstate(true);
if right.treetype<>ordconstn then if right.nodetype<>ordconstn then
begin begin
right:=gentypeconvnode(right,t2^.resulttype); right:=gentypeconvnode(right,t2.resulttype);
{$ifdef newcg} {$ifdef newcg}
tg.cleartempgen; tg.cleartempgen;
{$else newcg} {$else newcg}
@ -548,7 +550,7 @@ implementation
function texitnode.pass_1 : tnode; function texitnode.pass_1 : tnode;
var var
pt : tnode; pt : tfuncretnode;
begin begin
pass_1:=nil; pass_1:=nil;
resulttype:=voiddef; resulttype:=voiddef;
@ -563,10 +565,10 @@ implementation
firstpass(left); firstpass(left);
if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then if ret_in_param(procinfo^.returntype.def) or procinfo^.no_fast_exit then
begin begin
pt:=genzeronode(funcretn); pt:=cfuncretnode.create;
pt^.rettype.setdef(procinfo^.returntype.def); pt.rettype.setdef(procinfo^.returntype.def);
pt^.funcretprocinfo:=procinfo; pt.funcretprocinfo:=procinfo;
left:=gennode(assignn,pt,left); left:=cassignmentnode.create(pt,left);
firstpass(left); firstpass(left);
end; end;
registers32:=left.registers32; registers32:=left.registers32;
@ -629,6 +631,19 @@ implementation
constructor traisenode.create; constructor traisenode.create;
begin 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; end;
function traisenode.pass_1 : tnode; function traisenode.pass_1 : tnode;
@ -643,7 +658,7 @@ implementation
((left.resulttype^.deftype<>objectdef) or ((left.resulttype^.deftype<>objectdef) or
not(pobjectdef(left.resulttype)^.is_class)) then not(pobjectdef(left.resulttype)^.is_class)) then
CGMessage(type_e_mismatch); CGMessage(type_e_mismatch);
left.set_varstate(left); left.set_varstate(true);
if codegenerror then if codegenerror then
exit; exit;
{ insert needed typeconvs for addr,frame } { insert needed typeconvs for addr,frame }
@ -665,7 +680,7 @@ implementation
exit; exit;
end; end;
end; end;
left_right_max(p); left_right_max;
end; end;
end; end;
@ -720,10 +735,10 @@ implementation
aktexceptblock:=t1; aktexceptblock:=t1;
firstpass(t1); firstpass(t1);
aktexceptblock:=oldexceptblock; aktexceptblock:=oldexceptblock;
registers32:=max(registers32,t1^.registers32); registers32:=max(registers32,t1.registers32);
registersfpu:=max(registersfpu,t1^.registersfpu); registersfpu:=max(registersfpu,t1.registersfpu);
{$ifdef SUPPORT_MMX} {$ifdef SUPPORT_MMX}
registersmmx:=max(registersmmx,t1^.registersmmx); registersmmx:=max(registersmmx,t1.registersmmx);
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
end; end;
end; end;
@ -768,7 +783,7 @@ implementation
right.set_varstate(true); right.set_varstate(true);
if codegenerror then if codegenerror then
exit; exit;
left_right_max(p); left_right_max;
end; end;
@ -779,6 +794,20 @@ implementation
constructor tonnode.create; constructor tonnode.create;
begin 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; end;
function tonnode.pass_1 : tnode; function tonnode.pass_1 : tnode;
@ -846,7 +875,10 @@ begin
end. end.
{ {
$Log$ $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 * some errors fix to get more stuff compilable
Revision 1.2 2000/09/24 15:06:19 peter Revision 1.2 2000/09/24 15:06:19 peter

41
compiler/ninl.pas
View File

@ -27,7 +27,7 @@ unit ninl;
interface interface
uses uses
node; node,htypechk;
{$i innr.inc} {$i innr.inc}
@ -50,7 +50,7 @@ implementation
cobjects,verbose,globals,systems, cobjects,verbose,globals,systems,
globtype, globtype,
symconst,symtable,aasm,types, symconst,symtable,aasm,types,
pass_1,htypechk, pass_1,
ncal,ncon,ncnv,nadd,nld, ncal,ncon,ncnv,nadd,nld,
cpubase cpubase
{$ifdef newcg} {$ifdef newcg}
@ -110,7 +110,7 @@ implementation
dowrite, dowrite,
file_is_typed : boolean; file_is_typed : boolean;
procedure do_lowhigh(adef : pdef); function do_lowhigh(adef : pdef) : tnode;
var var
v : longint; v : longint;
@ -126,7 +126,7 @@ implementation
v:=porddef(adef)^.high; v:=porddef(adef)^.high;
hp:=genordinalconstnode(v,adef); hp:=genordinalconstnode(v,adef);
firstpass(hp); firstpass(hp);
pass_1:=hp; do_lowhigh:=hp;
end; end;
enumdef: enumdef:
begin begin
@ -135,7 +135,7 @@ implementation
while enum^.nextenum<>nil do while enum^.nextenum<>nil do
enum:=enum^.nextenum; enum:=enum^.nextenum;
hp:=genenumnode(enum); hp:=genenumnode(enum);
pass_1:=hp; do_lowhigh:=hp;
end; end;
else else
internalerror(87); internalerror(87);
@ -193,7 +193,7 @@ implementation
tcallparanode(left).firstcallparan(nil,false) tcallparanode(left).firstcallparan(nil,false)
else else
firstpass(left); firstpass(left);
left_right_max(self); left_max;
set_location(location,left.location); set_location(location,left.location);
end; end;
inc(parsing_para_level); inc(parsing_para_level);
@ -511,7 +511,7 @@ implementation
begin begin
hp:=gentypeconvnode(left,u8bitdef); hp:=gentypeconvnode(left,u8bitdef);
left:=nil; left:=nil;
ttypeconvnode(hp).convtyp:=tc_bool_2_int; ttypeconvnode(hp).convtype:=tc_bool_2_int;
include(hp.flags,nf_explizit); include(hp.flags,nf_explizit);
firstpass(hp); firstpass(hp);
pass_1:=hp; pass_1:=hp;
@ -879,7 +879,7 @@ implementation
tcallparanode(left).firstcallparan(nil,true); tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(true); left.set_varstate(true);
{ calc registers } { calc registers }
left_right_max(self); left_max;
if extra_register then if extra_register then
inc(registers32); inc(registers32);
end; end;
@ -930,7 +930,7 @@ implementation
tcallparanode(left).firstcallparan(nil,true); tcallparanode(left).firstcallparan(nil,true);
left.set_varstate(false); left.set_varstate(false);
{ remove warning when result is passed } { 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(left).right:=hp;
tcallparanode(tcallparanode(left).right).firstcallparan(nil,true); tcallparanode(tcallparanode(left).right).firstcallparan(nil,true);
tcallparanode(left).right.set_varstate(true); tcallparanode(left).right.set_varstate(true);
@ -1015,7 +1015,7 @@ implementation
exit; exit;
tcallparanode(left).firstcallparan(nil,true); tcallparanode(left).firstcallparan(nil,true);
{ calc registers } { calc registers }
left_right_max(self); left_max;
end; end;
in_val_x : in_val_x :
@ -1063,7 +1063,7 @@ implementation
if codegenerror then if codegenerror then
exit; exit;
{ remove warning when result is passed } { remove warning when result is passed }
set_funcret_is_valid(tcallparanode(hpp).left); tcallparanode(hpp).left.set_funcret_is_valid;
tcallparanode(hpp).right := hp; tcallparanode(hpp).right := hp;
if valid_for_assign(tcallparanode(hpp).left,false) then if valid_for_assign(tcallparanode(hpp).left,false) then
begin begin
@ -1088,7 +1088,7 @@ implementation
firstpass(hp); firstpass(hp);
end; end;
{ calc registers } { calc registers }
left_right_max(self); left_max;
{ val doesn't calculate the registers really } { val doesn't calculate the registers really }
{ correct, we need one register extra (FK) } { correct, we need one register extra (FK) }
@ -1112,7 +1112,7 @@ implementation
registersmmx:=left.registersmmx; registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
{ remove warning when result is passed } { 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 } { first param must be var }
valid_for_assign(tcallparanode(left).left,false); valid_for_assign(tcallparanode(left).left,false);
{ check type } { check type }
@ -1152,13 +1152,15 @@ implementation
case left.resulttype^.deftype of case left.resulttype^.deftype of
orddef,enumdef: orddef,enumdef:
begin begin
do_lowhigh(left.resulttype); hp:=do_lowhigh(left.resulttype);
firstpass(p); firstpass(hp);
pass_1:=hp;
end; end;
setdef: setdef:
begin begin
do_lowhigh(Psetdef(left.resulttype)^.elementtype.def); hp:=do_lowhigh(Psetdef(left.resulttype)^.elementtype.def);
firstpass(p); firstpass(hp);
pass_1:=hp;
end; end;
arraydef: arraydef:
begin begin
@ -1364,7 +1366,10 @@ begin
end. end.
{ {
$Log$ $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 *** *** empty log message ***
Revision 1.3 2000/09/27 21:33:22 florian 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); procedure postprocess(t : tnode);
begin begin
calcregisters(t,0,0,0); calcregisters(tbinarynode(t),0,0,0);
{ looks a little bit dangerous to me } { looks a little bit dangerous to me }
{ len-1 gives problems with is_open_array if len=0, } { len-1 gives problems with is_open_array if len=0, }
{ is_open_array checks now for isconstructor (FK) } { is_open_array checks now for isconstructor (FK) }
@ -769,7 +769,10 @@ begin
end. end.
{ {
$Log$ $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 * fixed a lot of syntax errors in the n*.pas stuff
Revision 1.2 2000/09/25 15:37:14 florian Revision 1.2 2000/09/25 15:37:14 florian

53
compiler/nmem.pas
View File

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

34
compiler/node.inc
View File

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

8
compiler/node.pas
View File

@ -35,14 +35,18 @@ interface
implementation implementation
uses uses
htypechk,ncal,hcodegen,verbose,nmat,pass_1,nld; htypechk,ncal,hcodegen,verbose,nmat,
pass_1,nld,symconst,cutils;
{$I node.inc} {$I node.inc}
end. end.
{ {
$Log$ $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 * fixed a lot of syntax errors in the n*.pas stuff
Revision 1.4 2000/09/24 15:06:19 peter Revision 1.4 2000/09/24 15:06:19 peter

9
compiler/nodeh.inc
View File

@ -213,7 +213,8 @@
nf_inlineconst, nf_inlineconst,
{ general } { general }
nf_isproperty { 30th } nf_isproperty, { 30th }
nf_varstateset
); );
tnodeflagset = set of tnodeflags; tnodeflagset = set of tnodeflags;
@ -311,6 +312,7 @@
procedure det_temp;override; procedure det_temp;override;
function docompare(p : tnode) : boolean;override; function docompare(p : tnode) : boolean;override;
function getcopy : tnode;override; function getcopy : tnode;override;
procedure left_max;
end; end;
pbinarynode = ^tbinarynode; pbinarynode = ^tbinarynode;
@ -336,7 +338,10 @@
{ {
$Log$ $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 * fixed a lot of syntax errors in the n*.pas stuff
Revision 1.8 2000/09/26 20:06:13 florian 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 } { !!!! this tbinarynode should be tassignmentnode }
(tbinarynode(hp.right).left.nodetype=funcretn) then (tbinarynode(hp.right).left.nodetype=funcretn) then
begin begin
if assigned(texitnode(tstatmentnode(hp.left).right).left) then if assigned(texitnode(tstatementnode(hp.left).right).left) then
CGMessage(cg_n_inefficient_code) CGMessage(cg_n_inefficient_code)
else else
begin begin
hp.left.right.left:=hp.right.right; texitnode(tstatementnode(hp.left).right).left:=tstatementnode(hp.right).right;
hp.right.right:=nil; tstatementnode(hp.right).right:=nil;
hp.right.free; hp.right.free;
hp.right:=nil; hp.right:=nil;
end; end;
end end
{ warning if unreachable code occurs and elimate this } { 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 [exitn,breakn,continuen,goton]) and
{ statement node (JM) } { statement node (JM) }
assigned(hp.left) and assigned(hp.left) and
{ kind of statement! (JM) } { kind of statement! (JM) }
assigned(hp.left.right) and assigned(tstatementnode(hp.left).right) and
(hp.left.right.treetype<>labeln) then (tstatementnode(hp.left).right.nodetype<>labeln) then
begin begin
{ use correct line number } { use correct line number }
aktfilepos:=hp.left.fileinfo; aktfilepos:=hp.left.fileinfo;
@ -613,7 +613,7 @@ implementation
else else
hp.registers32:=0; hp.registers32:=0;
if hp.registers32>p^.registers32 then if hp.registers32>registers32 then
registers32:=hp.registers32; registers32:=hp.registers32;
if hp.registersfpu>registersfpu then if hp.registersfpu>registersfpu then
registersfpu:=hp.registersfpu; registersfpu:=hp.registersfpu;
@ -622,7 +622,7 @@ implementation
registersmmx:=hp.registersmmx; registersmmx:=hp.registersmmx;
{$endif} {$endif}
inc(count); inc(count);
hp:=hp.left; hp:=tstatementnode(hp.left);
end; end;
end; end;
@ -631,6 +631,13 @@ implementation
TASMNODE TASMNODE
*****************************************************************************} *****************************************************************************}
constructor tasmnode.create;
begin
inherited create(asmn);
end;
function tasmnode.pass_1 : tnode; function tasmnode.pass_1 : tnode;
begin begin
pass_1:=nil; pass_1:=nil;
@ -641,7 +648,7 @@ implementation
Global procedures Global procedures
*****************************************************************************} *****************************************************************************}
procedure firstpass(var p : pnode); procedure firstpass(var p : tnode);
var var
oldcodegenerror : boolean; oldcodegenerror : boolean;
@ -656,14 +663,14 @@ implementation
begin begin
{$ifdef extdebug} {$ifdef extdebug}
inc(total_of_firstpass); inc(total_of_firstpass);
if (p^.firstpasscount>0) and only_one_pass then if (p.firstpasscount>0) and only_one_pass then
exit; exit;
{$endif extdebug} {$endif extdebug}
oldcodegenerror:=codegenerror; oldcodegenerror:=codegenerror;
oldpos:=aktfilepos; oldpos:=aktfilepos;
oldlocalswitches:=aktlocalswitches; oldlocalswitches:=aktlocalswitches;
{$ifdef extdebug} {$ifdef extdebug}
if p^.firstpasscount>0 then if p.firstpasscount>0 then
begin begin
move(p^,str1[1],sizeof(ttree)); move(p^,str1[1],sizeof(ttree));
str1[0]:=char(sizeof(ttree)); str1[0]:=char(sizeof(ttree));
@ -705,13 +712,13 @@ implementation
if str1<>str2 then if str1<>str2 then
begin begin
comment(v_debug,'tree changed after first counting pass ' comment(v_debug,'tree changed after first counting pass '
+tostr(longint(p^.treetype))); +tostr(longint(p.treetype)));
compare_trees(oldp,p); compare_trees(oldp,p);
end; end;
dispose(oldp); dispose(oldp);
end; end;
if count_ref then if count_ref then
inc(p^.firstpasscount); inc(p.firstpasscount);
{$endif extdebug} {$endif extdebug}
end; end;
@ -734,7 +741,10 @@ end.
{$endif cg11} {$endif cg11}
{ {
$Log$ $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 * some errors fix to get more stuff compilable
Revision 1.4 2000/09/24 15:06:21 peter Revision 1.4 2000/09/24 15:06:21 peter