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

* synchronised with trunk up to r26077

Browse Source 
git-svn-id: branches/hlcgllvm@26078 -
This commit is contained in:
Jonas Maebe 2013-11-13 13:12:49 +00:00
commit 386cda95b7
13 changed files with 307 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/browcol.pas
View File

@ -1673,6 +1673,8 @@ end;
Symbol^.Flags:=(Symbol^.Flags or sfObject); Symbol^.Flags:=(Symbol^.Flags or sfObject);
if tobjectdef(typedef).objecttype=odt_class then if tobjectdef(typedef).objecttype=odt_class then
Symbol^.Flags:=(Symbol^.Flags or sfClass); Symbol^.Flags:=(Symbol^.Flags or sfClass);
if tobjectdef(typedef).objecttype=odt_class then
if not(df_generic in typedef.defoptions) then
ProcessSymTable(Symbol,Symbol^.Items,tobjectdef(typedef).symtable); ProcessSymTable(Symbol,Symbol^.Items,tobjectdef(typedef).symtable);
end; end;
recorddef : recorddef :

221
compiler/i8086/n8086mat.pas
View File

@ -30,6 +30,8 @@ interface
type type
ti8086moddivnode = class(tmoddivnode) ti8086moddivnode = class(tmoddivnode)
function use_moddiv32bit_helper: boolean;
function first_moddivint: tnode; override;
procedure pass_generate_code;override; procedure pass_generate_code;override;
end; end;
@ -61,7 +63,26 @@ implementation
ti8086moddivnode ti8086moddivnode
*****************************************************************************} *****************************************************************************}
function log2(i : dword) : dword;
function ti8086moddivnode.use_moddiv32bit_helper: boolean;
begin
result:=is_32bit(left.resultdef) or
is_64bit(left.resultdef) or
is_32bit(right.resultdef) or
is_64bit(right.resultdef);
end;
function ti8086moddivnode.first_moddivint: tnode;
begin
if use_moddiv32bit_helper then
result:=inherited first_moddivint
else
result:=nil;
end;
function log2(i : word) : word;
begin begin
result:=0; result:=0;
i:=i shr 1; i:=i shr 1;
@ -79,9 +100,9 @@ implementation
power:longint; power:longint;
hl:Tasmlabel; hl:Tasmlabel;
op:Tasmop; op:Tasmop;
e : longint; e : smallint;
d,l,r,s,m,a,n,t : dword; d,l,r,s,m,a,n,t : word;
m_low,m_high,j,k : qword; m_low,m_high,j,k : dword;
begin begin
secondpass(left); secondpass(left);
if codegenerror then if codegenerror then
@ -90,7 +111,7 @@ implementation
if codegenerror then if codegenerror then
exit; exit;
if is_64bitint(resultdef) then if is_64bitint(resultdef) or is_32bitint(resultdef) then
{ should be handled in pass_1 (JM) } { should be handled in pass_1 (JM) }
internalerror(200109052); internalerror(200109052);
{ put numerator in register } { put numerator in register }
@ -107,39 +128,39 @@ implementation
"Cardinal($ffffffff) div 16" overflows! (JM) } "Cardinal($ffffffff) div 16" overflows! (JM) }
if is_signed(left.resultdef) Then if is_signed(left.resultdef) Then
begin begin
if (current_settings.optimizecputype <> cpu_386) and if (current_settings.optimizecputype > cpu_386) and
not(cs_opt_size in current_settings.optimizerswitches) then not(cs_opt_size in current_settings.optimizerswitches) then
{ use a sequence without jumps, saw this in { use a sequence without jumps, saw this in
comp.compilers (JM) } comp.compilers (JM) }
begin begin
{ no jumps, but more operations } { no jumps, but more operations }
hreg2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); hreg2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
emit_reg_reg(A_MOV,S_L,hreg1,hreg2); emit_reg_reg(A_MOV,S_W,hreg1,hreg2);
{If the left value is signed, hreg2=$ffffffff, otherwise 0.} {If the left value is signed, hreg2=$ffff, otherwise 0.}
emit_const_reg(A_SAR,S_L,31,hreg2); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,OS_16,15,hreg2);
{If signed, hreg2=right value-1, otherwise 0.} {If signed, hreg2=right value-1, otherwise 0.}
emit_const_reg(A_AND,S_L,tordconstnode(right).value.svalue-1,hreg2); emit_const_reg(A_AND,S_W,tordconstnode(right).value.svalue-1,hreg2);
{ add to the left value } { add to the left value }
emit_reg_reg(A_ADD,S_L,hreg2,hreg1); emit_reg_reg(A_ADD,S_W,hreg2,hreg1);
{ do the shift } { do the shift }
emit_const_reg(A_SAR,S_L,power,hreg1); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,OS_16,power,hreg1);
end end
else else
begin begin
{ a jump, but less operations } { a jump, but less operations }
emit_reg_reg(A_TEST,S_L,hreg1,hreg1); emit_reg_reg(A_TEST,S_W,hreg1,hreg1);
current_asmdata.getjumplabel(hl); current_asmdata.getjumplabel(hl);
cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NS,hl); cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NS,hl);
if power=1 then if power=1 then
emit_reg(A_INC,S_L,hreg1) emit_reg(A_INC,S_W,hreg1)
else else
emit_const_reg(A_ADD,S_L,tordconstnode(right).value.svalue-1,hreg1); emit_const_reg(A_ADD,S_W,tordconstnode(right).value.svalue-1,hreg1);
cg.a_label(current_asmdata.CurrAsmList,hl); cg.a_label(current_asmdata.CurrAsmList,hl);
emit_const_reg(A_SAR,S_L,power,hreg1); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,OS_16,power,hreg1);
end end
end end
else else
emit_const_reg(A_SHR,S_L,power,hreg1); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_16,power,hreg1);
location.register:=hreg1; location.register:=hreg1;
end end
else else
@ -148,85 +169,85 @@ implementation
begin begin
e:=tordconstnode(right).value.svalue; e:=tordconstnode(right).value.svalue;
d:=abs(e); d:=abs(e);
{ Determine algorithm (a), multiplier (m), and shift factor (s) for 32-bit { Determine algorithm (a), multiplier (m), and shift factor (s) for 16-bit
signed integer division. Based on: Granlund, T.; Montgomery, P.L.: signed integer division. Based on: Granlund, T.; Montgomery, P.L.:
"Division by Invariant Integers using Multiplication". SIGPLAN Notices, "Division by Invariant Integers using Multiplication". SIGPLAN Notices,
Vol. 29, June 1994, page 61. Vol. 29, June 1994, page 61.
} }
l:=log2(d); l:=log2(d);
j:=qword($80000000) mod qword(d); j:=dword($8000) mod dword(d);
k:=(qword(1) shl (32+l)) div (qword($80000000-j)); k:=(dword(1) shl (16+l)) div (dword($8000-j));
m_low:=((qword(1)) shl (32+l)) div d; m_low:=((dword(1)) shl (16+l)) div d;
m_high:=(((qword(1)) shl (32+l)) + k) div d; m_high:=(((dword(1)) shl (16+l)) + k) div d;
while ((m_low shr 1) < (m_high shr 1)) and (l > 0) do while ((m_low shr 1) < (m_high shr 1)) and (l > 0) do
begin begin
m_low:=m_low shr 1; m_low:=m_low shr 1;
m_high:=m_high shr 1; m_high:=m_high shr 1;
dec(l); dec(l);
end; end;
m:=dword(m_high); m:=word(m_high);
s:=l; s:=l;
if (m_high shr 31)<>0 then if (m_high shr 15)<>0 then
a:=1 a:=1
else else
a:=0; a:=0;
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_AX);
emit_const_reg(A_MOV,S_L,aint(m),NR_EAX); emit_const_reg(A_MOV,S_W,aint(m),NR_AX);
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_DX);
emit_reg(A_IMUL,S_L,hreg1); emit_reg(A_IMUL,S_W,hreg1);
emit_reg_reg(A_MOV,S_L,hreg1,NR_EAX); emit_reg_reg(A_MOV,S_W,hreg1,NR_AX);
if a<>0 then if a<>0 then
begin begin
emit_reg_reg(A_ADD,S_L,NR_EAX,NR_EDX); emit_reg_reg(A_ADD,S_W,NR_AX,NR_DX);
{ {
printf ("; dividend: memory location or register other than EAX or EDX\n"); printf ("; dividend: memory location or register other than AX or DX\n");
printf ("\n"); printf ("\n");
printf ("MOV EAX, 0%08LXh\n", m); printf ("MOV AX, 0%08LXh\n", m);
printf ("IMUL dividend\n"); printf ("IMUL dividend\n");
printf ("MOV EAX, dividend\n"); printf ("MOV AX, dividend\n");
printf ("ADD EDX, EAX\n"); printf ("ADD DX, AX\n");
if (s) printf ("SAR EDX, %d\n", s); if (s) printf ("SAR DX, %d\n", s);
printf ("SHR EAX, 31\n"); printf ("SHR AX, 15\n");
printf ("ADD EDX, EAX\n"); printf ("ADD DX, AX\n");
if (e < 0) printf ("NEG EDX\n"); if (e < 0) printf ("NEG DX\n");
printf ("\n"); printf ("\n");
printf ("; quotient now in EDX\n"); printf ("; quotient now in DX\n");
} }
end; end;
{ {
printf ("; dividend: memory location of register other than EAX or EDX\n"); printf ("; dividend: memory location of register other than AX or DX\n");
printf ("\n"); printf ("\n");
printf ("MOV EAX, 0%08LXh\n", m); printf ("MOV AX, 0%08LXh\n", m);
printf ("IMUL dividend\n"); printf ("IMUL dividend\n");
printf ("MOV EAX, dividend\n"); printf ("MOV AX, dividend\n");
if (s) printf ("SAR EDX, %d\n", s); if (s) printf ("SAR DX, %d\n", s);
printf ("SHR EAX, 31\n"); printf ("SHR AX, 15\n");
printf ("ADD EDX, EAX\n"); printf ("ADD DX, AX\n");
if (e < 0) printf ("NEG EDX\n"); if (e < 0) printf ("NEG DX\n");
printf ("\n"); printf ("\n");
printf ("; quotient now in EDX\n"); printf ("; quotient now in DX\n");
} }
if s<>0 then if s<>0 then
emit_const_reg(A_SAR,S_L,s,NR_EDX); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,OS_16,s,NR_DX);
emit_const_reg(A_SHR,S_L,31,NR_EAX); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_16,15,NR_AX);
emit_reg_reg(A_ADD,S_L,NR_EAX,NR_EDX); emit_reg_reg(A_ADD,S_W,NR_AX,NR_DX);
if e<0 then if e<0 then
emit_reg(A_NEG,S_L,NR_EDX); emit_reg(A_NEG,S_W,NR_DX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_DX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_AX);
location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_EDX,location.register) cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_DX,location.register)
end end
else else
begin begin
d:=tordconstnode(right).value.svalue; d:=tordconstnode(right).value.svalue;
if d>=$80000000 then if d>=$8000 then
begin begin
emit_const_reg(A_CMP,S_L,aint(d),hreg1); emit_const_reg(A_CMP,S_W,aint(d),hreg1);
location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
emit_const_reg(A_MOV,S_L,0,location.register); emit_const_reg(A_MOV,S_W,0,location.register);
emit_const_reg(A_SBB,S_L,-1,location.register); emit_const_reg(A_SBB,S_W,-1,location.register);
end end
else else
begin begin
@ -243,19 +264,19 @@ implementation
SIGPLAN Notices, Vol. 29, June 1994, page 61. SIGPLAN Notices, Vol. 29, June 1994, page 61.
} }
l:=log2(t)+1; l:=log2(t)+1;
j:=qword($ffffffff) mod qword(t); j:=dword($ffff) mod dword(t);
k:=(qword(1) shl (32+l)) div (qword($ffffffff-j)); k:=(dword(1) shl (16+l)) div (dword($ffff-j));
m_low:=((qword(1)) shl (32+l)) div t; m_low:=((dword(1)) shl (16+l)) div t;
m_high:=(((qword(1)) shl (32+l)) + k) div t; m_high:=(((dword(1)) shl (16+l)) + k) div t;
while ((m_low shr 1) < (m_high shr 1)) and (l>0) do while ((m_low shr 1) < (m_high shr 1)) and (l>0) do
begin begin
m_low:=m_low shr 1; m_low:=m_low shr 1;
m_high:=m_high shr 1; m_high:=m_high shr 1;
l:=l-1; l:=l-1;
end; end;
if (m_high shr 32)=0 then if (m_high shr 16)=0 then
begin begin
m:=dword(m_high); m:=word(m_high);
s:=l; s:=l;
a:=0; a:=0;
end end
@ -267,12 +288,12 @@ implementation
else else
begin begin
s:=log2(t); s:=log2(t);
m_low:=(qword(1) shl (32+s)) div qword(t); m_low:=(dword(1) shl (16+s)) div dword(t);
r:=dword(((qword(1)) shl (32+s)) mod qword(t)); r:=word(((dword(1)) shl (16+s)) mod dword(t));
if (r < ((t>>1)+1)) then if (r < ((t>>1)+1)) then
m:=dword(m_low) m:=word(m_low)
else else
m:=dword(m_low)+1; m:=word(m_low)+1;
a:=1; a:=1;
end; end;
{ Reduce multiplier for either algorithm to smallest possible } { Reduce multiplier for either algorithm to smallest possible }
@ -283,72 +304,72 @@ implementation
end; end;
{ Adjust multiplier for reduction of even divisors } { Adjust multiplier for reduction of even divisors }
inc(s,n); inc(s,n);
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_AX);
emit_const_reg(A_MOV,S_L,aint(m),NR_EAX); emit_const_reg(A_MOV,S_W,aint(m),NR_AX);
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_DX);
emit_reg(A_MUL,S_L,hreg1); emit_reg(A_MUL,S_W,hreg1);
if a<>0 then if a<>0 then
begin begin
{ {
printf ("; dividend: register other than EAX or memory location\n"); printf ("; dividend: register other than AX or memory location\n");
printf ("\n"); printf ("\n");
printf ("MOV EAX, 0%08lXh\n", m); printf ("MOV AX, 0%08lXh\n", m);
printf ("MUL dividend\n"); printf ("MUL dividend\n");
printf ("ADD EAX, 0%08lXh\n", m); printf ("ADD AX, 0%08lXh\n", m);
printf ("ADC EDX, 0\n"); printf ("ADC DX, 0\n");
if (s) printf ("SHR EDX, %d\n", s); if (s) printf ("SHR DX, %d\n", s);
printf ("\n"); printf ("\n");
printf ("; quotient now in EDX\n"); printf ("; quotient now in DX\n");
} }
emit_const_reg(A_ADD,S_L,aint(m),NR_EAX); emit_const_reg(A_ADD,S_W,aint(m),NR_AX);
emit_const_reg(A_ADC,S_L,0,NR_EDX); emit_const_reg(A_ADC,S_W,0,NR_DX);
end; end;
if s<>0 then if s<>0 then
emit_const_reg(A_SHR,S_L,aint(s),NR_EDX); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_16,aint(s),NR_DX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_DX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_AX);
location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_EDX,location.register) cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_DX,location.register)
end; end;
end end
end end
end end
else else
begin begin
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_AX);
emit_reg_reg(A_MOV,S_L,hreg1,NR_EAX); emit_reg_reg(A_MOV,S_W,hreg1,NR_AX);
cg.getcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.getcpuregister(current_asmdata.CurrAsmList,NR_DX);
{Sign extension depends on the left type.} {Sign extension depends on the left type.}
if torddef(left.resultdef).ordtype=u32bit then if torddef(left.resultdef).ordtype=u16bit then
emit_reg_reg(A_XOR,S_L,NR_EDX,NR_EDX) emit_reg_reg(A_XOR,S_W,NR_DX,NR_DX)
else else
emit_none(A_CDQ,S_NO); emit_none(A_CWD,S_NO);
{Division depends on the right type.} {Division depends on the right type.}
if Torddef(right.resultdef).ordtype=u32bit then if Torddef(right.resultdef).ordtype=u16bit then
op:=A_DIV op:=A_DIV
else else
op:=A_IDIV; op:=A_IDIV;
if right.location.loc in [LOC_REFERENCE,LOC_CREFERENCE] then if right.location.loc in [LOC_REFERENCE,LOC_CREFERENCE] then
emit_ref(op,S_L,right.location.reference) emit_ref(op,S_W,right.location.reference)
else if right.location.loc in [LOC_REGISTER,LOC_CREGISTER] then else if right.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
emit_reg(op,S_L,right.location.register) emit_reg(op,S_W,right.location.register)
else else
begin begin
hreg1:=cg.getintregister(current_asmdata.CurrAsmList,right.location.size); hreg1:=cg.getintregister(current_asmdata.CurrAsmList,right.location.size);
hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,u32inttype,right.location,hreg1); hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,u16inttype,right.location,hreg1);
emit_reg(op,S_L,hreg1); emit_reg(op,S_W,hreg1);
end; end;
{Copy the result into a new register. Release EAX & EDX.} {Copy the result into a new register. Release AX & DX.}
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EDX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_DX);
cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EAX); cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_AX);
location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
if nodetype=divn then if nodetype=divn then
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_EAX,location.register) cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_AX,location.register)
else else
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_EDX,location.register); cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_DX,location.register);
end; end;
end; end;

6
compiler/ogelf.pas
View File

@ -884,7 +884,7 @@ implementation
dec(data,len); dec(data,len);
if ElfTarget.relocs_use_addend then if ElfTarget.relocs_use_addend then
begin begin
objreloc.orgsize:=data; objreloc.orgsize:=aword(data);
data:=0; data:=0;
end; end;
end; end;
@ -1076,7 +1076,9 @@ implementation
rel.address:=objreloc.dataoffset; rel.address:=objreloc.dataoffset;
rel.info:=ELF_R_INFO(relsym,ElfTarget.encodereloc(objreloc)); rel.info:=ELF_R_INFO(relsym,ElfTarget.encodereloc(objreloc));
{$push}{$r-}
rel.addend:=objreloc.orgsize; rel.addend:=objreloc.orgsize;
{$pop}
{ write reloc } { write reloc }
{ ElfXX_Rel is essentially ElfXX_Rela without the addend field. } { ElfXX_Rel is essentially ElfXX_Rela without the addend field. }
@ -3114,7 +3116,9 @@ implementation
begin begin
rel.address:=dataofs; rel.address:=dataofs;
rel.info:=ELF_R_INFO(symidx,typ); rel.info:=ELF_R_INFO(symidx,typ);
{$push}{$r-}
rel.addend:=addend; rel.addend:=addend;
{$pop}
MaybeSwapElfReloc(rel); MaybeSwapElfReloc(rel);
dynrelocsec.write(rel,dynrelocsec.shentsize); dynrelocsec.write(rel,dynrelocsec.shentsize);
end; end;

11
compiler/x86_64/nx64flw.pas
View File

@ -143,6 +143,7 @@ function create_pd: tprocdef;
var var
st:TSymTable; st:TSymTable;
checkstack: psymtablestackitem; checkstack: psymtablestackitem;
oldsymtablestack: tsymtablestack;
sym:tprocsym; sym:tprocsym;
begin begin
{ get actual procedure symtable (skip withsymtables, etc.) } { get actual procedure symtable (skip withsymtables, etc.) }
@ -155,8 +156,16 @@ function create_pd: tprocdef;
break; break;
checkstack:=checkstack^.next; checkstack:=checkstack^.next;
end; end;
{ Create a nested procedure, even from main_program_level. } { Create a nested procedure, even from main_program_level.
Furthermore, force procdef and procsym into the same symtable
(by default, defs are registered with symtablestack.top which may be
something temporary like exceptsymtable - in that case, procdef can be
destroyed before procsym, leaving invalid pointers). }
oldsymtablestack:=symtablestack;
symtablestack:=nil;
result:=tprocdef.create(max(normal_function_level,st.symtablelevel)+1); result:=tprocdef.create(max(normal_function_level,st.symtablelevel)+1);
symtablestack:=oldsymtablestack;
st.insertdef(result);
result.struct:=current_procinfo.procdef.struct; result.struct:=current_procinfo.procdef.struct;
result.proctypeoption:=potype_exceptfilter; result.proctypeoption:=potype_exceptfilter;
handle_calling_convention(result); handle_calling_convention(result);

