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

--- Merging r43264 into '.':

Browse Source 
U    compiler/dbgdwarf.pas
--- Recording mergeinfo for merge of r43264 into '.':
 U   .
--- Merging r45050 into '.':
U    compiler/defutil.pas
U    compiler/nmat.pas
--- Recording mergeinfo for merge of r45050 into '.':
 G   .
--- Merging r45051 into '.':
U    compiler/scanner.pas
--- Recording mergeinfo for merge of r45051 into '.':
 G   .
--- Merging r45052 into '.':
G    compiler/scanner.pas
--- Recording mergeinfo for merge of r45052 into '.':
 G   .
--- Merging r45053 into '.':
G    compiler/scanner.pas
A    tests/tbs/tb0670.pp
--- Recording mergeinfo for merge of r45053 into '.':
 G   .
--- Merging r47601 into '.':
G    compiler/scanner.pas
--- Recording mergeinfo for merge of r47601 into '.':
 G   .
--- Merging r47602 into '.':
U    compiler/scandir.pas
U    tests/tbs/tb0596.pp
--- Recording mergeinfo for merge of r47602 into '.':
 G   .

git-svn-id: branches/fixes_3_2@47804 -
This commit is contained in:
svenbarth 2020-12-17 22:08:25 +00:00
parent c6e377b4a9
commit c60ce2af07
8 changed files with 239 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -12933,6 +12933,7 @@ tests/tbs/tb0666b.pp svneol=native#text/pascal
tests/tbs/tb0668a.pp svneol=native#text/pascal
tests/tbs/tb0668b.pp svneol=native#text/pascal
tests/tbs/tb0669.pp svneol=native#text/pascal
tests/tbs/tb0670.pp svneol=native#text/pascal
tests/tbs/tb0676.pp svneol=native#text/pascal
tests/tbs/tb0677.pp svneol=native#text/pascal
tests/tbs/tb0678.pp svneol=native#text/pascal

2
compiler/dbgdwarf.pas
View File

@ -4209,7 +4209,7 @@ implementation
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(ord(DW_OP_skip)));
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_16bit_unaligned(3));
{ no -> load length }
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(ord(DW_OP_lit0)+sizeof(ptrint)));
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(ord(DW_OP_lit0)+sizesinttype.size));
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(ord(DW_OP_minus)));
current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(ord(DW_OP_deref)));
append_labelentry_ref(DW_AT_type,def_dwarf_lab(def.rangedef));

57
compiler/defutil.pas
View File

@ -343,6 +343,10 @@ interface
signdness, the result will also get that signdness }
function get_common_intdef(ld, rd: torddef; keep_sign_if_equal: boolean): torddef;
{ # calculates "not v" based on the provided def; returns true if the def
was negatable, false otherwise }
function calc_not_ordvalue(var v:Tconstexprint; var def:tdef):boolean;
{ # returns whether the type is potentially a valid type of/for an "univ" parameter
(basically: it must have a compile-time size) }
function is_valid_univ_para_type(def: tdef): boolean;
@ -1670,6 +1674,59 @@ implementation
end;
function calc_not_ordvalue(var v:Tconstexprint;var def:tdef):boolean;
begin
if not assigned(def) or (def.typ<>orddef) then
exit(false);
result:=true;
case torddef(def).ordtype of
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64:
v:=byte(not(boolean(int64(v))));
bool8bit,
bool16bit,
bool32bit,
bool64bit:
begin
if v=0 then
v:=-1
else
v:=0;
end;
uchar,
uwidechar,
u8bit,
s8bit,
u16bit,
s16bit,
s32bit,
u32bit,
s64bit,
u64bit:
begin
{ unsigned, equal or bigger than the native int size? }
if (torddef(def).ordtype in [u64bit,u32bit,u16bit,u8bit,uchar,uwidechar]) and
(is_nativeord(def) or is_oversizedord(def)) then
begin
{ Delphi-compatible: not dword = dword (not word = longint) }
{ Extension: not qword = qword }
v:=qword(not qword(v));
{ will be truncated by the ordconstnode for u32bit }
end
else
begin
v:=int64(not int64(v));
def:=get_common_intdef(torddef(def),torddef(sinttype),false);
end;
end;
else
result:=false;
end;
end;
function is_valid_univ_para_type(def: tdef): boolean;
begin
result:=

48
compiler/nmat.pas
View File

