paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-21 08:09:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed bug that sporadically caused the column of certain nodes to

Browse Source 
change, resulting in slightly different DWARF debug information
    (mantis #13508)

    The cause was saving a node pointer in a local variable, processing
    it further, and later on checking whether it changed by comparing
    the stored and the current instance pointer. The problem was that
    the node could have been freed and reallocated at the same address
    (but with different contents), so this check sometimes resulted
    in (hard to reproduce) false negatives.

git-svn-id: trunk@13580 -
This commit is contained in:
Jonas Maebe 2009-08-22 22:15:27 +00:00
parent 2f7457f37e
commit a64c5a7b23
2 changed files with 436 additions and 395 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
compiler/pass_1.pas
View File

@ -30,6 +30,7 @@ interface
procedure typecheckpass(var p : tnode); procedure typecheckpass(var p : tnode);
function do_typecheckpass(var p : tnode) : boolean; function do_typecheckpass(var p : tnode) : boolean;
function do_typecheckpass_changed(var p : tnode; out nodechanged: boolean) : boolean;
procedure firstpass(var p : tnode); procedure firstpass(var p : tnode);
function do_firstpass(var p : tnode) : boolean; function do_firstpass(var p : tnode) : boolean;
@ -57,7 +58,7 @@ implementation
Global procedures Global procedures
*****************************************************************************} *****************************************************************************}
procedure typecheckpass(var p : tnode); procedure typecheckpass_internal(var p : tnode; out node_changed: boolean);
var var
oldcodegenerror : boolean; oldcodegenerror : boolean;
oldlocalswitches : tlocalswitches; oldlocalswitches : tlocalswitches;
@ -65,6 +66,7 @@ implementation
oldpos : tfileposinfo; oldpos : tfileposinfo;
hp : tnode; hp : tnode;
begin begin
node_changed:=false;
if (p.resultdef=nil) then if (p.resultdef=nil) then
begin begin
oldcodegenerror:=codegenerror; oldcodegenerror:=codegenerror;
@ -79,6 +81,7 @@ implementation
{ should the node be replaced? } { should the node be replaced? }
if assigned(hp) then if assigned(hp) then
begin begin
node_changed:=true;
p.free; p.free;
{ run typecheckpass } { run typecheckpass }
typecheckpass(hp); typecheckpass(hp);
@ -106,11 +109,27 @@ implementation
end; end;
function do_typecheckpass(var p : tnode) : boolean; procedure typecheckpass(var p : tnode);
var
node_changed: boolean;
begin
typecheckpass_internal(p,node_changed);
end;
function do_typecheckpass_changed(var p : tnode; out nodechanged: boolean) : boolean;
begin begin
codegenerror:=false; codegenerror:=false;
typecheckpass(p); typecheckpass_internal(p,nodechanged);
do_typecheckpass:=codegenerror; do_typecheckpass_changed:=codegenerror;
end;
function do_typecheckpass(var p : tnode) : boolean;
var
nodechanged: boolean;
begin
result:=do_typecheckpass_changed(p,nodechanged);
end; end;

804
compiler/pexpr.pas
View File

