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

* synchronized with trunk

Browse Source 
git-svn-id: branches/z80@44710 -
This commit is contained in:
nickysn 2020-04-12 20:45:34 +00:00
commit 1cfbae82c6
18 changed files with 412 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler/arm/aasmcpu.pas
View File

@ -2234,6 +2234,7 @@ implementation
{ fpu_vfpv3_d16 } IF_VFPv2 or IF_VFPv3, { fpu_vfpv3_d16 } IF_VFPv2 or IF_VFPv3,
{ fpu_fpv4_s16 } IF_NONE, { fpu_fpv4_s16 } IF_NONE,
{ fpu_vfpv4 } IF_VFPv2 or IF_VFPv3 or IF_VFPv4, { fpu_vfpv4 } IF_VFPv2 or IF_VFPv3 or IF_VFPv4,
{ fpu_vfpv4 } IF_VFPv2 or IF_VFPv3 or IF_VFPv4,
{ fpu_neon_vfpv4 } IF_VFPv2 or IF_VFPv3 or IF_VFPv4 or IF_NEON { fpu_neon_vfpv4 } IF_VFPv2 or IF_VFPv3 or IF_VFPv4 or IF_NEON
); );
begin begin

1
compiler/arm/agarmgas.pas
View File

@ -116,6 +116,7 @@ unit agarmgas;
result:='-mfpu=neon-vfpv3 '+result; result:='-mfpu=neon-vfpv3 '+result;
fpu_vfpv3_d16: fpu_vfpv3_d16:
result:='-mfpu=vfpv3-d16 '+result; result:='-mfpu=vfpv3-d16 '+result;
fpu_fpv4_sp_d16,
fpu_fpv4_s16: fpu_fpv4_s16:
result:='-mfpu=fpv4-sp-d16 '+result; result:='-mfpu=fpv4-sp-d16 '+result;
fpu_vfpv4: fpu_vfpv4:

39
compiler/arm/cgcpu.pas
View File