@ -1172,52 +1172,8 @@ implementation
begin
v:=tordconstnode(left).value;
def:=left.resultdef;
case torddef(left.resultdef).ordtype of
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64:
v:=byte(not(boolean(int64(v))));
bool8bit,
bool16bit,
bool32bit,
bool64bit:
begin
if v=0 then
v:=-1
else
v:=0;
end;
uchar,
uwidechar,
u8bit,
s8bit,
u16bit,
s16bit,
s32bit,
u32bit,
s64bit,
u64bit:
begin
{ unsigned, equal or bigger than the native int size? }
if (torddef(left.resultdef).ordtype in [u64bit,u32bit,u16bit,u8bit,uchar,uwidechar]) and
(is_nativeord(left.resultdef) or is_oversizedord(left.resultdef)) then
begin
{ Delphi-compatible: not dword = dword (not word = longint) }
{ Extension: not qword = qword }
v:=qword(not qword(v));
{ will be truncated by the ordconstnode for u32bit }
end
else
begin
v:=int64(not int64(v));
def:=get_common_intdef(torddef(left.resultdef),torddef(sinttype),false);
end;
end;
else
CGMessage(type_e_mismatch);
end;
if not calc_not_ordvalue(v,def) then
CGMessage(type_e_mismatch);
{ not-nodes are not range checked by the code generator -> also
don't range check while inlining; the resultdef is a bit tricky
though: the node's resultdef gets changed in most cases compared

26
compiler/scandir.pas
View File

@ -1328,30 +1328,32 @@ unit scandir;
procedure dir_setpeflags;
var
ident : string;
flags : int64;
begin
if not (target_info.system in (systems_all_windows)) then
Message(scan_w_setpeflags_not_support);
current_scanner.skipspace;
ident:=current_scanner.readid;
if ident<>'' then
peflags:=peflags or get_peflag_const(ident,scan_e_illegal_peflag)
else
peflags:=peflags or current_scanner.readval;
if current_scanner.readpreprocint(flags,'SETPEFLAGS') then
begin
if flags>$ffff then
message(scan_e_illegal_peflag);
peflags:=peflags or uint16(flags);
end;
SetPEFlagsSetExplicity:=true;
end;
procedure dir_setpeoptflags;
var
ident : string;
flags : int64;
begin
if not (target_info.system in (systems_all_windows)) then
Message(scan_w_setpeoptflags_not_support);
current_scanner.skipspace;
ident:=current_scanner.readid;
if ident<>'' then
peoptflags:=peoptflags or get_peflag_const(ident,scan_e_illegal_peoptflag)
else
peoptflags:=peoptflags or current_scanner.readval;
if current_scanner.readpreprocint(flags,'SETPEOPTFLAGS') then
begin
if flags>$ffff then
message(scan_e_illegal_peoptflag);
peoptflags:=peoptflags or uint16(flags);
end;
SetPEOptFlagsSetExplicity:=true;
end;

67
compiler/scanner.pas
View File

@ -227,6 +227,7 @@ interface
procedure skipoldtpcomment(read_first_char:boolean);
procedure readtoken(allowrecordtoken:boolean);
function readpreproc:ttoken;
function readpreprocint(var value:int64;const place:string):boolean;
function asmgetchar:char;
end;
@ -276,7 +277,6 @@ interface
Function SetCompileModeSwitch(s:string; changeInit: boolean):boolean;
procedure SetAppType(NewAppType:tapptype);
implementation
uses
@ -924,8 +924,10 @@ type
function evaluate(v:texprvalue;op:ttoken):texprvalue;
procedure error(expecteddef, place: string);
function isBoolean: Boolean;
function isInt: Boolean;
function asBool: Boolean;
function asInt: Integer;
function asInt64: Int64;
function asStr: String;
destructor destroy; override;
end;
@ -1140,6 +1142,12 @@ type
begin
if isBoolean then
result:=texprvalue.create_bool(not asBool)
else if is_ordinal(def) then
begin
result:=texprvalue.create_ord(value.valueord);
result.def:=def;
calc_not_ordvalue(result.value.valueord,result.def);
end
else
begin
error('Boolean', 'NOT');
@ -1156,6 +1164,14 @@ type
v.error('Boolean','OR');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord or v.value.valueord)
else
begin
v.error('Ordinal','OR');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','OR');
@ -1172,6 +1188,14 @@ type
v.error('Boolean','XOR');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord xor v.value.valueord)
else
begin
v.error('Ordinal','XOR');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','XOR');
@ -1188,6 +1212,14 @@ type
v.error('Boolean','AND');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord and v.value.valueord)
else
begin
v.error('Ordinal','AND');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','AND');
@ -1323,16 +1355,21 @@ type
function texprvalue.isBoolean: Boolean;
var
i: integer;
i: int64;
begin
result:=is_boolean(def);
if not result and is_integer(def) then
begin
i:=asInt;
i:=asInt64;
result:=(i=0)or(i=1);
end;
end;
function texprvalue.isInt: Boolean;
begin
result:=is_integer(def);
end;
function texprvalue.asBool: Boolean;
begin
result:=value.valueord<>0;
@ -1343,6 +1380,11 @@ type
result:=value.valueord.svalue;
end;
function texprvalue.asInt64: Int64;
begin
result:=value.valueord.svalue;
end;
function texprvalue.asStr: String;
var
b:byte;
@ -5614,6 +5656,25 @@ exit_label:
end;
function tscannerfile.readpreprocint(var value:int64;const place:string):boolean;
var
hs : texprvalue;
begin
hs:=preproc_comp_expr;
if hs.isInt then
begin
value:=hs.asInt64;
result:=true;
end
else
begin
hs.error('Integer',place);
result:=false;
end;
hs.free;
end;
function tscannerfile.asmgetchar : char;
begin
readchar;