@ -1283,7 +1283,7 @@ implementation
Factor_read_id Factor_read_id
---------------------------------------------} ---------------------------------------------}
procedure factor_read_id(var p1:tnode;var again:boolean); procedure factor_read_id(out p1:tnode;var again:boolean);
var var
pc : pchar; pc : pchar;
srsym : tsym; srsym : tsym;
@ -1702,7 +1702,8 @@ implementation
PostFixOperators PostFixOperators
---------------------------------------------} ---------------------------------------------}
procedure postfixoperators(var p1:tnode;var again:boolean); { returns whether or not p1 has been changed }
function postfixoperators(var p1:tnode;var again:boolean): boolean;
{ tries to avoid syntax errors after invalid qualifiers } { tries to avoid syntax errors after invalid qualifiers }
procedure recoverconsume_postfixops; procedure recoverconsume_postfixops;
@ -1819,14 +1820,17 @@ implementation
{ shouldn't be used that often, so the extra overhead is ok to save { shouldn't be used that often, so the extra overhead is ok to save
stack space } stack space }
dispatchstring : ansistring; dispatchstring : ansistring;
nodechanged : boolean;
label label
skipreckklammercheck; skipreckklammercheck;
begin begin
result:=false;
again:=true; again:=true;
while again do while again do
begin begin
{ we need the resultdef } { we need the resultdef }
do_typecheckpass(p1); do_typecheckpass_changed(p1,nodechanged);
result:=result or nodechanged;
if codegenerror then if codegenerror then
begin begin
@ -1887,6 +1891,7 @@ implementation
begin begin
consume(_LECKKLAMMER); consume(_LECKKLAMMER);
repeat repeat
{ in all of the cases below, p1 is changed }
case p1.resultdef.typ of case p1.resultdef.typ of
pointerdef: pointerdef:
begin begin
@ -2152,6 +2157,11 @@ implementation
again:=false; again:=false;
end; end;
end; end;
{ we only try again if p1 was changed }
if again or
(p1.nodetype=errorn) then
result:=true;
end; { while again } end; { while again }
end; end;
@ -2164,21 +2174,24 @@ implementation
l : longint; l : longint;
ic : int64; ic : int64;
qc : qword; qc : qword;
oldp1,
p1 : tnode; p1 : tnode;
code : integer; code : integer;
again : boolean;
srsym : tsym; srsym : tsym;
srsymtable : TSymtable; srsymtable : TSymtable;
pd : tprocdef; pd : tprocdef;
hclassdef : tobjectdef; hclassdef : tobjectdef;
d : bestreal; d : bestreal;
cur : currency; cur : currency;
hs,hsorg : string; hs,hsorg : string;
hdef : tdef; hdef : tdef;
filepos : tfileposinfo; filepos : tfileposinfo;
again,
updatefpos,
nodechanged : boolean;
begin begin
oldp1:=nil; { can't keep a copy of p1 and compare pointers afterwards, because
p1 may be freed and reallocated in the same place! }
updatefpos:=false;
p1:=nil; p1:=nil;
filepos:=current_tokenpos; filepos:=current_tokenpos;
again:=false; again:=false;
@ -2197,398 +2210,401 @@ implementation
else else
factor_read_id(p1,again); factor_read_id(p1,again);
if again then if assigned(p1) then
begin begin
if (p1<>oldp1) then { factor_read_id will set the filepos to after the id,
begin and in case of _SELF the filepos will already be the
if assigned(p1) then same as filepos (so setting it again doesn't hurt). }
p1.fileinfo:=filepos; p1.fileinfo:=filepos;
oldp1:=p1; filepos:=current_tokenpos;
filepos:=current_tokenpos;
end;
{ handle post fix operators }
postfixoperators(p1,again);
end; end;
{ handle post fix operators }
updatefpos:=postfixoperators(p1,again);
end end
else else
case token of begin
_RETURN : updatefpos:=true;
begin case token of
consume(_RETURN); _RETURN :
if not(token in [_SEMICOLON,_ELSE,_END]) then
p1 := cexitnode.create(comp_expr(true))
else
p1 := cexitnode.create(nil);
end;
_INHERITED :
begin
again:=true;
consume(_INHERITED);
if assigned(current_procinfo) and
assigned(current_objectdef) then
begin begin
hclassdef:=current_objectdef.childof; consume(_RETURN);
{ if inherited; only then we need the method with if not(token in [_SEMICOLON,_ELSE,_END]) then
the same name } p1 := cexitnode.create(comp_expr(true))
if token in endtokens then
begin
hs:=current_procinfo.procdef.procsym.name;
hsorg:=current_procinfo.procdef.procsym.realname;
anon_inherited:=true;
{ For message methods we need to search using the message
number or string }
pd:=tprocdef(tprocsym(current_procinfo.procdef.procsym).ProcdefList[0]);
srdef:=nil;
if (po_msgint in pd.procoptions) then
searchsym_in_class_by_msgint(hclassdef,pd.messageinf.i,srdef,srsym,srsymtable)
else
if (po_msgstr in pd.procoptions) then
searchsym_in_class_by_msgstr(hclassdef,pd.messageinf.str^,srsym,srsymtable)
else
searchsym_in_class(hclassdef,current_objectdef,hs,srsym,srsymtable);
end
else else
begin p1 := cexitnode.create(nil);
hs:=pattern;
hsorg:=orgpattern;
consume(_ID);
anon_inherited:=false;
searchsym_in_class(hclassdef,current_objectdef,hs,srsym,srsymtable);
end;
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions);
{ load the procdef from the inherited class and
not from self }
case srsym.typ of
procsym:
begin
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=tclassrefdef.create(hdef);
p1:=ctypenode.create(hdef);
end;
propertysym:
;
else
begin
Message(parser_e_methode_id_expected);
p1:=cerrornode.create;
end;
end;
do_member_read(hclassdef,getaddr,srsym,p1,again,[cnf_inherited,cnf_anon_inherited]);
end
else
begin
if anon_inherited then
begin
{ For message methods we need to call DefaultHandler }
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);
p1:=nil;
do_proc_call(srsym,srsym.owner,hclassdef,false,again,p1,[]);
end
else
begin
{ we need to ignore the inherited; }
p1:=cnothingnode.create;
end;
end
else
begin
Message1(sym_e_id_no_member,hsorg);
p1:=cerrornode.create;
end;
again:=false;
end;
{ turn auto inheriting off }
anon_inherited:=false;
end
else
begin
Message(parser_e_generic_methods_only_in_methods);
again:=false;
p1:=cerrornode.create;
end;
postfixoperators(p1,again);
end;
_INTCONST :
begin
{Try first wether the value fits in an int64.}
val(pattern,ic,code);
if code=0 then
begin
consume(_INTCONST);
int_to_type(ic,hdef);
p1:=cordconstnode.create(ic,hdef,true);
end
else
begin
{ try qword next }
val(pattern,qc,code);
if code=0 then
begin
consume(_INTCONST);
int_to_type(qc,hdef);
p1:=cordconstnode.create(qc,hdef,true);
end;
end;
if code<>0 then
begin
{ finally float }
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_invalid_integer);
consume(_INTCONST);
l:=1;
p1:=cordconstnode.create(l,sinttype,true);
end
else
begin
consume(_INTCONST);
p1:=crealconstnode.create(d,pbestrealtype^);
end;
end
else
{ the necessary range checking has already been done by val }
tordconstnode(p1).rangecheck:=false;
end;
_REALNUMBER :
begin
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_error_in_real);
d:=1.0;
end; end;
consume(_REALNUMBER); _INHERITED :
{$ifdef FPC_REAL2REAL_FIXED} begin
if current_settings.fputype=fpu_none then again:=true;
Message(parser_e_unsupported_real); consume(_INHERITED);
if (current_settings.minfpconstprec=s32real) and if assigned(current_procinfo) and
(d = single(d)) then assigned(current_objectdef) then
p1:=crealconstnode.create(d,s32floattype)
else if (current_settings.minfpconstprec=s64real) and
(d = double(d)) then
p1:=crealconstnode.create(d,s64floattype)
else
{$endif FPC_REAL2REAL_FIXED}
p1:=crealconstnode.create(d,pbestrealtype^);
{$ifdef FPC_HAS_STR_CURRENCY}
val(pattern,cur,code);
if code=0 then
trealconstnode(p1).value_currency:=cur;
{$endif FPC_HAS_STR_CURRENCY}
end;
_STRING :
begin
string_dec(hdef,true);
{ STRING can be also a type cast }
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,hdef);
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again);
end
else
p1:=ctypenode.create(hdef);
end;
_FILE :
begin
hdef:=cfiletype;
consume(_FILE);
{ FILE can be also a type cast }
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,hdef);
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again);
end
else
begin
p1:=ctypenode.create(hdef);
end;
end;
_CSTRING :
begin
p1:=cstringconstnode.createstr(pattern);
consume(_CSTRING);
end;
_CCHAR :
begin
p1:=cordconstnode.create(ord(pattern[1]),cchartype,true);
consume(_CCHAR);
end;
_CWSTRING:
begin
p1:=cstringconstnode.createwstr(patternw);
consume(_CWSTRING);
end;
_CWCHAR:
begin
p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
consume(_CWCHAR);
end;
_KLAMMERAFFE :
begin
consume(_KLAMMERAFFE);
got_addrn:=true;
{ support both @<x> and @(<x>) }
if try_to_consume(_LKLAMMER) then
begin
p1:=factor(true);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end;
consume(_RKLAMMER);
end
else
p1:=factor(true);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end;
got_addrn:=false;
p1:=caddrnode.create(p1);
if cs_typed_addresses in current_settings.localswitches then
include(p1.flags,nf_typedaddr);
{ Store the procvar that we are expecting, the
addrn will use the information to find the correct
procdef or it will return an error }
if assigned(getprocvardef) and
(taddrnode(p1).left.nodetype = loadn) then
taddrnode(p1).getprocvardef:=getprocvardef;
end;
_LKLAMMER :
begin
consume(_LKLAMMER);
p1:=comp_expr(true);
consume(_RKLAMMER);
{ it's not a good solution }
{ but (a+b)^ makes some problems }
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end;
end;
_LECKKLAMMER :
begin
consume(_LECKKLAMMER);
p1:=factor_read_set;
consume(_RECKKLAMMER);
end;
_PLUS :
begin
consume(_PLUS);
p1:=factor(false);
{ we must generate a new node to do 0+<p1> otherwise the + will
not be checked }
p1:=caddnode.create(addn,genintconstnode(0),p1);
end;
_MINUS :
begin
consume(_MINUS);
if (token = _INTCONST) then
begin begin
{ ugly hack, but necessary to be able to parse } hclassdef:=current_objectdef.childof;
{ -9223372036854775808 as int64 (JM) } { if inherited; only then we need the method with
pattern := '-'+pattern; the same name }
p1:=sub_expr(oppower,false); if token in endtokens then
{ -1 ** 4 should be - (1 ** 4) and not begin
(-1) ** 4 hs:=current_procinfo.procdef.procsym.name;
This was the reason of tw0869.pp test failure PM } hsorg:=current_procinfo.procdef.procsym.realname;
if p1.nodetype=starstarn then anon_inherited:=true;
begin { For message methods we need to search using the message
if tbinarynode(p1).left.nodetype=ordconstn then number or string }
begin pd:=tprocdef(tprocsym(current_procinfo.procdef.procsym).ProcdefList[0]);
tordconstnode(tbinarynode(p1).left).value:=-tordconstnode(tbinarynode(p1).left).value; srdef:=nil;
p1:=cunaryminusnode.create(p1); if (po_msgint in pd.procoptions) then
end searchsym_in_class_by_msgint(hclassdef,pd.messageinf.i,srdef,srsym,srsymtable)
else if tbinarynode(p1).left.nodetype=realconstn then else
begin if (po_msgstr in pd.procoptions) then
trealconstnode(tbinarynode(p1).left).value_real:=-trealconstnode(tbinarynode(p1).left).value_real; searchsym_in_class_by_msgstr(hclassdef,pd.messageinf.str^,srsym,srsymtable)
trealconstnode(tbinarynode(p1).left).value_currency:=-trealconstnode(tbinarynode(p1).left).value_currency; else
p1:=cunaryminusnode.create(p1); searchsym_in_class(hclassdef,current_objectdef,hs,srsym,srsymtable);
end end
else else
internalerror(20021029); begin
end; hs:=pattern;
hsorg:=orgpattern;
consume(_ID);
anon_inherited:=false;
searchsym_in_class(hclassdef,current_objectdef,hs,srsym,srsymtable);
end;
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions);
{ load the procdef from the inherited class and
not from self }
case srsym.typ of
procsym:
begin
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=tclassrefdef.create(hdef);
p1:=ctypenode.create(hdef);
end;
propertysym:
;
else
begin
Message(parser_e_methode_id_expected);
p1:=cerrornode.create;
end;
end;
do_member_read(hclassdef,getaddr,srsym,p1,again,[cnf_inherited,cnf_anon_inherited]);
end
else
begin
if anon_inherited then
begin
{ For message methods we need to call DefaultHandler }
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);
p1:=nil;
do_proc_call(srsym,srsym.owner,hclassdef,false,again,p1,[]);
end
else
begin
{ we need to ignore the inherited; }
p1:=cnothingnode.create;
end;
end
else
begin
Message1(sym_e_id_no_member,hsorg);
p1:=cerrornode.create;
end;
again:=false;
end;
{ turn auto inheriting off }
anon_inherited:=false;
end end
else else
begin begin
p1:=sub_expr(oppower,false); Message(parser_e_generic_methods_only_in_methods);
p1:=cunaryminusnode.create(p1); again:=false;
end; p1:=cerrornode.create;
end; end;
postfixoperators(p1,again);
end;
_OP_NOT : _INTCONST :
begin begin
consume(_OP_NOT); {Try first wether the value fits in an int64.}
p1:=factor(false); val(pattern,ic,code);
p1:=cnotnode.create(p1); if code=0 then
end; begin
consume(_INTCONST);
int_to_type(ic,hdef);
p1:=cordconstnode.create(ic,hdef,true);
end
else
begin
{ try qword next }
val(pattern,qc,code);
if code=0 then
begin
consume(_INTCONST);
int_to_type(qc,hdef);
p1:=cordconstnode.create(qc,hdef,true);
end;
end;
if code<>0 then
begin
{ finally float }
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_invalid_integer);
consume(_INTCONST);
l:=1;
p1:=cordconstnode.create(l,sinttype,true);
end
else
begin
consume(_INTCONST);
p1:=crealconstnode.create(d,pbestrealtype^);
end;
end
else
{ the necessary range checking has already been done by val }
tordconstnode(p1).rangecheck:=false;
end;
_TRUE : _REALNUMBER :
begin begin
consume(_TRUE); val(pattern,d,code);
p1:=cordconstnode.create(1,booltype,false); if code<>0 then
end; begin
Message(parser_e_error_in_real);
d:=1.0;
end;
consume(_REALNUMBER);
{$ifdef FPC_REAL2REAL_FIXED}
if current_settings.fputype=fpu_none then
Message(parser_e_unsupported_real);
if (current_settings.minfpconstprec=s32real) and
(d = single(d)) then
p1:=crealconstnode.create(d,s32floattype)
else if (current_settings.minfpconstprec=s64real) and
(d = double(d)) then
p1:=crealconstnode.create(d,s64floattype)
else
{$endif FPC_REAL2REAL_FIXED}
p1:=crealconstnode.create(d,pbestrealtype^);
{$ifdef FPC_HAS_STR_CURRENCY}
val(pattern,cur,code);
if code=0 then
trealconstnode(p1).value_currency:=cur;
{$endif FPC_HAS_STR_CURRENCY}
end;
_FALSE : _STRING :
begin begin
consume(_FALSE); string_dec(hdef,true);
p1:=cordconstnode.create(0,booltype,false); { STRING can be also a type cast }
end; if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,hdef);
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again);
end
else
p1:=ctypenode.create(hdef);
end;
_NIL : _FILE :
begin begin
consume(_NIL); hdef:=cfiletype;
p1:=cnilnode.create; consume(_FILE);
{ It's really ugly code nil^, but delphi allows it } { FILE can be also a type cast }
if token in [_CARET] then if try_to_consume(_LKLAMMER) then
begin begin
again:=true; p1:=comp_expr(true);
postfixoperators(p1,again); consume(_RKLAMMER);
end; p1:=ctypeconvnode.create_explicit(p1,hdef);
end; { handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again);
end
else
begin
p1:=ctypenode.create(hdef);
end;
end;
else _CSTRING :
begin begin
Message(parser_e_illegal_expression); p1:=cstringconstnode.createstr(pattern);
p1:=cerrornode.create; consume(_CSTRING);
{ recover } end;
consume(token);
end; _CCHAR :
begin
p1:=cordconstnode.create(ord(pattern[1]),cchartype,true);
consume(_CCHAR);
end;
_CWSTRING:
begin
p1:=cstringconstnode.createwstr(patternw);
consume(_CWSTRING);
end;
_CWCHAR:
begin
p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
consume(_CWCHAR);
end;
_KLAMMERAFFE :
begin
consume(_KLAMMERAFFE);
got_addrn:=true;
{ support both @<x> and @(<x>) }
if try_to_consume(_LKLAMMER) then
begin
p1:=factor(true);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end
else
consume(_RKLAMMER);
end
else
p1:=factor(true);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end;
got_addrn:=false;
p1:=caddrnode.create(p1);
p1.fileinfo:=filepos;
if cs_typed_addresses in current_settings.localswitches then
include(p1.flags,nf_typedaddr);
{ Store the procvar that we are expecting, the
addrn will use the information to find the correct
procdef or it will return an error }
if assigned(getprocvardef) and
(taddrnode(p1).left.nodetype = loadn) then
taddrnode(p1).getprocvardef:=getprocvardef;
end;
_LKLAMMER :
begin
consume(_LKLAMMER);
p1:=comp_expr(true);
consume(_RKLAMMER);
{ it's not a good solution }
{ but (a+b)^ makes some problems }
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again);
end;
end;
_LECKKLAMMER :
begin
consume(_LECKKLAMMER);
p1:=factor_read_set;
consume(_RECKKLAMMER);
end;
_PLUS :
begin
consume(_PLUS);
p1:=factor(false);
{ we must generate a new node to do 0+<p1> otherwise the + will
not be checked }
p1:=caddnode.create(addn,genintconstnode(0),p1);
end;
_MINUS :
begin
consume(_MINUS);
if (token = _INTCONST) then
begin
{ ugly hack, but necessary to be able to parse }
{ -9223372036854775808 as int64 (JM) }
pattern := '-'+pattern;
p1:=sub_expr(oppower,false);
{ -1 ** 4 should be - (1 ** 4) and not
(-1) ** 4
This was the reason of tw0869.pp test failure PM }
if p1.nodetype=starstarn then
begin
if tbinarynode(p1).left.nodetype=ordconstn then
begin
tordconstnode(tbinarynode(p1).left).value:=-tordconstnode(tbinarynode(p1).left).value;
p1:=cunaryminusnode.create(p1);
end
else if tbinarynode(p1).left.nodetype=realconstn then
begin
trealconstnode(tbinarynode(p1).left).value_real:=-trealconstnode(tbinarynode(p1).left).value_real;
trealconstnode(tbinarynode(p1).left).value_currency:=-trealconstnode(tbinarynode(p1).left).value_currency;
p1:=cunaryminusnode.create(p1);
end
else
internalerror(20021029);
end;
end
else
begin
p1:=sub_expr(oppower,false);
p1:=cunaryminusnode.create(p1);
end;
end;
_OP_NOT :
begin
consume(_OP_NOT);
p1:=factor(false);
p1:=cnotnode.create(p1);
end;
_TRUE :
begin
consume(_TRUE);
p1:=cordconstnode.create(1,booltype,false);
end;
_FALSE :
begin
consume(_FALSE);
p1:=cordconstnode.create(0,booltype,false);
end;
_NIL :
begin
consume(_NIL);
p1:=cnilnode.create;
{ It's really ugly code nil^, but delphi allows it }
if token in [_CARET] then
begin
again:=true;
postfixoperators(p1,again);
end;
end;
else
begin
Message(parser_e_illegal_expression);
p1:=cerrornode.create;
{ recover }
consume(token);
end;
end;
end; end;
{ generate error node if no node is created } { generate error node if no node is created }
@ -2598,14 +2614,18 @@ implementation
Comment(V_Warning,'factor: p1=nil'); Comment(V_Warning,'factor: p1=nil');
{$endif} {$endif}
p1:=cerrornode.create; p1:=cerrornode.create;
updatefpos:=true;
end; end;
{ get the resultdef for the node } { get the resultdef for the node }
if (not assigned(p1.resultdef)) then if (not assigned(p1.resultdef)) then
do_typecheckpass(p1); begin
do_typecheckpass_changed(p1,nodechanged);
updatefpos:=updatefpos or nodechanged;
end;
if assigned(p1) and if assigned(p1) and
(p1<>oldp1) then updatefpos then
p1.fileinfo:=filepos; p1.fileinfo:=filepos;
factor:=p1; factor:=p1;
end; end;
@ -2736,9 +2756,9 @@ implementation
var var
p1,p2 : tnode; p1,p2 : tnode;
oldafterassignment : boolean;
oldp1 : tnode;
filepos : tfileposinfo; filepos : tfileposinfo;
oldafterassignment,
updatefpos : boolean;
begin begin
oldafterassignment:=afterassignment; oldafterassignment:=afterassignment;
@ -2749,7 +2769,7 @@ implementation
filepos:=current_tokenpos; filepos:=current_tokenpos;
if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true; afterassignment:=true;
oldp1:=p1; updatefpos:=true;
case token of case token of
_POINTPOINT : _POINTPOINT :
begin begin
@ -2792,12 +2812,14 @@ implementation
p2:=sub_expr(opcompare,true); p2:=sub_expr(opcompare,true);
p1:=gen_c_style_operator(slashn,p1,p2); p1:=gen_c_style_operator(slashn,p1,p2);
end; end;
else
updatefpos:=false;
end; end;
{ get the resultdef for this expression } { get the resultdef for this expression }
if not assigned(p1.resultdef) then if not assigned(p1.resultdef) then
do_typecheckpass(p1); do_typecheckpass(p1);
afterassignment:=oldafterassignment; afterassignment:=oldafterassignment;
if p1<>oldp1 then if updatefpos then
p1.fileinfo:=filepos; p1.fileinfo:=filepos;
expr:=p1; expr:=p1;
end; end;