@ -2084,7 +2084,7 @@ unit cgcpu;
begin begin
reference_reset(ref,4,[]); reference_reset(ref,4,[]);
if (tg.direction*tcpuprocinfo(current_procinfo).floatregstart>=1023) or if (tg.direction*tcpuprocinfo(current_procinfo).floatregstart>=1023) or
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then (FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype]) then
begin begin
if not is_shifter_const(tcpuprocinfo(current_procinfo).floatregstart,shift) then if not is_shifter_const(tcpuprocinfo(current_procinfo).floatregstart,shift) then
begin begin
@ -2115,14 +2115,16 @@ unit cgcpu;
begin begin
ref.index:=ref.base; ref.index:=ref.base;
ref.base:=NR_NO; ref.base:=NR_NO;
{ FSTMX is deprecated on ARMv6 and later }
{if (current_settings.cputype<cpu_armv6) then
postfix:=PF_IAX
else
postfix:=PF_IAD;}
if mmregs<>[] then if mmregs<>[] then
list.concat(taicpu.op_ref_regset(A_VSTM,ref,R_MMREGISTER,R_SUBFD,mmregs)); list.concat(taicpu.op_ref_regset(A_VSTM,ref,R_MMREGISTER,R_SUBFD,mmregs));
end end
else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin
ref.index:=ref.base;
ref.base:=NR_NO;
if mmregs<>[] then
list.concat(taicpu.op_ref_regset(A_VSTM,ref,R_MMREGISTER,R_SUBFS,mmregs));
end
else else
internalerror(2019050923); internalerror(2019050923);
end; end;
@ -2176,7 +2178,7 @@ unit cgcpu;
} }
end; end;
end; end;
else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
{ restore vfp registers? } { restore vfp registers? }
{ the *[0..31] is a hack to prevent that the compiler tries to save odd single-type registers, { the *[0..31] is a hack to prevent that the compiler tries to save odd single-type registers,
@ -2193,7 +2195,7 @@ unit cgcpu;
begin begin
reference_reset(ref,4,[]); reference_reset(ref,4,[]);
if (tg.direction*tcpuprocinfo(current_procinfo).floatregstart>=1023) or if (tg.direction*tcpuprocinfo(current_procinfo).floatregstart>=1023) or
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then (FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype]) then
begin begin
if not is_shifter_const(tcpuprocinfo(current_procinfo).floatregstart,shift) then if not is_shifter_const(tcpuprocinfo(current_procinfo).floatregstart,shift) then
begin begin
@ -2223,14 +2225,16 @@ unit cgcpu;
begin begin
ref.index:=ref.base; ref.index:=ref.base;
ref.base:=NR_NO; ref.base:=NR_NO;
{ FLDMX is deprecated on ARMv6 and later }
{if (current_settings.cputype<cpu_armv6) then
mmpostfix:=PF_IAX
else
mmpostfix:=PF_IAD;}
if mmregs<>[] then if mmregs<>[] then
list.concat(taicpu.op_ref_regset(A_VLDM,ref,R_MMREGISTER,R_SUBFD,mmregs)); list.concat(taicpu.op_ref_regset(A_VLDM,ref,R_MMREGISTER,R_SUBFD,mmregs));
end end
else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin
ref.index:=ref.base;
ref.base:=NR_NO;
if mmregs<>[] then
list.concat(taicpu.op_ref_regset(A_VLDM,ref,R_MMREGISTER,R_SUBFS,mmregs));
end
else else
internalerror(2019050921); internalerror(2019050921);
end; end;
@ -4328,12 +4332,19 @@ unit cgcpu;
rg[R_FPUREGISTER]:=trgcpu.create(R_FPUREGISTER,R_SUBNONE, rg[R_FPUREGISTER]:=trgcpu.create(R_FPUREGISTER,R_SUBNONE,
[RS_F0,RS_F1,RS_F2,RS_F3,RS_F4,RS_F5,RS_F6,RS_F7],first_fpu_imreg,[]); [RS_F0,RS_F1,RS_F2,RS_F3,RS_F4,RS_F5,RS_F6,RS_F7],first_fpu_imreg,[]);
if FPUARM_HAS_32REGS in fpu_capabilities[current_settings.fputype] then if (FPUARM_HAS_32REGS in fpu_capabilities[current_settings.fputype]) and
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then
rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBFD, rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBFD,
[RS_D0,RS_D1,RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7, [RS_D0,RS_D1,RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7,
RS_D16,RS_D17,RS_D18,RS_D19,RS_D20,RS_D21,RS_D22,RS_D23,RS_D24,RS_D25,RS_D26,RS_D27,RS_D28,RS_D29,RS_D30,RS_D31, RS_D16,RS_D17,RS_D18,RS_D19,RS_D20,RS_D21,RS_D22,RS_D23,RS_D24,RS_D25,RS_D26,RS_D27,RS_D28,RS_D29,RS_D30,RS_D31,
RS_D8,RS_D9,RS_D10,RS_D11,RS_D12,RS_D13,RS_D14,RS_D15 RS_D8,RS_D9,RS_D10,RS_D11,RS_D12,RS_D13,RS_D14,RS_D15
],first_mm_imreg,[]) ],first_mm_imreg,[])
else if (FPUARM_HAS_32REGS in fpu_capabilities[current_settings.fputype]) then
rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBFS,
[RS_S0,RS_S1,RS_S2,RS_S3,RS_S4,RS_S5,RS_S6,RS_S7,
RS_S16,RS_S17,RS_S18,RS_S19,RS_S20,RS_S21,RS_S22,RS_S23,RS_S24,RS_S25,RS_S26,RS_S27,RS_S28,RS_S29,RS_S30,RS_S31,
RS_S8,RS_S9,RS_S10,RS_S11,RS_S12,RS_S13,RS_S14,RS_S15
],first_mm_imreg,[])
else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBFD, rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBFD,
[RS_D0,RS_D1,RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7, [RS_D0,RS_D1,RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7,

16
compiler/arm/cpuinfo.pas
View File

@ -73,8 +73,9 @@ Type
fpu_vfpv3, fpu_vfpv3,
fpu_neon_vfpv3, fpu_neon_vfpv3,
fpu_vfpv3_d16, fpu_vfpv3_d16,
fpu_fpv4_s16, fpu_fpv4_s16, { same as fpu_fpv4_sp_d32, kept for backwards compatibility }
fpu_vfpv4, fpu_vfpv4,
fpu_fpv4_sp_d16, { 32 registers single precision, for load/store/move they can be accessed as 16 double registers }
fpu_neon_vfpv4 fpu_neon_vfpv4
{ when new elements added afterwards, update also fpu_vfp_last below and { when new elements added afterwards, update also fpu_vfp_last below and
update class procedure tarmnodeutils.InsertObjectInfo; in narmutil.pas } update class procedure tarmnodeutils.InsertObjectInfo; in narmutil.pas }
@ -84,7 +85,7 @@ Const
fpu_vfp_first = fpu_vfpv2; fpu_vfp_first = fpu_vfpv2;
fpu_vfp_last = fpu_neon_vfpv4; fpu_vfp_last = fpu_neon_vfpv4;
fputypestrllvm : array[tfputype] of string[14] = ('', fputypestrllvm : array[tfputype] of string[15] = ('',
'', '',
'', '',
'', '',
@ -96,6 +97,7 @@ Const
'fpu=vfpv3-d16', 'fpu=vfpv3-d16',
'fpu=vfpv4-s16', 'fpu=vfpv4-s16',
'fpu=vfpv4', 'fpu=vfpv4',
'fpu=fpv4-sp-d16',
'fpu=neon-vfpv4' 'fpu=neon-vfpv4'
); );
@ -570,7 +572,7 @@ Const
'ARMV7EM' 'ARMV7EM'
); );
fputypestr : array[tfputype] of string[10] = ( fputypestr : array[tfputype] of string[11] = (
'NONE', 'NONE',
'SOFT', 'SOFT',
'LIBGCC', 'LIBGCC',
@ -583,6 +585,7 @@ Const
'VFPV3_D16', 'VFPV3_D16',
'FPV4_S16', 'FPV4_S16',
'VFPV4', 'VFPV4',
'FPV4_SP_D16',
'NEON_VFPV4' 'NEON_VFPV4'
); );
@ -1071,9 +1074,9 @@ Const
tfpuflags = tfpuflags =
( (
FPUARM_HAS_FPA, { fpu is an fpa based FPU } FPUARM_HAS_FPA, { fpu is an fpa based FPU }
FPUARM_HAS_VFP_EXTENSION, { fpu is a vfp extension } FPUARM_HAS_VFP_EXTENSION, { fpu is a vfp extension, it means at least single operation support }
FPUARM_HAS_VFP_DOUBLE, { vfp has double support } FPUARM_HAS_VFP_DOUBLE, { vfp has double support }
FPUARM_HAS_VFP_SINGLE_ONLY, { vfp has only single support, disjunct to FPUARM_HAS_VFP_DOUBLE, for error checking } FPUARM_HAS_VFP_DOUBLE_MOVLDST, { vfp has only single support, but MOV, LD, ST can be done on pairs as double }
FPUARM_HAS_32REGS, { vfp has 32 regs, without this flag, 16 are assumed } FPUARM_HAS_32REGS, { vfp has 32 regs, without this flag, 16 are assumed }
FPUARM_HAS_VMOV_CONST, { vmov supports (some) real constants } FPUARM_HAS_VMOV_CONST, { vmov supports (some) real constants }
FPUARM_HAS_EXCEPTION_TRAPPING, { vfp does exceptions trapping } FPUARM_HAS_EXCEPTION_TRAPPING, { vfp does exceptions trapping }
@ -1115,8 +1118,9 @@ Const
{ fpu_vfpv3 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST], { fpu_vfpv3 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST],
{ fpu_neon_vfpv3 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_NEON], { fpu_neon_vfpv3 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_NEON],
{ fpu_vfpv3_d16 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_VMOV_CONST], { fpu_vfpv3_d16 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_VMOV_CONST],
{ fpu_fpv4_s16 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_SINGLE_ONLY,FPUARM_HAS_VMOV_CONST], { fpu_fpv4_s16 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_32REGS,FPUARM_HAS_VFP_DOUBLE_MOVLDST,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_FMA],
{ fpu_vfpv4 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_FMA], { fpu_vfpv4 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_FMA],
{ fpu_fpv4_sp_d16 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_32REGS,FPUARM_HAS_VFP_DOUBLE_MOVLDST,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_FMA],
{ fpu_neon_vfpv4 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_NEON,FPUARM_HAS_FMA] { fpu_neon_vfpv4 } [FPUARM_HAS_VFP_EXTENSION,FPUARM_HAS_VFP_DOUBLE,FPUARM_HAS_32REGS,FPUARM_HAS_VMOV_CONST,FPUARM_HAS_NEON,FPUARM_HAS_FMA]
); );

4
compiler/arm/cpupara.pas
View File

@ -149,7 +149,7 @@ unit cpupara;
getparaloc:=LOC_MMREGISTER getparaloc:=LOC_MMREGISTER
else if (calloption in cdecl_pocalls) or else if (calloption in cdecl_pocalls) or
(cs_fp_emulation in current_settings.moduleswitches) or (cs_fp_emulation in current_settings.moduleswitches) or
(current_settings.fputype in [fpu_vfp_first..fpu_vfp_last]) then (FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype]) then
{ the ARM eabi also allows passing VFP values via VFP registers, { the ARM eabi also allows passing VFP values via VFP registers,
but Mac OS X doesn't seem to do that and linux only does it if but Mac OS X doesn't seem to do that and linux only does it if
built with the "-mfloat-abi=hard" option } built with the "-mfloat-abi=hard" option }
@ -782,7 +782,7 @@ unit cpupara;
end end
else if (p.proccalloption in [pocall_softfloat]) or else if (p.proccalloption in [pocall_softfloat]) or
(cs_fp_emulation in current_settings.moduleswitches) or (cs_fp_emulation in current_settings.moduleswitches) or
(current_settings.fputype in [fpu_vfp_first..fpu_vfp_last]) then (FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype]) then
begin begin
case retcgsize of case retcgsize of
OS_64, OS_64,

72
compiler/arm/narmadd.pas
View File

