Commit ed94ca4b authored by Sven/Sarah Barth's avatar Sven/Sarah Barth
Browse files

Add support for IfThen() instrinsic that works like the if-statement in that...

Add support for IfThen() instrinsic that works like the if-statement in that it evaluates only the expression that is indeed executed.
The result type of the intrinsic is determined by the Then-expression to provide a bit of control. There might however be some situations in which this fails, for this exceptions need to be added (e.g. a constant string needs to be converted to a normal string).

compinnr.inc:
  + add new constant in_ifthen_x_y_z for the IfThen() intrinsic
psystem.pas: 
  + create_intern_symbols: add symbol for IfThen() intrinsic
pexpr.pas:
  * statement_syssym: parse parameters of IfThen() intrinsic and return corresponding inline node
ninl.pas, tinlinenode:
  + new method handle_ifthen() which converts the inline node to an if-node which assigns the expressions to a temp node that is returned
  * pass_typecheck: handle in_ifthen_x_y_z using handle_ifthen()
  * pass_1: in_ifthen_x_y_z does not need a first pass as it's already converted after the typecheck pass

+ added tests

git-svn-id: trunk@33036 -
parent 1951b8aa
......@@ -12337,6 +12337,8 @@ tests/test/thlp6.pp svneol=native#text/pascal
tests/test/thlp7.pp svneol=native#text/pascal
tests/test/thlp8.pp svneol=native#text/pascal
tests/test/thlp9.pp svneol=native#text/pascal
tests/test/tifthen1.pp svneol=native#text/pascal
tests/test/tifthen2.pp svneol=native#text/pascal
tests/test/timplements1.pp svneol=native#text/plain
tests/test/timplements2.pp svneol=native#text/plain
tests/test/timplements3.pp svneol=native#text/plain
......
......@@ -89,6 +89,7 @@
in_popcnt_x = 79;
in_aligned_x = 80;
in_setstring_x_y_z = 81;
in_ifthen_x_y_z = 82;
{ Internal constant functions }
in_const_sqr = 100;
......
......@@ -99,6 +99,7 @@ tinlinenode = class(tunarynode)
function handle_copy: tnode;
function handle_box: tnode;
function handle_unbox: tnode;
function handle_ifthen: tnode;
end;
tinlinenodeclass = class of tinlinenode;
......@@ -3281,6 +3282,10 @@ if (def.typ=recorddef) and not (m_delphi in current_settings.modes
set_varstate(tcallparanode(tcallparanode(tcallparanode(left).right).right).left,vs_read,[vsf_must_be_valid]);
resultdef:=tcallparanode(left).left.resultdef;
end;
in_ifthen_x_y_z:
begin
result:=handle_ifthen;
end;
else
internalerror(8);
end;
......@@ -3631,6 +3636,8 @@ if (def.typ=recorddef) and not (m_delphi in current_settings.modes
in_fma_extended,
in_fma_float128:
result:=first_fma;
in_ifthen_x_y_z:
internalerror(2016013105);
else
internalerror(89);
end;
......@@ -4245,6 +4252,77 @@ resultdef:=class_tobject;
end;
function tinlinenode.handle_ifthen: tnode;
var
stat : tstatementnode;
tempnode : ttempcreatenode;
n,
condexpr,
thenexpr,
elseexpr : tnode;
resdef : tdef;
begin
if left.nodetype<>callparan then
internalerror(2016013101);
condexpr:=tcallparanode(left).left;
tcallparanode(left).left:=nil;
n:=tcallparanode(left).right;
if n.nodetype<>callparan then
internalerror(2016013102);
thenexpr:=tcallparanode(n).left;
tcallparanode(n).left:=nil;
n:=tcallparanode(n).right;
if n.nodetype<>callparan then
internalerror(2016013103);
elseexpr:=tcallparanode(n).left;
tcallparanode(n).left:=nil;
if assigned(tcallparanode(n).right) then
internalerror(2016013104);
{ The result type of the expression is that of the then-expression; the
else-expression is converted to that if possible (otherwise error)
There are a few special cases however:
- constant strings need to be converted to strings
- chars need to be checked with strings
}
if is_conststringnode(thenexpr) then
begin
if is_constwidestringnode(elseexpr) or is_constwidecharnode(elseexpr) then
resdef:=cwidestringtype
else
resdef:=cansistringtype;
end
else if is_constcharnode(thenexpr) then
begin
if is_constcharnode(elseexpr) then
resdef:=cansichartype
else if is_constwidecharnode(elseexpr) then
resdef:=cwidechartype
else if is_string(elseexpr.resultdef) then
resdef:=elseexpr.resultdef
else
resdef:=thenexpr.resultdef;
end
else
resdef:=thenexpr.resultdef;
result:=internalstatements(stat);
{ create the tempnode that will hold our result }
tempnode:=ctempcreatenode.create(resdef,resdef.size,tt_persistent,true);
addstatement(stat,tempnode);
n:=cifnode.create(condexpr,
cassignmentnode.create(ctemprefnode.create(tempnode),thenexpr),
cassignmentnode.create(ctemprefnode.create(tempnode),elseexpr)
);
addstatement(stat,n);
addstatement(stat,ctempdeletenode.create_normal_temp(tempnode));
addstatement(stat,ctemprefnode.create(tempnode));
end;
function tinlinenode.first_pack_unpack: tnode;
var
loopstatement : tstatementnode;
......
......@@ -914,6 +914,20 @@ (p1.resultdef.typ=classrefdef))) then
begin
statement_syssym := inline_setstring;
end;
in_ifthen_x_y_z:
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr([ef_accept_equal]);
consume(_COMMA);
p2:=comp_expr([ef_accept_equal]);
consume(_COMMA);
paras:=comp_expr([ef_accept_equal]);
statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,ccallparanode.create(paras,nil))));
consume(_RKLAMMER);
end;
else
internalerror(15);
......
......@@ -105,6 +105,7 @@ implementation
systemunit.insert(csyssym.create('ObjCEncode',in_objc_encode_x)); { objc only }
systemunit.insert(csyssym.create('Default',in_default_x));
systemunit.insert(csyssym.create('SetString',in_setstring_x_y_z));
systemunit.insert(csyssym.create('IfThen',in_ifthen_x_y_z));
systemunit.insert(cconstsym.create_ord('False',constord,0,pasbool8type));
systemunit.insert(cconstsym.create_ord('True',constord,1,pasbool8type));
end;
......
program tifthen1;
procedure Test(aValue: Boolean; aErrOffset: LongInt);
var
i: LongInt;
s: String;
b: Boolean;
c: Char;
begin
i := IfThen(aValue, 42, 21);
if (aValue and (i <> 42)) or (not aValue and (i <> 21)) then
Halt(aErrOffset + 1);
b := IfThen(aValue, False, True);
if (aValue and b) or (not aValue and not b) then
Halt(aErrOffset + 2);
s := IfThen(aValue, 'Hello', 'World');
if (aValue and (s <> 'Hello')) or (not aValue and (s <> 'World')) then
Halt(aErrOffset + 3);
c := IfThen(aValue, #13, #10);
if (aValue and (c <> #13)) or (not aValue and (c <> #10)) then
Halt(aErrOffset + 4);
end;
begin
Test(False, 0);
Test(True, 40);
end.
program tifthen2;
var
execA: Boolean = False;
execB: Boolean = False;
function A: LongInt;
begin
A := 42;
execA := True;
end;
function B: LongInt;
begin
B := 21;
execB := True;
end;
procedure Test(aValue: Boolean; aErrOffset: LongInt);
begin
execA := False;
execB := False;
IfThen(aValue, A, B);
if (aValue and not execA) or (not aValue and not execB) then
Halt(aErrOffset + 1);
if (aValue and execB) or (not aValue and execA) then
Halt(aErrOffset + 2);
end;
begin
Test(True, 0);
Test(False, 10);
end.
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment