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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46887 -
This commit is contained in:
nickysn 2020-09-17 21:06:06 +00:00
commit e752df6a9d
39 changed files with 1521 additions and 1361 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -16617,6 +16617,7 @@ tests/webtbf/tw37460.pp svneol=native#text/pascal
tests/webtbf/tw37462.pp svneol=native#text/pascal
tests/webtbf/tw37475.pp svneol=native#text/pascal
tests/webtbf/tw37476.pp svneol=native#text/pascal
tests/webtbf/tw37763.pp svneol=native#text/pascal
tests/webtbf/tw3790.pp svneol=native#text/plain
tests/webtbf/tw3812.pp svneol=native#text/plain
tests/webtbf/tw3930a.pp svneol=native#text/plain
@ -16758,6 +16759,7 @@ tests/webtbf/uw4541.pp svneol=native#text/pascal
tests/webtbf/uw6922.pp svneol=native#text/plain
tests/webtbf/uw8738a.pas svneol=native#text/plain
tests/webtbf/uw8738b.pas svneol=native#text/plain
tests/webtbs/DAT_TW37415 svneol=native#text/plain
tests/webtbs/Integer.ns.pp svneol=native#text/pascal
tests/webtbs/Integer.pp svneol=native#text/pascal
tests/webtbs/tu2002.pp svneol=native#text/plain
@ -18477,6 +18479,7 @@ tests/webtbs/tw37393.pp svneol=native#text/pascal
tests/webtbs/tw37397.pp svneol=native#text/plain
tests/webtbs/tw37398.pp svneol=native#text/pascal
tests/webtbs/tw37400.pp svneol=native#text/pascal
tests/webtbs/tw37415.pp svneol=native#text/plain
tests/webtbs/tw3742.pp svneol=native#text/plain
tests/webtbs/tw37423.pp svneol=native#text/plain
tests/webtbs/tw37427.pp svneol=native#text/pascal

13
compiler/aarch64/cgcpu.pas
View File

@ -2507,7 +2507,7 @@ implementation
procedure tcgaarch64.g_check_for_fpu_exception(list: TAsmList;force,clear : boolean);
var
r : TRegister;
r, tmpreg: TRegister;
ai: taicpu;
l1,l2: TAsmLabel;
begin
@ -2516,18 +2516,17 @@ implementation
(force or current_procinfo.FPUExceptionCheckNeeded)) then
begin
r:=getintregister(list,OS_INT);
tmpreg:=getintregister(list,OS_INT);
list.concat(taicpu.op_reg_reg(A_MRS,r,NR_FPSR));
list.concat(taicpu.op_reg_const(A_TST,r,$1f));
list.concat(taicpu.op_reg_reg_const(A_AND,tmpreg,r,$1f));
current_asmdata.getjumplabel(l1);
current_asmdata.getjumplabel(l2);
ai:=taicpu.op_sym(A_B,l1);
ai:=taicpu.op_reg_sym_ofs(A_CBNZ,tmpreg,l1,0);
ai.is_jmp:=true;
ai.condition:=C_NE;
list.concat(ai);
list.concat(taicpu.op_reg_const(A_TST,r,$80));
ai:=taicpu.op_sym(A_B,l2);
list.concat(taicpu.op_reg_reg_const(A_AND,tmpreg,r,$80));
ai:=taicpu.op_reg_sym_ofs(A_CBZ,tmpreg,l2,0);
ai.is_jmp:=true;
ai.condition:=C_EQ;
list.concat(ai);
a_label(list,l1);
alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));

10
compiler/aoptobj.pas
View File

@ -344,6 +344,9 @@ Unit AoptObj;
{ removes p from asml, updates registers and replaces p with hp1 (if the next instruction was known beforehand) }
procedure RemoveCurrentP(var p: tai; const hp1: tai); inline;
{ removes hp from asml then frees it }
procedure RemoveInstruction(const hp: tai); inline;
{ traces sucessive jumps to their final destination and sets it, e.g.
je l1 je l3
<code> <code>
@ -1510,6 +1513,13 @@ Unit AoptObj;
end;
procedure TAOptObj.RemoveInstruction(const hp: tai); inline;
begin
AsmL.Remove(hp);
hp.Free;
end;
function FindLiveLabel(hp: tai; var l: tasmlabel): Boolean;
var
next: tai;

35
compiler/m68k/n68kmem.pas
View File

@ -99,7 +99,7 @@ implementation
if (location.reference.base=NR_NO) and not (scaled) and not assigned(location.reference.symbol) then
begin
{ prefer an address reg, if we will be a base, for indexes any register works }
{ prefer an address reg, if we will be a base, for indexes any register works }
if isintregister(maybe_const_reg) then
begin
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: copytoa')));
@ -109,26 +109,33 @@ implementation
end;
location.reference.base:=maybe_const_reg;
end
else if location.reference.index=NR_NO then
begin
location.reference.index:=maybe_const_reg;
if (scaled) then
location.reference.scalefactor:=l;
end
else
begin
hreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,location.reference,hreg);
reference_reset_base(location.reference,hreg,0,location.reference.temppos,location.reference.alignment,location.reference.volatility);
if location.reference.index<>NR_NO then
begin
{ if we already have an index register, dereference the ref to a new base, to be able to insert an index }
hreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,location.reference,hreg);
reference_reset_base(location.reference,hreg,0,location.reference.temppos,location.reference.alignment,location.reference.volatility);
end;
if def_cgsize(regsize) in [OS_8,OS_16] then
begin
{ index registers are always sign extended on m68k, so we have to zero extend by hand,
if the index variable is unsigned, and its width is less than the whole register }
//current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('updref: index zero extend')));
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,def_cgsize(regsize),OS_ADDR,maybe_const_reg,hreg);
maybe_const_reg:=hreg;
end;
{ insert new index register }
location.reference.index:=maybe_const_reg;
if (scaled) then
location.reference.scalefactor:=l;
end;
{ update alignment }
if (location.reference.alignment=0) then
internalerror(2009020704);
location.reference.alignment:=newalignment(location.reference.alignment,l);
{ update alignment }
if (location.reference.alignment=0) then
internalerror(2009020704);
location.reference.alignment:=newalignment(location.reference.alignment,l);
end;
{ see remarks for tcgvecnode.update_reference_reg_mul above }

3
compiler/msg/errore.msg
View File

@ -2064,6 +2064,9 @@ type_e_forward_interface_type_does_not_match=04127_E_The interface type of the f
type_e_generic_const_type_not_allowed=04128_E_Type not allowed for generic constant parameter: $1
% Only types that can also be used (indirectly) for untyped constants can be used as a
% type for a generic constant parameter.
type_e_cant_read_write_type_in_iso_mode=04129_E_Can't read or write variables of this type in iso mode
% You are trying to \var{read} or \var{write} a variable from or to a
% file of type text, which doesn't support that variable's type in the selected language mode (iso mode).
% \end{description}
#
# Symtable

5
compiler/msgidx.inc
View File

@ -585,6 +585,7 @@ const
type_e_cblock_callconv=04126;
type_e_forward_interface_type_does_not_match=04127;
type_e_generic_const_type_not_allowed=04128;
type_e_cant_read_write_type_in_iso_mode=04129;
sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002;
@ -1126,9 +1127,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 85732;
MsgTxtSize = 85795;
MsgIdxMax : array[1..20] of longint=(
28,106,356,129,99,63,143,36,223,68,
28,106,356,130,99,63,143,36,223,68,
62,20,30,1,1,1,1,1,1,1
);

1023
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

106
compiler/ngenutil.pas
View File

