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

* varset support fixed

Browse Source 
git-svn-id: trunk@5294 -
This commit is contained in:
florian 2006-11-08 22:48:44 +00:00
parent 80d964067a
commit 7781e842fc
8 changed files with 41 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/defutil.pas
View File

@ -1011,7 +1011,7 @@ implementation
{# returns true, if the type passed is a varset }
function is_varset(p : tdef) : boolean;
begin
result:=(p.typ=setdef) and not(p.size=4) and not(p.size=32);
result:=(p.typ=setdef) and not(p.size=4);
end;

19
compiler/htypechk.pas
View File

@ -895,6 +895,7 @@ implementation
function valid_for_assign(p:tnode;opts:TValidAssigns; report_errors: boolean):boolean;
var
hp2,
hp : tnode;
gotstring,
gotsubscript,
@ -1084,6 +1085,24 @@ implementation
gotdynarray:=true;
hp:=tunarynode(hp).left;
end;
blockn :
begin
hp2:=tblocknode(hp).statements;
if assigned(hp2) then
begin
if hp2.nodetype<>statementn then
internalerror(2006110801);
while assigned(tstatementnode(hp2).next) do
hp2:=tstatementnode(hp2).next;
hp:=tstatementnode(hp2).statement;
end
else
begin
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
end;
asn :
begin
{ asn can't be assigned directly, it returns the value in a register instead

12
compiler/nadd.pas
View File

@ -1729,10 +1729,8 @@ implementation
newstatement : tstatementnode;
temp : ttempcreatenode;
begin
if is_varset(left.resultdef) then
if is_varset(left.resultdef) or is_varset(right.resultdef) then
begin
if not(is_varset(right.resultdef)) then
internalerror(2006091901);
case nodetype of
equaln,unequaln,lten,gten:
begin
@ -1778,7 +1776,7 @@ implementation
addstatement(newstatement,ccallnode.createintern('fpc_varset_create_element',
ccallparanode.create(ctemprefnode.create(temp),
ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
ccallparanode.create(tsetelementnode(right).left,nil))))
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),nil))))
);
{ the last statement should return the value as
@ -1804,15 +1802,15 @@ implementation
if assigned(tsetelementnode(right).right) then
addstatement(newstatement,ccallnode.createintern('fpc_varset_set_range',
ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
ccallparanode.create(tsetelementnode(right).right,
ccallparanode.create(tsetelementnode(right).left,
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(tsetelementnode(right).right),sinttype),
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(tsetelementnode(right).left),sinttype),
ccallparanode.create(ctemprefnode.create(temp),
ccallparanode.create(left,nil))))))
)
else
addstatement(newstatement,ccallnode.createintern('fpc_varset_set',
ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
ccallparanode.create(tsetelementnode(right).left,
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),
ccallparanode.create(ctemprefnode.create(temp),
ccallparanode.create(left,nil)))))
);

3
compiler/nbas.pas
View File

@ -73,6 +73,8 @@ interface
function pass_1 : tnode;override;
function pass_typecheck:tnode;override;
procedure printnodetree(var t:text);override;
property statement : tnode read left write left;
property next : tnode read right write right;
end;
tstatementnodeclass = class of tstatementnode;
@ -84,6 +86,7 @@ interface
{$ifdef state_tracking}
function track_state_pass(exec_known:boolean):boolean;override;
{$endif state_tracking}
property statements : tnode read left write left;
end;
tblocknodeclass = class of tblocknode;

2
compiler/ncgadd.pas
View File

@ -219,7 +219,7 @@ interface
{ when it is not allowed to swap we have a constant on
left, that will give problems }
if not allow_swap then
internalerror(200307041);
internalerror(200307043);
swapleftright;
end;
end;

10
compiler/symdef.pas
View File

@ -2012,10 +2012,14 @@ implementation
if high<32 then
begin
settype:=smallset;
{
if current_settings.setalloc=0 then { $PACKSET Fixed?}
}
savesize:=Sizeof(longint)
{
else {No, use $PACKSET VALUE for rounding}
savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
savesize:=current_settings.setalloc*(((high+1)+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
}
end
else
if high<256 then
@ -2024,10 +2028,10 @@ implementation
if current_settings.setalloc=0 then { $PACKSET Fixed?}
savesize:=32
else {No, use $PACKSET VALUE for rounding}
savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
savesize:=current_settings.setalloc*(((high+1)+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
end
else
savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
savesize:=current_settings.setalloc*(((high+1)+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
end;

4
rtl/inc/compproc.inc
View File

@ -313,8 +313,8 @@ function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compil
procedure fpc_varset_load_small(l: fpc_small_set;var dest;size : ptrint); compilerproc;
procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
procedure fpc_varset_set(var source,dest; b,size : ptrint); compilerproc;
procedure fpc_varset_unset(var source,dest; b,size : ptrint); compilerproc;
procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc;
procedure fpc_varset_set_range(const orgset; var dest;l,h,size : ptrint); compilerproc;
function fpc_varset_in(const p; b : ptrint): boolean; compilerproc;
procedure fpc_varset_add_sets(const set1,set2; var dest;size : ptrint); compilerproc;

6
rtl/inc/genset.inc
View File

@ -239,11 +239,11 @@ procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
{
add the element b to the set "source"
}
procedure fpc_varset_set(var source,dest; b,size : ptrint); compilerproc;
procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
begin
move(source,dest,sizeof(source));
move(source,dest,size);
tbytearray(dest)[b div 8]:=tbytearray(dest)[b div 8] or (1 shl (b mod 8));
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SET_BYTE}
@ -254,7 +254,7 @@ procedure fpc_varset_set(var source,dest; b,size : ptrint); compilerproc;
suppresses the element b to the set pointed by p
used for exclude(set,element)
}
procedure fpc_varset_unset(var source,dest; b,size : ptrint); compilerproc;
procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
begin