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

Merging -c 29493,29826,31916,32447,33176:33180,33190

Browse Source 
git-svn-id: branches/fixes_3_0@33849 -
This commit is contained in:
Jonas Maebe 2016-05-29 16:15:44 +00:00
parent 5107d65b32
commit a7fb19313a
10 changed files with 191 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -663,7 +663,6 @@ compiler/symbase.pas svneol=native#text/plain
compiler/symconst.pas svneol=native#text/plain
compiler/symcreat.pas svneol=native#text/plain
compiler/symdef.pas svneol=native#text/plain
compiler/symnot.pas svneol=native#text/plain
compiler/symsym.pas svneol=native#text/plain
compiler/symtable.pas svneol=native#text/plain
compiler/symtype.pas svneol=native#text/plain
@ -14591,6 +14590,8 @@ tests/webtbs/tw2958.pp svneol=native#text/plain
tests/webtbs/tw29609.pp svneol=native#text/pascal
tests/webtbs/tw29620.pp svneol=native#text/plain
tests/webtbs/tw2966.pp svneol=native#text/plain
tests/webtbs/tw29669.pp svneol=native#text/plain
tests/webtbs/tw29669a.pp svneol=native#text/plain
tests/webtbs/tw29745.pp svneol=native#text/pascal
tests/webtbs/tw2975.pp svneol=native#text/plain
tests/webtbs/tw2976.pp svneol=native#text/plain

16
compiler/ncgmem.pas
View File

@ -320,6 +320,7 @@ implementation
paraloc1 : tcgpara;
tmpref: treference;
sref: tsubsetreference;
awordoffset,
offsetcorrection : aint;
pd : tprocdef;
sym : tsym;
@ -446,14 +447,19 @@ implementation
offsetcorrection:=0;
if (left.location.size in [OS_PAIR,OS_SPAIR]) then
begin
if (vs.fieldoffset>=sizeof(aword)) then
begin
location.sreg.subsetreg := left.location.registerhi;
offsetcorrection:=sizeof(aword)*8;
end
if not is_packed_record_or_object(left.resultdef) then
awordoffset:=sizeof(aword)
else
awordoffset:=sizeof(aword)*8;
if (vs.fieldoffset>=awordoffset) xor (target_info.endian=endian_big) then
location.sreg.subsetreg := left.location.registerhi
else
location.sreg.subsetreg := left.location.register;
if vs.fieldoffset>=awordoffset then
offsetcorrection := sizeof(aword)*8;
location.sreg.subsetregsize := OS_INT;
end
else

1
compiler/ncgnstld.pas
View File

@ -56,7 +56,6 @@ implementation
uses
cutils,verbose,globtype,globals,systems,constexp,
symnot,
defutil,defcmp,
htypechk,pass_1,procinfo,paramgr,
cpuinfo,

22
compiler/nflw.pas
View File

@ -29,7 +29,6 @@ interface
uses
cclasses,
node,cpubase,
symnot,
symtype,symbase,symdef,symsym,
optloop;
@ -101,7 +100,6 @@ interface
loopiteration : tnode;
loopvar_notid:cardinal;
constructor create(l,r,_t1,_t2 : tnode;back : boolean);virtual;reintroduce;
procedure loop_var_access(not_type:Tnotification_flag;symbol:Tsym);
function wrap_to_value:tnode;
function pass_typecheck:tnode;override;
function pass_1 : tnode;override;
@ -1432,26 +1430,6 @@ implementation
include(loopflags,lnf_testatbegin);
end;
procedure Tfornode.loop_var_access(not_type:Tnotification_flag;
symbol:Tsym);
begin
{If there is a read access, the value of the loop counter is important;
at the end of the loop the loop variable should contain the value it
had in the last iteration.}
if not_type=vn_onwrite then
begin
writeln('Loopvar does not matter on exit');
end
else
begin
exclude(loopflags,lnf_dont_mind_loopvar_on_exit);
writeln('Loopvar does matter on exit');
end;
Tabstractvarsym(symbol).unregister_notification(loopvar_notid);
end;
function tfornode.simplify(forinline : boolean) : tnode;
begin
result:=nil;

6
compiler/nld.pas
View File

@ -174,7 +174,7 @@ implementation
uses
verbose,globtype,globals,systems,constexp,
symnot,symtable,
symtable,
defutil,defcmp,
htypechk,pass_1,procinfo,paramgr,
cpuinfo,
@ -425,10 +425,6 @@ implementation
{ call to get address of threadvar }
if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
include(current_procinfo.flags,pi_do_call);
if nf_write in flags then
Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite)
else
Tabstractvarsym(symtableentry).trigger_notifications(vn_onread);
end;
procsym :
begin

50
compiler/symdef.pas
View File

@ -281,6 +281,8 @@ interface
function jvm_full_typename(with_package_name: boolean): string;
{ check if the symtable contains a float field }
function contains_float_field : boolean;
{ check if the symtable contains a field that spans an aword boundary }
function contains_cross_aword_field: boolean;
end;
pvariantrecdesc = ^tvariantrecdesc;
@ -2059,13 +2061,14 @@ implementation
recsize:=size;
is_intregable:=
ispowerof2(recsize,temp) and
{ sizeof(asizeint)*2 records in int registers is currently broken for endian_big targets }
(((recsize <= sizeof(asizeint)*2) and (target_info.endian=endian_little)
((recsize<=sizeof(aint)*2) and
not trecorddef(self).contains_cross_aword_field and
{ records cannot go into registers on 16 bit targets for now }
and (sizeof(asizeint)>2)
and not trecorddef(self).contains_float_field) or
(recsize <= sizeof(asizeint)))
and not needs_inittable;
(sizeof(aint)>2) and
(not trecorddef(self).contains_float_field) or
(recsize <= sizeof(aint))
) and
not needs_inittable;
end;
end;
end;
@ -4060,6 +4063,41 @@ implementation
end;
function tabstractrecorddef.contains_cross_aword_field: boolean;
var
i : longint;
foffset, fsize: aword;
begin
result:=true;
for i:=0 to symtable.symlist.count-1 do
begin
if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
(sp_static in tsym(symtable.symlist[i]).symoptions) then
continue;
if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
begin
if is_packed then
begin
foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset;
fsize:=tfieldvarsym(symtable.symlist[i]).vardef.packedbitsize;
end
else
begin
foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset*8;
fsize:=tfieldvarsym(symtable.symlist[i]).vardef.size*8;
end;
if (foffset div (sizeof(aword)*8)) <> ((foffset+fsize-1) div (sizeof(aword)*8)) then
exit;
{ search recursively }
if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
(tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_cross_aword_field) then
exit;
end;
end;
result:=false;
end;
{***************************************************************************
trecorddef
***************************************************************************}

63
compiler/symnot.pas
View File

@ -1,63 +0,0 @@
{
Copyright (c) 2002 by Daniel Mantione
This unit contains support routines for the variable access
notifier.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit symnot;
{$i fpcdefs.inc}
interface
uses cclasses,symtype;
type Tnotification_flag=(vn_onread,vn_onwrite,vn_unknown);
Tnotification_flags=set of Tnotification_flag;
Tnotification_callback=procedure(not_type:Tnotification_flag;
symbol:Tsym) of object;
Tnotification=class(Tlinkedlistitem)
flags:Tnotification_flags;
callback:Tnotification_callback;
id:cardinal;
constructor create(Aflags:Tnotification_flags;
Acallback:Tnotification_callback);
end;
implementation
var notification_counter:cardinal;
constructor Tnotification.create(Aflags:Tnotification_flags;
Acallback:Tnotification_callback);
begin
inherited create;
flags:=Aflags;
callback:=Acallback;
id:=notification_counter;
inc(notification_counter);
end;
begin
notification_counter:=0;
end.

123
compiler/symsym.pas
View File

@ -33,7 +33,7 @@ interface
symconst,symbase,symtype,symdef,defcmp,
{ ppu }
ppu,finput,
cclasses,symnot,
cclasses,
{ aasm }
aasmbase,
cpuinfo,cpubase,cgbase,cgutils,parabase
@ -168,7 +168,6 @@ interface
tabstractvarsym = class(tstoredsym)
varoptions : tvaroptions;
notifications : Tlinkedlist;
varspez : tvarspez; { sets the type of access }
varregable : tvarregable;
varstate : tvarstate;
@ -179,24 +178,21 @@ interface
addr_taken : boolean;
constructor create(st:tsymtyp;const n : string;vsp:tvarspez;def:tdef;vopts:tvaroptions);
constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
destructor destroy;override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure buildderef;override;
procedure deref;override;
function getsize : asizeint;
function getpackedbitsize : longint;
function is_regvar(refpara: boolean):boolean;
procedure trigger_notifications(what:Tnotification_flag);
function register_notification(flags:Tnotification_flags;
callback:Tnotification_callback):cardinal;
procedure unregister_notification(id:cardinal);
private
_vardef : tdef;
vardefderef : tderef;
procedure setvardef(def:tdef);
procedure setregable;
procedure setvardef(const def: tdef);
procedure setvardef_and_regable(def:tdef);
public
property vardef: tdef read _vardef write setvardef;
property vardef: tdef read _vardef write setvardef_and_regable;
end;
tfieldvarsym = class(tabstractvarsym)
@ -1573,14 +1569,6 @@ implementation
end;
destructor tabstractvarsym.destroy;
begin
if assigned(notifications) then
notifications.destroy;
inherited destroy;
end;
procedure tabstractvarsym.buildderef;
begin
vardefderef.build(vardef);
@ -1588,16 +1576,12 @@ implementation
procedure tabstractvarsym.deref;
var
oldvarregable: tvarregable;
begin
{ setting the vardef also updates varregable. We just loaded this }
{ assigning vardef also updates varregable. We just loaded this }
{ value from a ppu, so it must not be changed (e.g. tw7817a.pp/ }
{ tw7817b.pp: the address is taken of a local variable in an }
{ inlined procedure -> must remain non-regable when inlining) }
oldvarregable:=varregable;
vardef:=tdef(vardefderef.resolve);
varregable:=oldvarregable;
setvardef(tdef(vardefderef.resolve));
end;
@ -1663,67 +1647,18 @@ implementation
end;
procedure tabstractvarsym.trigger_notifications(what:Tnotification_flag);
var n:Tnotification;
begin
if assigned(notifications) then
begin
n:=Tnotification(notifications.first);
while assigned(n) do
begin
if what in n.flags then
n.callback(what,self);
n:=Tnotification(n.next);
end;
end;
end;
function Tabstractvarsym.register_notification(flags:Tnotification_flags;callback:
Tnotification_callback):cardinal;
var n:Tnotification;
begin
if not assigned(notifications) then
notifications:=Tlinkedlist.create;
n:=Tnotification.create(flags,callback);
register_notification:=n.id;
notifications.concat(n);
end;
procedure Tabstractvarsym.unregister_notification(id:cardinal);
var n:Tnotification;
begin
if not assigned(notifications) then
internalerror(200212311)
else
begin
n:=Tnotification(notifications.first);
while assigned(n) do
begin
if n.id=id then
begin
notifications.remove(n);
n.destroy;
exit;
end;
n:=Tnotification(n.next);
end;
internalerror(200212311)
end;
end;
procedure tabstractvarsym.setvardef(def:tdef);
procedure tabstractvarsym.setvardef_and_regable(def:tdef);
begin
setvardef(def);
setregable;
end;
procedure tabstractvarsym.setregable;
begin
_vardef := def;
{ can we load the value into a register ? }
if not assigned(owner) or
(owner.symtabletype in [localsymtable,parasymtable]) or
(owner.symtabletype in [localsymtable, parasymtable]) or
(
(owner.symtabletype=staticsymtable) and
not(cs_create_pic in current_settings.moduleswitches)
@ -1746,23 +1681,23 @@ implementation
(typ=paravarsym) and
(varspez=vs_const)) then
varregable:=vr_intreg
else
{ $warning TODO: no fpu regvar in staticsymtable yet, need initialization with 0 }
if {(
not assigned(owner) or
(owner.symtabletype<>staticsymtable)
) and }
tstoreddef(vardef).is_fpuregable then
begin
if use_vectorfpu(vardef) then
varregable:=vr_mmreg
else
varregable:=vr_fpureg;
end;
else if tstoreddef(vardef).is_fpuregable then
begin
if use_vectorfpu(vardef) then
varregable:=vr_mmreg
else
varregable:=vr_fpureg;
end;
end;
end;
procedure tabstractvarsym.setvardef(const def: tdef);
begin
_vardef := def;
end;
{****************************************************************************
TFIELDVARSYM
****************************************************************************}

52
tests/webtbs/tw29669.pp Normal file
View File

@ -0,0 +1,52 @@
{$mode objfpc}
program Project1;
uses
SysUtils;
type
TPackedIdLevel1 = 0..255;
TPackedIdLevel2 = 0..65535;
TPackedIdLevel3 = 0..65535;
TPackedIdLevel4 = 0..65535;
TPackedIdLevel5 = 0..255;
TPackedId = bitpacked record
clusterId : TPackedIdLevel5;
agentId : TPackedIdLevel4;
dataSourceId : TPackedIdLevel3;
deviceId : TPackedIdLevel2;
esmId : TPackedIdLevel1;
end;
function PackedIdToStr(const ipsid : qword) : string;
begin
result := IntToStr(TPackedId(ipsid).esmId) + '-' +
IntToStr(TPackedId(ipsid).deviceId) + '-' +
IntToStr(TPackedId(ipsid).dataSourceId) + '-' +
IntToStr(TPackedId(ipsid).agentId) + '-' +
IntToStr(TPackedId(ipsid).clusterId);
if TPackedId(ipsid).clusterid<>123 then
halt(1);
if TPackedId(ipsid).agentid<>45678 then
halt(2);
if TPackedId(ipsid).datasourceid<>9012 then
halt(3);
if TPackedId(ipsid).deviceid<>34567 then
halt(4);
if TPackedId(ipsid).esmid<>89 then
halt(5);
end;
var
pi: TPackedId;
begin
pi.clusterid:=123;
pi.agentid:=45678;
pi.datasourceid:=9012;
pi.deviceid:=34567;
pi.esmid:=89;
writeln(PackedIdToStr(qword(pi)));
end.

52
tests/webtbs/tw29669a.pp Normal file
View File

@ -0,0 +1,52 @@
{$mode objfpc}
program Project1;
uses
SysUtils;
type
TPackedIdLevel1 = 0..255;
TPackedIdLevel2 = 0..65535;
TPackedIdLevel3 = 0..65535;
TPackedIdLevel4 = 0..65535;
TPackedIdLevel5 = 0..255;
TPackedId = bitpacked record
clusterId : TPackedIdLevel5;
esmId : TPackedIdLevel1;
agentId : TPackedIdLevel4;
dataSourceId : TPackedIdLevel3;
deviceId : TPackedIdLevel2;
end;
function PackedIdToStr(const ipsid : qword) : string;
begin
result := IntToStr(TPackedId(ipsid).esmId) + '-' +
IntToStr(TPackedId(ipsid).deviceId) + '-' +
IntToStr(TPackedId(ipsid).dataSourceId) + '-' +
IntToStr(TPackedId(ipsid).agentId) + '-' +
IntToStr(TPackedId(ipsid).clusterId);
if TPackedId(ipsid).clusterid<>123 then
halt(1);
if TPackedId(ipsid).agentid<>45678 then
halt(2);
if TPackedId(ipsid).datasourceid<>9012 then
halt(3);
if TPackedId(ipsid).deviceid<>34567 then
halt(4);
if TPackedId(ipsid).esmid<>89 then
halt(5);
end;
var
pi: TPackedId;
begin
pi.clusterid:=123;
pi.agentid:=45678;
pi.datasourceid:=9012;
pi.deviceid:=34567;
pi.esmid:=89;
writeln(PackedIdToStr(qword(pi)));
end.