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

* cg64 patch

Browse Source 
* basics for currency
  * asnode updates for class and interface (not finished)
This commit is contained in:
peter 2002-07-01 16:23:52 +00:00
parent 09de3f8d5b
commit 68ce5a00e5
26 changed files with 594 additions and 330 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

321
compiler/cg64f32.pas
View File

@ -23,8 +23,7 @@
****************************************************************************
}
{# This unit implements the code generation for 64 bit int arithmethics on
32 bit processors. All 32-bit processors should use this class as
the base code generator class instead of tcg.
32 bit processors.
}
unit cg64f32;
@ -40,51 +39,42 @@ unit cg64f32;
type
{# Defines all the methods required on 32-bit processors
to handle 64-bit integers. All 32-bit processors should
create derive a class of this type instead of @var(tcg).
to handle 64-bit integers.
}
tcg64f32 = class(tcg)
procedure a_load64_const_ref(list : taasmoutput;valuelo, valuehi : AWord;const ref : treference);
procedure a_load64_reg_ref(list : taasmoutput;reglo, reghi : tregister;const ref : treference);
procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reglo,reghi : tregister);
procedure a_load64_reg_reg(list : taasmoutput;reglosrc,reghisrc,reglodst,reghidst : tregister);
procedure a_load64_const_reg(list : taasmoutput;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);
procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reglo,reghi : tregister);
procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);
procedure a_load64_const_loc(list : taasmoutput;valuelo, valuehi : AWord;const l : tlocation);
procedure a_load64_reg_loc(list : taasmoutput;reglo, reghi : tregister;const l : tlocation);
procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
tcg64f32 = class(tcg64)
procedure a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);override;
procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);override;
procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);override;
procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);override;
procedure a_load64_const_reg(list : taasmoutput;value: qword;reg : tregister64);override;
procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);override;
procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);override;
procedure a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);override;
procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);override;
procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reglo,reghi : tregister);virtual;abstract;
procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;reglosrc,reghisrc,reglodst,reghidst : tregister);virtual;abstract;
procedure a_op64_reg_ref(list : taasmoutput;op:TOpCG;reglosrc,reghisrc : tregister;const ref : treference);virtual;abstract;
procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);virtual;abstract;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;const ref : treference);virtual;abstract;
procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:aword;const l: tlocation);
procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;reglo,reghi : tregister;const l : tlocation);
procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reglo,reghi : tregister);
procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
procedure a_param64_reg(list : taasmoutput;reglo,reghi : tregister;nr : longint);
procedure a_param64_const(list : taasmoutput;valuelo,valuehi : aword;nr : longint);
procedure a_param64_ref(list : taasmoutput;const r : treference;nr : longint);
procedure a_param64_loc(list : taasmoutput;const l : tlocation;nr : longint);
procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);override;
procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);override;
procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg : tregister64);override;
{ override to catch 64bit rangechecks }
procedure g_rangecheck(list: taasmoutput; const p: tnode;
procedure a_param64_reg(list : taasmoutput;reg : tregister64;nr : longint);override;
procedure a_param64_const(list : taasmoutput;value : qword;nr : longint);override;
procedure a_param64_ref(list : taasmoutput;const r : treference;nr : longint);override;
procedure a_param64_loc(list : taasmoutput;const l : tlocation;nr : longint);override;
procedure g_rangecheck64(list: taasmoutput; const p: tnode;
const todef: tdef); override;
private
{ produces range check code for 32bit processors when one of the }
{ operands is 64 bit }
procedure g_rangecheck64(list : taasmoutput; p : tnode;todef : tdef);
end;
{# Creates a tregister64 record from 2 32 Bit registers. }
function joinreg64(reglo,reghi : tregister) : tregister64;
implementation
uses
@ -93,42 +83,45 @@ unit cg64f32;
verbose,
symbase,symconst,symdef,types;
procedure tcg64f32.a_load64_reg_ref(list : taasmoutput;reglo, reghi : tregister;const ref : treference);
function joinreg64(reglo,reghi : tregister) : tregister64;
begin
result.reglo:=reglo;
result.reghi:=reghi;
end;
procedure tcg64f32.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);
var
tmpreg: tregister;
tmpref: treference;
begin
if target_info.endian = endian_big then
if target_info.endian=endian_big then
begin
tmpreg := reglo;
reglo := reghi;
reghi := tmpreg;
tmpreg:=reg.reglo;
reg.reglo:=reg.reghi;
reg.reghi:=tmpreg;
end;
a_load_reg_ref(list,OS_32,reglo,ref);
cg.a_load_reg_ref(list,OS_32,reg.reglo,ref);
tmpref := ref;
inc(tmpref.offset,4);
a_load_reg_ref(list,OS_32,reghi,tmpref);
cg.a_load_reg_ref(list,OS_32,reg.reghi,tmpref);
end;
procedure tcg64f32.a_load64_const_ref(list : taasmoutput;valuelo, valuehi : AWord;const ref : treference);
procedure tcg64f32.a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);
var
tmpvalue: AWord;
tmpvalue : DWord;
tmpref: treference;
begin
if target_info.endian = endian_big then
begin
tmpvalue := valuelo;
valuelo := valuehi;
valuehi := tmpvalue;
end;
a_load_const_ref(list,OS_32,valuelo,ref);
if target_info.endian<>source_info.endian then
swap_qword(value);
cg.a_load_const_ref(list,OS_32,lo(value),ref);
tmpref := ref;
inc(tmpref.offset,4);
a_load_const_ref(list,OS_32,valuehi,tmpref);
cg.a_load_const_ref(list,OS_32,hi(value),tmpref);
end;
procedure tcg64f32.a_load64_ref_reg(list : taasmoutput;const ref : treference;reglo,reghi : tregister);
procedure tcg64f32.a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);
var
tmpreg: tregister;
tmpref: treference;
@ -136,59 +129,64 @@ unit cg64f32;
begin
if target_info.endian = endian_big then
begin
tmpreg := reglo;
reglo := reghi;
reghi := tmpreg;
tmpreg := reg.reglo;
reg.reglo := reg.reghi;
reg.reghi := tmpreg;
end;
got_scratch:=false;
tmpref := ref;
if (tmpref.base=reglo) then
if (tmpref.base=reg.reglo) then
begin
tmpreg := get_scratch_reg_int(list);
tmpreg := cg.get_scratch_reg_int(list);
got_scratch:=true;
a_load_reg_reg(list,OS_ADDR,tmpref.base,tmpreg);
cg.a_load_reg_reg(list,OS_ADDR,tmpref.base,tmpreg);
tmpref.base:=tmpreg;
end
else
if (tmpref.index=reglo) then
{ this works only for the i386, thus the i386 needs to override }
{ this method and this method must be replaced by a more generic }
{ implementation FK }
if (tmpref.index=reg.reglo) then
begin
tmpreg := get_scratch_reg_int(list);
tmpreg:=cg.get_scratch_reg_int(list);
got_scratch:=true;
a_load_reg_reg(list,OS_ADDR,tmpref.index,tmpreg);
cg.a_load_reg_reg(list,OS_ADDR,tmpref.index,tmpreg);
tmpref.index:=tmpreg;
end;
a_load_ref_reg(list,OS_32,tmpref,reglo);
cg.a_load_ref_reg(list,OS_32,tmpref,reg.reglo);
inc(tmpref.offset,4);
a_load_ref_reg(list,OS_32,tmpref,reghi);
cg.a_load_ref_reg(list,OS_32,tmpref,reg.reghi);
if got_scratch then
free_scratch_reg(list,tmpreg);
cg.free_scratch_reg(list,tmpreg);
end;
procedure tcg64f32.a_load64_reg_reg(list : taasmoutput;reglosrc,reghisrc,reglodst,reghidst : tregister);
procedure tcg64f32.a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);
begin
a_load_reg_reg(list,OS_32,reglosrc,reglodst);
a_load_reg_reg(list,OS_32,reghisrc,reghidst);
cg.a_load_reg_reg(list,OS_32,regsrc.reglo,regdst.reglo);
cg.a_load_reg_reg(list,OS_32,regsrc.reghi,regdst.reghi);
end;
procedure tcg64f32.a_load64_const_reg(list : taasmoutput;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);
procedure tcg64f32.a_load64_const_reg(list : taasmoutput;value : qword;reg : tregister64);
begin
a_load_const_reg(list,OS_32,valuelosrc,reglodst);
a_load_const_reg(list,OS_32,valuehisrc,reghidst);
if target_info.endian<>source_info.endian then
swap_qword(value);
cg.a_load_const_reg(list,OS_32,lo(value),reg.reglo);
cg.a_load_const_reg(list,OS_32,hi(value),reg.reghi);
end;
procedure tcg64f32.a_load64_loc_reg(list : taasmoutput;const l : tlocation;reglo,reghi : tregister);
procedure tcg64f32.a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_load64_ref_reg(list,l.reference,reglo,reghi);
a_load64_ref_reg(list,l.reference,reg);
LOC_REGISTER,LOC_CREGISTER:
a_load64_reg_reg(list,l.registerlow,l.registerhigh,reglo,reghi);
a_load64_reg_reg(list,l.register64,reg);
LOC_CONSTANT :
a_load64_const_reg(list,l.valuelow,l.valuehigh,reglo,reghi);
a_load64_const_reg(list,l.valueqword,reg);
else
internalerror(200112292);
end;
@ -199,37 +197,37 @@ unit cg64f32;
begin
case l.loc of
LOC_REGISTER,LOC_CREGISTER:
a_load64_reg_ref(list,l.registerlow,l.registerhigh,ref);
a_load64_reg_ref(list,l.reg64,ref);
LOC_CONSTANT :
a_load64_const_ref(list,l.valuelow,l.valuehigh,ref);
a_load64_const_ref(list,l.valueqword,ref);
else
internalerror(200203288);
end;
end;
procedure tcg64f32.a_load64_const_loc(list : taasmoutput;valuelo, valuehi : AWord;const l : tlocation);
procedure tcg64f32.a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_load64_const_ref(list,valuelo,valuehi,l.reference);
a_load64_const_ref(list,value,l.reference);
LOC_REGISTER,LOC_CREGISTER:
a_load64_const_reg(list,valuelo,valuehi,l.registerlow,l.registerhigh);
a_load64_const_reg(list,value,l.reg64);
else
internalerror(200112293);
end;
end;
procedure tcg64f32.a_load64_reg_loc(list : taasmoutput;reglo,reghi : tregister;const l : tlocation);
procedure tcg64f32.a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_load64_reg_ref(list,reglo,reghi,l.reference);
a_load64_reg_ref(list,reg,l.reference);
LOC_REGISTER,LOC_CREGISTER:
a_load64_reg_reg(list,reglo,reghi,l.registerlow,l.registerhigh);
a_load64_reg_reg(list,reg,l.register64);
else
internalerror(200112293);
end;
@ -242,12 +240,12 @@ unit cg64f32;
tmpref: treference;
begin
if target_info.endian = endian_big then
a_load_reg_ref(list,OS_32,reg,ref)
cg.a_load_reg_ref(list,OS_32,reg,ref)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_reg_ref(list,OS_32,reg,tmpref)
cg.a_load_reg_ref(list,OS_32,reg,tmpref)
end;
end;
@ -256,12 +254,12 @@ unit cg64f32;
tmpref: treference;
begin
if target_info.endian = endian_little then
a_load_reg_ref(list,OS_32,reg,ref)
cg.a_load_reg_ref(list,OS_32,reg,ref)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_reg_ref(list,OS_32,reg,tmpref)
cg.a_load_reg_ref(list,OS_32,reg,tmpref)
end;
end;
@ -270,12 +268,12 @@ unit cg64f32;
tmpref: treference;
begin
if target_info.endian = endian_big then
a_load_ref_reg(list,OS_32,ref,reg)
cg.a_load_ref_reg(list,OS_32,ref,reg)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_ref_reg(list,OS_32,tmpref,reg)
cg.a_load_ref_reg(list,OS_32,tmpref,reg)
end;
end;
@ -284,12 +282,12 @@ unit cg64f32;
tmpref: treference;
begin
if target_info.endian = endian_little then
a_load_ref_reg(list,OS_32,ref,reg)
cg.a_load_ref_reg(list,OS_32,ref,reg)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_ref_reg(list,OS_32,tmpref,reg)
cg.a_load_ref_reg(list,OS_32,tmpref,reg)
end;
end;
@ -300,9 +298,9 @@ unit cg64f32;
LOC_CREFERENCE :
a_load64low_ref_reg(list,l.reference,reg);
LOC_REGISTER :
a_load_reg_reg(list,OS_32,l.registerlow,reg);
cg.a_load_reg_reg(list,OS_32,l.registerlow,reg);
LOC_CONSTANT :
a_load_const_reg(list,OS_32,l.valuelow,reg);
cg.a_load_const_reg(list,OS_32,l.valuelow,reg);
else
internalerror(200203244);
end;
@ -315,35 +313,35 @@ unit cg64f32;
LOC_CREFERENCE :
a_load64high_ref_reg(list,l.reference,reg);
LOC_REGISTER :
a_load_reg_reg(list,OS_32,l.registerhigh,reg);
cg.a_load_reg_reg(list,OS_32,l.registerhigh,reg);
LOC_CONSTANT :
a_load_const_reg(list,OS_32,l.valuehigh,reg);
cg.a_load_const_reg(list,OS_32,l.valuehigh,reg);
else
internalerror(200203244);
end;
end;
procedure tcg64f32.a_op64_const_loc(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:aword;const l: tlocation);
procedure tcg64f32.a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_op64_const_reg(list,op,valuelosrc,valuehisrc,l.registerlow,l.registerhigh);
a_op64_const_reg(list,op,value,l.register64);
LOC_REGISTER,LOC_CREGISTER:
a_op64_const_ref(list,op,valuelosrc,valuehisrc,l.reference);
a_op64_const_ref(list,op,value,l.reference);
else
internalerror(200203292);
end;
end;
procedure tcg64f32.a_op64_reg_loc(list : taasmoutput;op:TOpCG;reglo,reghi : tregister;const l : tlocation);
procedure tcg64f32.a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_op64_reg_ref(list,op,reglo,reghi,l.reference);
a_op64_reg_ref(list,op,reg,l.reference);
LOC_REGISTER,LOC_CREGISTER:
a_op64_reg_reg(list,op,reglo,reghi,l.registerlow,l.registerhigh);
a_op64_reg_reg(list,op,reg,l.register64);
else
internalerror(2002032422);
end;
@ -351,32 +349,42 @@ unit cg64f32;
procedure tcg64f32.a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reglo,reghi : tregister);
procedure tcg64f32.a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg : tregister64);
begin
case l.loc of
LOC_REFERENCE, LOC_CREFERENCE:
a_op64_ref_reg(list,op,l.reference,reglo,reghi);
a_op64_ref_reg(list,op,l.reference,reg);
LOC_REGISTER,LOC_CREGISTER:
a_op64_reg_reg(list,op,l.registerlow,l.registerhigh,reglo,reghi);
a_op64_reg_reg(list,op,l.register64,reg);
LOC_CONSTANT :
a_op64_const_reg(list,op,l.valuelow,l.valuehigh,reglo,reghi);
a_op64_const_reg(list,op,l.valueqword,reg);
else
internalerror(200203242);
end;
end;
procedure tcg64f32.a_param64_reg(list : taasmoutput;reglo,reghi : tregister;nr : longint);
procedure tcg64f32.a_param64_reg(list : taasmoutput;reg : tregister64;nr : longint);
begin
a_param_reg(list,OS_32,reghi,nr);
a_param_reg(list,OS_32,reglo,nr+1);
cg.a_param_reg(list,OS_32,reg.reghi,nr);
{ the nr+1 needs definitivly a fix FK }
{ maybe the parameter numbering needs }
{ to take care of this on 32 Bit }
{ systems FK }
cg.a_param_reg(list,OS_32,reg.reglo,nr+1);
end;
procedure tcg64f32.a_param64_const(list : taasmoutput;valuelo,valuehi : aword;nr : longint);
procedure tcg64f32.a_param64_const(list : taasmoutput;value : qword;nr : longint);
begin
a_param_const(list,OS_32,valuehi,nr);
a_param_const(list,OS_32,valuelo,nr+1);
if target_info.endian<>source_info.endian then
swap_qword(value);
cg.a_param_const(list,OS_32,hi(value),nr);
{ the nr+1 needs definitivly a fix FK }
{ maybe the parameter numbering needs }
{ to take care of this on 32 Bit }
{ systems FK }
cg.a_param_const(list,OS_32,lo(value),nr+1);
end;
@ -386,8 +394,12 @@ unit cg64f32;
begin
tmpref := r;
inc(tmpref.offset,4);
a_param_ref(list,OS_32,tmpref,nr);
a_param_ref(list,OS_32,r,nr+1);
cg.a_param_ref(list,OS_32,tmpref,nr);
{ the nr+1 needs definitivly a fix FK }
{ maybe the parameter numbering needs }
{ to take care of this on 32 Bit }
{ systems FK }
cg.a_param_ref(list,OS_32,r,nr+1);
end;
@ -396,9 +408,9 @@ unit cg64f32;
case l.loc of
LOC_REGISTER,
LOC_CREGISTER :
a_param64_reg(list,l.registerlow,l.registerhigh,nr);
a_param64_reg(list,l.register64,nr);
LOC_CONSTANT :
a_param64_const(list,l.valuelow,l.valuehigh,nr);
a_param64_const(list,l.valueqword,nr);
LOC_CREFERENCE,
LOC_REFERENCE :
a_param64_ref(list,l.reference,nr);
@ -408,23 +420,7 @@ unit cg64f32;
end;
procedure tcg64f32.g_rangecheck(list: taasmoutput; const p: tnode;
const todef: tdef);
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then
exit;
{ special case for 64bit rangechecks }
if is_64bitint(p.resulttype.def) or is_64bitint(todef) then
g_rangecheck64(list,p,todef)
else
inherited g_rangecheck(list,p,todef);
end;
procedure tcg64f32.g_rangecheck64(list : taasmoutput; p : tnode;todef : tdef);
procedure tcg64f32.g_rangecheck64(list : taasmoutput;const p : tnode;const todef : tdef);
var
neglabel,
@ -456,36 +452,36 @@ unit cg64f32;
end
else
begin
hreg := get_scratch_reg_int(list);
hreg := cg.get_scratch_reg_int(list);
got_scratch := true;
a_load64high_ref_reg(list,p.location.reference,hreg);
end;
getlabel(poslabel);
{ check high dword, must be 0 (for positive numbers) }
a_cmp_const_reg_label(list,OS_32,OC_EQ,0,hreg,poslabel);
cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,0,hreg,poslabel);
{ It can also be $ffffffff, but only for negative numbers }
if from_signed and to_signed then
begin
getlabel(neglabel);
a_cmp_const_reg_label(list,OS_32,OC_EQ,aword(-1),hreg,neglabel);
cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,aword(-1),hreg,neglabel);
end;
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
cg.free_scratch_reg(list,hreg);
{ For all other values we have a range check error }
a_call_name(list,'FPC_RANGEERROR');
cg.a_call_name(list,'FPC_RANGEERROR');
{ if the high dword = 0, the low dword can be considered a }
{ simple cardinal }
a_label(list,poslabel);
cg.a_label(list,poslabel);
hdef:=torddef.create(u32bit,0,cardinal($ffffffff));
{ the real p.resulttype.def is already saved in fromdef }
p.resulttype.def := hdef;
{ no use in calling just "g_rangecheck" since that one will }
{ simply call the inherited method too (JM) }
inherited g_rangecheck(list,p,todef);
cg.g_rangecheck(list,p,todef);
hdef.free;
{ restore original resulttype.def }
p.resulttype.def := todef;
@ -493,10 +489,10 @@ unit cg64f32;
if from_signed and to_signed then
begin
getlabel(endlabel);
a_jmp_always(list,endlabel);
cg.a_jmp_always(list,endlabel);
{ if the high dword = $ffffffff, then the low dword (when }
{ considered as a longint) must be < 0 }
a_label(list,neglabel);
cg.a_label(list,neglabel);
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
hreg := p.location.registerlow;
@ -504,27 +500,27 @@ unit cg64f32;
end
else
begin
hreg := get_scratch_reg_int(list);
hreg := cg.get_scratch_reg_int(list);
got_scratch := true;
a_load64low_ref_reg(list,p.location.reference,hreg);
end;
{ get a new neglabel (JM) }
getlabel(neglabel);
a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
cg.a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
cg.free_scratch_reg(list,hreg);
a_call_name(list,'FPC_RANGEERROR');
cg.a_call_name(list,'FPC_RANGEERROR');
{ if we get here, the 64bit value lies between }
{ longint($80000000) and -1 (JM) }
a_label(list,neglabel);
cg.a_label(list,neglabel);
hdef:=torddef.create(s32bit,longint($80000000),-1);
p.resulttype.def := hdef;
inherited g_rangecheck(list,p,todef);
cg.g_rangecheck(list,p,todef);
hdef.free;
a_label(list,endlabel);
cg.a_label(list,endlabel);
end;
registerdef := oldregisterdef;
p.resulttype.def := fromdef;
@ -558,23 +554,23 @@ unit cg64f32;
end
else
begin
hreg := get_scratch_reg_int(list);
hreg := cg.get_scratch_reg_int(list);
got_scratch := true;
opsize := def_cgsize(p.resulttype.def);
if opsize in [OS_64,OS_S64] then
a_load64high_ref_reg(list,p.location.reference,hreg)
else
a_load_ref_reg(list,opsize,p.location.reference,hreg);
cg.a_load_ref_reg(list,opsize,p.location.reference,hreg);
end;
getlabel(poslabel);
a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
cg.a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
a_call_name(list,'FPC_RANGEERROR');
a_label(list,poslabel);
cg.free_scratch_reg(list,hreg);
cg.a_call_name(list,'FPC_RANGEERROR');
cg.a_label(list,poslabel);
end;
end;
@ -591,7 +587,12 @@ begin
end.
{
$Log$
Revision 1.14 2002-05-20 13:30:40 carl
Revision 1.15 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.14 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

9
compiler/cg64f64.pas
View File

@ -77,7 +77,7 @@ unit cg64f64;
procedure tcg64f64.a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);
begin
cg.a_load_const_ref(list,OS_64,value,ref);
cg.a_load_const_ref(list,OS_64,value,ref);
end;
procedure tcg64f64.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);
@ -177,7 +177,12 @@ unit cg64f64;
end.
{
$Log$
Revision 1.1 2002-06-08 19:36:54 florian
Revision 1.2 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.1 2002/06/08 19:36:54 florian
* initial release
}