@ -240,7 +240,7 @@ interface
location.register,left.location.register,right.location.register),pf)); location.register,left.location.register,right.location.register),pf));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
{ force mmreg as location, left right doesn't matter { force mmreg as location, left right doesn't matter
as both will be in a fpureg } as both will be in a fpureg }
@ -326,7 +326,7 @@ interface
current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_VMRS,NR_APSR_nzcv,NR_FPSCR)); current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_VMRS,NR_APSR_nzcv,NR_FPSCR));
location.resflags:=GetFpuResFlags; location.resflags:=GetFpuResFlags;
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,left.location,left.resultdef,true); hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,left.location,left.resultdef,true);
hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,right.location,right.resultdef,true); hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,right.location,right.resultdef,true);
@ -576,77 +576,19 @@ interface
end; end;
end; end;
function tarmaddnode.first_addfloat: tnode; function tarmaddnode.first_addfloat: tnode;
var
procname: string[31];
{ do we need to reverse the result ? }
notnode : boolean;
fdef : tdef;
begin begin
result := nil; result := nil;
notnode := false;
if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then if (FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype]) and
not(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then
begin begin
case tfloatdef(left.resultdef).floattype of case tfloatdef(left.resultdef).floattype of
s32real: s32real:
begin ;
result:=nil;
notnode:=false;
end;
s64real: s64real:
begin result:=first_addfloat_soft;
fdef:=search_system_type('FLOAT64').typedef;
procname:='float64';
case nodetype of
addn:
procname:=procname+'_add';
muln:
procname:=procname+'_mul';
subn:
procname:=procname+'_sub';
slashn:
procname:=procname+'_div';
ltn:
procname:=procname+'_lt';
lten:
procname:=procname+'_le';
gtn:
begin
procname:=procname+'_lt';
swapleftright;
end;
gten:
begin
procname:=procname+'_le';
swapleftright;
end;
equaln:
procname:=procname+'_eq';
unequaln:
begin
procname:=procname+'_eq';
notnode:=true;
end;
else
CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resultdef.typename,right.resultdef.typename);
end;
if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
resultdef:=pasbool1type;
result:=ctypeconvnode.create_internal(ccallnode.createintern(procname,ccallparanode.create(
ctypeconvnode.create_internal(right,fdef),
ccallparanode.create(
ctypeconvnode.create_internal(left,fdef),nil))),resultdef);
left:=nil;
right:=nil;
{ do we need to reverse the result }
if notnode then
result:=cnotnode.create(result);
end;
else else
internalerror(2019050933); internalerror(2019050933);
end; end;

6
compiler/arm/narmcnv.pas
View File

@ -60,7 +60,7 @@ implementation
{$ifdef cpufpemu} {$ifdef cpufpemu}
(current_settings.fputype=fpu_soft) or (current_settings.fputype=fpu_soft) or
{$endif cpufpemu} {$endif cpufpemu}
(FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype]) then not(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then
result:=inherited first_int_to_real result:=inherited first_int_to_real
else else
begin begin
@ -109,7 +109,7 @@ implementation
function tarmtypeconvnode.first_real_to_real: tnode; function tarmtypeconvnode.first_real_to_real: tnode;
begin begin
if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then if not(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) then
begin begin
case tfloatdef(left.resultdef).floattype of case tfloatdef(left.resultdef).floattype of
s32real: s32real:
@ -237,7 +237,7 @@ implementation
location.register,left.location.register), location.register,left.location.register),
signedprec2vfppf[signed,location.size])); signedprec2vfppf[signed,location.size]));
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef)); location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef));
signed:=left.location.size=OS_S32; signed:=left.location.size=OS_S32;

8
compiler/arm/narmcon.pas
View File

@ -55,7 +55,9 @@ interface
begin begin
result:=nil; result:=nil;
if (FPUARM_HAS_VMOV_CONST in fpu_capabilities[current_settings.fputype]) and if (FPUARM_HAS_VMOV_CONST in fpu_capabilities[current_settings.fputype]) and
IsVFPFloatImmediate(tfloatdef(resultdef).floattype,value_real) then IsVFPFloatImmediate(tfloatdef(resultdef).floattype,value_real) and
((tfloatdef(resultdef).floattype=s32real) or
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[init_settings.fputype])) then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
else else
expectloc:=LOC_CREFERENCE; expectloc:=LOC_CREFERENCE;
@ -76,7 +78,9 @@ interface
begin begin
if (FPUARM_HAS_VMOV_CONST in fpu_capabilities[current_settings.fputype]) and if (FPUARM_HAS_VMOV_CONST in fpu_capabilities[current_settings.fputype]) and
IsVFPFloatImmediate(tfloatdef(resultdef).floattype,value_real) then IsVFPFloatImmediate(tfloatdef(resultdef).floattype,value_real) and
((tfloatdef(resultdef).floattype=s32real) or
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[init_settings.fputype])) then
begin begin
location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef)); location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef));
location.register:=cg.getmmregister(current_asmdata.CurrAsmList,location.size); location.register:=cg.getmmregister(current_asmdata.CurrAsmList,location.size);

12
compiler/arm/narminl.pas
View File

@ -125,7 +125,7 @@ implementation
expectloc:=LOC_FPUREGISTER; expectloc:=LOC_FPUREGISTER;
else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
if tfloatdef(left.resultdef).floattype=s32real then if tfloatdef(left.resultdef).floattype=s32real then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
@ -153,7 +153,7 @@ implementation
expectloc:=LOC_FPUREGISTER; expectloc:=LOC_FPUREGISTER;
else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
if tfloatdef(left.resultdef).floattype=s32real then if tfloatdef(left.resultdef).floattype=s32real then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
@ -181,7 +181,7 @@ implementation
expectloc:=LOC_FPUREGISTER; expectloc:=LOC_FPUREGISTER;
else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype] then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
if tfloatdef(left.resultdef).floattype=s32real then if tfloatdef(left.resultdef).floattype=s32real then
expectloc:=LOC_MMREGISTER expectloc:=LOC_MMREGISTER
@ -265,7 +265,7 @@ implementation
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VABS,location.register,left.location.register),pf)); current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VABS,location.register,left.location.register),pf));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
current_asmdata.CurrAsmList.Concat(setoppostfix(taicpu.op_reg_reg(A_VABS,location.register,left.location.register), PF_F32)); current_asmdata.CurrAsmList.Concat(setoppostfix(taicpu.op_reg_reg(A_VABS,location.register,left.location.register), PF_F32));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
@ -296,7 +296,7 @@ implementation
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg_reg(A_VMUL,location.register,left.location.register,left.location.register),pf)); current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg_reg(A_VMUL,location.register,left.location.register,left.location.register),pf));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
current_asmdata.CurrAsmList.Concat(setoppostfix(taicpu.op_reg_reg_reg(A_VMUL,location.register,left.location.register,left.location.register), PF_F32)); current_asmdata.CurrAsmList.Concat(setoppostfix(taicpu.op_reg_reg_reg(A_VMUL,location.register,left.location.register,left.location.register), PF_F32));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
@ -327,7 +327,7 @@ implementation
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VSQRT,location.register,left.location.register),pf)); current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VSQRT,location.register,left.location.register),pf));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype] then
begin begin
current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VSQRT,location.register,left.location.register), PF_F32)); current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_VSQRT,location.register,left.location.register), PF_F32));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);