@ -105,9 +105,9 @@ interface
class procedure insertbsssym(list: tasmlist; sym: tstaticvarsym; size: asizeint; varalign: shortint; _typ: Tasmsymtype); virtual;
{ initialization of iso styled program parameters }
class procedure initialize_textrec(p : TObject; statn : pointer);
class procedure initialize_filerecs(p : TObject; statn : pointer);
{ finalization of iso styled program parameters }
class procedure finalize_textrec(p : TObject; statn : pointer);
class procedure finalize_filerecs(p : TObject; statn : pointer);
public
class procedure insertbssdata(sym : tstaticvarsym); virtual;
@ -546,49 +546,83 @@ implementation
end;
class procedure tnodeutils.initialize_textrec(p:TObject;statn:pointer);
class procedure tnodeutils.initialize_filerecs(p:TObject;statn:pointer);
var
stat: ^tstatementnode absolute statn;
begin
if (tsym(p).typ=staticvarsym) and
(tstaticvarsym(p).vardef.typ=filedef) and
(tfiledef(tstaticvarsym(p).vardef).filetyp=ft_text) and
(tstaticvarsym(p).isoindex<>0) then
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_textinit_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_textinit_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
(tstaticvarsym(p).vardef.typ=filedef) and
(tstaticvarsym(p).isoindex<>0) then
case tfiledef(tstaticvarsym(p).vardef).filetyp of
ft_text:
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_textinit_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_textinit_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
ft_typed:
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_typedfile_init_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_typedfile_init_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
else
;
end;
end;
class procedure tnodeutils.finalize_textrec(p:TObject;statn:pointer);
class procedure tnodeutils.finalize_filerecs(p:TObject;statn:pointer);
var
stat: ^tstatementnode absolute statn;
begin
if (tsym(p).typ=staticvarsym) and
(tstaticvarsym(p).vardef.typ=filedef) and
(tfiledef(tstaticvarsym(p).vardef).filetyp=ft_text) and
(tstaticvarsym(p).isoindex<>0) then
begin
addstatement(stat^,ccallnode.createintern('fpc_textclose_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
(tstaticvarsym(p).vardef.typ=filedef) and
(tstaticvarsym(p).isoindex<>0) then
case tfiledef(tstaticvarsym(p).vardef).filetyp of
ft_text:
begin
addstatement(stat^,ccallnode.createintern('fpc_textclose_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
ft_typed:
begin
addstatement(stat^,ccallnode.createintern('fpc_typedfile_close_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
else
;
end;
end;
@ -637,9 +671,9 @@ implementation
(pd.proctypeoption=potype_proginit) then
begin
block:=internalstatements(stat);
pd.localst.SymList.ForEachCall(@initialize_textrec,@stat);
pd.localst.SymList.ForEachCall(@initialize_filerecs,@stat);
addstatement(stat,result);
pd.localst.SymList.ForEachCall(@finalize_textrec,@stat);
pd.localst.SymList.ForEachCall(@finalize_filerecs,@stat);
result:=block;
end;

9
compiler/ninl.pas
View File

@ -765,7 +765,14 @@ implementation
else
case para.left.resultdef.typ of
stringdef :
name:=procprefixes[do_read]+tstringdef(para.left.resultdef).stringtypname;
begin
name:=procprefixes[do_read]+tstringdef(para.left.resultdef).stringtypname;
if (m_isolike_io in current_settings.modeswitches) and (tstringdef(para.left.resultdef).stringtype<>st_shortstring) then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type_in_iso_mode);
error_para := true;
end;
end;
pointerdef :
begin
if (not is_pchar(para.left.resultdef)) or do_read then

88
compiler/ogcoff.pas
View File

@ -914,6 +914,64 @@ const pemagic : array[0..3] of byte = (
end;
function encodeBase64(p:aword):string;
const
alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
'abcdefghijklmnopqrstuvwxyz' +
'0123456789+/';
var
i,
idx,
rem : longint;
begin
setlength(result,6);
idx := 6;
for i:=0 to 5 do
begin
rem:=p mod 64;
p:=p div 64;
result[idx]:=alphabet[rem+1];
dec(idx);
end;
if p<>0 then
internalerror(2020091601);
end;
function decodeBase64(const s:string;out p:longint):boolean;
var
i : longint;
v : aword;
begin
if length(s)>6 then
exit(false);
p:=0;
for i:=1 to length(s) do
begin
v:=0;
if (s[i]>='A') and (s[i]<='Z') then // 0..25
v:=Ord(s[i])-Ord('A')
else if (s[i]>='a') and (s[i]<='z') then // 26..51
v:=Ord(s[i])-Ord('a')+26
else if (s[i]>='0') and (s[i]<='9') then // 52..61
v:=Ord(s[i])-Ord('0')+52
else if s[i]='+' then // 62
v:=62
else if s[i]='/' then // 63
v:=63
else
exit(false);
p:=(p*64)+v;
end;
result:=true;
end;
{****************************************************************************
TCoffObjSection
****************************************************************************}
@ -1652,7 +1710,12 @@ const pemagic : array[0..3] of byte = (
strpos:=FCoffStrs.size+4;
FCoffStrs.writestr(s);
FCoffStrs.writestr(#0);
s:='/'+ToStr(strpos);
if strpos>=10000000 then
s:='//'+encodeBase64(strpos)
else
s:='/'+ToStr(strpos);
if length(s)>8 then
internalerror(2020091501);
end;
move(s[1],sechdr.name,length(s));
if not win32 then
@ -2323,13 +2386,26 @@ const pemagic : array[0..3] of byte = (
secname:=strpas(secnamebuf);
if secname[1]='/' then
begin
Val(Copy(secname,2,8),strpos,code);
if code=0 then
secname:=Read_str(strpos)
if secname[2]='/' then
begin
if not decodeBase64(copy(secname,3,8),strpos) then
begin
InputError('Error reading COFF Section Headers');
secname:='error';
end
else
secname:=Read_str(strpos);
end
else
begin
InputError('Error reading COFF Section Headers');
secname:='error';
Val(Copy(secname,2,8),strpos,code);
if code=0 then
secname:=Read_str(strpos)
else
begin
InputError('Error reading COFF Section Headers');
secname:='error';
end;
end;
end;
if win32 then

286
compiler/x86/aoptx86.pas
View File

@ -1090,8 +1090,7 @@ unit aoptx86;
else
Internalerror(2017050701)
end;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
end;
end;
@ -1383,8 +1382,7 @@ unit aoptx86;
(getregtype(tai_regalloc(hp2).reg) = R_INTREGISTER) and
(getsupreg(tai_regalloc(hp2).reg) = supreg) then
begin
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
break;
end;
until not(assigned(hp2)) or regInInstruction(newreg(R_INTREGISTER,supreg,R_SUBWHOLE),hp2);
@ -1444,8 +1442,7 @@ unit aoptx86;
begin
DebugMsg(SPeepholeOptimization + '(V)MOVA*(V)MOVA*2(V)MOVA* 1',p);
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
exit;
end
@ -1457,8 +1454,7 @@ unit aoptx86;
else if MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^) then
begin
DebugMsg(SPeepholeOptimization + '(V)MOVA*(V)MOVA*2(V)MOVA* 2',p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
exit;
end
@ -1482,8 +1478,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization + '(V)MOVA*(V)MOVS*2(V)MOVS* 1',p);
taicpu(p).opcode:=taicpu(hp1).opcode;
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
exit;
end
@ -1566,8 +1561,7 @@ unit aoptx86;
begin
taicpu(hp1).loadoper(2,taicpu(p).oper[0]^);
RemoveCurrentP(p, hp1); // <-- Is this actually safe? hp1 is not necessarily the next instruction. [Kit]
asml.Remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
end;
end
else if (hp1.typ = ait_instruction) and
@ -1606,8 +1600,7 @@ unit aoptx86;
RemoveCurrentP(p, nil);
p:=hp1;
taicpu(hp1).loadoper(1, taicpu(hp2).oper[1]^);
asml.remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
result:=true;
end;
end;
@ -1643,8 +1636,7 @@ unit aoptx86;
begin
taicpu(p).loadoper(2,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'VOpVmov2VOp done',p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
end;
end;
@ -1972,9 +1964,7 @@ unit aoptx86;
begin
{ We can remove the original MOV }
DebugMsg(SPeepholeOptimization + 'Mov2Nop 3 done',p);
Asml.Remove(p);
p.Free;
p := hp1;
RemoveCurrentp(p, hp1);
{ TmpUsedRegs contains the results of "UpdateUsedRegs(tai(p.Next))" already,
so just restore it to UsedRegs instead of calculating it again }
@ -2042,8 +2032,7 @@ unit aoptx86;
begin
GetNextInstruction_p := GetNextInstruction(hp1, hp2);
DebugMsg(SPeepholeOptimization + 'Mov2Nop 4 done',hp1);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
{ The instruction after what was hp1 is now the immediate next instruction,
so we can continue to make optimisations if it's present }
@ -2130,8 +2119,7 @@ unit aoptx86;
InternalError(2020021001);
end;
DebugMsg(SPeepholeOptimization + 'MovMovXX2MovXX 2 done',p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result := True;
Exit;
end;
@ -2186,8 +2174,7 @@ unit aoptx86;
and ffffffffh, %reg
}
DebugMsg(SPeepholeOptimization + 'MovAnd2Mov 1 done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
exit;
end;
@ -2199,8 +2186,7 @@ unit aoptx86;
and ffffffffffffffffh, %reg
}
DebugMsg(SPeepholeOptimization + 'MovAnd2Mov 2 done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
exit;
end;
@ -2225,8 +2211,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization + 'MovAndTest2Test done',p);
taicpu(hp1).loadoper(1,taicpu(p).oper[0]^);
taicpu(hp1).opcode:=A_TEST;
asml.Remove(hp2);
hp2.free;
RemoveInstruction(hp2);
RemoveCurrentP(p, hp1);
Result:=true;
exit;
@ -2325,8 +2310,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization + PreMessage + '; and' + debug_opsize2str(taicpu(hp1).opsize) + ' $' + MaskNum + ',' + RegName2 +
' -> movz' + debug_opsize2str(NewSize) + ' ' + InputVal + ',' + RegName2, p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
end;
Result := True;
@ -2375,8 +2359,7 @@ unit aoptx86;
AllocRegBetween(taicpu(hp1).oper[1]^.reg,p,hp1,usedregs);
taicpu(p).loadOper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'MovMov2Mov 5 done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
@ -2394,8 +2377,7 @@ unit aoptx86;
}
taicpu(p).loadreg(1, taicpu(hp1).oper[1]^.reg);
DebugMsg(SPeepholeOptimization + 'MovMov2Mov 3 done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
@ -2438,8 +2420,7 @@ unit aoptx86;
if taicpu(p).oper[0]^.typ=top_reg then
AllocRegBetween(taicpu(p).oper[0]^.reg,p,hp1,usedregs);
DebugMsg(SPeepholeOptimization + 'MovMov2Mov 1',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
exit;
end
@ -2462,8 +2443,7 @@ unit aoptx86;
cmp mem1, reg1
}
begin
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
taicpu(hp1).opcode := A_CMP;
taicpu(hp1).loadref(1,taicpu(hp1).oper[0]^.ref^);
taicpu(hp1).loadreg(0,taicpu(p).oper[0]^.reg);
@ -2502,8 +2482,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization + 'MovMovMov2MovMov 1 done',p);
taicpu(p).loadoper(1,taicpu(hp2).oper[1]^);
taicpu(hp1).loadoper(0,taicpu(hp2).oper[1]^);
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
end
{$ifdef i386}
{ this is enabled for i386 only, as the rules to create the reg sets below
@ -2548,8 +2527,7 @@ unit aoptx86;
end
else
begin
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
end
{$endif i386}
;
@ -2663,13 +2641,11 @@ unit aoptx86;
begin
DebugMsg(SPeepholeOptimization + debug_regname(CurrentReg) + ' = ' + RegName1 + '; removed unnecessary instruction (MovMov2MovNop 6b}',hp2);
AllocRegBetween(CurrentReg, p, hp2, UsedRegs);
asml.remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
end
else
begin
asml.remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
{ We can remove the original MOV too }
DebugMsg(SPeepholeOptimization + 'MovMov2NopNop 6b done',p);
@ -2769,8 +2745,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization + 'Removed movs/z instruction and extended earlier write (MovMovs/z2Mov/s/z)', hp2);
AllocRegBetween(taicpu(hp2).oper[1]^.reg, p, hp2, UsedRegs);
AsmL.Remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
Result := True;
Exit;
@ -2800,8 +2775,7 @@ unit aoptx86;
and ffffffffh, %reg
}
DebugMsg(SPeepholeOptimization + 'MovAnd2Mov 3 done',p);
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
Result:=true;
exit;
end;
@ -2833,9 +2807,7 @@ unit aoptx86;
)
) then
begin
asml.remove(p);
p.free;
p:=hp1;
RemoveCurrentp(p, hp1);
DebugMsg(SPeepholeOptimization + 'removed deadstore before leave/ret',p);
RemoveLastDeallocForFuncRes(p);
Result:=true;
@ -2975,8 +2947,7 @@ unit aoptx86;
->
decw %si addw %dx,%si p
}
asml.remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
RemoveCurrentP(p, hp1);
Result:=True;
Exit;
@ -3060,8 +3031,7 @@ unit aoptx86;
->
decw %si addw %dx,%si p
}
asml.remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
end;
end;
@ -3080,9 +3050,7 @@ unit aoptx86;
Taicpu(hp2).opcode:=A_MOV;
asml.remove(hp1);
insertllitem(hp2,hp2.next,hp1);
asml.remove(p);
p.free;
p:=hp1;
RemoveCurrentp(p, hp1);
Result:=true;
exit;
end;
@ -3124,15 +3092,15 @@ unit aoptx86;
if (taicpu(p).oper[1]^.typ=top_reg) and
not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,UsedRegs)) then
begin
asml.remove(p);
p.free;
GetNextInstruction(hp1,p);
DebugMsg(SPeepholeOptimization + 'MovXXMovXX2Nop 1 done',p);
RemoveInstruction(hp1);
RemoveCurrentp(p); { p will now be equal to the instruction that follows what was hp1 }
end
else
DebugMsg(SPeepholeOptimization + 'MovXXMovXX2MoVXX 1 done',p);
asml.remove(hp1);
hp1.free;
begin
DebugMsg(SPeepholeOptimization + 'MovXXMovXX2MoVXX 1 done',p);
RemoveInstruction(hp1);
end;
Result:=true;
exit;
end
@ -3171,8 +3139,7 @@ unit aoptx86;
taicpu(p).loadoper(0,taicpu(hp1).oper[0]^);
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'OpMov2Op done',p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
end;
end;
@ -3243,8 +3210,7 @@ unit aoptx86;
begin
taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
DebugMsg(SPeepholeOptimization + 'LeaMov2Lea done',p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
result:=true;
end;
end;
@ -3403,16 +3369,14 @@ unit aoptx86;
MatchOperand(taicpu(hp1).oper[0]^,taicpu(p).oper[1]^) then
begin
taicpu(p).loadConst(0,taicpu(p).oper[0]^.val+1);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
A_SUB:
if MatchOpType(taicpu(hp1),top_const,top_reg) and
MatchOperand(taicpu(hp1).oper[1]^,taicpu(p).oper[1]^) then
begin
taicpu(p).loadConst(0,taicpu(p).oper[0]^.val+taicpu(hp1).oper[0]^.val);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
A_ADD:
begin
@ -3420,13 +3384,11 @@ unit aoptx86;
MatchOperand(taicpu(hp1).oper[1]^,taicpu(p).oper[1]^) then
begin
taicpu(p).loadConst(0,taicpu(p).oper[0]^.val-taicpu(hp1).oper[0]^.val);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
if (taicpu(p).oper[0]^.val = 0) then
begin
hp1 := tai(p.next);
asml.remove(p);
p.free;
RemoveInstruction(p); { Note, the choice to not use RemoveCurrentp is deliberate }
if not GetLastInstruction(hp1, p) then
p := hp1;
DoSubAddOpt := True;
@ -3474,9 +3436,7 @@ unit aoptx86;
if taicpu(hp1).oper[0]^.typ=top_reg then
setsubreg(taicpu(hp1).oper[0]^.reg,R_SUBWHOLE);
hp1 := tai(p.next);
asml.remove(p);
p.free;
p := hp1;
RemoveCurrentp(p, hp1);
Result:=true;
exit;
end;
@ -3546,8 +3506,7 @@ unit aoptx86;
if taicpu(hp1).oper[0]^.ref^.scalefactor<>0 then
tmpref.scalefactor:=tmpref.scalefactor*taicpu(hp1).oper[0]^.ref^.scalefactor;
TmpRef.base := taicpu(hp1).oper[0]^.ref^.base;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end
end
else if (taicpu(hp1).oper[0]^.typ = Top_Const) then
@ -3562,8 +3521,7 @@ unit aoptx86;
else
internalerror(2019050536);
end;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end
else
if (taicpu(hp1).oper[0]^.typ = Top_Reg) and
@ -3584,8 +3542,7 @@ unit aoptx86;
else
internalerror(2019050535);
end;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
end;
if TmpBool2
@ -3715,14 +3672,12 @@ unit aoptx86;
{ Don't remove the 'mov' instruction if its register is used elsewhere }
if not(RegUsedAfterInstruction(taicpu(hp1).oper[1]^.reg, hp2, TmpUsedRegs)) then
begin
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result := True;
end;
{ Only set Result to True if the 'mov' instruction was removed }
asml.Remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
end;
end
else
@ -3734,8 +3689,7 @@ unit aoptx86;
if not(RegUsedAfterInstruction(NR_DEFAULTFLAGS, hp1, TmpUsedRegs)) then
begin
DebugMsg(SPeepholeOptimization + 'ShlAnd2Shl', p);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result := True;
end;
end;
@ -3825,8 +3779,7 @@ unit aoptx86;
Exit;
end;
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
if Unconditional then
MakeUnconditional(taicpu(hp2))
@ -3840,11 +3793,8 @@ unit aoptx86;
if not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp2, TmpUsedRegs) then
begin
asml.Remove(p);
UpdateUsedRegs(next);
p.Free;
RemoveCurrentp(p, hp2);
Result := True;
p := hp2;
end;
DebugMsg(SPeepholeOptimization + 'SETcc/TESTCmp/Jcc -> Jcc',p);
@ -3879,11 +3829,8 @@ unit aoptx86;
(taicpu(p).oper[0]^.ref^.offset < tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.reference.offset)) and
(taicpu(p).oper[0]^.ref^.index = NR_NO) then
begin
asml.remove(p);
asml.remove(hp1);
p.free;
hp1.free;
p := hp2;
RemoveInstruction(hp1);
RemoveCurrentP(p, hp2);
RemoveLastDeallocForFuncRes(p);
Result := true;
end
@ -3896,8 +3843,7 @@ unit aoptx86;
if (taicpu(p).opcode = A_FSTP) then
taicpu(p).opcode := A_FST
else taicpu(p).opcode := A_FIST;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end
*)
end;
@ -3937,9 +3883,7 @@ unit aoptx86;
end;
taicpu(hp1).oper[0]^.reg := taicpu(p).oper[0]^.reg;
taicpu(hp1).oper[1]^.reg := NR_ST;
asml.remove(p);
p.free;
p := hp1;
RemoveCurrentP(p, hp1);
Result:=true;
exit;
end;
@ -3967,9 +3911,7 @@ unit aoptx86;
faddp/ fmul st, st
fmulp st, st1 (hp2) }
begin
asml.remove(p);
p.free;
p := hp1;
RemoveCurrentP(p, hp1);
if (taicpu(hp2).opcode = A_FADDP) then
taicpu(hp2).opcode := A_FADD
else
@ -4004,8 +3946,7 @@ unit aoptx86;
else
internalerror(2019050533);
end;
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
end
else
;
@ -4055,8 +3996,7 @@ unit aoptx86;
begin
DebugMsg(SPeepholeOptimization + 'Cmpcc2Testcc - condition B/C/NAE/O --> Never (jump removed)', hp1);
TAsmLabel(taicpu(hp1).oper[0]^.ref^.symbol).decrefs;
AsmL.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
{ Since hp1 was deleted, hp2 must not be updated }
Continue;
end
@ -4221,8 +4161,7 @@ unit aoptx86;
MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^) then
begin
DebugMsg(SPeepholeOptimization + 'PXorPXor2PXor done',hp1);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
@ -4249,8 +4188,7 @@ unit aoptx86;
MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^,taicpu(hp1).oper[2]^) then
begin
DebugMsg(SPeepholeOptimization + 'VPXorVPXor2PXor done',hp1);
asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result:=true;
Exit;
end;
@ -4348,8 +4286,7 @@ unit aoptx86;
taicpu(p).opcode := A_LEA;
taicpu(p).loadref(0, NewRef);
Asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
Result := True;
Exit;
@ -4379,9 +4316,7 @@ unit aoptx86;
not RegUsedAfterInstruction(taicpu(p).oper[1]^.reg, hp1, TmpUsedRegs)
then
begin
asml.remove(p);
p.free;
p := hp1;
RemoveCurrentP(p, hp1);
Result:=true;
end;
@ -4420,12 +4355,9 @@ unit aoptx86;
AllocRegBetween(taicpu(hp2).oper[1]^.reg, p, hp1, UsedRegs);
taicpu(hp1).opcode := A_XCHG;
asml.Remove(p);
asml.Remove(hp2);
p.Free;
hp2.Free;
RemoveCurrentP(p, hp1);
RemoveInstruction(hp2);
p := hp1;
Result := True;
Exit;
end;
@ -4449,8 +4381,7 @@ unit aoptx86;
cltd
}
DebugMsg(SPeepholeOptimization + 'MovSar2Cltd', p);
Asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
taicpu(p).opcode := A_CDQ;
taicpu(p).opsize := S_NO;
taicpu(p).clearop(1);
@ -4531,8 +4462,7 @@ unit aoptx86;
taicpu(p).clearop(0);
taicpu(p).ops:=0;
AsmL.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
taicpu(hp2).loadreg(0, NR_EDX);
taicpu(hp2).loadreg(1, NR_EAX);
@ -4578,8 +4508,7 @@ unit aoptx86;
cqto
}
DebugMsg(SPeepholeOptimization + 'MovSar2Cqto', p);
Asml.Remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
taicpu(p).opcode := A_CQO;
taicpu(p).opsize := S_NO;
taicpu(p).clearop(1);
@ -4660,8 +4589,7 @@ unit aoptx86;
taicpu(hp1).clearop(0);
taicpu(hp1).ops:=0;
AsmL.Remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
(*
{$ifdef x86_64}
end
@ -4708,8 +4636,7 @@ unit aoptx86;
taicpu(hp1).clearop(0);
taicpu(hp1).ops:=0;
AsmL.Remove(hp2);
hp2.Free;
RemoveInstruction(hp2);
{$endif x86_64}
*)
end;
@ -4799,8 +4726,7 @@ unit aoptx86;
taicpu(hp1).opcode := A_ADD;
{ Delete old ADD/LEA instruction }
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
{ Convert "shrq $1, reg1q" to "rcr $1, reg1d" }
taicpu(hp3).opcode := A_RCR;
@ -4839,8 +4765,7 @@ unit aoptx86;
taicpu(p).loadreg(2,taicpu(p).oper[1]^.reg);
taicpu(p).loadreg(1,taicpu(hp1).oper[0]^.reg);
DebugMsg(SPeepholeOptimization + 'MovImul2Imul done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
result:=true;
end;
end;
@ -5270,8 +5195,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization+'JccMov2CMov',p);
{ Remove the original jump }
asml.Remove(p);
p.Free;
RemoveInstruction(p); { Note, the choice to not use RemoveCurrentp is deliberate }
GetNextInstruction(hp2, p); { Instruction after the label }
@ -5369,8 +5293,7 @@ unit aoptx86;
DebugMsg(SPeepholeOptimization+'JccMovJmpMov2CMovCMov',hp1);
{ remove jCC }
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
{ Now we can safely decrement it }
tasmlabel(symbol).decrefs;
@ -5381,8 +5304,7 @@ unit aoptx86;
{ remove jmp }
symbol := taicpu(hp2).oper[0]^.ref^.symbol;
asml.remove(hp2);
hp2.free;
RemoveInstruction(hp2);
{ As before, now we can safely decrement it }
tasmlabel(symbol).decrefs;
@ -5483,11 +5405,8 @@ unit aoptx86;
decw %si addw %dx,%si p
}
DebugMsg(SPeepholeOptimization + 'var3',p);
asml.remove(p);
asml.remove(hp2);
p.free;
hp2.free;
p:=hp1;
RemoveCurrentP(p, hp1);
RemoveInstruction(hp2);
end
else if reg_and_hp1_is_instr and
(taicpu(hp1).opcode = A_MOV) and
@ -5525,8 +5444,7 @@ unit aoptx86;
else
{$endif x86_64}
taicpu(p).loadreg(1,taicpu(hp1).oper[1]^.reg);
asml.remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
end;
end
else if reg_and_hp1_is_instr and
@ -5571,15 +5489,13 @@ unit aoptx86;
if (taicpu(hp1).oper[0]^.val = $ff) then
begin
DebugMsg(SPeepholeOptimization + 'var4',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
S_WL{$ifdef x86_64}, S_WQ{$endif x86_64}:
if (taicpu(hp1).oper[0]^.val = $ffff) then
begin
DebugMsg(SPeepholeOptimization + 'var5',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
end;
{$ifdef x86_64}
S_LQ:
@ -5587,8 +5503,7 @@ unit aoptx86;
begin
if (cs_asm_source in current_settings.globalswitches) then
asml.insertbefore(tai_comment.create(strpnew(SPeepholeOptimization + 'var6')),p);
asml.remove(hp1);
hp1.Free;
RemoveInstruction(hp1);
end;
{$endif x86_64}
else
@ -5781,9 +5696,7 @@ unit aoptx86;
begin
taicpu(hp1).loadConst(0, taicpu(p).oper[0]^.val and taicpu(hp1).oper[0]^.val);
DebugMsg(SPeepholeOptimization + 'AndAnd2And done',hp1);
asml.remove(p);
p.Free;
p:=hp1;
RemoveCurrentP(p, hp1);
Result:=true;
exit;
end
@ -5819,8 +5732,7 @@ unit aoptx86;
}
DebugMsg(SPeepholeOptimization + 'AndMovzToAnd done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Exit;
end;
end
@ -5880,8 +5792,7 @@ unit aoptx86;
then
begin
DebugMsg(SPeepholeOptimization + 'AndMovsxToAnd',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Exit;
end;
end
@ -6074,10 +5985,8 @@ unit aoptx86;
taicpu(hp1).is_jmp := true;
DebugMsg(SPeepholeOptimization + 'LeaCallLeaRet2Jmp done',p);
RemoveCurrentP(p, hp4);
AsmL.Remove(hp2);
hp2.free;
AsmL.Remove(hp3);
hp3.free;
RemoveInstruction(hp2);
RemoveInstruction(hp3);
Result:=true;
end;
end;
@ -6127,10 +6036,8 @@ unit aoptx86;
taicpu(hp1).is_jmp := true;
DebugMsg(SPeepholeOptimization + 'PushCallPushRet2Jmp done',p);
RemoveCurrentP(p, hp4);
AsmL.Remove(hp2);
hp2.free;
AsmL.Remove(hp3);
hp3.free;
RemoveInstruction(hp2);
RemoveInstruction(hp3);
Result:=true;
end;
{$endif x86_64}
@ -6283,10 +6190,7 @@ unit aoptx86;
((taicpu(hp1).opcode <> A_ADD) and
(taicpu(hp1).opcode <> A_SUB))) then
begin
hp1 := tai(p.next);
asml.remove(p);
p.free;
p := tai(hp1);
RemoveCurrentP(p, hp2);
Result:=true;
end;
end;
@ -6302,10 +6206,7 @@ unit aoptx86;
{ and in case of carry for A(E)/B(E)/C/NC }
(taicpu(hp2).condition in [C_Z,C_NZ,C_E,C_NE]) then
begin
hp1 := tai(p.next);
asml.remove(p);
p.free;
p := tai(hp1);
RemoveCurrentP(p, hp2);
Result:=true;
end;
end;
@ -6333,10 +6234,7 @@ unit aoptx86;
else
;
end;
hp1 := tai(p.next);
asml.remove(p);
p.free;
p := tai(hp1);
RemoveCurrentP(p, hp2);
Result:=true;
end;
end
@ -6373,8 +6271,7 @@ unit aoptx86;
InsertLLItem(p.previous, p, hp2);
taicpu(p).opcode := A_JMP;
taicpu(p).is_jmp := true;
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
end
else
@ -6405,8 +6302,7 @@ unit aoptx86;
end
else
DebugMsg(SPeepholeOptimization + 'CallRet2Call done',p);
asml.remove(hp1);
hp1.free;
RemoveInstruction(hp1);
Result:=true;
end;
end;

2
packages/fcl-passrc/src/pastree.pp
View File

@ -5724,7 +5724,7 @@ begin
Result:=Result+', ';
Result:=Result+Params[I].GetDeclaration(Full);
end;
if Kind = pekSet then
if Kind in [pekSet,pekArrayParams] then
Result := '[' + Result + ']'
else
Result := '(' + Result + ')';

31
packages/fcl-passrc/src/paswrite.pp
View File

@ -1241,31 +1241,38 @@ begin
end;
procedure TPasWriter.WriteImplIfElse(AIfElse: TPasImplIfElse);
Var
DoBeginEnd : Boolean;
begin
Add('if ' + AIfElse.Condition + ' then');
if Assigned(AIfElse.IfBranch) then
begin
begin
AddLn;
if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
(AIfElse.IfBranch.ClassType = TPasImplBlock) then
DoBeginEnd:=(AIfElse.IfBranch.ClassType = TPasImplCommands) or
(AIfElse.IfBranch.ClassType = TPasImplBlock) or
Assigned(aIfElse.ElseBranch);
if DoBeginEnd then
AddLn('begin');
IncIndent;
WriteImplElement(AIfElse.IfBranch, False);
DecIndent;
if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
(AIfElse.IfBranch.ClassType = TPasImplBlock) then
if DoBeginEnd then
begin
if Assigned(AIfElse.ElseBranch) then
Add('end ')
else
AddLn('end;')
end
else
if Assigned(AIfElse.ElseBranch) then
AddLn;
end else
if not Assigned(AIfElse.ElseBranch) then
AddLn(';')
else
AddLn;
end
else if not Assigned(AIfElse.ElseBranch) then
AddLn(';')
else
AddLn;
if Assigned(AIfElse.ElseBranch) then
if AIfElse.ElseBranch.ClassType = TPasImplIfElse then
@ -1277,10 +1284,10 @@ begin
AddLn('else');
IncIndent;
WriteImplElement(AIfElse.ElseBranch, True);
if (not Assigned(AIfElse.Parent)) or
{ if (not Assigned(AIfElse.Parent)) or
(AIfElse.Parent.ClassType <> TPasImplIfElse) or
(TPasImplIfElse(AIfElse.Parent).IfBranch <> AIfElse) then
AddLn(';');
AddLn(';');}
DecIndent;
end;
end;

26
rtl/aarch64/mathu.inc
View File

@ -103,21 +103,23 @@ function GetExceptionMask: TFPUExceptionMask;
if ((fpcr and fpu_ide)=0) then
result := result+[exDenormalized];
}
{ as the fpcr flags might be RAZ, the softfloat exception mask
is considered as the authoritative mask }
result:=softfloat_exception_mask;
end;
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
{
var
newfpcr: dword;
}
begin
{ as I am not aware of any hardware exception supporting AArch64 implementation,
and else the trapping enable flags are RAZ, work solely with softfloat_exception_mask (FK)
}
{ clear "exception happened" flags }
ClearExceptions(false);
softfloat_exception_mask:=mask;
{
{ at least the ThunderX AArch64 support apperently hardware exceptions,
so set fpcr correctly, thought it might be WI on most implementations it does not hurt
}
newfpcr:=fpu_exception_mask;
if exInvalidOp in Mask then
newfpcr:=newfpcr and not(fpu_ioe);
@ -131,14 +133,10 @@ function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
newfpcr:=newfpcr and not(fpu_ixe);
if exDenormalized in Mask then
newfpcr:=newfpcr and not(fpu_ide);
}
{ clear "exception happened" flags }
ClearExceptions(false);
{ set new exception mask }
// setfpcr((getfpcr and not(fpu_exception_mask)) or newfpcr);
{ unsupported mask bits will remain 0 -> read exception mask again }
// result:=GetExceptionMask;
// softfloat_exception_mask:=result;
setfpcr((getfpcr and not(fpu_exception_mask)) or newfpcr);
{ as the fpcr flags might be RAZ, the softfloat exception mask
is considered as the authoritative mask }
result:=softfloat_exception_mask;
end;

11
rtl/aix/sysos.inc
View File

@ -96,10 +96,15 @@ end;
*****************************************************************************}
function do_isdevice(handle:longint):boolean;
var
StatRec: Stat;
begin
do_isdevice:= (handle=StdInputHandle) or
(handle=StdOutputHandle) or
(handle=StdErrorHandle);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
S_IFCHR, S_IFIFO, S_IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