2
ide/fphelp.pas
View File

@ -183,7 +183,7 @@ const
hint_reloadmodifiedfile= 'Reload file modified on disk'; hint_reloadmodifiedfile= 'Reload file modified on disk';
hint_tools = 'Create or change tools'; hint_tools = 'Create or change tools';
hint_environmentmenu = 'Specify environment settins'; hint_environmentmenu = 'Specify environment settins';
hint_preferences = 'Specify desktop settings'; hint_preferences = 'Specify preferences settings';
hint_editoroptions = 'Specify default editor settings'; hint_editoroptions = 'Specify default editor settings';
hint_codecomplete = 'Specify CodeComplete keywords'; hint_codecomplete = 'Specify CodeComplete keywords';
hint_codetemplates = 'Specify CodeTemplates'; hint_codetemplates = 'Specify CodeTemplates';

4
ide/fpide.pas
View File

@ -875,7 +875,7 @@ begin
{$endif DebugUndo} {$endif DebugUndo}
NewLine( NewLine(
NewItem(menu_edit_cut,menu_key_edit_cut, cut_key, cmCut, hcCut, NewItem(menu_edit_cut,menu_key_edit_cut, cut_key, cmCut, hcCut,
NewItem(menu_edit_copy,menu_key_edit_copy, copy_key, cmCopy, hcCut, NewItem(menu_edit_copy,menu_key_edit_copy, copy_key, cmCopy, hcCopy,
NewItem(menu_edit_paste,menu_key_edit_paste, paste_key, cmPaste, hcPaste, NewItem(menu_edit_paste,menu_key_edit_paste, paste_key, cmPaste, hcPaste,
NewItem(menu_edit_clear,menu_key_edit_clear, kbCtrlDel, cmClear, hcClear, NewItem(menu_edit_clear,menu_key_edit_clear, kbCtrlDel, cmClear, hcClear,
NewItem(menu_edit_selectall,'', kbNoKey, cmSelectAll, hcSelectAll, NewItem(menu_edit_selectall,'', kbNoKey, cmSelectAll, hcSelectAll,
@ -934,7 +934,7 @@ begin
NewItem('~E~valuate...','Ctrl+F4', kbCtrlF4, cmEvaluate, hcEvaluate, NewItem('~E~valuate...','Ctrl+F4', kbCtrlF4, cmEvaluate, hcEvaluate,
NewItem(menu_debug_callstack,menu_key_debug_callstack, kbCtrlF3, cmStack, hcStackWindow, NewItem(menu_debug_callstack,menu_key_debug_callstack, kbCtrlF3, cmStack, hcStackWindow,
NewLine( NewLine(
NewItem(menu_debug_disassemble,'', kbNoKey, cmDisassemble, hcStackWindow, NewItem(menu_debug_disassemble,'', kbNoKey, cmDisassemble, hcDisassemblyWindow,
NewItem(menu_debug_registers,'', kbNoKey, cmRegisters, hcRegistersWindow, NewItem(menu_debug_registers,'', kbNoKey, cmRegisters, hcRegistersWindow,
NewItem(menu_debug_fpu_registers,'', kbNoKey, cmFPURegisters, hcFPURegisters, NewItem(menu_debug_fpu_registers,'', kbNoKey, cmFPURegisters, hcFPURegisters,
NewItem(menu_debug_vector_registers,'', kbNoKey, cmVectorRegisters, hcVectorRegisters, NewItem(menu_debug_vector_registers,'', kbNoKey, cmVectorRegisters, hcVectorRegisters,

4
ide/wconstse.inc
View File

@ -99,9 +99,9 @@
msg_cutting = 'Cutting'; msg_cutting = 'Cutting';
{ Help system } { Help system }
msg_nohelpfilesinstalled1 = 'To keep the size of the FPC download reasonable low, it comes without html formatted docs'; msg_nohelpfilesinstalled1 = 'To keep the size of the FPC download reasonably low, it comes without html formatted docs';
msg_nohelpfilesinstalled2 = 'which are necessary for the IDE.'; msg_nohelpfilesinstalled2 = 'which are necessary for the IDE.';
msg_nohelpfilesinstalled3 = 'To get these docs, go to http://www.freepascal.org/down/docs/docs.html and get one'; msg_nohelpfilesinstalled3 = 'To get these docs, go to http://www.freepascal.org/down/docs/docs.var and get one';
msg_nohelpfilesinstalled4 = 'of the html doc archives and unpack the enclosed contents into your FPC directory.'; msg_nohelpfilesinstalled4 = 'of the html doc archives and unpack the enclosed contents into your FPC directory.';
msg_nohelpfilesinstalled5 = 'Add fpctoc.html via Help|Files ... to the IDE help file system.'; msg_nohelpfilesinstalled5 = 'Add fpctoc.html via Help|Files ... to the IDE help file system.';
msg_helpindex = 'Help index'; msg_helpindex = 'Help index';

6
rtl/go32v2/v2prt0.as
View File

@ -857,6 +857,7 @@ _pascal_start:
movl 12(%ebx),%eax movl 12(%ebx),%eax
movl %eax,operatingsystem_parameter_envp movl %eax,operatingsystem_parameter_envp
movl %eax,__environ movl %eax,__environ
movl %eax,_environ
movl 8(%ebx),%eax movl 8(%ebx),%eax
movl %eax,_args movl %eax,_args
movl 4(%ebx),%eax movl 4(%ebx),%eax
@ -895,9 +896,10 @@ ___v2prt0_start_fs:
/* corresponding to _environ C variable */ /* corresponding to _environ C variable */
/* instead of _environ symbol since commit rev 1.11 */ /* instead of _environ symbol since commit rev 1.11 */
/* Thu Aug 19 9:11:52 2004 UTC by peuha */ /* Thu Aug 19 9:11:52 2004 UTC by peuha */
/* _environ is provided by linker script at the same address */ /* Provide both here to avoid crt1.o loading. */
/* as __environ if needed by linker. */
.comm __environ,4 .comm __environ,4
.comm _environ,4
/* Here Pierre Muller added all what was in crt1.c */ /* Here Pierre Muller added all what was in crt1.c */
/* in assembler */ /* in assembler */

175
rtl/inc/genmath.inc
View File

@ -136,122 +136,18 @@ end;
type type
float32 = longint; float32 = longint;
{$endif FPC_SYSTEM_HAS_float32} {$endif FPC_SYSTEM_HAS_float32}
{$ifndef FPC_SYSTEM_HAS_flag}
type
flag = byte;
{$endif FPC_SYSTEM_HAS_flag}
{$ifndef FPC_SYSTEM_HAS_extractFloat64Frac0} {$ifdef SUPPORT_DOUBLE}
Function extractFloat64Frac0(const a: float64): longint; { based on softfloat float64_to_int64_round_to_zero }
Begin function fpc_trunc_real(d : valreal) : int64; compilerproc;
extractFloat64Frac0 := a.high and $000FFFFF;
End;
{$endif not FPC_SYSTEM_HAS_extractFloat64Frac0}
{$ifndef FPC_SYSTEM_HAS_extractFloat64Frac1}
Function extractFloat64Frac1(const a: float64): longint;
Begin
extractFloat64Frac1 := a.low;
End;
{$endif not FPC_SYSTEM_HAS_extractFloat64Frac1}
{$ifndef FPC_SYSTEM_HAS_extractFloat64Exp}
Function extractFloat64Exp(const a: float64): smallint;
Begin
extractFloat64Exp:= ( a.high shr 20 ) AND $7FF;
End;
{$endif not FPC_SYSTEM_HAS_extractFloat64Exp}
{$ifndef FPC_SYSTEM_HAS_extractFloat64Frac}
Function extractFloat64Frac(const a: float64): int64;
Begin
extractFloat64Frac:=int64(a) and $000FFFFFFFFFFFFF;
End;
{$endif not FPC_SYSTEM_HAS_extractFloat64Frac}
{$ifndef FPC_SYSTEM_HAS_extractFloat64Sign}
Function extractFloat64Sign(const a: float64) : flag;
Begin
extractFloat64Sign := a.high shr 31;
End;
{$endif not FPC_SYSTEM_HAS_extractFloat64Sign}
Procedure shortShift64Left(a0:longint; a1:longint; count:smallint; VAR z0Ptr:longint; VAR z1Ptr:longint );
Begin
z1Ptr := a1 shl count;
if count = 0 then
z0Ptr := a0
else
z0Ptr := ( a0 shl count ) OR ( a1 shr ( ( - count ) AND 31 ) );
End;
function float64_to_int32_round_to_zero(a: float64 ): longint;
Var
aSign: flag;
aExp, shiftCount: smallint;
aSig0, aSig1, absZ, aSigExtra: longint;
z: longint;
label
invalid;
Begin
aSig1 := extractFloat64Frac1( a );
aSig0 := extractFloat64Frac0( a );
aExp := extractFloat64Exp( a );
aSign := extractFloat64Sign( a );
shiftCount := aExp - $413;
if 0<=shiftCount then
Begin
if (aExp=$7FF) and ((aSig0 or aSig1)<>0) then
goto invalid;
shortShift64Left(aSig0 OR $00100000, aSig1, shiftCount, absZ, aSigExtra );
End
else
Begin
if aExp<$3FF then
begin
float64_to_int32_round_to_zero := 0;
exit;
end;
aSig0 := aSig0 or $00100000;
aSigExtra := ( aSig0 shl ( shiftCount and 31 ) ) OR aSig1;
absZ := aSig0 shr ( - shiftCount );
End;
if aSign<>0 then
z:=-absZ
else
z:=absZ;
if ((aSign<>0) xor (z<0)) AND (z<>0) then
begin
invalid:
float_raise(float_flag_invalid);
if (aSign <> 0) then
float64_to_int32_round_to_zero:=longint($80000000)
else
float64_to_int32_round_to_zero:=$7FFFFFFF;
exit;
end;
if ( aSigExtra <> 0) then
float_raise(float_flag_inexact);
float64_to_int32_round_to_zero := z;
End;
function genmath_float64_to_int64_round_to_zero(a : float64) : int64;
var var
aSign : flag;
aExp, shiftCount : smallint; aExp, shiftCount : smallint;
aSig : int64; aSig : int64;
z : int64; z : int64;
a: float64 absolute d;
begin begin
aSig:=extractFloat64Frac(a); aSig:=(int64(a.high and $000fffff) shl 32) or longword(a.low);
aExp:=extractFloat64Exp(a); aExp:=(a.high shr 20) and $7FF;
aSign:=extractFloat64Sign(a);
if aExp<>0 then if aExp<>0 then
aSig:=aSig or $0010000000000000; aSig:=aSig or $0010000000000000;
shiftCount:= aExp-$433; shiftCount:= aExp-$433;
@ -259,10 +155,10 @@ invalid:
begin begin
if aExp>=$43e then if aExp>=$43e then
begin begin
if int64(a)<>$C3E0000000000000 then if (a.high<>$C3E00000) or (a.low<>0) then
begin begin
float_raise(float_flag_invalid); float_raise(float_flag_invalid);
if (aSign=0) or ((aExp=$7FF) and if (a.high>=0) or ((aExp=$7FF) and
(aSig<>$0010000000000000 )) then (aSig<>$0010000000000000 )) then
begin begin
result:=$7FFFFFFFFFFFFFFF; result:=$7FFFFFFFFFFFFFFF;
@ -287,71 +183,50 @@ invalid:
float_exception_flags |= float_flag_inexact; float_exception_flags |= float_flag_inexact;
} }
end; end;
if aSign<>0 then if a.high<0 then
z:=-z; z:=-z;
result:=z; result:=z;
end; end;
{$else SUPPORT_DOUBLE}
Function float32_to_int32_round_to_zero( a: Float32 ): longint; { based on softfloat float32_to_int64_round_to_zero }
Function fpc_trunc_real( d: valreal ): int64; compilerproc;
Var Var
aSign : flag; a : float32 absolute d;
aExp, shiftCount : smallint; aExp, shiftCount : smallint;
aSig : longint; aSig : longint;
z : longint; aSig64, z : int64;
Begin Begin
aSig := a and $007FFFFF; aSig := a and $007FFFFF;
aExp := (a shr 23) and $FF; aExp := (a shr 23) and $FF;
aSign := a shr 31; shiftCount := aExp - $BE;
shiftCount := aExp - $9E;
if ( 0 <= shiftCount ) then if ( 0 <= shiftCount ) then
Begin Begin
if ( a <> Float32($CF000000) ) then if ( a <> Float32($DF000000) ) then
Begin Begin
float_raise( float_flag_invalid ); float_raise( float_flag_invalid );
if ( (aSign=0) or ( ( aExp = $FF ) and (aSig<>0) ) ) then if ( (a>=0) or ( ( aExp = $FF ) and (aSig<>0) ) ) then
Begin Begin
float32_to_int32_round_to_zero:=$7fffffff; result:=$7fffffffffffffff;
exit; exit;
end; end;
End; End;
float32_to_int32_round_to_zero:=longint($80000000); result:=$8000000000000000;
exit; exit;
End End
else else
if ( aExp <= $7E ) then if ( aExp <= $7E ) then
Begin Begin
float32_to_int32_round_to_zero := 0; result := 0;
exit; exit;
End; End;
aSig := ( aSig or $00800000 ) shl 8; aSig64 := int64( aSig or $00800000 ) shl 40;
z := aSig shr ( - shiftCount ); z := aSig64 shr ( - shiftCount );
if ( aSign<>0 ) then z := - z; if ( a<0 ) then z := - z;
float32_to_int32_round_to_zero := z; result := z;
End; End;
{$endif SUPPORT_DOUBLE}
function fpc_trunc_real(d : ValReal) : int64;compilerproc;
var
f32 : float32;
f64 : float64;
Begin
{ in emulation mode the real is equal to a single }
{ otherwise in fpu mode, it is equal to a double }
{ extended is not supported yet. }
if sizeof(D) > 8 then
HandleError(255);
if sizeof(D)=8 then
begin
move(d,f64,sizeof(f64));
result:=genmath_float64_to_int64_round_to_zero(f64);
end
else
begin
move(d,f32,sizeof(f32));
result:=float32_to_int32_round_to_zero(f32);
end;
end;
{$endif not FPC_SYSTEM_HAS_TRUNC} {$endif not FPC_SYSTEM_HAS_TRUNC}

111
rtl/msdos/prt0stm.asm
View File

@ -31,6 +31,10 @@
extern __nearheap_start extern __nearheap_start
extern __nearheap_end extern __nearheap_end
extern __SaveInt00
extern FPC_HANDLEERROR
%ifdef __TINY__ %ifdef __TINY__
resb 0100h resb 0100h
%endif %endif
@ -175,6 +179,113 @@ error_msg:
mov ax, 4CFFh mov ax, 4CFFh
int 21h int 21h
FPC_INT00_HANDLER:
sub sp, 4 ; reserve space on the stack for the retf
push bx
push cx
push ds
; init ds
%ifdef __TINY__
mov bx, cs
%else
mov bx, dgroup
%endif
mov ds, bx
; check whether we're running on the same stack
mov cx, ss
cmp bx, cx
jne .call_previous_handler
%ifndef __FAR_CODE__
; check whether we're coming from the same code segment
mov bx, sp
mov cx, [bx + 3*2 + 6] ; get caller segment
mov bx, cs
cmp bx, cx
jne .call_previous_handler
%endif
; runerror 200
mov bx, sp
mov cx, [bx + 3*2 + 4] ; get caller offset
%ifdef __FAR_CODE__
mov dx, [bx + 3*2 + 6] ; get caller segment
%endif
add sp, 3*2 + 4 + 6
xor ax, ax
push ax
mov ax, 200
push ax
%ifdef __FAR_CODE__
push dx
%endif
push cx
%ifdef __FAR_CODE__
jmp far FPC_HANDLEERROR
%else
jmp FPC_HANDLEERROR
%endif
.call_previous_handler:
mov bx, sp
mov cx, [__SaveInt00]
mov [ss:bx + 3*2], cx
mov cx, [__SaveInt00+2]
mov [ss:bx + 3*2 + 2], cx
pop ds
pop cx
pop bx
retf ; jumps to the previous handler with all registers and stack intact
global FPC_INSTALL_INTERRUPT_HANDLERS
FPC_INSTALL_INTERRUPT_HANDLERS:
push ds
; save old int 00 handler
mov ax, 3500h
int 21h
mov [__SaveInt00], bx
mov bx, es
mov [__SaveInt00+2], bx
; install the new int 00 handler
%ifndef __TINY__
push cs
pop ds
%endif
mov dx, FPC_INT00_HANDLER
mov ax, 2500h
int 21h
pop ds
%ifdef __FAR_CODE__
retf
%else
ret
%endif
global FPC_RESTORE_INTERRUPT_HANDLERS
FPC_RESTORE_INTERRUPT_HANDLERS:
push ds
mov ax, 2500h
lds dx, [__SaveInt00]
int 21h
pop ds
%ifdef __FAR_CODE__
retf
%else
ret
%endif
global FPC_MSDOS_CARRY global FPC_MSDOS_CARRY
FPC_MSDOS_CARRY: FPC_MSDOS_CARRY:
stc stc

7
rtl/msdos/system.pp
View File

@ -63,6 +63,8 @@ var
dos_psp:Word;public name 'dos_psp'; dos_psp:Word;public name 'dos_psp';
SaveInt00: FarPointer;public name '__SaveInt00';
AllFilesMask: string [3]; AllFilesMask: string [3];
{$ifndef RTLLITE} {$ifndef RTLLITE}
{ System info } { System info }
@ -111,6 +113,9 @@ procedure MsDos(var Regs: Registers); external name 'FPC_MSDOS';
support them } support them }
procedure MsDos_Carry(var Regs: Registers); external name 'FPC_MSDOS_CARRY'; procedure MsDos_Carry(var Regs: Registers); external name 'FPC_MSDOS_CARRY';
procedure InstallInterruptHandlers; external name 'FPC_INSTALL_INTERRUPT_HANDLERS';
procedure RestoreInterruptHandlers; external name 'FPC_RESTORE_INTERRUPT_HANDLERS';
{$I system.inc} {$I system.inc}
{$I tinyheap.inc} {$I tinyheap.inc}
@ -264,6 +269,7 @@ procedure system_exit;
var var
h : byte; h : byte;
begin begin
RestoreInterruptHandlers;
for h:=0 to max_files-1 do for h:=0 to max_files-1 do
if openfiles[h] then if openfiles[h] then
begin begin
@ -333,6 +339,7 @@ begin
StackTop := __stktop; StackTop := __stktop;
StackBottom := __stkbottom; StackBottom := __stkbottom;
StackLength := __stktop - __stkbottom; StackLength := __stktop - __stkbottom;
InstallInterruptHandlers;
if DetectFPU then if DetectFPU then
SysInitFPU; SysInitFPU;
{ To be set if this is a GUI or console application } { To be set if this is a GUI or console application }

16
tests/test/tobjc36.pp
View File

@ -20,6 +20,11 @@ type
procedure extraproc(a: longint); override; procedure extraproc(a: longint); override;
end; end;
MyObject2 = objcclass(NSObject)
// overrides extraproc added to NSObject
procedure extraproc(a: longint); override;
end;
procedure MyCategory.extraproc(a: longint); procedure MyCategory.extraproc(a: longint);
begin begin
if a<>1 then if a<>1 then
@ -33,10 +38,18 @@ procedure MyObject.extraproc(a: longint);
inherited extraproc(1); inherited extraproc(1);
end; end;
procedure MyObject2.extraproc(a: longint);
begin
if a<>3 then
halt(3);
inherited extraproc(1);
end;
var var
a: NSObject; a: NSObject;
b: MyObject; b: MyObject;
c: MyObject2;
begin begin
a:=NSObject.alloc.init; a:=NSObject.alloc.init;
a.extraproc(1); a.extraproc(1);
@ -44,4 +57,7 @@ begin
b:=MyObject.alloc.init; b:=MyObject.alloc.init;
b.extraproc(2); b.extraproc(2);
b.release; b.release;
c:=MyObject.alloc.init;
c.extraproc(2);
c.release;
end. end.

2
utils/dxegen/fpmake.pp
View File

@ -29,7 +29,7 @@ begin
P.Directory:=ADirectory; P.Directory:=ADirectory;
P.Version:='2.7.1'; P.Version:='2.7.1';
T:=P.Targets.AddProgram('dxegen.pas'); T:=P.Targets.AddProgram('dxegen.pp');
T.Dependencies.AddUnit('coff'); T.Dependencies.AddUnit('coff');
P.Targets.AddUnit('coff.pp').install:=false; P.Targets.AddUnit('coff.pp').install:=false;