4
compiler/arm/narmmat.pas
View File

@ -367,7 +367,7 @@ implementation
exit; exit;
end; end;
if not(FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[current_settings.fputype]) or if (FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[current_settings.fputype]) or
(tfloatdef(resultdef).floattype=s32real) then (tfloatdef(resultdef).floattype=s32real) then
exit(inherited pass_1); exit(inherited pass_1);
@ -447,7 +447,7 @@ implementation
location.register,left.location.register), pf)); location.register,left.location.register), pf));
cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList); cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
end end
else if FPUARM_HAS_VFP_SINGLE_ONLY in fpu_capabilities[init_settings.fputype] then else if FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype] then
begin begin
hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,left.location,left.resultdef,true); hlcg.location_force_mmregscalar(current_asmdata.CurrAsmList,left.location,left.resultdef,true);
location:=left.location; location:=left.location;

1
compiler/arm/narmutil.pas
View File

@ -207,6 +207,7 @@ interface
current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,3)); current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,3));
fpu_vfpv3_d16: fpu_vfpv3_d16:
current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,4)); current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,4));
fpu_fpv4_sp_d16,
fpu_fpv4_s16: fpu_fpv4_s16:
current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,6)); current_asmdata.asmlists[al_start].Concat(tai_eabi_attribute.create(Tag_FP_Arch,6));
fpu_vfpv4, fpu_vfpv4,

1
compiler/globals.pas
View File

@ -951,6 +951,7 @@ implementation
Replace(s,'$FPCDATE',date_string); Replace(s,'$FPCDATE',date_string);
Replace(s,'$FPCCPU',target_cpu_string); Replace(s,'$FPCCPU',target_cpu_string);
Replace(s,'$FPCOS',target_os_string); Replace(s,'$FPCOS',target_os_string);
Replace(s,'$FPCBINDIR',exepath);
if (tf_use_8_3 in Source_Info.Flags) or if (tf_use_8_3 in Source_Info.Flags) or
(tf_use_8_3 in Target_Info.Flags) then (tf_use_8_3 in Target_Info.Flags) then
Replace(s,'$FPCTARGET',target_os_string) Replace(s,'$FPCTARGET',target_os_string)

4
compiler/symdef.pas
View File

@ -2361,6 +2361,10 @@ implementation
{$ifdef xtensa} {$ifdef xtensa}
and (FPUXTENSA_SINGLE in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real) and (FPUXTENSA_SINGLE in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)
{$endif xtensa} {$endif xtensa}
{$ifdef arm}
and (((FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)) or
(FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[init_settings.fputype]))
{$endif arm}
; ;
{$endif x86} {$endif x86}
end; end;

4
compiler/systems.pas
View File

@ -439,9 +439,9 @@ interface
(name: 'AIX' ; supported:{$if defined(powerpc) or defined(powerpc64)}true{$else}false{$endif}), (name: 'AIX' ; supported:{$if defined(powerpc) or defined(powerpc64)}true{$else}false{$endif}),
(name: 'DARWIN' ; supported:{$if defined(powerpc) or defined(powerpc64)}true{$else}false{$endif}), (name: 'DARWIN' ; supported:{$if defined(powerpc) or defined(powerpc64)}true{$else}false{$endif}),
(name: 'ELFV2' ; supported:{$if defined(powerpc64)}true{$else}false{$endif}), (name: 'ELFV2' ; supported:{$if defined(powerpc64)}true{$else}false{$endif}),
(name: 'EABI' ; supported:{$ifdef FPC_ARMEL}true{$else}false{$endif}), (name: 'EABI' ; supported:{$if defined(arm)}true{$else}false{$endif}),
(name: 'ARMEB' ; supported:{$ifdef FPC_ARMEB}true{$else}false{$endif}), (name: 'ARMEB' ; supported:{$ifdef FPC_ARMEB}true{$else}false{$endif}),
(name: 'EABIHF' ; supported:{$ifdef FPC_ARMHF}true{$else}false{$endif}), (name: 'EABIHF' ; supported:{$if defined(arm)}true{$else}false{$endif}),
(name: 'OLDWIN32GNU'; supported:{$ifdef I386}true{$else}false{$endif}), (name: 'OLDWIN32GNU'; supported:{$ifdef I386}true{$else}false{$endif}),
(name: 'AARCH64IOS'; supported:{$ifdef aarch64}true{$else}false{$endif}), (name: 'AARCH64IOS'; supported:{$ifdef aarch64}true{$else}false{$endif}),
(name: 'RISCVHF'; supported:{$if defined(riscv32) or defined(riscv64)}true{$else}false{$endif}), (name: 'RISCVHF'; supported:{$if defined(riscv32) or defined(riscv64)}true{$else}false{$endif}),