19
rtl/beos/sysos.inc
View File

@ -132,17 +132,14 @@ end;
*****************************************************************************}
Function Do_IsDevice(Handle:Longint):boolean;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
CONST
IOCtl_TCGETS=$5401;
var
Data : array[0..255] of byte; {Large enough for termios info}
StatRec: Stat;
begin
Do_IsDevice:=(Fpioctl(handle,IOCTL_TCGETS,@data)<>-1);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
(* S_IFSOCK supposedly not available under BeOS, thus omitted *)
S_IFCHR, S_IFIFO: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

18
rtl/bsd/sysos.inc
View File

@ -156,19 +156,15 @@ end;
*****************************************************************************}
Function Do_IsDevice(Handle:Longint):boolean;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
CONST
IOCtl_TCGETS=$40000000+$2C7400+ 19;
var
Data : array[0..255] of byte; {Large enough for termios info}
StatRec: Stat;
begin
Do_IsDevice:=(Fpioctl(handle,IOCTL_TCGETS,@data)<>-1);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
S_IFCHR, S_IFIFO, S_IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

2
rtl/emx/sysfile.inc
View File

@ -397,7 +397,7 @@ asm
call syscall
mov eax, 1
jc @IsDevEnd
test edx, 80h { verify if it is a file }
test edx, 80h { bit 7 is set if it is a device or a pipe }
jnz @IsDevEnd
dec eax { nope, so result is zero }
@IsDevEnd:

9
rtl/gba/sysfile.inc
View File

@ -74,7 +74,14 @@ begin
end;
function do_isdevice(handle: longint): boolean;
var
StatRec: TStat;
begin
result := false;
FStat (Handle, StatRec);
case StatRec.st_Mode and _IFMT of
_IFCHR, _IFIFO, _IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

18
rtl/haiku/sysos.inc
View File

@ -108,15 +108,13 @@ end;
*****************************************************************************}
Function Do_IsDevice(Handle:Longint):boolean;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
var
StatRec: Stat;
begin
do_isdevice:= (handle=StdInputHandle) or
(handle=StdOutputHandle) or
(handle=StdErrorHandle);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
S_IFCHR, S_IFIFO, S_IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

5
rtl/inc/compproc.inc
View File

@ -806,6 +806,11 @@ Procedure fpc_rewrite_typed_name_iso(var f : TypedFile;const FileName : String;S
Procedure fpc_typed_write(TypeSize : Longint;var f : TypedFile;const Buf); compilerproc;
Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
Procedure fpc_typed_read_iso(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
Procedure fpc_typedfile_init_iso(var t : TypedFile;nr : DWord);compilerproc;
Procedure fpc_typedfile_init_filename_iso(var t : TypedFile;nr : DWord;const filename : string); compilerproc;
Procedure fpc_typedfile_close_iso(var t : TypedFile); compilerproc;
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE}

69
rtl/inc/text.inc
View File

@ -96,12 +96,6 @@ end;
Procedure Assign(out t:Text;const s : UnicodeString);
begin
InitText(t);
if Length (S) >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
{$ifdef FPC_ANSI_TEXTFILEREC}
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
{$else FPC_ANSI_TEXTFILEREC}
@ -115,29 +109,12 @@ end;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out t:Text;const s: RawByteString);
{$ifdef FPC_ANSI_TEXTFILEREC}
var
R: RawByteString;
{$endif FPC_ANSI_TEXTFILEREC}
Begin
InitText(t);
{$ifdef FPC_ANSI_TEXTFILEREC}
{ ensure the characters in the record's filename are encoded correctly }
R:=ToSingleByteFileSystemEncodedFileName(S);
if Length (R) >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
TextRec(t).Name:=R;
TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
{$else FPC_ANSI_TEXTFILEREC}
if Length (S) >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
TextRec(t).Name:=S;
{$endif FPC_ANSI_TEXTFILEREC}
{ null terminate, since the name array is regularly used as p(wide)char }
@ -161,61 +138,27 @@ End;
Procedure Assign(out t:Text;const p: PAnsiChar);
var
{$IFDEF FPC_HAS_FEATURE_ANSISTRINGS}
S: ansistring;
{$ELSE FPC_HAS_FEATURE_ANSISTRINGS}
Counter: SizeInt;
{$ENDIF FPC_HAS_FEATURE_ANSISTRINGS}
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
S := AnsiString (P);
if Length (S) >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
Assign(t,S);
Assign(t,AnsiString(p));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
{ no use in making this the one that does the work, since the name field is
limited to 255 characters anyway }
{ Assign(t,strpas(p));}
{ TH: The length of name field may be extended sooner or later, let's play
safely }
Counter := IndexByte(P^,-1,0);
if Counter >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
Move(P^,TextRec(t).Name,counter+1);
Assign(t,strpas(p));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Assign(out t:Text;const c: AnsiChar);
{$IFNDEF FPC_HAS_FEATURE_ANSISTRINGS}
var
Counter: SizeInt;
{$ENDIF FPC_HAS_FEATURE_ANSISTRINGS}
Begin
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Assign(t,AnsiString(c));
{$else FPC_HAS_FEATURE_ANSISTRINGS}
Counter := IndexByte(c,-1,0);
if Counter >= Length (TextRec.Name) then
{ The last character of TextRec.Name needs to be #0 }
begin
InOutRes:=3;
Exit;
end;
Move(c,TextRec(F).Name,counter+1);
{ Assign(t,ShortString(c));}
Assign(t,ShortString(c));
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
End;
Procedure Close(var t : Text);[IOCheck];
Begin
if InOutRes<>0 then
@ -565,7 +508,7 @@ Begin
if not isdevice then
{ if we didn't modify the buffer, simply restore the BufPos and BufEnd }
{ (the latter because it's now probably set to zero because nothing was }
{ read anymore) }
{ was read anymore) }
if (reads = 0) then
begin
TextRec(t).BufPos:=oldbufpos;

41
rtl/inc/typefile.inc
View File

@ -199,3 +199,44 @@ Begin
Result:=pbyte(@f)+sizeof(TypedFile);
end;
Procedure fpc_typedfile_init_iso(var t : TypedFile;nr : DWord);compilerproc;
begin
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
assign(t,paramstr(nr));
{$else FPC_HAS_FEATURE_COMMANDARGS}
{ primitive workaround for targets supporting no command line arguments,
invent some file name, try to avoid complex procedures like concating strings which might
pull-in bigger parts of the rtl }
assign(t,chr((nr mod 16)+65));
{$endif FPC_HAS_FEATURE_COMMANDARGS}
end;
Procedure fpc_typedfile_init_filename_iso(var t : TypedFile;nr : DWord;const filename : string);compilerproc;
begin
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
if paramstr(nr)='' then
assign(t,filename)
else
assign(t,paramstr(nr));
{$else FPC_HAS_FEATURE_COMMANDARGS}
{ primitive workaround for targets supporting no command line arguments,
invent some file name, try to avoid complex procedures like concating strings which might
pull-in bigger parts of the rtl }
assign(t,chr((nr mod 16)+65));
{$endif FPC_HAS_FEATURE_COMMANDARGS}
end;
Procedure fpc_typedfile_close_iso(var t : TypedFile);compilerproc;
begin
{ reset inout result as this procedure is only called by the compiler and no I/O checking is carried out,
so further I/O does not fail }
inoutres:=0;
close(t);
inoutres:=0;
end;

23
rtl/linux/aarch64/sighnd.inc
View File

@ -15,6 +15,8 @@
**********************************************************************}
{ $define SYSTEM_DEBUG}
procedure SignalToRunerror(Sig: longint; SigInfo: PSigInfo; UContext: PUContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
var
@ -23,7 +25,19 @@ begin
res:=0;
case sig of
SIGFPE:
begin
res:=207;
{$ifdef SYSTEM_DEBUG}
writeln('magic of FPSIMD_Context: $',hexstr(uContext^.uc_mcontext.FPSIMD_Context.head.magic,8));
writeln('size of FPSIMD_Context: $',hexstr(uContext^.uc_mcontext.FPSIMD_Context.head.size,8));
{$endif SYSTEM_DEBUG}
if (uContext^.uc_mcontext.FPSIMD_Context.head.magic=$46508001) and
(uContext^.uc_mcontext.FPSIMD_Context.head.size=$210) then
begin
with uContext^.uc_mcontext.FPSIMD_Context do
fpsr:=fpsr and not(fpu_exception_mask shr fpu_exception_mask_to_status_mask_shift);
end;
end;
SIGILL:
res:=216;
SIGSEGV :
@ -38,7 +52,10 @@ begin
reenable_signal(sig);
{ give runtime error at the position where the signal was raised }
if res<>0 then
HandleErrorAddrFrame(res,
pointer(uContext^.uc_mcontext.pc),
pointer(uContext^.uc_mcontext.regs[29]));
begin
uContext^.uc_mcontext.regs[0]:=res;
uContext^.uc_mcontext.regs[1]:=uContext^.uc_mcontext.pc;
uContext^.uc_mcontext.regs[2]:=uContext^.uc_mcontext.regs[29];
pointer(uContext^.uc_mcontext.pc):=@HandleErrorAddrFrame;
end;
end;

18
rtl/linux/aarch64/sighndh.inc
View File

@ -17,6 +17,18 @@
{$packrecords C}
type
TAarch64_ctx = record
magic,
size : DWord
end;
TFPSIMD_Context = record
head : TAarch64_ctx;
fpsr,
fpcr : DWord;
vregs : array[0..31] of array[0..7] of Byte;
end;
PSigContext = ^TSigContext;
TSigContext = record
fault_address : cULong;
@ -25,10 +37,12 @@ type
pc : cULong;
pstate : cULong;
__pad : cULong;
{ The following field should be 16-byte-aligned. Currently the
{ The following fields should be 16-byte-aligned. Currently the
directive for specifying alignment is buggy, so the preceding
field was added so that the record has the right size. }
__reserved : array[0..4095] of cUChar;
case Byte of
1: (__reserved : array[0..4095] of cUChar);
2: (FPSIMD_Context : TFPSIMD_Context);
end;
stack_t = record

2
rtl/linux/ptypes.inc
View File

@ -30,7 +30,7 @@ and all three 32-bit systems returned completely identical types too
introduction)
}
{$ifdef CPUSPARC}
{$define __USE_LARGEFILE64}
{ define __USE_LARGEFILE64}
{$endif}
{$if defined(CPUMIPS) or defined(cpuaarch64) or defined(cpusparc64)}

26
rtl/linux/sysos.inc
View File

@ -137,27 +137,15 @@ end;
*****************************************************************************}
Function Do_IsDevice(Handle:THandle):boolean;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
const
{$if defined(cpupowerpc) or defined(cpupowerpc64)}
IOCtl_TCGETS=$402c7413;
{$else}
{$if defined(cpusparc) or defined(cpusparc64)}
IOCtl_TCGETS=$40245408;
{$else}
IOCtl_TCGETS=$5401; // TCGETS is also in termios.inc, but the sysunix needs only this
{$endif}
{$endif}
var
Data : array[0..255] of byte; {Large enough for termios info}
StatRec: Stat;
begin
Do_IsDevice:=(Fpioctl(handle,IOCTL_TCGETS,@data)<>-1);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
S_IFCHR, S_IFIFO, S_IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

10
rtl/nds/sysfile.inc
View File

@ -296,9 +296,15 @@ end;
function do_isdevice(handle: THandle): boolean;
var
StatRec: TStat;
begin
//result := (isatty(fileno(P_FILE(handle))) > 0);
do_isdevice := (_isatty(handle) > 0);
FStat (Handle, StatRec);
case StatRec.st_Mode and _IFMT of
_IFCHR, _IFIFO, _IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

5
rtl/os2/sysfile.inc
View File

@ -343,6 +343,9 @@ function do_isdevice (Handle: THandle): boolean;
var
HT, Attr: cardinal;
RC: cardinal;
const
dhDevice = 1;
dhPipe = 2;
begin
do_isdevice:=false;
RC := DosQueryHType(Handle, HT, Attr);
@ -351,7 +354,7 @@ begin
OSErrorWatch (RC);
Exit;
end;
if ht=1 then
if (HT = dhDevice) or (HT = dhPipe) then
do_isdevice:=true;
end;
{$ASMMODE ATT}

11
rtl/solaris/sysos.inc
View File

@ -97,10 +97,15 @@ end;
*****************************************************************************}
function do_isdevice(handle:longint):boolean;
var
StatRec: Stat;
begin
do_isdevice:= (handle=StdInputHandle) or
(handle=StdOutputHandle) or
(handle=StdErrorHandle);
fpFStat (Handle, StatRec);
case StatRec.st_Mode and S_IFMT of
S_IFCHR, S_IFIFO, S_IFSOCK: Do_IsDevice := true
else
Do_IsDevice := false;
end;
end;