17
compiler/cginfo.pas
View File

@ -55,14 +55,14 @@ interface
(
OC_NONE,
OC_EQ, { equality comparison }
OC_GT, { greater than (signed) }
OC_GT, { greater than (signed) }
OC_LT, { less than (signed) }
OC_GTE, { greater or equal than (signed) }
OC_GTE, { greater or equal than (signed) }
OC_LTE, { less or equal than (signed) }
OC_NE, { not equal }
OC_NE, { not equal }
OC_BE, { less or equal than (unsigned) }
OC_B, { less than (unsigned) }
OC_AE, { greater or equal than (unsigned) }
OC_AE, { greater or equal than (unsigned) }
OC_A { greater than (unsigned) }
);
@ -88,7 +88,7 @@ interface
1,2,4,8,16,1,2,4,8,16);
tfloat2tcgsize: array[tfloattype] of tcgsize =
(OS_F32,OS_F64,OS_F80,OS_C64);
(OS_F32,OS_F64,OS_F80,OS_C64,OS_C64);
tcgsize2tfloat: array[OS_F32..OS_C64] of tfloattype =
(s32real,s64real,s80real,s64comp);
@ -101,7 +101,12 @@ implementation
end.
{
$Log$
Revision 1.11 2002-05-27 19:16:08 carl
Revision 1.12 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.11 2002/05/27 19:16:08 carl
+ added comments to virtual comparison flags
Revision 1.10 2002/05/18 13:34:05 peter

82
compiler/cgobj.pas
View File

@ -71,7 +71,7 @@ unit cgobj;
{# @abstract(Returns an int register for use as scratch register)
This routine returns a register which can be used by
the code generator as a general purpose scratch register.
the code generator as a general purpose scratch register.
Since scratch_registers are scarce resources, the register
should be freed by calling @link(free_scratch_reg) as
soon as it is no longer required.
@ -79,7 +79,7 @@ unit cgobj;
function get_scratch_reg_int(list : taasmoutput) : tregister;virtual;
{# @abstract(Returns an address register for use as scratch register)
This routine returns a register which can be used by
the code generator as a pointer scratch register.
the code generator as a pointer scratch register.
Since scratch_registers are scarce resources, the register
should be freed by calling @link(free_scratch_reg) as
soon as it is no longer required.
@ -335,8 +335,52 @@ unit cgobj;
procedure g_restore_all_registers(list : taasmoutput;selfused,accused,acchiused:boolean);virtual;abstract;
end;
{# @abstract(Abstract code generator for 64 Bit operations)
This class implements an abstract code generator class
for 64 Bit operations.
}
tcg64 = class
procedure a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);virtual;abstract;
procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);virtual;abstract;
procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);virtual;abstract;
procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);virtual;abstract;
procedure a_load64_const_reg(list : taasmoutput;value : qword;reg : tregister64);virtual;abstract;
procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);virtual;abstract;
procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);virtual;abstract;
procedure a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);virtual;abstract;
procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);virtual;abstract;
procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);virtual;abstract;
procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);virtual;abstract;
procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);virtual;abstract;
procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);virtual;abstract;
procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);virtual;abstract;
procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);virtual;abstract;
procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reg : tregister64);virtual;abstract;
procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;regsrc,regdst : tregister64);virtual;abstract;
procedure a_op64_reg_ref(list : taasmoutput;op:TOpCG;regsrc : tregister64;const ref : treference);virtual;abstract;
procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;value : qword;regdst : tregister64);virtual;abstract;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;value : qword;const ref : treference);virtual;abstract;
procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);virtual;abstract;
procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);virtual;abstract;
procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg64 : tregister64);virtual;abstract;
procedure a_param64_reg(list : taasmoutput;reg64 : tregister64;nr : longint);virtual;abstract;
procedure a_param64_const(list : taasmoutput;value : qword;nr : longint);virtual;abstract;
procedure a_param64_ref(list : taasmoutput;const r : treference;nr : longint);virtual;abstract;
procedure a_param64_loc(list : taasmoutput;const l : tlocation;nr : longint);virtual;abstract;
{ override to catch 64bit rangechecks }
procedure g_rangecheck64(list: taasmoutput; const p: tnode;
const todef: tdef);virtual;abstract;
end;
var
cg : tcg; { this is the main code generator class }
{# Main code generator class }
cg : tcg;
{# Code generator class for all operations working with 64-Bit operands }
cg64 : tcg64;
implementation
@ -404,13 +448,13 @@ unit cgobj;
a_reg_alloc(list,r);
get_scratch_reg_int:=r;
end;
{ the default behavior simply returns a general purpose register }
{ the default behavior simply returns a general purpose register }
function tcg.get_scratch_reg_address(list : taasmoutput) : tregister;
begin
get_scratch_reg_address := get_scratch_reg_int(list);
end;
procedure tcg.free_scratch_reg(list : taasmoutput;r : tregister);
@ -992,6 +1036,11 @@ unit cgobj;
if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then
exit;
if is_64bitint(p.resulttype.def) or is_64bitint(todef) then
begin
cg64.g_rangecheck64(list,p,todef);
exit;
end;
{ only check when assigning to scalar, subranges are different, }
{ when todef=fromdef then the check is always generated }
fromdef:=p.resulttype.def;
@ -1202,7 +1251,7 @@ unit cgobj;
g_finalize(list,procinfo^._class,href,false);
a_label(list,nofinal);
end;
{ actually call destructor }
{ actually call destructor }
{ parameter 3 :vmt_offset }
a_param_const(list, OS_32, procinfo^._class.vmt_offset, 3);
{ parameter 2 : pointer to vmt }
@ -1220,8 +1269,8 @@ unit cgobj;
else
internalerror(200006162);
end;
procedure tcg.g_call_fail_helper(list : taasmoutput);
var
href : treference;
@ -1230,7 +1279,7 @@ unit cgobj;
if is_class(procinfo^._class) then
begin
{$warning todo}
{ Should simply casll FPC_DISPOSE_CLASS and then set the
{ Should simply casll FPC_DISPOSE_CLASS and then set the
SELF_POINTER_REGISTER to NIL
}
internalerror(20020523);
@ -1262,7 +1311,7 @@ unit cgobj;
else
internalerror(200006163);
end;
procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput);
begin
@ -1278,16 +1327,17 @@ unit cgobj;
begin
end;
finalization
cg.free;
end.
{
$Log$
Revision 1.28 2002-06-06 18:53:17 jonas
Revision 1.29 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.28 2002/06/06 18:53:17 jonas
* fixed internalerror(10) with -Or for i386 (a_load_ref_ref now saves
a general purpose register if it needs one but none are available)

9
compiler/cstreams.pas
View File

@ -387,7 +387,7 @@ end;
function TCFileStream.Write(const Buffer; Count: Longint): Longint;
begin
CStreamError:=0;
BlockWrite (FHandle,Buffer,Count,Result);
BlockWrite (FHandle,(@Buffer)^,Count,Result);
If Result=-1 then Result:=0;
end;
@ -610,7 +610,12 @@ end;
end.
{
$Log$
Revision 1.5 2002-05-18 13:34:06 peter
Revision 1.6 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.5 2002/05/18 13:34:06 peter
* readded missing revisions
Revision 1.4 2002/05/16 19:46:36 carl

13
compiler/globals.pas
View File

@ -280,6 +280,7 @@ interface
function string2guid(const s: string; var GUID: TGUID): boolean;
function guid2string(const GUID: TGUID): string;
procedure swap_qword(var q : qword);
function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
@ -1266,6 +1267,11 @@ implementation
end;
procedure swap_qword(var q : qword);
begin
q:=(qword(lo(q)) shl 32) or hi(q);
end;
function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
var
tok : string;
@ -1460,7 +1466,12 @@ begin
end.
{
$Log$
Revision 1.58 2002-05-18 13:34:08 peter
Revision 1.59 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.58 2002/05/18 13:34:08 peter
* readded missing revisions
Revision 1.57 2002/05/16 19:46:36 carl

62
compiler/i386/cgcpu.pas
View File

@ -33,7 +33,7 @@ unit cgcpu;
node,symconst;
type
tcg386 = class(tcg64f32)
tcg386 = class(tcg)
{ passing parameters, per default the parameter is pushed }
{ nr gives the number of the parameter (enumerated from }
@ -95,11 +95,6 @@ unit cgcpu;
procedure g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); override;
procedure g_flags2ref(list: taasmoutput; const f: tresflags; const ref: TReference); override;
procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reglo,reghi : tregister);override;
procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;reglosrc,reghisrc,reglodst,reghidst : tregister);override;
procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);override;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;const ref : treference);override;
procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword; delsource,loadref : boolean);override;
procedure g_push_exception(list : taasmoutput;const exceptbuf:treference;l:AWord; exceptlabel:TAsmLabel);override;
@ -119,7 +114,7 @@ unit cgcpu;
procedure g_call_constructor_helper(list : taasmoutput);override;
procedure g_call_destructor_helper(list : taasmoutput);override;
procedure g_call_fail_helper(list : taasmoutput);override;
{$endif}
{$endif}
procedure g_save_standard_registers(list : taasmoutput);override;
procedure g_restore_standard_registers(list : taasmoutput);override;
procedure g_save_all_registers(list : taasmoutput);override;
@ -128,20 +123,25 @@ unit cgcpu;
procedure g_overflowcheck(list: taasmoutput; const p: tnode);override;
private
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
procedure get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
procedure sizes2load(s1 : tcgsize;s2 : topsize; var op: tasmop; var s3: topsize);
procedure floatload(list: taasmoutput; t : tcgsize;const ref : treference);
procedure floatstore(list: taasmoutput; t : tcgsize;const ref : treference);
procedure floatloadops(t : tcgsize;var op : tasmop;var s : topsize);
procedure floatstoreops(t : tcgsize;var op : tasmop;var s : topsize);
end;
tcg64f386 = class(tcg64f32)
procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reg : tregister64);override;
procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;regsrc,regdst : tregister64);override;
procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;value : qword;reg : tregister64);override;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;value : qword;const ref : treference);override;
private
procedure get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
end;
const
TOpCG2AsmOp: Array[topcg] of TAsmOp = (A_NONE,A_ADD,A_AND,A_DIV,
A_IDIV,A_MUL, A_IMUL, A_NEG,A_NOT,A_OR,
A_SAR,A_SHL,A_SHR,A_SUB,A_XOR);
@ -1068,7 +1068,7 @@ unit cgcpu;
{ ************* 64bit operations ************ }
procedure tcg386.get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
procedure tcg64f386.get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
begin
case op of
OP_ADD :
@ -1102,45 +1102,45 @@ unit cgcpu;
end;
procedure tcg386.a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reglo,reghi : tregister);
procedure tcg64f386.a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reg : tregister64);
var
op1,op2 : TAsmOp;
tempref : treference;
begin
get_64bit_ops(op,op1,op2);
list.concat(taicpu.op_ref_reg(op1,S_L,ref,reglo));
list.concat(taicpu.op_ref_reg(op1,S_L,ref,reg.reglo));
tempref:=ref;
inc(tempref.offset,4);
list.concat(taicpu.op_ref_reg(op2,S_L,tempref,reghi));
list.concat(taicpu.op_ref_reg(op2,S_L,tempref,reg.reghi));
end;
procedure tcg386.a_op64_reg_reg(list : taasmoutput;op:TOpCG;reglosrc,reghisrc,reglodst,reghidst : tregister);
procedure tcg64f386.a_op64_reg_reg(list : taasmoutput;op:TOpCG;regsrc,regdst : tregister64);
var
op1,op2 : TAsmOp;
begin
get_64bit_ops(op,op1,op2);
list.concat(taicpu.op_reg_reg(op1,S_L,reglosrc,reglodst));
list.concat(taicpu.op_reg_reg(op2,S_L,reghisrc,reghidst));
list.concat(taicpu.op_reg_reg(op1,S_L,regsrc.reglo,regdst.reglo));
list.concat(taicpu.op_reg_reg(op2,S_L,regsrc.reghi,regdst.reghi));
end;
procedure tcg386.a_op64_const_reg(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);
procedure tcg64f386.a_op64_const_reg(list : taasmoutput;op:TOpCG;value : qword;reg : tregister64);
var
op1,op2 : TAsmOp;
begin
case op of
OP_AND,OP_OR,OP_XOR:
begin
a_op_const_reg(list,op,valuelosrc,reglodst);
a_op_const_reg(list,op,valuehisrc,reghidst);
cg.a_op_const_reg(list,op,lo(value),reg.reglo);
cg.a_op_const_reg(list,op,hi(value),reg.reghi);
end;
OP_ADD, OP_SUB:
begin
// can't use a_op_const_ref because this may use dec/inc
get_64bit_ops(op,op1,op2);
list.concat(taicpu.op_const_reg(op1,S_L,valuelosrc,reglodst));
list.concat(taicpu.op_const_reg(op2,S_L,valuehisrc,reghidst));
list.concat(taicpu.op_const_reg(op1,S_L,lo(value),reg.reglo));
list.concat(taicpu.op_const_reg(op2,S_L,hi(value),reg.reghi));
end;
else
internalerror(200204021);
@ -1148,7 +1148,7 @@ unit cgcpu;
end;
procedure tcg386.a_op64_const_ref(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;const ref : treference);
procedure tcg64f386.a_op64_const_ref(list : taasmoutput;op:TOpCG;value : qword;const ref : treference);
var
op1,op2 : TAsmOp;
tempref : treference;
@ -1156,19 +1156,19 @@ unit cgcpu;
case op of
OP_AND,OP_OR,OP_XOR:
begin
a_op_const_ref(list,op,OS_32,valuelosrc,ref);
cg.a_op_const_ref(list,op,OS_32,lo(value),ref);
tempref:=ref;
inc(tempref.offset,4);
a_op_const_ref(list,op,OS_32,valuehisrc,tempref);
cg.a_op_const_ref(list,op,OS_32,hi(value),tempref);
end;
OP_ADD, OP_SUB:
begin
get_64bit_ops(op,op1,op2);
// can't use a_op_const_ref because this may use dec/inc
list.concat(taicpu.op_const_ref(op1,S_L,valuelosrc,ref));
list.concat(taicpu.op_const_ref(op1,S_L,lo(value),ref));
tempref:=ref;
inc(tempref.offset,4);
list.concat(taicpu.op_const_ref(op2,S_L,valuehisrc,tempref));
list.concat(taicpu.op_const_ref(op2,S_L,hi(value),tempref));
end;
else
internalerror(200204022);
@ -1779,10 +1779,16 @@ unit cgcpu;
begin
cg := tcg386.create;
cg64 := tcg64f386.create;
end.
{
$Log$
Revision 1.23 2002-06-16 08:16:59 carl
Revision 1.24 2002-07-01 16:23:55 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.23 2002/06/16 08:16:59 carl
* bugfix of missing popecx for shift operations
Revision 1.22 2002/05/22 19:02:16 carl

24
compiler/i386/cpubase.pas
View File

@ -91,10 +91,18 @@ uses
R_XMM0,R_XMM1,R_XMM2,R_XMM3,R_XMM4,R_XMM5,R_XMM6,R_XMM7
);
{# A type to store register locations for 64 Bit values. }
tregister64 = packed record
reglo,reghi : tregister;
end;
{# alias for compact code }
treg64 = tregister64;
{# Set type definition for registers }
tregisterset = set of tregister;
{# Type definition for the array of string of register nnames }
{# Type definition for the array of string of register names }
reg2strtable = array[tregister] of string[6];
const
@ -246,15 +254,20 @@ uses
case longint of
1 : (value : AWord);
2 : (valuelow, valuehigh:AWord);
{ overlay a complete 64 Bit value }
3 : (valueqword : qword);
);
LOC_CREFERENCE,
LOC_REFERENCE : (reference : treference);
{ segment in reference at the same place as in loc_register }
LOC_REGISTER,LOC_CREGISTER : (
case longint of
1 : (register,segment,registerhigh : tregister);
1 : (register,registerhigh,segment : tregister);
{ overlay a registerlow }
2 : (registerlow : tregister);
{ overlay a 64 Bit register type }
3 : (reg64 : tregister64);
4 : (register64 : tregister64);
);
{ it's only for better handling }
LOC_MMXREGISTER,LOC_CMMXREGISTER : (mmxreg : tregister);
@ -439,7 +452,12 @@ implementation
end.
{
$Log$
Revision 1.23 2002-05-18 13:34:22 peter
Revision 1.24 2002-07-01 16:23:55 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.23 2002/05/18 13:34:22 peter
* readded missing revisions
Revision 1.22 2002/05/16 19:46:50 carl

29
compiler/i386/n386add.pas
View File

@ -964,7 +964,7 @@ interface
end;
hregister:=rg.getregisterint(exprasmlist);
hregister2:=rg.getregisterint(exprasmlist);
tcg64f32(cg).a_load64_loc_reg(exprasmlist,left.location,hregister,hregister2);
cg64.a_load64_loc_reg(exprasmlist,left.location,joinreg64(hregister,hregister2));
location_reset(left.location,LOC_REGISTER,OS_64);
left.location.registerlow:=hregister;
left.location.registerhigh:=hregister2;
@ -983,9 +983,9 @@ interface
{ when swapped another result register }
if (nodetype=subn) and (nf_swaped in flags) then
begin
tcg64f32(cg).a_op64_reg_reg(exprasmlist,op,
left.location.registerlow,left.location.registerhigh,
right.location.registerlow,right.location.registerhigh);
cg64.a_op64_reg_reg(exprasmlist,op,
left.location.register64,
right.location.register64);
location_swap(left.location,right.location);
toggleflag(nf_swaped);
end
@ -998,9 +998,9 @@ interface
end
else
begin
tcg64f32(cg).a_op64_reg_reg(exprasmlist,op,
right.location.registerlow,right.location.registerhigh,
left.location.registerlow,left.location.registerhigh);
cg64.a_op64_reg_reg(exprasmlist,op,
right.location.register64,
left.location.register64);
end;
location_release(exprasmlist,right.location);
end
@ -1010,10 +1010,10 @@ interface
if (nodetype=subn) and (nf_swaped in flags) then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
tcg64f32(cg).a_load64low_loc_reg(exprasmlist,right.location,R_EDI);
cg64.a_load64low_loc_reg(exprasmlist,right.location,R_EDI);
emit_reg_reg(op1,opsize,left.location.registerlow,R_EDI);
emit_reg_reg(A_MOV,opsize,R_EDI,left.location.registerlow);
tcg64f32(cg).a_load64high_loc_reg(exprasmlist,right.location,R_EDI);
cg64.a_load64high_loc_reg(exprasmlist,right.location,R_EDI);
{ the carry flag is still ok }
emit_reg_reg(op2,opsize,left.location.registerhigh,R_EDI);
emit_reg_reg(A_MOV,opsize,R_EDI,left.location.registerhigh);
@ -1061,8 +1061,8 @@ interface
else
begin
tcg64f32(cg).a_op64_loc_reg(exprasmlist,op,right.location,
left.location.registerlow,left.location.registerhigh);
cg64.a_op64_loc_reg(exprasmlist,op,right.location,
left.location.register64);
if (right.location.loc<>LOC_CREGISTER) then
begin
location_freetemp(exprasmlist,right.location);
@ -1572,7 +1572,12 @@ begin
end.
{
$Log$
Revision 1.39 2002-05-18 13:34:22 peter
Revision 1.40 2002-07-01 16:23:55 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.39 2002/05/18 13:34:22 peter
* readded missing revisions
Revision 1.38 2002/05/16 19:46:51 carl

20
compiler/i386/n386cal.pas
View File

@ -176,15 +176,6 @@ implementation
{ handle call by reference parameter }
else if (defcoll.paratyp in [vs_var,vs_out]) then
begin
{ get temp for constants }
if left.location.loc=LOC_CONSTANT then
begin
tg.gettempofsizereference(exprasmlist,left.resulttype.def.size,href);
cg.a_load_loc_ref(exprasmlist,left.location,href);
location_reset(left.location,LOC_REFERENCE,def_cgsize(left.resulttype.def));
left.location.reference:=href;
end;
if (left.location.loc<>LOC_REFERENCE) then
begin
{ passing self to a var parameter is allowed in
@ -1206,8 +1197,8 @@ implementation
location.registerhigh:=rg.getexplicitregisterint(exprasmlist,accumulatorhigh);
location.registerlow:=rg.getexplicitregisterint(exprasmlist,accumulator);
end;
tcg64f32(cg).a_load64_reg_reg(exprasmlist,accumulator,accumulatorhigh,
location.registerlow,location.registerhigh);
cg64.a_load64_reg_reg(exprasmlist,joinreg64(accumulator,accumulatorhigh),
location.register64);
end
else
begin
@ -1484,7 +1475,12 @@ begin
end.
{
$Log$
Revision 1.54 2002-05-20 13:30:40 carl
Revision 1.55 2002-07-01 16:23:56 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.54 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

19
compiler/i386/n386inl.pas
View File

@ -179,8 +179,8 @@ implementation
location_force_reg(exprasmlist,location,cgsize,false);
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_const_reg(exprasmlist,cgop,1,0,
location.registerlow,location.registerhigh)
cg64.a_op64_const_reg(exprasmlist,cgop,1,
location.register64)
else
cg.a_op_const_reg(exprasmlist,cgop,1,location.register);
@ -235,8 +235,8 @@ implementation
if addconstant then
begin
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,0,tcallparanode(left).left.location)
cg64.a_op64_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,tcallparanode(left).left.location)
else
cg.a_op_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,tcallparanode(left).left.location);
@ -244,8 +244,8 @@ implementation
else
begin
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_reg_loc(exprasmlist,addsubop[inlinenumber],
hregister,hregisterhi,tcallparanode(left).left.location)
cg64.a_op64_reg_loc(exprasmlist,addsubop[inlinenumber],
joinreg64(hregister,hregisterhi),tcallparanode(left).left.location)
else
cg.a_op_reg_loc(exprasmlist,addsubop[inlinenumber],
hregister,tcallparanode(left).left.location);
@ -460,7 +460,12 @@ begin
end.
{
$Log$
Revision 1.44 2002-05-18 13:34:25 peter
Revision 1.45 2002-07-01 16:23:56 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.44 2002/05/18 13:34:25 peter
* readded missing revisions
Revision 1.43 2002/05/16 19:46:51 carl

10
compiler/ncal.pas
View File

@ -1512,7 +1512,8 @@ implementation
is_ansistring(resulttype.def) then
begin
{ we use ansistrings so no fast exit here }
procinfo^.no_fast_exit:=true;
if assigned(procinfo) then
procinfo^.no_fast_exit:=true;
end;
end;
end;
@ -1870,7 +1871,12 @@ begin
end.
{
$Log$
Revision 1.76 2002-05-18 13:34:09 peter
Revision 1.77 2002-07-01 16:23:52 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.76 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.75 2002/05/16 19:46:37 carl

53
compiler/ncgcnv.pas
View File

@ -444,18 +444,40 @@ interface
var
pushed : tpushedsaved;
begin
{ instance to check }
secondpass(left);
rg.saveusedregisters(exprasmlist,pushed,all_registers);
cg.a_param_loc(exprasmlist,left.location,2);
{ type information }
secondpass(right);
cg.a_param_loc(exprasmlist,right.location,1);
location_release(exprasmlist,right.location);
{ call helper }
cg.a_call_name(exprasmlist,'FPC_DO_AS');
cg.g_maybe_loadself(exprasmlist);
rg.restoreusedregisters(exprasmlist,pushed);
if (right.nodetype=guidconstn) then
begin
{$warning need to push a third parameter}
{ instance to check }
secondpass(left);
rg.saveusedregisters(exprasmlist,pushed,all_registers);
cg.a_param_loc(exprasmlist,left.location,2);
{ type information }
secondpass(right);
cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
location_release(exprasmlist,right.location);
{ call helper }
if is_class(left.resulttype.def) then
cg.a_call_name(exprasmlist,'FPC_CLASS_AS_INTF')
else
cg.a_call_name(exprasmlist,'FPC_INTF_AS');
cg.g_maybe_loadself(exprasmlist);
rg.restoreusedregisters(exprasmlist,pushed);
end
else
begin
{ instance to check }
secondpass(left);
rg.saveusedregisters(exprasmlist,pushed,all_registers);
cg.a_param_loc(exprasmlist,left.location,2);
{ type information }
secondpass(right);
cg.a_param_loc(exprasmlist,right.location,1);
location_release(exprasmlist,right.location);
{ call helper }
cg.a_call_name(exprasmlist,'FPC_DO_AS');
cg.g_maybe_loadself(exprasmlist);
rg.restoreusedregisters(exprasmlist,pushed);
end;
location_copy(location,left.location);
end;
@ -468,7 +490,12 @@ end.
{
$Log$
Revision 1.15 2002-05-18 13:34:09 peter
Revision 1.16 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.15 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.14 2002/05/16 19:46:37 carl

9
compiler/ncgcon.pas
View File

@ -80,7 +80,7 @@ implementation
const
floattype2ait:array[tfloattype] of tait=
(ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit);
(ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_comp_64bit);
var
hp1 : tai;
@ -519,7 +519,12 @@ begin
end.
{
$Log$
Revision 1.10 2002-05-18 13:34:09 peter
Revision 1.11 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.10 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.9 2002/05/16 19:46:37 carl

17
compiler/ncgflw.pas
View File

@ -515,8 +515,8 @@ implementation
begin
cg.a_reg_alloc(exprasmlist,accumulatorhigh);
allocated_acchigh := true;
tcg64f32(cg).a_load64_loc_reg(exprasmlist,left.location,
accumulator,accumulatorhigh);
cg64.a_load64_loc_reg(exprasmlist,left.location,
joinreg64(accumulator,accumulatorhigh));
end
else
begin
@ -601,8 +601,8 @@ do_jmp:
rg.cleartempgen;
secondpass(left);
end;
{*****************************************************************************
SecondFail
*****************************************************************************}
@ -612,7 +612,7 @@ do_jmp:
cg.a_jmp_always(exprasmlist,faillabel);
end;
begin
@ -628,7 +628,12 @@ begin
end.
{
$Log$
Revision 1.19 2002-05-20 13:30:40 carl
Revision 1.20 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.19 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

29
compiler/ncgld.pas
View File

@ -264,10 +264,10 @@ implementation
begin
if assigned(left) then
begin
{
THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK
ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS
CONSISTS OF TWO OS_ADDR, so you cannot set it
{
THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK
ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS
CONSISTS OF TWO OS_ADDR, so you cannot set it
to OS_64 - how to solve?? Carl
}
if (sizeof(aword) = 4) then
@ -529,8 +529,8 @@ implementation
LOC_CONSTANT :
begin
if right.location.size in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_const_loc(exprasmlist,
right.location.valuelow,right.location.valuehigh,left.location)
cg64.a_load64_const_loc(exprasmlist,
right.location.valueqword,left.location)
else
cg.a_load_const_loc(exprasmlist,right.location.value,left.location);
end;
@ -542,8 +542,8 @@ implementation
begin
cgsize:=def_cgsize(left.resulttype.def);
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_ref_reg(exprasmlist,
right.location.reference,left.location.registerlow,left.location.registerhigh)
cg64.a_load64_ref_reg(exprasmlist,
right.location.reference,left.location.register64)
else
cg.a_load_ref_reg(exprasmlist,cgsize,
right.location.reference,left.location.register);
@ -583,8 +583,8 @@ implementation
begin
cgsize:=def_cgsize(left.resulttype.def);
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_reg_loc(exprasmlist,
right.location.registerlow,right.location.registerhigh,left.location)
cg64.a_load64_reg_loc(exprasmlist,
right.location.register64,left.location)
else
cg.a_load_reg_loc(exprasmlist,right.location.size,right.location.register,left.location);
end;
@ -893,7 +893,7 @@ implementation
8 :
begin
if hp.left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
tcg64f32(cg).a_load64_loc_ref(exprasmlist,hp.left.location,href)
cg64.a_load64_loc_ref(exprasmlist,hp.left.location,href)
else
cg.g_concatcopy(exprasmlist,hp.left.location.reference,href,elesize,freetemp,false);
end;
@ -921,7 +921,12 @@ begin
end.
{
$Log$
Revision 1.9 2002-05-20 13:30:40 carl
Revision 1.10 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.9 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

9
compiler/ncgmem.pas
View File

@ -369,7 +369,7 @@ implementation
tmpreg := cg.get_scratch_reg_address(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,
left.location.reference,tmpreg);
end;
end;
end;
location_release(exprasmlist,left.location);
@ -462,7 +462,12 @@ begin
end.
{
$Log$
Revision 1.13 2002-05-20 13:30:40 carl
Revision 1.14 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.13 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

37
compiler/ncgset.pas
View File

@ -36,16 +36,16 @@ interface
tcginnode = class(tinnode)
procedure pass_2;override;
{# Routine to test bitnumber in bitnumber register on value
in value register. The __result register should be set
to one if the bit is set, otherwise __result register
{# Routine to test bitnumber in bitnumber register on value
in value register. The __result register should be set
to one if the bit is set, otherwise __result register
should be set to zero.
Should be overriden on processors which have specific
instructions to do bit tests.
}
procedure emit_bit_test_reg_reg(list : taasmoutput; bitnumber : tregister;
procedure emit_bit_test_reg_reg(list : taasmoutput; bitnumber : tregister;
value : tregister; __result :tregister);virtual;
end;
@ -287,7 +287,7 @@ implementation
{ "x in [y..z]" expression }
adjustment := 0;
hr := R_NO;
for i:=1 to numparts do
if setparts[i].range then
{ use fact that a <= x <= b <=> cardinal(x-a) <= cardinal(b-a) }
@ -301,7 +301,7 @@ implementation
{ so in case of a LOC_CREGISTER first move the value }
{ to edi (not done before because now we can do the }
{ move and substract in one instruction with LEA) }
if (left.location.loc = LOC_CREGISTER) and
if (left.location.loc = LOC_CREGISTER) and
(hr <> pleftreg) then
begin
hr:=cg.get_scratch_reg_int(exprasmlist);
@ -396,13 +396,13 @@ implementation
else
internalerror(200203312);
end;
{ then do AND with constant and register }
{ then do AND with constant and register }
cg.a_op_const_reg(exprasmlist,OP_AND,1 shl
(tordconstnode(left).value and 31),hr);
{ if the value in the AND register is <> 0 then the value is equal. }
cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_EQ,1 shl
cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_EQ,1 shl
(tordconstnode(left).value and 31),hr,l);
cg.free_scratch_reg(exprasmlist,hr);
cg.free_scratch_reg(exprasmlist,hr);
getlabel(l3);
cg.a_jmp_always(exprasmlist,l3);
{ Now place the end label if IN success }
@ -422,7 +422,7 @@ implementation
hr3:=rg.makeregsize(left.location.register,OS_INT);
cg.a_load_reg_reg(exprasmlist,left.location.size,left.location.register,hr3);
hr:=cg.get_scratch_reg_int(exprasmlist);
cg.a_load_reg_reg(exprasmlist,OS_INT,hr3,hr);
cg.a_load_reg_reg(exprasmlist,OS_INT,hr3,hr);
end;
else
begin
@ -540,7 +540,7 @@ implementation
getlabel(l);
{ use location.register as scratch register here }
inc(right.location.reference.offset,tordconstnode(left).value shr 3);
cg.a_load_ref_reg(exprasmlist, OS_8, right.location.reference, location.register);
cg.a_load_ref_reg(exprasmlist, OS_8, right.location.reference, location.register);
cg.a_op_const_reg(exprasmlist, OP_AND,1 shl (tordconstnode(left).value and 7),
location.register);
cg.a_cmp_const_reg_label(exprasmlist,OS_8, OC_NE,0,location.register,l2);
@ -580,13 +580,18 @@ implementation
begin
csetelementnode:=tcgsetelementnode;
{$ifdef TEST_GENERIC}
{$ifdef TEST_GENERIC}
cinnode:=tcginnode;
{$endif}
{$endif}
end.
{
$Log$
Revision 1.1 2002-06-16 08:14:56 carl
Revision 1.2 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.1 2002/06/16 08:14:56 carl
+ generic sets
}

27
compiler/ncgutil.pas
View File

@ -214,6 +214,7 @@ implementation
var
hregister,
hregisterhi : tregister;
hreg64 : tregister64;
hl : tasmlabel;
begin
{ handle transformations to 64bit separate }
@ -281,8 +282,10 @@ implementation
hregister:=rg.getregisterint(list);
hregisterhi:=rg.getregisterint(list);
end;
hreg64.reglo:=hregister;
hreg64.reghi:=hregisterhi;
{ load value in new register }
tcg64f32(cg).a_load64_loc_reg(list,l,hregister,hregisterhi);
cg64.a_load64_loc_reg(list,l,hreg64);
location_reset(l,LOC_REGISTER,dst_size);
l.registerlow:=hregister;
l.registerhigh:=hregisterhi;
@ -464,7 +467,7 @@ implementation
begin
tg.gettempofsizereference(list,TCGSize2Size[l.size],r);
if l.size in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_loc_ref(list,l,r)
cg64.a_load64_loc_ref(list,l,r)
else
cg.a_load_loc_ref(list,l,r);
location_reset(l,LOC_REFERENCE,l.size);
@ -498,7 +501,7 @@ implementation
if l.size in [OS_64,OS_S64] then
begin
tg.gettempofsizereference(exprasmlist,8,s.ref);
tcg64f32(cg).a_load64_reg_ref(exprasmlist,l.registerlow,l.registerhigh,s.ref);
cg64.a_load64_reg_ref(exprasmlist,joinreg64(l.registerlow,l.registerhigh),s.ref);
end
else
begin
@ -545,7 +548,7 @@ implementation
begin
l.registerlow:=rg.getregisterint(exprasmlist);
l.registerhigh:=rg.getregisterint(exprasmlist);
tcg64f32(cg).a_load64_ref_reg(exprasmlist,s.ref,l.registerlow,l.registerhigh);
cg64.a_load64_ref_reg(exprasmlist,s.ref,joinreg64(l.registerlow,l.registerhigh));
end
else
begin
@ -692,10 +695,10 @@ implementation
if inlined then
begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
tcg64f32(cg).a_load64_loc_ref(exprasmlist,p.location,href);
cg64.a_load64_loc_ref(exprasmlist,p.location,href);
end
else
tcg64f32(cg).a_param64_loc(exprasmlist,p.location,-1);
cg64.a_param64_loc(exprasmlist,p.location,-1);
end
else
begin
@ -878,6 +881,7 @@ implementation
cg.a_load_ref_reg(list,OS_ADDR,href,tmpreg);
reference_reset_base(href,tmpreg,0);
cg.g_initialize(list,tvarsym(p).vartype.def,href,false);
cg.free_scratch_reg(list,tmpreg);
end;
end;
end;
@ -988,7 +992,7 @@ implementation
begin
uses_acchi:=true;
cg.a_reg_alloc(list,accumulatorhigh);
tcg64f32(cg).a_load64_ref_reg(list,href,accumulator,accumulatorhigh);
cg64.a_load64_ref_reg(list,href,joinreg64(accumulator,accumulatorhigh));
end
else
begin
@ -1029,7 +1033,7 @@ implementation
enumdef :
begin
if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_reg_ref(list,accumulator,accumulatorhigh,href)
cg64.a_load64_reg_ref(list,joinreg64(accumulator,accumulatorhigh),href)
else
begin
hreg:=rg.makeregsize(accumulator,cgsize);
@ -1607,7 +1611,12 @@ implementation
end.
{
$Log$
Revision 1.17 2002-05-20 13:30:40 carl
Revision 1.18 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.17 2002/05/20 13:30:40 carl
* bugfix of hdisponen (base must be set, not index)
* more portability fixes

27
compiler/ncnv.pas
View File

@ -102,7 +102,6 @@ interface
procedure second_class_to_intf;virtual;abstract;
procedure second_char_to_char;virtual;abstract;
procedure second_nothing; virtual;abstract;
end;
ttypeconvnodeclass = class of ttypeconvnode;
@ -703,7 +702,6 @@ implementation
begin
t:=crealconstnode.create(tordconstnode(left).value,resulttype);
result:=t;
exit;
end;
end;
@ -715,6 +713,13 @@ implementation
begin
result:=nil;
if is_currency(left.resulttype.def) and not(is_currency(resulttype.def)) then
begin
end
else
if is_currency(resulttype.def) then
begin
end;
if left.nodetype=realconstn then
begin
t:=crealconstnode.create(trealconstnode(left).value_real,resulttype);
@ -1713,7 +1718,18 @@ implementation
end
else
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
resulttype:=right.resulttype;
{ load the GUID of the interface }
if (right.nodetype=typen) then
begin
if tobjectdef(left.resulttype.def).isiidguidvalid then
right:=cguidconstnode.create(tobjectdef(left.resulttype.def).iidguid)
else
internalerror(200206282);
resulttypepass(right);
end;
end
else
CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
@ -1739,7 +1755,12 @@ begin
end.
{
$Log$
Revision 1.58 2002-05-18 13:34:09 peter
Revision 1.59 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.58 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.57 2002/05/16 19:46:37 carl

8
compiler/options.pas
View File

@ -1354,6 +1354,7 @@ begin
def_symbol('HASCOMPILERPROC');
def_symbol('VALUEGETMEM');
def_symbol('VALUEFREEMEM');
def_symbol('HASCURRENCY');
{ some stuff for TP compatibility }
case target_info.cpu of
@ -1664,7 +1665,12 @@ finalization
end.
{
$Log$
Revision 1.73 2002-05-18 13:34:11 peter
Revision 1.74 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.73 2002/05/18 13:34:11 peter
* readded missing revisions
Revision 1.72 2002/05/16 19:46:41 carl

41
compiler/pdecobj.pas
View File

@ -972,18 +972,23 @@ implementation
end;
_PUBLISHED :
begin
{ we've to check for a pushlished section in non- }
{ publishable classes later, if a real declaration }
{ this is the way, delphi does it }
if is_interface(aktclass) then
Message(parser_e_no_access_specifier_in_interfaces)
else
if not(oo_can_have_published in aktclass.objectoptions) then
Message(parser_e_cant_have_published);
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLISHED);
current_object_option:=[sp_published];
end;
else
begin
if is_interface(aktclass) then
Message(parser_e_no_vars_in_interfaces);
Message(parser_e_no_vars_in_interfaces);
if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then
Message(parser_e_cant_have_published);
read_var_decs(false,true,false);
end;
end;
@ -996,6 +1001,10 @@ implementation
_FUNCTION,
_CLASS :
begin
if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then
Message(parser_e_cant_have_published);
oldparse_only:=parse_only;
parse_only:=true;
parse_proc_dec;
@ -1024,10 +1033,16 @@ implementation
end;
_CONSTRUCTOR :
begin
if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then
Message(parser_e_cant_have_published);
if not(sp_public in current_object_option) then
Message(parser_w_constructor_should_be_public);
if is_interface(aktclass) then
Message(parser_e_no_con_des_in_interfaces);
oldparse_only:=parse_only;
parse_only:=true;
constructor_head;
@ -1046,13 +1061,20 @@ implementation
end;
_DESTRUCTOR :
begin
if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then
Message(parser_e_cant_have_published);
if there_is_a_destructor then
Message(parser_n_only_one_destructor);
if is_interface(aktclass) then
Message(parser_e_no_con_des_in_interfaces);
there_is_a_destructor:=true;
if not(sp_public in current_object_option) then
Message(parser_w_destructor_should_be_public);
there_is_a_destructor:=true;
oldparse_only:=parse_only;
parse_only:=true;
destructor_head;
@ -1111,7 +1133,12 @@ implementation
end.
{
$Log$
Revision 1.45 2002-05-18 13:34:12 peter
Revision 1.46 2002-07-01 16:23:53 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.45 2002/05/18 13:34:12 peter
* readded missing revisions
Revision 1.44 2002/05/16 19:46:42 carl

11
compiler/psystem.pas
View File

@ -116,6 +116,7 @@ begin
addtype('Real',s64floattype);
{$ifdef i386}
adddef('Comp',tfloatdef.create(s64comp));
addtype('Currency',s64currencytype);
{$endif}
addtype('Pointer',voidpointertype);
addtype('FarPointer',voidfarpointertype);
@ -161,6 +162,7 @@ begin
addtype('$s32real',s32floattype);
addtype('$s64real',s64floattype);
addtype('$s80real',s80floattype);
addtype('$s64currency',s64currencytype);
{ Add a type for virtual method tables }
vmtsymtable:=trecordsymtable.create;
vmttype.setdef(trecorddef.create(vmtsymtable));
@ -205,6 +207,7 @@ begin
globaldef('s32real',s32floattype);
globaldef('s64real',s64floattype);
globaldef('s80real',s80floattype);
globaldef('s64currency',s64currencytype);
globaldef('boolean',booltype);
globaldef('void_pointer',voidpointertype);
globaldef('char_pointer',charpointertype);
@ -249,6 +252,7 @@ begin
s32floattype.setdef(tfloatdef.create(s32real));
s64floattype.setdef(tfloatdef.create(s64real));
s80floattype.setdef(tfloatdef.create(s80real));
s64currencytype.setdef(tfloatdef.create(s64currency));
{$endif}
{$ifdef m68k}
s32floattype.setdef(tfloatdef.create(s32real));
@ -276,7 +280,12 @@ end;
end.
{
$Log$
Revision 1.26 2002-05-18 13:34:16 peter
Revision 1.27 2002-07-01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.26 2002/05/18 13:34:16 peter
* readded missing revisions
Revision 1.25 2002/05/16 19:46:44 carl

9
compiler/symconst.pas
View File

@ -146,7 +146,7 @@ type
{ float types }
tfloattype = (
s32real,s64real,s80real,
s64comp
s64comp,s64currency
);
{ string types }
@ -334,7 +334,12 @@ implementation
end.
{
$Log$
Revision 1.32 2002-05-18 13:34:18 peter
Revision 1.33 2002-07-01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.32 2002/05/18 13:34:18 peter
* readded missing revisions
Revision 1.31 2002/05/16 19:46:44 carl

13
compiler/symdef.pas
View File

@ -648,6 +648,7 @@ interface
s32floattype, { pointer for realconstn }
s64floattype, { pointer for realconstn }
s80floattype, { pointer to type of temp. floats }
s64currencytype, { pointer to a currency type }
s32fixedtype, { pointer to type of temp. fixed }
cshortstringtype, { pointer to type of short string const }
clongstringtype, { pointer to type of long string const }
@ -1938,6 +1939,7 @@ implementation
s64real : stabstring := strpnew('r'+
tstoreddef(s32bittype.def).numberstring+';'+tostr(savesize)+';0;');
{ found this solution in stabsread.c from GDB v4.16 }
s64currency,
s64comp : stabstring := strpnew('r'+
tstoreddef(s32bittype.def).numberstring+';-'+tostr(savesize)+';0;');
{ under dos at least you must give a size of twelve instead of 10 !! }
@ -1954,7 +1956,7 @@ implementation
const
{tfloattype = (s32real,s64real,s80real,s64bit);}
translate : array[tfloattype] of byte =
(ftSingle,ftDouble,ftExtended,ftComp);
(ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
begin
rttiList.concat(Tai_const.Create_8bit(tkFloat));
write_rtti_name;
@ -1971,7 +1973,7 @@ implementation
const
names : array[tfloattype] of string[20] = (
'Single','Double','Extended','Comp');
'Single','Double','Extended','Comp','Currency');
begin
gettypename:=names[typ];
@ -5476,7 +5478,12 @@ implementation
end.
{
$Log$
Revision 1.79 2002-05-18 13:34:18 peter
Revision 1.80 2002-07-01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.79 2002/05/18 13:34:18 peter
* readded missing revisions
Revision 1.78 2002/05/16 19:46:44 carl

19
compiler/types.pas
View File

@ -151,6 +151,9 @@ interface
{# Returns true, if definition is float }
function is_fpu(def : tdef) : boolean;
{# Returns true, if def is a currency type }
function is_currency(def : tdef) : boolean;
{# Returns true if the return value can be put in accumulator }
function ret_in_acc(def : tdef) : boolean;
@ -534,7 +537,14 @@ implementation
end;
function range_to_basetype(low,high:TConstExprInt):tbasetype;
{ returns true, if def is a currency type }
function is_currency(def : tdef) : boolean;
begin
is_currency:=(def.deftype=floatdef) and (tfloatdef(def).typ=s64currency);
end;
function range_to_basetype(low,high:TConstExprInt):tbasetype;
begin
{ generate a unsigned range if high<0 and low>=0 }
if (low>=0) and (high<0) then
@ -1970,7 +1980,12 @@ implementation
end.
{
$Log$
Revision 1.73 2002-05-18 13:34:21 peter
Revision 1.74 2002-07-01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.73 2002/05/18 13:34:21 peter
* readded missing revisions
Revision 1.72 2002/05/16 19:46:47 carl