10
compiler/systems/t_linux.pas
View File

@ -150,14 +150,16 @@ begin
{$ifdef arm} {$ifdef arm}
{ some newer Debian have the crt*.o files at uncommon locations, { some newer Debian have the crt*.o files at uncommon locations,
for other arm flavours, this cannot hurt } for other arm flavours, this cannot hurt }
{$ifdef FPC_ARMHF} if target_info.abi=abi_eabihf then
begin
LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/arm-linux-gnueabihf',true); LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/arm-linux-gnueabihf',true);
LibrarySearchPath.AddLibraryPath(sysrootpath,'=/lib/arm-linux-gnueabihf',true); LibrarySearchPath.AddLibraryPath(sysrootpath,'=/lib/arm-linux-gnueabihf',true);
{$endif FPC_ARMHF} end;
{$ifdef FPC_ARMEL} if target_info.abi=abi_eabi then
begin
LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/arm-linux-gnueabi',true); LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/arm-linux-gnueabi',true);
LibrarySearchPath.AddLibraryPath(sysrootpath,'=/lib/arm-linux-gnueabi',true); LibrarySearchPath.AddLibraryPath(sysrootpath,'=/lib/arm-linux-gnueabi',true);
{$endif} end;
{$endif arm} {$endif arm}
{$ifdef x86_64} {$ifdef x86_64}
LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/x86_64-linux-gnu',true); LibrarySearchPath.AddLibraryPath(sysrootpath,'=/usr/lib/x86_64-linux-gnu',true);

4
rtl/amicommon/dos.pp
View File