80
rtl/unix/scripts/check_rtl_types.sh
View File

@ -1,7 +1,23 @@
#!/usr/bin/env bash
filename="$1"
shift
FPC_OPTS="$*"
verbose=0
i=1
while [ $i -le $# ] ; do
arg="${!i}"
echo "Handling arg $i, \"$arg\""
if [ "${arg//=}" != "$arg" ] ; then
echo "Evaluating \"$arg\""
arg2="${arg/=*/}=\"${arg/*=/}\""
eval "$arg2"
elif [ "$arg" == "-v" ] ; then
verbose=1
else
FPC_OPTS="$FPC_OPTS $arg"
fi
let i++
done
if [ ! -f "$filename" ] ; then
echo "Usage: $0 file.h2paschk"
@ -58,8 +74,16 @@ if [ $res -ne 0 ] ; then
exit
fi
echo "Calling $CC $CC_OPT -o ${filebase}_c ${filebase}.c"
$CC $CC_OPT -o ${filebase}_c${VERSION} ${filebase}.c > ${filebase}${VERSION}_c.comp.log 2>&1
TMP_DIR=tmp_$VERSION
if [ -d $TMP_DIR ] ; then
rm -Rf $TMP_DIR
fi
mkdir $TMP_DIR
mv ${filebase}.c ${filebase}.pas $TMP_DIR
cd $TMP_DIR
echo "Calling $CC $CC_OPT -o ${filebase}_${VERSION}_c ${filebase}.c"
$CC $CC_OPT -o ${filebase}_${VERSION}_c ${filebase}.c > ${filebase}_${VERSION}_c.comp.log 2>&1
res=$?
if [ $res -ne 0 ] ; then
echo "$CC call failed in $VERSION, res=$res"
@ -67,15 +91,15 @@ if [ $res -ne 0 ] ; then
exit
fi
./${filebase}_c${VERSION} > ${filebase}_c${VERSION}.out
./${filebase}_${VERSION}_c > ${filebase}_${VERSION}_c.out
res=$?
if [ $res -ne 0 ] ; then
echo "./${filebase}_c${VERSION} failed in $VERSION, res=$res"
echo "./${filebase}_${VERSION}_c failed in $VERSION, res=$res"
exit
fi
echo "Calling $MAKE all OPT=\"-n -gwl $FPC_OPTS\" FPC=$FPC"
$MAKE all OPT="-n -gwl $FPC_OPTS" FPC=$FPC > ${filebase}${VERSION}_make_all.log 2>&1
echo "Calling $MAKE -C .. all OPT=\"-n -gwl $FPC_OPTS\" FPC=$FPC"
$MAKE -C .. all OPT="-n -gwl $FPC_OPTS" FPC=$FPC > ${filebase}${VERSION}_make_all.log 2>&1
res=$?
if [ $res -ne 0 ] ; then
echo "$MAKE call failed in $VERSION, res=$res"
@ -85,24 +109,24 @@ fi
OS_TARGET=`$FPC $FPC_OPTS -iTO`
CPU_TARGET=`$FPC $FPC_OPTS -iTP`
echo "Calling $MAKE -C ${filedir} ${filebaseonly} FPC=$FPC OPT=\"-n -gwl $FPC_OPTS\" -Fu../units/$CPU_TARGET-$OS_TARGET"
$MAKE -C ${filedir} ${filebaseonly} FPC=$FPC OPT="-n -gwl $FPC_OPTS -Fu../units/$CPU_TARGET-$OS_TARGET" > ${filebase}${VERSION}_pas.comp.log 2>&1
echo "Calling $MAKE -C .. ${TMP_DIR}/${filebaseonly} FPC=$FPC OPT=\"-n -gwl $FPC_OPTS\" -Fu../units/$CPU_TARGET-$OS_TARGET"
$MAKE -C .. ${TMP_DIR}/${filebaseonly} FPC=$FPC OPT="-n -gwl $FPC_OPTS -Fu../units/$CPU_TARGET-$OS_TARGET" > ${filebase}_${VERSION}_pas.comp.log 2>&1
res=$?
if [ $res -ne 0 ] ; then
echo "$FPC call failed in $VERSION, res=$res"
cat ${filebase}${VERSION}_pas.comp.log
cat ${filebase}_${VERSION}_pas.comp.log
exit
fi
mv -f ${filebase} ${filebase}${VERSION}
mv -f ../${filebase} ./${filebase}_${VERSION}_pas
./${filebase}${VERSION} > ${filebase}_pas${VERSION}.out
./${filebase}_${VERSION}_pas > ${filebase}_${VERSION}_pas.out
res=$?
if [ $res -ne 0 ] ; then
echo "./${filebase}${VERSION} call failed in $VERSION, res=$res"
exit
fi
diff ${filebase}_c${VERSION}.out ${filebase}_pas${VERSION}.out > ${filebase}${VERSION}.diffs
diff ${filebase}_${VERSION}_c.out ${filebase}_${VERSION}_pas.out > ${filebase}_${VERSION}.diffs
res=$?
if [ $res -eq 0 ] ; then
echo "No difference found!"
@ -110,19 +134,21 @@ else
echo "Diffs for ${VERSION} are:"
echo "< C results"
echo "> Pascal results"
cat ${filebase}${VERSION}.diffs
cat ${filebase}_${VERSION}.diffs
fi
# Clean up
rm -f ${filebase}_c${VERSION}
rm -f ${filebase}${VERSION}
rm -f ${filebase}_c${VERSION}.out
rm -f ${filebase}_pas${VERSION}.out
rm -f ${filebase}${VERSION}_c.comp.log
rm -f ${filebase}${VERSION}_pas.comp.log
rm -f ${filebase}${VERSION}_make_all.log
rm -f ${filebase}.c
rm -f ${filebase}.pas
if [ $verbose -eq 0 ] ; then
rm -f ${filebase}_${VERSION}_c
rm -f ${filebase}_${VERSION}_pas
rm -f ${filebase}_${VERSION}_c.out
rm -f ${filebase}_pas${VERSION}.out
rm -f ${filebase}_${VERSION}_c.comp.log
rm -f ${filebase}_${VERSION}_pas.comp.log
rm -f ${filebase}_${VERSION}_make_all.log
rm -f ${filebase}.c
rm -f ${filebase}.pas
fi
cd ..
}
function check_64 ()
@ -207,10 +233,10 @@ if [ $default_fpc -eq 1 ] ; then
else
if [ "${FPC}" == "$FPC64" ] ; then
check_64
fi
if [ "${FPC}" == "$FPC32" ] ; then
elif [ "${FPC}" == "$FPC32" ] ; then
check_32
else
echo "Unrecognized FPC=\"$FPC\""
fi
fi