8
tests/tbs/tb0596.pp
View File

@ -5,13 +5,21 @@ program tb0596;
const
IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020;
IMAGE_REMOVABLE_RUN_FROM_SWAP = $0400;
IMAGE_NET_RUN_FROM_SWAP = $0800;
IMAGE_DLLCHARACTERISTICS_NO_ISOLATION = $0200;
IMAGE_DLLCHARACTERISTICS_APPCONTAINER = $1000;
IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000;
{$setpeflags IMAGE_FILE_LARGE_ADDRESS_AWARE}
{$setpeflags $0800}
{$setpeflags IMAGE_REMOVABLE_RUN_FROM_SWAP or IMAGE_NET_RUN_FROM_SWAP}
{$setpeflags $0008 or $0004}
{$setpeoptflags IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE}
{$setpeoptflags $0040}
{$setpeoptflags IMAGE_DLLCHARACTERISTICS_APPCONTAINER or IMAGE_DLLCHARACTERISTICS_NO_ISOLATION}
{$setpeoptflags $0008 or $0004}
begin

92
tests/tbs/tb0670.pp Normal file
View File

@ -0,0 +1,92 @@
{ %NORUN }
program tb0670;
const
Value1 = $06;
Value2 = $60;
Value3 = $6000;
Value4 = $60000000;
Value5 = $60000000000;
Value6 = $40;
Value7 = $4000;
Value8 = $40000000;
Value9 = $40000000000;
ValueNot1 = not Value1;
ValueNot2 = not Value2;
ValueNot3 = not Value3;
ValueNot4 = not Value4;
ValueNot5 = not Value5;
ValueOr1 = Value1 or Value2;
ValueOr2 = Value1 or Value3;
ValueOr3 = Value1 or Value4;
ValueOr4 = Value1 or Value5;
ValueAnd1 = Value2 and Value6;
ValueAnd2 = Value3 and Value7;
ValueAnd3 = Value4 and Value8;
ValueAnd4 = Value5 and Value9;
{ Test "not X" }
{$if not (not Value1 = ValueNot1)}
{$error 'not Value1 = ValueNot1'}
{$endif}
{$if not (not Value2 = ValueNot2)}
{$error 'not Value2 = ValueNot2'}
{$endif}
{$if not (not Value3 = ValueNot3)}
{$error 'not Value3 = ValueNot3'}
{$endif}
{$if not (not Value4 = ValueNot4)}
{$error 'not Value4 = ValueNot4'}
{$endif}
{$if not (not Value5 = ValueNot5)}
{$error 'not Value5 = ValueNot5'}
{$endif}
{ Test "X or Y" }
{$if Value1 or Value2 <> ValueOr1}
{$error 'Value1 or Value2 = ValueOr1'}
{$endif}
{$if Value1 or Value3 <> ValueOr2}
{$error 'Value1 or Value3 = ValueOr2'}
{$endif}
{$if Value1 or Value4 <> ValueOr3}
{$error 'Value1 or Value4 = ValueOr3'}
{$endif}
{$if Value1 or Value5 <> ValueOr4}
{$error 'Value1 or Value5 = ValueOr4'}
{$endif}
{ Test "X and Y" }
{$if Value2 and Value6 <> ValueAnd1 }
{$error 'Value2 and Value6 = ValueAnd1' }
{$endif}
{$if Value3 and Value7 <> ValueAnd2 }
{$error 'Value3 and Value7 = ValueAnd2' }
{$endif}
{$if Value4 and Value8 <> ValueAnd3 }
{$error 'Value4 and Value8 = ValueAnd3' }
{$endif}
{$if Value5 and Value9 <> ValueAnd4 }
{$error 'Value5 and Value9 = ValueAnd4' }
{$endif}
begin
end.