@ -1081,6 +1081,9 @@ Var
Res: Integer; Res: Integer;
begin begin
SetLength(EnvList, 0); SetLength(EnvList, 0);
// pr_LocalVars are introduced with OS2.0
if PLibrary(AOS_ExecBase)^.lib_Version >= 36 then
begin
ThisProcess := PProcess(FindTask(nil)); //Get the pointer to our process ThisProcess := PProcess(FindTask(nil)); //Get the pointer to our process
LocalVars_List := @(ThisProcess^.pr_LocalVars); //get the list of pr_LocalVars as pointer LocalVars_List := @(ThisProcess^.pr_LocalVars); //get the list of pr_LocalVars as pointer
LocalVar_Node := pLocalVar(LocalVars_List^.mlh_head); //get the headnode of the LocalVars list LocalVar_Node := pLocalVar(LocalVars_List^.mlh_head); //get the headnode of the LocalVars list
@ -1109,6 +1112,7 @@ begin
end; end;
LocalVar_Node := pLocalVar(LocalVar_Node^.lv_node.ln_Succ); //we need to get the next node LocalVar_Node := pLocalVar(LocalVar_Node^.lv_node.ln_Succ); //we need to get the next node
end; end;
end;
// search in env for all Variables // search in env for all Variables
FillChar(Anchor,sizeof(TAnchorPath),#0); FillChar(Anchor,sizeof(TAnchorPath),#0);
Res := MatchFirst('ENV:#?', @Anchor); Res := MatchFirst('ENV:#?', @Anchor);

176
rtl/amiga/m68k/legacydos.inc
View File

@ -113,29 +113,191 @@ begin
NextDosEntry:=nil; NextDosEntry:=nil;
end; end;
// Very first dirty version of MatchFirst/Next/End)
//TODO: pattern detection, for now only simple "*" or "#?" or full name (without patterns) is supported
function MatchFirst(pat : PChar; function MatchFirst(pat : PChar;
anchor: PAnchorPath): LongInt; public name '_fpc_amiga_matchfirst'; anchor: PAnchorPath): LongInt; public name '_fpc_amiga_matchfirst';
var
p: PChar;
len: LongInt;
Path,FileN: AnsiString;
LastSeparatorPos: Integer;
i: Integer;
DirLock: BPTR;
ib: TFileInfoBlock;
Res: LongInt;
NChain: PAChain;
begin begin
{$warning MatchFirst unimplemented!} MatchFirst := -1;
MatchFirst:=-1; if not Assigned(Anchor) then
Exit;
// Search for last '/' or ':' and determine length
Len := strlen(Pat);
P := Pat;
LastSeparatorPos := 0;
for i := 1 to Len do
begin
if (P^ = '/') or (P^ = ':') then
begin
LastSeparatorPos := i;
end;
Inc(P);
end;
// copy Directory name
SetLength(Path, LastSeparatorPos);
Move(Pat^, Path[1], LastSeparatorPos);
// copy filename
SetLength(FileN, Len - LastSeparatorPos);
P := Pat;
Inc(P, LastSeparatorPos);
Move(P^, FileN[1], Len - LastSeparatorPos);
// searchpattern lowercase
FileN := LowerCase(FileN);
// if no path is given use the current working dir, or try to lock the dir
if Path = '' then
DirLock := CurrentDir(0)
else
DirLock := Lock(PChar(Path), ACCESS_READ);
//
// no dirlock found -> dir not found
if DirLock = 0 then
begin
MatchFirst := -1;
Exit;
end;
// examine the dir to get the fib for ExNext
if Examine(DirLock, @ib) = 0 then
begin
MatchFirst := -1;
Exit;
end;
// we search here directly what we need to find
// guess it's not meant that way but works
repeat
// get next dir entry
Res := ExNext(DirLock, @ib);
// nothing nore found -> exit
if Res = 0 then
break;
// include some nifty pattern compare here? later maybe!
if (FileN = '*') or (FileN = '#?') or (FileN = lowercase(AnsiString(ib.fib_FileName))) then
begin
// Match found
// new chain
NChain := AllocMem(SizeOf(TAChain));
if Assigned(Anchor^.ap_First) then
begin
// put chain entry to the list
Anchor^.ap_Last^.an_Child := NChain;
NChain^.an_Parent := Anchor^.ap_Last;
Anchor^.ap_Last := NChain;
end
else
begin
// first chain Entry
Anchor^.ap_Last := NChain;
Anchor^.ap_First := NChain;
NChain^.an_Parent := Pointer(Anchor);
end;
// copy the fileinfoblock into the chain
Move(ib, NChain^.an_Info, SizeOf(TFileInfoBlock));
end;
until Res = 0; // useless... we jump oput earlier
//
// if we found something
if Assigned(Anchor^.ap_Last) then
begin
// set current to the first entry we found
Anchor^.ap_Last := Anchor^.ap_First;
// we only copy the file info block, rest is not needed for freepascal stuff
Move(Anchor^.ap_First^.an_Info, Anchor^.ap_Info, SizeOf(TFileInfoBlock));
// most importantly set the return code
MatchFirst := 0;
end;
Unlock(DirLock);
end; end;
function MatchNext(anchor: PAnchorPath): LongInt; public name '_fpc_amiga_matchnext'; function MatchNext(anchor: PAnchorPath): LongInt; public name '_fpc_amiga_matchnext';
begin begin
{$warning MatchNext unimplemented!} MatchNext := -1;
MatchNext:=-1; if not Assigned(Anchor) then
Exit;
// was already last entry?
if not Assigned(Anchor^.ap_Last) then
Exit;
// Get the next Chain Entry
anchor^.ap_Last := anchor^.ap_Last^.an_Child;
// check if next one is valid and copy the file infoblock, or just set the error code ;)
if Assigned(anchor^.ap_Last) then
begin
Move(Anchor^.ap_Last^.an_Info, Anchor^.ap_Info, SizeOf(TFileInfoBlock));
MatchNext := 0;
end
else
MatchNext := ERROR_NO_MORE_ENTRIES;
end; end;
procedure MatchEnd(anchor: PAnchorPath); public name '_fpc_amiga_matchend'; procedure MatchEnd(anchor: PAnchorPath); public name '_fpc_amiga_matchend';
var
p, nextp: PAChain;
begin begin
{$warning MatchEnd unimplemented!} if Assigned(Anchor) then
begin
// destroy all the chain entries we created before
p := Anchor^.ap_First;
while Assigned(p) do
begin
Nextp := p^.an_Child;
FreeMem(P);
P := NextP;
end;
// reset the contents (is this needed?)
Anchor^.ap_First := nil;
Anchor^.ap_Last := nil;
end;
end; end;
procedure NextTag(var Tag: PTagItem); inline;
begin
if Tag^.ti_Tag = TAG_END then
Exit;
Inc(Tag);
repeat
case Tag^.ti_Tag of
TAG_IGNORE: Inc(Tag);
TAG_SKIP: Inc(Tag, Tag^.ti_Data);
TAG_MORE: Tag := PTagItem(Tag^.ti_Data);
else
Break;
end;
until False;
end;
// we emulate that by the old execute command, should be enough for most cases
function SystemTagList(command: PChar; function SystemTagList(command: PChar;
tags : PTagItem): LongInt; public name '_fpc_amiga_systemtaglist'; tags : PTagItem): LongInt; public name '_fpc_amiga_systemtaglist';
var
I,O: BPTR; // in / ouput handles
tag: PTagItem;
begin begin
{$warning SystemTagList unimplemented!} i := 0;
SystemTagList:=-1; O := 0;
tag := Tags;
if Assigned(tag) then
begin
repeat
case Tag^.ti_Tag of
SYS_Input: I := Tag^.ti_Data;
SYS_Output: O := Tag^.ti_Data;
end;
NextTag(Tag);
until tag^.ti_Tag = TAG_END;
end;
if Execute(command, I, O) then
SystemTagList := 0
else
SystemTagList := -1;
end; end;
function GetVar(name : PChar; function GetVar(name : PChar;

127
rtl/amiga/m68k/legacyutil.inc
View File

@ -22,14 +22,133 @@
functional enough for the RTL code. functional enough for the RTL code.
} }
const
// Start day of every month (without leap)
StartOfMonth: array[0..11] of LongInt = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
SecsPerMin = 60;
SecsPerHour = 60 * SecsPerMin;
SecsPerDay = 24 * SecsPerHour;
SecsPerYear = 365 * SecsPerDay;// without leap
AmigaStartYear = 1978; // Amiga starts @1978;
DaysPerYear = 365;
DaysPerLeapYear = DaysPerYear + 1;
Daysof4Years = DaysPerLeapYear + 3 * DaysPerYear;
Daysof100Years = 24 * DaysPerLeapYear + 76 * DaysPerYear;
Daysof400Years = 97 * DaysPerLeapYear + 303 * DaysPerYear;
procedure Amiga2Date(seconds: Cardinal; procedure Amiga2Date(seconds: Cardinal;
result : PClockData); public name '_fpc_amiga_amiga2date'; result : PClockData); public name '_fpc_amiga_amiga2date';
begin var
{$warning Amiga2Date unimplemented!} IsLeap: boolean;
d, y, i: LongWord;
begin// how many days are passed
d := seconds div SecsPerDay;
// the easier time part
Result^.wday := d mod 7;
Result^.sec := seconds mod 60;
seconds := seconds div 60;
Result^.min := seconds mod 60;
seconds := seconds div 60;
Result^.hour := seconds mod 24;
// the leap year correction part
IsLeap := True;
//
// before 2100 easier case (function mostly used for now(), so its usually in this range)
if d < 92 * DaysPerYear + 30 * DaysPerLeapYear then // 1978 - 2100 = 92 non leap, 30 leap years
begin
d := d + DaysPerLeapYear + DaysPerYear; // we want to start from 1976 (a leap year) so we add 2 more years to the nubmer we have
y := 4 *(d div Daysof4Years) + 1976; // how many 4 year spans (1 leap + 3 non leap) are there?
d := d mod Daysof4Years; //( get the day in the 4 year span)
// the first yoear of such a 4 year span, is always a leap year, all other not (thats the reason we want to start at 1976)
if d > DaysPerLeapYear then
begin
IsLeap := False;
d := d - 1;
y := y + d div DaysPerYear;
d := d mod DaysPerYear;
end;
end
else
begin
// more complicated way for dates > 2100 (not tested until now!)
// we do the same as before but not 4 years together but 400 (because of the special years which are not leap even divided by 4)
// and we start at 2000
d := d - 17 * DaysPerYear + 5 * DaysPerLeapYear;
y := 400 * (d div Daysof400Years) + 2000;
d := d mod Daysof400Years;
// first is always NOT leap year.. other we have to test
if d >= DaysPerLeapYear then
begin
// we do the same again, and test for 100 year spans
d := d - 1; // not a leap year one day down
IsLeap := False;
y := y + 100 * (d div Daysof100Years);
d := d mod Daysof100Years;
if d >= DaysPerYear then
begin
d := d + 1; // a leap year, one day up
IsLeap := True;
// and the same as we did before 4 years span
y := y + 4 * (d div Daysof4Years);
d := d mod Daysof4Years;
if d >= DaysPerLeapYear then
begin
d := d - 1;
IsLeap := False;
y := y + d div DaysPerYear;
d := d mod DaysPerYear;
end;
end;
end;
end;
// the current year is a leap year and we are after Februar
if IsLeap and (d >= StartOfMonth[2]) then
d := d + 1;
// get the actual month
for i := 1 to High(StartOfMonth) do
begin
if StartOfMonth[i] > d then
begin
Result^.Month := i;
d := d - (StartOfMonth[i - 1] + 1);
break;
end;
end;
Result^.year := y;
Result^.mday := d;
end; end;
function Date2Amiga(date: PClockData): Cardinal; public name '_fpc_amiga_date2amiga'; function Date2Amiga(date: PClockData): Cardinal; public name '_fpc_amiga_date2amiga';
var
Y: LongInt;
Leaps, LeapsBefore1978, Res: LongWord;
begin begin
{$warning Date2Amiga unimplemented!} // the easy time part
Date2Amiga:=0; Res := date^.hour * SecsPerHour + date^.min * SecsPerMin + date^.sec;
Res := Res + ((date^.mday - 1) + StartOfMonth[date^.month - 1]) * SecsPerDay;
Res := Res + (date^.year - AmigaStartYear) * SecsPerYear;
// leap year correction ;)
// current year
y := date^.year;
// from IsLeapYear dos.pp
if (y mod 400 = 0) or ((y mod 4 = 0) and (y mod 100 <> 0)) then
begin
// add a day if its after feb in a leap year
if date^.month > 2 then
Res := Res + SecsPerDay;
end;
// previous years
y := date^.year - 1;
Leaps := (y div 4) - (y div 100) + (y div 400);
// exclude the ones before 1978
LeapsBefore1978 := (AmigaStartYear div 4) - (AmigaStartYear div 100) + (AmigaStartYear div 400);
Date2Amiga := Res + (leaps - leapsBefore1978) * SecsPerDay;
end; end;