13
rtl/win/sysfile.inc
View File

@ -2,7 +2,7 @@
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
Low leve file functions
Low level file functions
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -19,8 +19,17 @@
*****************************************************************************}
function do_isdevice(handle:thandle):boolean;
{$IFNDEF WINCE}
var
HT: dword;
{$ENDIF WINCE}
begin
do_isdevice:=(handle = StdInputHandle) or (handle = StdOutputHandle) or (handle = StdErrorHandle);
{$IFDEF WINCE}
Do_IsDevice := false;
{$ELSE WINCE}
HT := GetFileType (Handle);
Do_IsDevice := (HT = FILE_TYPE_CHAR) or (HT = FILE_TYPE_PIPE);
{$ENDIF WINCE}
end;

1
rtl/win16/sysfile.inc
View File

@ -404,6 +404,7 @@ function do_isdevice(handle:THandle):boolean;
var
regs: Registers;
begin
(* Is this explicit check for the first three handles appropriate here??? *)
if (handle=StdInputHandle) or (handle=StdOutputHandle) or (handle=StdErrorHandle) then
begin
do_isdevice:=true;

7
tests/webtbf/tw37763.pp Normal file
View File

@ -0,0 +1,7 @@
{ %fail }
{$MODE ISO}
program forum(output);
var f:rawbytestring;
begin
writeln(f)
end.

