From d0910b5ac837d58c141ceb758c366bb8a87f56ff Mon Sep 17 00:00:00 2001 From: florian Date: Fri, 5 Feb 2021 22:10:27 +0000 Subject: [PATCH] * allow sub/add nodes in constant pointer expressions, resolves #34027 git-svn-id: trunk@48514 - --- .gitattributes | 1 + compiler/aasmcnst.pas | 16 ++++++++++++++++ compiler/ngtcon.pas | 32 +++++++++++++++++++++++++++----- tests/webtbs/tw34027.pp | 27 +++++++++++++++++++++++++++ 4 files changed, 71 insertions(+), 5 deletions(-) create mode 100644 tests/webtbs/tw34027.pp diff --git a/.gitattributes b/.gitattributes index d8018b4c89..6d104a96cc 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18400,6 +18400,7 @@ tests/webtbs/tw33898.pp -text svneol=native#text/pascal tests/webtbs/tw33963.pp svneol=native#text/pascal tests/webtbs/tw3402.pp svneol=native#text/plain tests/webtbs/tw34021.pp -text svneol=native#text/pascal +tests/webtbs/tw34027.pp svneol=native#text/pascal tests/webtbs/tw34037.pp svneol=native#text/pascal tests/webtbs/tw34055.pp svneol=native#text/plain tests/webtbs/tw3411.pp svneol=native#text/plain diff --git a/compiler/aasmcnst.pas b/compiler/aasmcnst.pas index 4d106564fa..d37cd74b76 100644 --- a/compiler/aasmcnst.pas +++ b/compiler/aasmcnst.pas @@ -427,6 +427,10 @@ type function queue_subscriptn_multiple_by_name(def: tabstractrecorddef; const fields: array of TIDString): tdef; { queue a type conversion operation } procedure queue_typeconvn(fromdef, todef: tdef); virtual; + { queue a add operation } + procedure queue_addn(def: tdef; const index: tconstexprint); virtual; + { queue a sub operation } + procedure queue_subn(def: tdef; const index: tconstexprint); virtual; { finalise the queue (so a new one can be created) and flush the previously queued operations, applying them in reverse order on a...} { ... procdef } @@ -2080,6 +2084,18 @@ implementation end; + procedure ttai_typedconstbuilder.queue_addn(def: tdef; const index: tconstexprint); + begin + inc(fqueue_offset,def.size*int64(index)); + end; + + + procedure ttai_typedconstbuilder.queue_subn(def: tdef; const index: tconstexprint); + begin + dec(fqueue_offset,def.size*int64(index)); + end; + + procedure ttai_typedconstbuilder.queue_subscriptn(def: tabstractrecorddef; vs: tfieldvarsym); begin inc(fqueue_offset,vs.fieldoffset); diff --git a/compiler/ngtcon.pas b/compiler/ngtcon.pas index 2158670d82..f08ec07c21 100644 --- a/compiler/ngtcon.pas +++ b/compiler/ngtcon.pas @@ -150,7 +150,7 @@ uses defutil,defcmp, { pass 1 } htypechk,procinfo, - nmem,ncnv,ninl,ncon,nld, + nmem,ncnv,ninl,ncon,nld,nadd, { parser specific stuff } pbase,pexpr, { codegen } @@ -826,7 +826,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis { maybe pchar ? } else if is_char(def.pointeddef) and - (node.nodetype<>addrn) then + ((node.nodetype=stringconstn) or is_constcharnode(node)) then begin { create a tcb for the string data (it's placed in a separate asmlist) } @@ -875,7 +875,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis { maybe pwidechar ? } else if is_widechar(def.pointeddef) and - (node.nodetype<>addrn) then + (node.nodetype in [stringconstn,ordconstn]) then begin if (node.nodetype in [stringconstn,ordconstn]) then begin @@ -912,13 +912,13 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis Message(parser_e_illegal_expression); end else - if (node.nodetype=addrn) or + if (node.nodetype in [addrn,addn,subn]) or is_proc2procvar_load(node,pd) then begin { insert typeconv } inserttypeconv(node,def); hp:=node; - while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do + while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn,addn,subn]) do hp:=tunarynode(hp).left; if (hp.nodetype=loadn) then begin @@ -927,6 +927,28 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis while assigned(hp) and (hp.nodetype<>loadn) do begin case hp.nodetype of + addn : + begin + if (is_constintnode(taddnode(hp).right) or + is_constenumnode(taddnode(hp).right) or + is_constcharnode(taddnode(hp).right) or + is_constboolnode(taddnode(hp).right)) and + is_pointer(taddnode(hp).left.resultdef) then + ftcb.queue_addn(tpointerdef(taddnode(hp).left.resultdef).pointeddef,get_ordinal_value(taddnode(hp).right)) + else + Message(parser_e_illegal_expression); + end; + subn : + begin + if (is_constintnode(taddnode(hp).right) or + is_constenumnode(taddnode(hp).right) or + is_constcharnode(taddnode(hp).right) or + is_constboolnode(taddnode(hp).right)) and + is_pointer(taddnode(hp).left.resultdef) then + ftcb.queue_subn(tpointerdef(taddnode(hp).left.resultdef).pointeddef,get_ordinal_value(taddnode(hp).right)) + else + Message(parser_e_illegal_expression); + end; vecn : begin if (is_constintnode(tvecnode(hp).right) or diff --git a/tests/webtbs/tw34027.pp b/tests/webtbs/tw34027.pp new file mode 100644 index 0000000000..feacc2e199 --- /dev/null +++ b/tests/webtbs/tw34027.pp @@ -0,0 +1,27 @@ +uses + strings; + +type tz = record + name : pchar; + end; +const aa :array[0..2] of char = 'aa'#0; + +const testArrZ : array [0..4] of tz = ( + (name: @aa), { Ok } + (name: pchar(@aa)), { Ok } + (name: pchar(@aa)+1), + (name: pchar(@aa)+1+1), + (name: pchar(@aa)+1+1-1) + ); + +var b : pchar; + +begin + b:=pchar(@aa)+1; {Ok} + if strlen(testArrZ[2].name)<>1 then + halt(1); + if strlen(testArrZ[3].name)<>0 then + halt(2); + if strlen(testArrZ[4].name)<>1 then + halt(2); +end.