1
tests/webtbs/DAT_TW37415 Normal file
View File

@ -0,0 +1 @@
1234

9
tests/webtbs/tw37415.pp Normal file
View File

@ -0,0 +1,9 @@
{ %OPT=-Miso -Sr }
{ %FILES=DAT_TW37415 }
program fileTest(dat_tw37415);
var
dat_tw37415: file of integer;
begin
reset(dat_tw37415);
end.

822
utils/fpcm/fpcmake.inc
View File

File diff suppressed because it is too large Load Diff

20
utils/fpcm/fpcmake.ini
View File

@ -871,11 +871,16 @@ ifneq ($(findstring sparc64,$(shell uname -a)),)
ifeq ($(BINUTILSPREFIX),)
GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
else
# gcc mips seems not to recognize -m32/-m64
ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
CROSSGCCOPT=-mabi=32
else
CROSSGCCOPT=-m32
endif
endif
endif
endif
endif
# Check if FPCFPMAKE compiler is same target as FPC
ifdef FPCFPMAKE
@ -883,6 +888,21 @@ FPCFPMAKE_CPU_TARGET=$(shell $(FPCFPMAKE) -iTP)
ifeq ($(CPU_TARGET),$(FPCFPMAKE_CPU_TARGET))
# In that case use GCCLIBDIR value for FPCMAKEGCCLIBDIR
FPCMAKEGCCLIBDIR:=$(GCCLIBDIR)
else
ifneq ($(findstring $(FPCFPMAKE_CPU_TARGET),aarch64 powerpc64 riscv64 sparc64 x86_64),)
FPCMAKE_CROSSGCCOPT=-m64
else
ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips64 mips64el),)
FPCMAKE_CROSSGCCOPT=-mabi=64
else
ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
FPCMAKE_CROSSGCCOPT=-mabi=32
else
FPCMAKE_CROSSGCCOPT=-m32
endif
endif
endif
FPCMAKEGCCLIBDIR:=$(shell dirname `gcc $(FPCMAKE_CROSSGCCOPT) -print-libgcc-file-name`)
endif
endif

2
utils/fpcm/revision.inc
View File

@ -1 +1 @@
'2020-08-06 rev 46290'
'2020-09-16 rev 46877'