paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-20 03:18:18 +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 {# This unit implements the code generation for 64 bit int arithmethics on
32 bit processors. All 32-bit processors should use this class as 32 bit processors.
the base code generator class instead of tcg.
} }
unit cg64f32; unit cg64f32;
@ -40,51 +39,42 @@ unit cg64f32;
type type
{# Defines all the methods required on 32-bit processors {# Defines all the methods required on 32-bit processors
to handle 64-bit integers. All 32-bit processors should to handle 64-bit integers.
create derive a class of this type instead of @var(tcg).
} }
tcg64f32 = class(tcg) tcg64f32 = class(tcg64)
procedure a_load64_const_ref(list : taasmoutput;valuelo, valuehi : AWord;const ref : treference); procedure a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);override;
procedure a_load64_reg_ref(list : taasmoutput;reglo, reghi : tregister;const ref : treference); procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);override;
procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reglo,reghi : tregister); procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);override;
procedure a_load64_reg_reg(list : taasmoutput;reglosrc,reghisrc,reglodst,reghidst : tregister); procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);override;
procedure a_load64_const_reg(list : taasmoutput;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister); procedure a_load64_const_reg(list : taasmoutput;value: qword;reg : tregister64);override;
procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reglo,reghi : tregister); 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); procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);override;
procedure a_load64_const_loc(list : taasmoutput;valuelo, valuehi : AWord;const l : tlocation); procedure a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);override;
procedure a_load64_reg_loc(list : taasmoutput;reglo, reghi : tregister;const l : tlocation); procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);override;
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);
procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;const ref : treference;reglo,reghi : tregister);virtual;abstract; procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;reglosrc,reghisrc,reglodst,reghidst : tregister);virtual;abstract; procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
procedure a_op64_reg_ref(list : taasmoutput;op:TOpCG;reglosrc,reghisrc : tregister;const ref : treference);virtual;abstract; procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;reglodst,reghidst : tregister);virtual;abstract; procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;const ref : treference);virtual;abstract; procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:aword;const l: tlocation); procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
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_param64_reg(list : taasmoutput;reglo,reghi : tregister;nr : longint); procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);override;
procedure a_param64_const(list : taasmoutput;valuelo,valuehi : aword;nr : longint); procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);override;
procedure a_param64_ref(list : taasmoutput;const r : treference;nr : longint); procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg : tregister64);override;
procedure a_param64_loc(list : taasmoutput;const l : tlocation;nr : longint);
{ override to catch 64bit rangechecks } procedure a_param64_reg(list : taasmoutput;reg : tregister64;nr : longint);override;
procedure g_rangecheck(list: taasmoutput; const p: tnode; 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; 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; end;
{# Creates a tregister64 record from 2 32 Bit registers. }
function joinreg64(reglo,reghi : tregister) : tregister64;
implementation implementation
uses uses
@ -93,42 +83,45 @@ unit cg64f32;
verbose, verbose,
symbase,symconst,symdef,types; 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 var
tmpreg: tregister; tmpreg: tregister;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_big then if target_info.endian=endian_big then
begin begin
tmpreg := reglo; tmpreg:=reg.reglo;
reglo := reghi; reg.reglo:=reg.reghi;
reghi := tmpreg; reg.reghi:=tmpreg;
end; end;
a_load_reg_ref(list,OS_32,reglo,ref); cg.a_load_reg_ref(list,OS_32,reg.reglo,ref);
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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; 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 var
tmpvalue: AWord; tmpvalue : DWord;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_big then if target_info.endian<>source_info.endian then
begin swap_qword(value);
tmpvalue := valuelo; cg.a_load_const_ref(list,OS_32,lo(value),ref);
valuelo := valuehi;
valuehi := tmpvalue;
end;
a_load_const_ref(list,OS_32,valuelo,ref);
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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; 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 var
tmpreg: tregister; tmpreg: tregister;
tmpref: treference; tmpref: treference;
@ -136,59 +129,64 @@ unit cg64f32;
begin begin
if target_info.endian = endian_big then if target_info.endian = endian_big then
begin begin
tmpreg := reglo; tmpreg := reg.reglo;
reglo := reghi; reg.reglo := reg.reghi;
reghi := tmpreg; reg.reghi := tmpreg;
end; end;
got_scratch:=false; got_scratch:=false;
tmpref := ref; tmpref := ref;
if (tmpref.base=reglo) then if (tmpref.base=reg.reglo) then
begin begin
tmpreg := get_scratch_reg_int(list); tmpreg := cg.get_scratch_reg_int(list);
got_scratch:=true; 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; tmpref.base:=tmpreg;
end end
else 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 begin
tmpreg := get_scratch_reg_int(list); tmpreg:=cg.get_scratch_reg_int(list);
got_scratch:=true; 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; tmpref.index:=tmpreg;
end; 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); 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 if got_scratch then
free_scratch_reg(list,tmpreg); cg.free_scratch_reg(list,tmpreg);
end; 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 begin
a_load_reg_reg(list,OS_32,reglosrc,reglodst); cg.a_load_reg_reg(list,OS_32,regsrc.reglo,regdst.reglo);
a_load_reg_reg(list,OS_32,reghisrc,reghidst); cg.a_load_reg_reg(list,OS_32,regsrc.reghi,regdst.reghi);
end; 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 begin
a_load_const_reg(list,OS_32,valuelosrc,reglodst); if target_info.endian<>source_info.endian then
a_load_const_reg(list,OS_32,valuehisrc,reghidst); 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; 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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: 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 : LOC_CONSTANT :
a_load64_const_reg(list,l.valuelow,l.valuehigh,reglo,reghi); a_load64_const_reg(list,l.valueqword,reg);
else else
internalerror(200112292); internalerror(200112292);
end; end;
@ -199,37 +197,37 @@ unit cg64f32;
begin begin
case l.loc of case l.loc of
LOC_REGISTER,LOC_CREGISTER: LOC_REGISTER,LOC_CREGISTER:
a_load64_reg_ref(list,l.registerlow,l.registerhigh,ref); a_load64_reg_ref(list,l.reg64,ref);
LOC_CONSTANT : LOC_CONSTANT :
a_load64_const_ref(list,l.valuelow,l.valuehigh,ref); a_load64_const_ref(list,l.valueqword,ref);
else else
internalerror(200203288); internalerror(200203288);
end; end;
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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: LOC_REGISTER,LOC_CREGISTER:
a_load64_const_reg(list,valuelo,valuehi,l.registerlow,l.registerhigh); a_load64_const_reg(list,value,l.reg64);
else else
internalerror(200112293); internalerror(200112293);
end; end;
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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: LOC_REGISTER,LOC_CREGISTER:
a_load64_reg_reg(list,reglo,reghi,l.registerlow,l.registerhigh); a_load64_reg_reg(list,reg,l.register64);
else else
internalerror(200112293); internalerror(200112293);
end; end;
@ -242,12 +240,12 @@ unit cg64f32;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_big then 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 else
begin begin
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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;
end; end;
@ -256,12 +254,12 @@ unit cg64f32;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_little then 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 else
begin begin
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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;
end; end;
@ -270,12 +268,12 @@ unit cg64f32;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_big then 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 else
begin begin
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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;
end; end;
@ -284,12 +282,12 @@ unit cg64f32;
tmpref: treference; tmpref: treference;
begin begin
if target_info.endian = endian_little then 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 else
begin begin
tmpref := ref; tmpref := ref;
inc(tmpref.offset,4); 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;
end; end;
@ -300,9 +298,9 @@ unit cg64f32;
LOC_CREFERENCE : LOC_CREFERENCE :
a_load64low_ref_reg(list,l.reference,reg); a_load64low_ref_reg(list,l.reference,reg);
LOC_REGISTER : 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 : LOC_CONSTANT :
a_load_const_reg(list,OS_32,l.valuelow,reg); cg.a_load_const_reg(list,OS_32,l.valuelow,reg);
else else
internalerror(200203244); internalerror(200203244);
end; end;
@ -315,35 +313,35 @@ unit cg64f32;
LOC_CREFERENCE : LOC_CREFERENCE :
a_load64high_ref_reg(list,l.reference,reg); a_load64high_ref_reg(list,l.reference,reg);
LOC_REGISTER : 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 : LOC_CONSTANT :
a_load_const_reg(list,OS_32,l.valuehigh,reg); cg.a_load_const_reg(list,OS_32,l.valuehigh,reg);
else else
internalerror(200203244); internalerror(200203244);
end; end;
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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: LOC_REGISTER,LOC_CREGISTER:
a_op64_const_ref(list,op,valuelosrc,valuehisrc,l.reference); a_op64_const_ref(list,op,value,l.reference);
else else
internalerror(200203292); internalerror(200203292);
end; end;
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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: 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 else
internalerror(2002032422); internalerror(2002032422);
end; 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 begin
case l.loc of case l.loc of
LOC_REFERENCE, LOC_CREFERENCE: 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: 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 : LOC_CONSTANT :
a_op64_const_reg(list,op,l.valuelow,l.valuehigh,reglo,reghi); a_op64_const_reg(list,op,l.valueqword,reg);
else else
internalerror(200203242); internalerror(200203242);
end; end;
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 begin
a_param_reg(list,OS_32,reghi,nr); cg.a_param_reg(list,OS_32,reg.reghi,nr);
a_param_reg(list,OS_32,reglo,nr+1); { 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; 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 begin
a_param_const(list,OS_32,valuehi,nr); if target_info.endian<>source_info.endian then
a_param_const(list,OS_32,valuelo,nr+1); 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; end;
@ -386,8 +394,12 @@ unit cg64f32;
begin begin
tmpref := r; tmpref := r;
inc(tmpref.offset,4); inc(tmpref.offset,4);
a_param_ref(list,OS_32,tmpref,nr); cg.a_param_ref(list,OS_32,tmpref,nr);
a_param_ref(list,OS_32,r,nr+1); { 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; end;
@ -396,9 +408,9 @@ unit cg64f32;
case l.loc of case l.loc of
LOC_REGISTER, LOC_REGISTER,
LOC_CREGISTER : LOC_CREGISTER :
a_param64_reg(list,l.registerlow,l.registerhigh,nr); a_param64_reg(list,l.register64,nr);
LOC_CONSTANT : LOC_CONSTANT :
a_param64_const(list,l.valuelow,l.valuehigh,nr); a_param64_const(list,l.valueqword,nr);
LOC_CREFERENCE, LOC_CREFERENCE,
LOC_REFERENCE : LOC_REFERENCE :
a_param64_ref(list,l.reference,nr); a_param64_ref(list,l.reference,nr);
@ -408,23 +420,7 @@ unit cg64f32;
end; end;
procedure tcg64f32.g_rangecheck64(list : taasmoutput;const p : tnode;const todef : tdef);
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);
var var
neglabel, neglabel,
@ -456,36 +452,36 @@ unit cg64f32;
end end
else else
begin begin
hreg := get_scratch_reg_int(list); hreg := cg.get_scratch_reg_int(list);
got_scratch := true; got_scratch := true;
a_load64high_ref_reg(list,p.location.reference,hreg); a_load64high_ref_reg(list,p.location.reference,hreg);
end; end;
getlabel(poslabel); getlabel(poslabel);
{ check high dword, must be 0 (for positive numbers) } { 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 } { It can also be $ffffffff, but only for negative numbers }
if from_signed and to_signed then if from_signed and to_signed then
begin begin
getlabel(neglabel); 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; end;
{ !!! freeing of register should happen directly after compare! (JM) } { !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then 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 } { 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 } { if the high dword = 0, the low dword can be considered a }
{ simple cardinal } { simple cardinal }
a_label(list,poslabel); cg.a_label(list,poslabel);
hdef:=torddef.create(u32bit,0,cardinal($ffffffff)); hdef:=torddef.create(u32bit,0,cardinal($ffffffff));
{ the real p.resulttype.def is already saved in fromdef } { the real p.resulttype.def is already saved in fromdef }
p.resulttype.def := hdef; p.resulttype.def := hdef;
{ no use in calling just "g_rangecheck" since that one will } { no use in calling just "g_rangecheck" since that one will }
{ simply call the inherited method too (JM) } { simply call the inherited method too (JM) }
inherited g_rangecheck(list,p,todef); cg.g_rangecheck(list,p,todef);
hdef.free; hdef.free;
{ restore original resulttype.def } { restore original resulttype.def }
p.resulttype.def := todef; p.resulttype.def := todef;
@ -493,10 +489,10 @@ unit cg64f32;
if from_signed and to_signed then if from_signed and to_signed then
begin begin
getlabel(endlabel); getlabel(endlabel);
a_jmp_always(list,endlabel); cg.a_jmp_always(list,endlabel);
{ if the high dword = $ffffffff, then the low dword (when } { if the high dword = $ffffffff, then the low dword (when }
{ considered as a longint) must be < 0 } { 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 if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin begin
hreg := p.location.registerlow; hreg := p.location.registerlow;
@ -504,27 +500,27 @@ unit cg64f32;
end end
else else
begin begin
hreg := get_scratch_reg_int(list); hreg := cg.get_scratch_reg_int(list);
got_scratch := true; got_scratch := true;
a_load64low_ref_reg(list,p.location.reference,hreg); a_load64low_ref_reg(list,p.location.reference,hreg);
end; end;
{ get a new neglabel (JM) } { get a new neglabel (JM) }
getlabel(neglabel); 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) } { !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then 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 } { if we get here, the 64bit value lies between }
{ longint($80000000) and -1 (JM) } { longint($80000000) and -1 (JM) }
a_label(list,neglabel); cg.a_label(list,neglabel);
hdef:=torddef.create(s32bit,longint($80000000),-1); hdef:=torddef.create(s32bit,longint($80000000),-1);
p.resulttype.def := hdef; p.resulttype.def := hdef;
inherited g_rangecheck(list,p,todef); cg.g_rangecheck(list,p,todef);
hdef.free; hdef.free;
a_label(list,endlabel); cg.a_label(list,endlabel);
end; end;
registerdef := oldregisterdef; registerdef := oldregisterdef;
p.resulttype.def := fromdef; p.resulttype.def := fromdef;
@ -558,23 +554,23 @@ unit cg64f32;
end end
else else
begin begin
hreg := get_scratch_reg_int(list); hreg := cg.get_scratch_reg_int(list);
got_scratch := true; got_scratch := true;
opsize := def_cgsize(p.resulttype.def); opsize := def_cgsize(p.resulttype.def);
if opsize in [OS_64,OS_S64] then if opsize in [OS_64,OS_S64] then
a_load64high_ref_reg(list,p.location.reference,hreg) a_load64high_ref_reg(list,p.location.reference,hreg)
else else
a_load_ref_reg(list,opsize,p.location.reference,hreg); cg.a_load_ref_reg(list,opsize,p.location.reference,hreg);
end; end;
getlabel(poslabel); 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) } { !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then 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');
a_label(list,poslabel); cg.a_label(list,poslabel);
end; end;
end; end;
@ -591,7 +587,12 @@ begin
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * 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); procedure tcg64f64.a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);
begin begin
cg.a_load_const_ref(list,OS_64,value,ref); cg.a_load_const_ref(list,OS_64,value,ref);
end; end;
procedure tcg64f64.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference); procedure tcg64f64.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);
@ -177,7 +177,12 @@ unit cg64f64;
end. end.
{ {
$Log$ $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 * initial release
} }

17
compiler/cginfo.pas
View File

@ -55,14 +55,14 @@ interface
( (
OC_NONE, OC_NONE,
OC_EQ, { equality comparison } OC_EQ, { equality comparison }
OC_GT, { greater than (signed) } OC_GT, { greater than (signed) }
OC_LT, { less 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_LTE, { less or equal than (signed) }
OC_NE, { not equal } OC_NE, { not equal }
OC_BE, { less or equal than (unsigned) } OC_BE, { less or equal than (unsigned) }
OC_B, { less 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) } OC_A { greater than (unsigned) }
); );
@ -88,7 +88,7 @@ interface
1,2,4,8,16,1,2,4,8,16); 1,2,4,8,16,1,2,4,8,16);
tfloat2tcgsize: array[tfloattype] of tcgsize = 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 = tcgsize2tfloat: array[OS_F32..OS_C64] of tfloattype =
(s32real,s64real,s80real,s64comp); (s32real,s64real,s80real,s64comp);
@ -101,7 +101,12 @@ implementation
end. end.
{ {
$Log$ $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 + added comments to virtual comparison flags
Revision 1.10 2002/05/18 13:34:05 peter 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) {# @abstract(Returns an int register for use as scratch register)
This routine returns a register which can be used by 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 Since scratch_registers are scarce resources, the register
should be freed by calling @link(free_scratch_reg) as should be freed by calling @link(free_scratch_reg) as
soon as it is no longer required. soon as it is no longer required.
@ -79,7 +79,7 @@ unit cgobj;
function get_scratch_reg_int(list : taasmoutput) : tregister;virtual; function get_scratch_reg_int(list : taasmoutput) : tregister;virtual;
{# @abstract(Returns an address register for use as scratch register) {# @abstract(Returns an address register for use as scratch register)
This routine returns a register which can be used by 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 Since scratch_registers are scarce resources, the register
should be freed by calling @link(free_scratch_reg) as should be freed by calling @link(free_scratch_reg) as
soon as it is no longer required. 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; procedure g_restore_all_registers(list : taasmoutput;selfused,accused,acchiused:boolean);virtual;abstract;
end; 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 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 implementation
@ -404,13 +448,13 @@ unit cgobj;
a_reg_alloc(list,r); a_reg_alloc(list,r);
get_scratch_reg_int:=r; get_scratch_reg_int:=r;
end; 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; function tcg.get_scratch_reg_address(list : taasmoutput) : tregister;
begin begin
get_scratch_reg_address := get_scratch_reg_int(list); get_scratch_reg_address := get_scratch_reg_int(list);
end; end;
procedure tcg.free_scratch_reg(list : taasmoutput;r : tregister); procedure tcg.free_scratch_reg(list : taasmoutput;r : tregister);
@ -992,6 +1036,11 @@ unit cgobj;
if not(cs_check_range in aktlocalswitches) or if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then not(todef.deftype in [orddef,enumdef,arraydef]) then
exit; 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, } { only check when assigning to scalar, subranges are different, }
{ when todef=fromdef then the check is always generated } { when todef=fromdef then the check is always generated }
fromdef:=p.resulttype.def; fromdef:=p.resulttype.def;
@ -1202,7 +1251,7 @@ unit cgobj;
g_finalize(list,procinfo^._class,href,false); g_finalize(list,procinfo^._class,href,false);
a_label(list,nofinal); a_label(list,nofinal);
end; end;
{ actually call destructor } { actually call destructor }
{ parameter 3 :vmt_offset } { parameter 3 :vmt_offset }
a_param_const(list, OS_32, procinfo^._class.vmt_offset, 3); a_param_const(list, OS_32, procinfo^._class.vmt_offset, 3);
{ parameter 2 : pointer to vmt } { parameter 2 : pointer to vmt }
@ -1220,8 +1269,8 @@ unit cgobj;
else else
internalerror(200006162); internalerror(200006162);
end; end;
procedure tcg.g_call_fail_helper(list : taasmoutput); procedure tcg.g_call_fail_helper(list : taasmoutput);
var var
href : treference; href : treference;
@ -1230,7 +1279,7 @@ unit cgobj;
if is_class(procinfo^._class) then if is_class(procinfo^._class) then
begin begin
{$warning todo} {$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 SELF_POINTER_REGISTER to NIL
} }
internalerror(20020523); internalerror(20020523);
@ -1262,7 +1311,7 @@ unit cgobj;
else else
internalerror(200006163); internalerror(200006163);
end; end;
procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput); procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput);
begin begin
@ -1278,16 +1327,17 @@ unit cgobj;
begin begin
end; end;
finalization finalization
cg.free; cg.free;
end. end.
{ {
$Log$ $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 * 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) 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; function TCFileStream.Write(const Buffer; Count: Longint): Longint;
begin begin
CStreamError:=0; CStreamError:=0;
BlockWrite (FHandle,Buffer,Count,Result); BlockWrite (FHandle,(@Buffer)^,Count,Result);
If Result=-1 then Result:=0; If Result=-1 then Result:=0;
end; end;
@ -610,7 +610,12 @@ end;
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.4 2002/05/16 19:46:36 carl 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 string2guid(const s: string; var GUID: TGUID): boolean;
function guid2string(const GUID: TGUID): string; function guid2string(const GUID: TGUID): string;
procedure swap_qword(var q : qword);
function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean; function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
@ -1266,6 +1267,11 @@ implementation
end; 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; function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
var var
tok : string; tok : string;
@ -1460,7 +1466,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.57 2002/05/16 19:46:36 carl 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; node,symconst;
type type
tcg386 = class(tcg64f32) tcg386 = class(tcg)
{ passing parameters, per default the parameter is pushed } { passing parameters, per default the parameter is pushed }
{ nr gives the number of the parameter (enumerated from } { 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_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); override;
procedure g_flags2ref(list: taasmoutput; const f: tresflags; const ref: TReference); 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_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; 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_constructor_helper(list : taasmoutput);override;
procedure g_call_destructor_helper(list : taasmoutput);override; procedure g_call_destructor_helper(list : taasmoutput);override;
procedure g_call_fail_helper(list : taasmoutput);override; procedure g_call_fail_helper(list : taasmoutput);override;
{$endif} {$endif}
procedure g_save_standard_registers(list : taasmoutput);override; procedure g_save_standard_registers(list : taasmoutput);override;
procedure g_restore_standard_registers(list : taasmoutput);override; procedure g_restore_standard_registers(list : taasmoutput);override;
procedure g_save_all_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; procedure g_overflowcheck(list: taasmoutput; const p: tnode);override;
private private
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel); 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 sizes2load(s1 : tcgsize;s2 : topsize; var op: tasmop; var s3: topsize);
procedure floatload(list: taasmoutput; t : tcgsize;const ref : treference); procedure floatload(list: taasmoutput; t : tcgsize;const ref : treference);
procedure floatstore(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 floatloadops(t : tcgsize;var op : tasmop;var s : topsize);
procedure floatstoreops(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; end;
const const
TOpCG2AsmOp: Array[topcg] of TAsmOp = (A_NONE,A_ADD,A_AND,A_DIV, 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_IDIV,A_MUL, A_IMUL, A_NEG,A_NOT,A_OR,
A_SAR,A_SHL,A_SHR,A_SUB,A_XOR); A_SAR,A_SHL,A_SHR,A_SUB,A_XOR);
@ -1068,7 +1068,7 @@ unit cgcpu;
{ ************* 64bit operations ************ } { ************* 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 begin
case op of case op of
OP_ADD : OP_ADD :
@ -1102,45 +1102,45 @@ unit cgcpu;
end; 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 var
op1,op2 : TAsmOp; op1,op2 : TAsmOp;
tempref : treference; tempref : treference;
begin begin
get_64bit_ops(op,op1,op2); 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; tempref:=ref;
inc(tempref.offset,4); 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; 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 var
op1,op2 : TAsmOp; op1,op2 : TAsmOp;
begin begin
get_64bit_ops(op,op1,op2); get_64bit_ops(op,op1,op2);
list.concat(taicpu.op_reg_reg(op1,S_L,reglosrc,reglodst)); list.concat(taicpu.op_reg_reg(op1,S_L,regsrc.reglo,regdst.reglo));
list.concat(taicpu.op_reg_reg(op2,S_L,reghisrc,reghidst)); list.concat(taicpu.op_reg_reg(op2,S_L,regsrc.reghi,regdst.reghi));
end; 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 var
op1,op2 : TAsmOp; op1,op2 : TAsmOp;
begin begin
case op of case op of
OP_AND,OP_OR,OP_XOR: OP_AND,OP_OR,OP_XOR:
begin begin
a_op_const_reg(list,op,valuelosrc,reglodst); cg.a_op_const_reg(list,op,lo(value),reg.reglo);
a_op_const_reg(list,op,valuehisrc,reghidst); cg.a_op_const_reg(list,op,hi(value),reg.reghi);
end; end;
OP_ADD, OP_SUB: OP_ADD, OP_SUB:
begin begin
// can't use a_op_const_ref because this may use dec/inc // can't use a_op_const_ref because this may use dec/inc
get_64bit_ops(op,op1,op2); get_64bit_ops(op,op1,op2);
list.concat(taicpu.op_const_reg(op1,S_L,valuelosrc,reglodst)); list.concat(taicpu.op_const_reg(op1,S_L,lo(value),reg.reglo));
list.concat(taicpu.op_const_reg(op2,S_L,valuehisrc,reghidst)); list.concat(taicpu.op_const_reg(op2,S_L,hi(value),reg.reghi));
end; end;
else else
internalerror(200204021); internalerror(200204021);
@ -1148,7 +1148,7 @@ unit cgcpu;
end; 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 var
op1,op2 : TAsmOp; op1,op2 : TAsmOp;
tempref : treference; tempref : treference;
@ -1156,19 +1156,19 @@ unit cgcpu;
case op of case op of
OP_AND,OP_OR,OP_XOR: OP_AND,OP_OR,OP_XOR:
begin 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; tempref:=ref;
inc(tempref.offset,4); 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; end;
OP_ADD, OP_SUB: OP_ADD, OP_SUB:
begin begin
get_64bit_ops(op,op1,op2); get_64bit_ops(op,op1,op2);
// can't use a_op_const_ref because this may use dec/inc // 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; tempref:=ref;
inc(tempref.offset,4); 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; end;
else else
internalerror(200204022); internalerror(200204022);
@ -1779,10 +1779,16 @@ unit cgcpu;
begin begin
cg := tcg386.create; cg := tcg386.create;
cg64 := tcg64f386.create;
end. end.
{ {
$Log$ $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 * bugfix of missing popecx for shift operations
Revision 1.22 2002/05/22 19:02:16 carl 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 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 } {# Set type definition for registers }
tregisterset = set of tregister; 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]; reg2strtable = array[tregister] of string[6];
const const
@ -246,15 +254,20 @@ uses
case longint of case longint of
1 : (value : AWord); 1 : (value : AWord);
2 : (valuelow, valuehigh:AWord); 2 : (valuelow, valuehigh:AWord);
{ overlay a complete 64 Bit value }
3 : (valueqword : qword);
); );
LOC_CREFERENCE, LOC_CREFERENCE,
LOC_REFERENCE : (reference : treference); LOC_REFERENCE : (reference : treference);
{ segment in reference at the same place as in loc_register } { segment in reference at the same place as in loc_register }
LOC_REGISTER,LOC_CREGISTER : ( LOC_REGISTER,LOC_CREGISTER : (
case longint of case longint of
1 : (register,segment,registerhigh : tregister); 1 : (register,registerhigh,segment : tregister);
{ overlay a registerlow } { overlay a registerlow }
2 : (registerlow : tregister); 2 : (registerlow : tregister);
{ overlay a 64 Bit register type }
3 : (reg64 : tregister64);
4 : (register64 : tregister64);
); );
{ it's only for better handling } { it's only for better handling }
LOC_MMXREGISTER,LOC_CMMXREGISTER : (mmxreg : tregister); LOC_MMXREGISTER,LOC_CMMXREGISTER : (mmxreg : tregister);
@ -439,7 +452,12 @@ implementation
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.22 2002/05/16 19:46:50 carl Revision 1.22 2002/05/16 19:46:50 carl

29
compiler/i386/n386add.pas
View File

@ -964,7 +964,7 @@ interface
end; end;
hregister:=rg.getregisterint(exprasmlist); hregister:=rg.getregisterint(exprasmlist);
hregister2:=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); location_reset(left.location,LOC_REGISTER,OS_64);
left.location.registerlow:=hregister; left.location.registerlow:=hregister;
left.location.registerhigh:=hregister2; left.location.registerhigh:=hregister2;
@ -983,9 +983,9 @@ interface
{ when swapped another result register } { when swapped another result register }
if (nodetype=subn) and (nf_swaped in flags) then if (nodetype=subn) and (nf_swaped in flags) then
begin begin
tcg64f32(cg).a_op64_reg_reg(exprasmlist,op, cg64.a_op64_reg_reg(exprasmlist,op,
left.location.registerlow,left.location.registerhigh, left.location.register64,
right.location.registerlow,right.location.registerhigh); right.location.register64);
location_swap(left.location,right.location); location_swap(left.location,right.location);
toggleflag(nf_swaped); toggleflag(nf_swaped);
end end
@ -998,9 +998,9 @@ interface
end end
else else
begin begin
tcg64f32(cg).a_op64_reg_reg(exprasmlist,op, cg64.a_op64_reg_reg(exprasmlist,op,
right.location.registerlow,right.location.registerhigh, right.location.register64,
left.location.registerlow,left.location.registerhigh); left.location.register64);
end; end;
location_release(exprasmlist,right.location); location_release(exprasmlist,right.location);
end end
@ -1010,10 +1010,10 @@ interface
if (nodetype=subn) and (nf_swaped in flags) then if (nodetype=subn) and (nf_swaped in flags) then
begin begin
rg.getexplicitregisterint(exprasmlist,R_EDI); 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(op1,opsize,left.location.registerlow,R_EDI);
emit_reg_reg(A_MOV,opsize,R_EDI,left.location.registerlow); 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 } { the carry flag is still ok }
emit_reg_reg(op2,opsize,left.location.registerhigh,R_EDI); emit_reg_reg(op2,opsize,left.location.registerhigh,R_EDI);
emit_reg_reg(A_MOV,opsize,R_EDI,left.location.registerhigh); emit_reg_reg(A_MOV,opsize,R_EDI,left.location.registerhigh);
@ -1061,8 +1061,8 @@ interface
else else
begin begin
tcg64f32(cg).a_op64_loc_reg(exprasmlist,op,right.location, cg64.a_op64_loc_reg(exprasmlist,op,right.location,
left.location.registerlow,left.location.registerhigh); left.location.register64);
if (right.location.loc<>LOC_CREGISTER) then if (right.location.loc<>LOC_CREGISTER) then
begin begin
location_freetemp(exprasmlist,right.location); location_freetemp(exprasmlist,right.location);
@ -1572,7 +1572,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.38 2002/05/16 19:46:51 carl 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 } { handle call by reference parameter }
else if (defcoll.paratyp in [vs_var,vs_out]) then else if (defcoll.paratyp in [vs_var,vs_out]) then
begin 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 if (left.location.loc<>LOC_REFERENCE) then
begin begin
{ passing self to a var parameter is allowed in { passing self to a var parameter is allowed in
@ -1206,8 +1197,8 @@ implementation
location.registerhigh:=rg.getexplicitregisterint(exprasmlist,accumulatorhigh); location.registerhigh:=rg.getexplicitregisterint(exprasmlist,accumulatorhigh);
location.registerlow:=rg.getexplicitregisterint(exprasmlist,accumulator); location.registerlow:=rg.getexplicitregisterint(exprasmlist,accumulator);
end; end;
tcg64f32(cg).a_load64_reg_reg(exprasmlist,accumulator,accumulatorhigh, cg64.a_load64_reg_reg(exprasmlist,joinreg64(accumulator,accumulatorhigh),
location.registerlow,location.registerhigh); location.register64);
end end
else else
begin begin
@ -1484,7 +1475,12 @@ begin
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * more portability fixes

19
compiler/i386/n386inl.pas
View File

@ -179,8 +179,8 @@ implementation
location_force_reg(exprasmlist,location,cgsize,false); location_force_reg(exprasmlist,location,cgsize,false);
if cgsize in [OS_64,OS_S64] then if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_const_reg(exprasmlist,cgop,1,0, cg64.a_op64_const_reg(exprasmlist,cgop,1,
location.registerlow,location.registerhigh) location.register64)
else else
cg.a_op_const_reg(exprasmlist,cgop,1,location.register); cg.a_op_const_reg(exprasmlist,cgop,1,location.register);
@ -235,8 +235,8 @@ implementation
if addconstant then if addconstant then
begin begin
if cgsize in [OS_64,OS_S64] then if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_const_loc(exprasmlist,addsubop[inlinenumber], cg64.a_op64_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,0,tcallparanode(left).left.location) addvalue,tcallparanode(left).left.location)
else else
cg.a_op_const_loc(exprasmlist,addsubop[inlinenumber], cg.a_op_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,tcallparanode(left).left.location); addvalue,tcallparanode(left).left.location);
@ -244,8 +244,8 @@ implementation
else else
begin begin
if cgsize in [OS_64,OS_S64] then if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_op64_reg_loc(exprasmlist,addsubop[inlinenumber], cg64.a_op64_reg_loc(exprasmlist,addsubop[inlinenumber],
hregister,hregisterhi,tcallparanode(left).left.location) joinreg64(hregister,hregisterhi),tcallparanode(left).left.location)
else else
cg.a_op_reg_loc(exprasmlist,addsubop[inlinenumber], cg.a_op_reg_loc(exprasmlist,addsubop[inlinenumber],
hregister,tcallparanode(left).left.location); hregister,tcallparanode(left).left.location);
@ -460,7 +460,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.43 2002/05/16 19:46:51 carl 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 is_ansistring(resulttype.def) then
begin begin
{ we use ansistrings so no fast exit here } { 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; end;
end; end;
@ -1870,7 +1871,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.75 2002/05/16 19:46:37 carl Revision 1.75 2002/05/16 19:46:37 carl

53
compiler/ncgcnv.pas
View File

@ -444,18 +444,40 @@ interface
var var
pushed : tpushedsaved; pushed : tpushedsaved;
begin begin
{ instance to check } if (right.nodetype=guidconstn) then
secondpass(left); begin
rg.saveusedregisters(exprasmlist,pushed,all_registers); {$warning need to push a third parameter}
cg.a_param_loc(exprasmlist,left.location,2); { instance to check }
{ type information } secondpass(left);
secondpass(right); rg.saveusedregisters(exprasmlist,pushed,all_registers);
cg.a_param_loc(exprasmlist,right.location,1); cg.a_param_loc(exprasmlist,left.location,2);
location_release(exprasmlist,right.location); { type information }
{ call helper } secondpass(right);
cg.a_call_name(exprasmlist,'FPC_DO_AS'); cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
cg.g_maybe_loadself(exprasmlist); location_release(exprasmlist,right.location);
rg.restoreusedregisters(exprasmlist,pushed); { 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); location_copy(location,left.location);
end; end;
@ -468,7 +490,12 @@ end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.14 2002/05/16 19:46:37 carl Revision 1.14 2002/05/16 19:46:37 carl

9
compiler/ncgcon.pas
View File

@ -80,7 +80,7 @@ implementation
const const
floattype2ait:array[tfloattype] of tait= 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 var
hp1 : tai; hp1 : tai;
@ -519,7 +519,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.9 2002/05/16 19:46:37 carl Revision 1.9 2002/05/16 19:46:37 carl

17
compiler/ncgflw.pas
View File

@ -515,8 +515,8 @@ implementation
begin begin
cg.a_reg_alloc(exprasmlist,accumulatorhigh); cg.a_reg_alloc(exprasmlist,accumulatorhigh);
allocated_acchigh := true; allocated_acchigh := true;
tcg64f32(cg).a_load64_loc_reg(exprasmlist,left.location, cg64.a_load64_loc_reg(exprasmlist,left.location,
accumulator,accumulatorhigh); joinreg64(accumulator,accumulatorhigh));
end end
else else
begin begin
@ -601,8 +601,8 @@ do_jmp:
rg.cleartempgen; rg.cleartempgen;
secondpass(left); secondpass(left);
end; end;
{***************************************************************************** {*****************************************************************************
SecondFail SecondFail
*****************************************************************************} *****************************************************************************}
@ -612,7 +612,7 @@ do_jmp:
cg.a_jmp_always(exprasmlist,faillabel); cg.a_jmp_always(exprasmlist,faillabel);
end; end;
begin begin
@ -628,7 +628,12 @@ begin
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * more portability fixes

29
compiler/ncgld.pas
View File

@ -264,10 +264,10 @@ implementation
begin begin
if assigned(left) then if assigned(left) then
begin begin
{ {
THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK
ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS
CONSISTS OF TWO OS_ADDR, so you cannot set it CONSISTS OF TWO OS_ADDR, so you cannot set it
to OS_64 - how to solve?? Carl to OS_64 - how to solve?? Carl
} }
if (sizeof(aword) = 4) then if (sizeof(aword) = 4) then
@ -529,8 +529,8 @@ implementation
LOC_CONSTANT : LOC_CONSTANT :
begin begin
if right.location.size in [OS_64,OS_S64] then if right.location.size in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_const_loc(exprasmlist, cg64.a_load64_const_loc(exprasmlist,
right.location.valuelow,right.location.valuehigh,left.location) right.location.valueqword,left.location)
else else
cg.a_load_const_loc(exprasmlist,right.location.value,left.location); cg.a_load_const_loc(exprasmlist,right.location.value,left.location);
end; end;
@ -542,8 +542,8 @@ implementation
begin begin
cgsize:=def_cgsize(left.resulttype.def); cgsize:=def_cgsize(left.resulttype.def);
if cgsize in [OS_64,OS_S64] then if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_ref_reg(exprasmlist, cg64.a_load64_ref_reg(exprasmlist,
right.location.reference,left.location.registerlow,left.location.registerhigh) right.location.reference,left.location.register64)
else else
cg.a_load_ref_reg(exprasmlist,cgsize, cg.a_load_ref_reg(exprasmlist,cgsize,
right.location.reference,left.location.register); right.location.reference,left.location.register);
@ -583,8 +583,8 @@ implementation
begin begin
cgsize:=def_cgsize(left.resulttype.def); cgsize:=def_cgsize(left.resulttype.def);
if cgsize in [OS_64,OS_S64] then if cgsize in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_reg_loc(exprasmlist, cg64.a_load64_reg_loc(exprasmlist,
right.location.registerlow,right.location.registerhigh,left.location) right.location.register64,left.location)
else else
cg.a_load_reg_loc(exprasmlist,right.location.size,right.location.register,left.location); cg.a_load_reg_loc(exprasmlist,right.location.size,right.location.register,left.location);
end; end;
@ -893,7 +893,7 @@ implementation
8 : 8 :
begin begin
if hp.left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then 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 else
cg.g_concatcopy(exprasmlist,hp.left.location.reference,href,elesize,freetemp,false); cg.g_concatcopy(exprasmlist,hp.left.location.reference,href,elesize,freetemp,false);
end; end;
@ -921,7 +921,12 @@ begin
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * more portability fixes

9
compiler/ncgmem.pas
View File

@ -369,7 +369,7 @@ implementation
tmpreg := cg.get_scratch_reg_address(exprasmlist); tmpreg := cg.get_scratch_reg_address(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist, cg.a_loadaddr_ref_reg(exprasmlist,
left.location.reference,tmpreg); left.location.reference,tmpreg);
end; end;
end; end;
location_release(exprasmlist,left.location); location_release(exprasmlist,left.location);
@ -462,7 +462,12 @@ begin
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * more portability fixes

37
compiler/ncgset.pas
View File

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

27
compiler/ncgutil.pas
View File

@ -214,6 +214,7 @@ implementation
var var
hregister, hregister,
hregisterhi : tregister; hregisterhi : tregister;
hreg64 : tregister64;
hl : tasmlabel; hl : tasmlabel;
begin begin
{ handle transformations to 64bit separate } { handle transformations to 64bit separate }
@ -281,8 +282,10 @@ implementation
hregister:=rg.getregisterint(list); hregister:=rg.getregisterint(list);
hregisterhi:=rg.getregisterint(list); hregisterhi:=rg.getregisterint(list);
end; end;
hreg64.reglo:=hregister;
hreg64.reghi:=hregisterhi;
{ load value in new register } { 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); location_reset(l,LOC_REGISTER,dst_size);
l.registerlow:=hregister; l.registerlow:=hregister;
l.registerhigh:=hregisterhi; l.registerhigh:=hregisterhi;
@ -464,7 +467,7 @@ implementation
begin begin
tg.gettempofsizereference(list,TCGSize2Size[l.size],r); tg.gettempofsizereference(list,TCGSize2Size[l.size],r);
if l.size in [OS_64,OS_S64] then 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 else
cg.a_load_loc_ref(list,l,r); cg.a_load_loc_ref(list,l,r);
location_reset(l,LOC_REFERENCE,l.size); location_reset(l,LOC_REFERENCE,l.size);
@ -498,7 +501,7 @@ implementation
if l.size in [OS_64,OS_S64] then if l.size in [OS_64,OS_S64] then
begin begin
tg.gettempofsizereference(exprasmlist,8,s.ref); 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 end
else else
begin begin
@ -545,7 +548,7 @@ implementation
begin begin
l.registerlow:=rg.getregisterint(exprasmlist); l.registerlow:=rg.getregisterint(exprasmlist);
l.registerhigh:=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 end
else else
begin begin
@ -692,10 +695,10 @@ implementation
if inlined then if inlined then
begin begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize); 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 end
else else
tcg64f32(cg).a_param64_loc(exprasmlist,p.location,-1); cg64.a_param64_loc(exprasmlist,p.location,-1);
end end
else else
begin begin
@ -878,6 +881,7 @@ implementation
cg.a_load_ref_reg(list,OS_ADDR,href,tmpreg); cg.a_load_ref_reg(list,OS_ADDR,href,tmpreg);
reference_reset_base(href,tmpreg,0); reference_reset_base(href,tmpreg,0);
cg.g_initialize(list,tvarsym(p).vartype.def,href,false); cg.g_initialize(list,tvarsym(p).vartype.def,href,false);
cg.free_scratch_reg(list,tmpreg);
end; end;
end; end;
end; end;
@ -988,7 +992,7 @@ implementation
begin begin
uses_acchi:=true; uses_acchi:=true;
cg.a_reg_alloc(list,accumulatorhigh); 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 end
else else
begin begin
@ -1029,7 +1033,7 @@ implementation
enumdef : enumdef :
begin begin
if cgsize in [OS_64,OS_S64] then 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 else
begin begin
hreg:=rg.makeregsize(accumulator,cgsize); hreg:=rg.makeregsize(accumulator,cgsize);
@ -1607,7 +1611,12 @@ implementation
end. end.
{ {
$Log$ $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) * bugfix of hdisponen (base must be set, not index)
* more portability fixes * more portability fixes

27
compiler/ncnv.pas
View File

@ -102,7 +102,6 @@ interface
procedure second_class_to_intf;virtual;abstract; procedure second_class_to_intf;virtual;abstract;
procedure second_char_to_char;virtual;abstract; procedure second_char_to_char;virtual;abstract;
procedure second_nothing; virtual;abstract; procedure second_nothing; virtual;abstract;
end; end;
ttypeconvnodeclass = class of ttypeconvnode; ttypeconvnodeclass = class of ttypeconvnode;
@ -703,7 +702,6 @@ implementation
begin begin
t:=crealconstnode.create(tordconstnode(left).value,resulttype); t:=crealconstnode.create(tordconstnode(left).value,resulttype);
result:=t; result:=t;
exit;
end; end;
end; end;
@ -715,6 +713,13 @@ implementation
begin begin
result:=nil; 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 if left.nodetype=realconstn then
begin begin
t:=crealconstnode.create(trealconstnode(left).value_real,resulttype); t:=crealconstnode.create(trealconstnode(left).value_real,resulttype);
@ -1713,7 +1718,18 @@ implementation
end end
else else
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename); CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
resulttype:=right.resulttype; 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 end
else else
CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename); CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
@ -1739,7 +1755,12 @@ begin
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.57 2002/05/16 19:46:37 carl 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('HASCOMPILERPROC');
def_symbol('VALUEGETMEM'); def_symbol('VALUEGETMEM');
def_symbol('VALUEFREEMEM'); def_symbol('VALUEFREEMEM');
def_symbol('HASCURRENCY');
{ some stuff for TP compatibility } { some stuff for TP compatibility }
case target_info.cpu of case target_info.cpu of
@ -1664,7 +1665,12 @@ finalization
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.72 2002/05/16 19:46:41 carl Revision 1.72 2002/05/16 19:46:41 carl

41
compiler/pdecobj.pas
View File

@ -972,18 +972,23 @@ implementation
end; end;
_PUBLISHED : _PUBLISHED :
begin 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 if is_interface(aktclass) then
Message(parser_e_no_access_specifier_in_interfaces) 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);
consume(_PUBLISHED); consume(_PUBLISHED);
current_object_option:=[sp_published]; current_object_option:=[sp_published];
end; end;
else else
begin begin
if is_interface(aktclass) then 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); read_var_decs(false,true,false);
end; end;
end; end;
@ -996,6 +1001,10 @@ implementation
_FUNCTION, _FUNCTION,
_CLASS : _CLASS :
begin 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; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
parse_proc_dec; parse_proc_dec;
@ -1024,10 +1033,16 @@ implementation
end; end;
_CONSTRUCTOR : _CONSTRUCTOR :
begin 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 if not(sp_public in current_object_option) then
Message(parser_w_constructor_should_be_public); Message(parser_w_constructor_should_be_public);
if is_interface(aktclass) then if is_interface(aktclass) then
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
constructor_head; constructor_head;
@ -1046,13 +1061,20 @@ implementation
end; end;
_DESTRUCTOR : _DESTRUCTOR :
begin 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 if there_is_a_destructor then
Message(parser_n_only_one_destructor); Message(parser_n_only_one_destructor);
if is_interface(aktclass) then if is_interface(aktclass) then
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
there_is_a_destructor:=true;
if not(sp_public in current_object_option) then if not(sp_public in current_object_option) then
Message(parser_w_destructor_should_be_public); Message(parser_w_destructor_should_be_public);
there_is_a_destructor:=true;
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
destructor_head; destructor_head;
@ -1111,7 +1133,12 @@ implementation
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.44 2002/05/16 19:46:42 carl Revision 1.44 2002/05/16 19:46:42 carl

11
compiler/psystem.pas
View File

@ -116,6 +116,7 @@ begin
addtype('Real',s64floattype); addtype('Real',s64floattype);
{$ifdef i386} {$ifdef i386}
adddef('Comp',tfloatdef.create(s64comp)); adddef('Comp',tfloatdef.create(s64comp));
addtype('Currency',s64currencytype);
{$endif} {$endif}
addtype('Pointer',voidpointertype); addtype('Pointer',voidpointertype);
addtype('FarPointer',voidfarpointertype); addtype('FarPointer',voidfarpointertype);
@ -161,6 +162,7 @@ begin
addtype('$s32real',s32floattype); addtype('$s32real',s32floattype);
addtype('$s64real',s64floattype); addtype('$s64real',s64floattype);
addtype('$s80real',s80floattype); addtype('$s80real',s80floattype);
addtype('$s64currency',s64currencytype);
{ Add a type for virtual method tables } { Add a type for virtual method tables }
vmtsymtable:=trecordsymtable.create; vmtsymtable:=trecordsymtable.create;
vmttype.setdef(trecorddef.create(vmtsymtable)); vmttype.setdef(trecorddef.create(vmtsymtable));
@ -205,6 +207,7 @@ begin
globaldef('s32real',s32floattype); globaldef('s32real',s32floattype);
globaldef('s64real',s64floattype); globaldef('s64real',s64floattype);
globaldef('s80real',s80floattype); globaldef('s80real',s80floattype);
globaldef('s64currency',s64currencytype);
globaldef('boolean',booltype); globaldef('boolean',booltype);
globaldef('void_pointer',voidpointertype); globaldef('void_pointer',voidpointertype);
globaldef('char_pointer',charpointertype); globaldef('char_pointer',charpointertype);
@ -249,6 +252,7 @@ begin
s32floattype.setdef(tfloatdef.create(s32real)); s32floattype.setdef(tfloatdef.create(s32real));
s64floattype.setdef(tfloatdef.create(s64real)); s64floattype.setdef(tfloatdef.create(s64real));
s80floattype.setdef(tfloatdef.create(s80real)); s80floattype.setdef(tfloatdef.create(s80real));
s64currencytype.setdef(tfloatdef.create(s64currency));
{$endif} {$endif}
{$ifdef m68k} {$ifdef m68k}
s32floattype.setdef(tfloatdef.create(s32real)); s32floattype.setdef(tfloatdef.create(s32real));
@ -276,7 +280,12 @@ end;
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.25 2002/05/16 19:46:44 carl Revision 1.25 2002/05/16 19:46:44 carl

9
compiler/symconst.pas
View File

@ -146,7 +146,7 @@ type
{ float types } { float types }
tfloattype = ( tfloattype = (
s32real,s64real,s80real, s32real,s64real,s80real,
s64comp s64comp,s64currency
); );
{ string types } { string types }
@ -334,7 +334,12 @@ implementation
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.31 2002/05/16 19:46:44 carl 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 } s32floattype, { pointer for realconstn }
s64floattype, { pointer for realconstn } s64floattype, { pointer for realconstn }
s80floattype, { pointer to type of temp. floats } s80floattype, { pointer to type of temp. floats }
s64currencytype, { pointer to a currency type }
s32fixedtype, { pointer to type of temp. fixed } s32fixedtype, { pointer to type of temp. fixed }
cshortstringtype, { pointer to type of short string const } cshortstringtype, { pointer to type of short string const }
clongstringtype, { pointer to type of long string const } clongstringtype, { pointer to type of long string const }
@ -1938,6 +1939,7 @@ implementation
s64real : stabstring := strpnew('r'+ s64real : stabstring := strpnew('r'+
tstoreddef(s32bittype.def).numberstring+';'+tostr(savesize)+';0;'); tstoreddef(s32bittype.def).numberstring+';'+tostr(savesize)+';0;');
{ found this solution in stabsread.c from GDB v4.16 } { found this solution in stabsread.c from GDB v4.16 }
s64currency,
s64comp : stabstring := strpnew('r'+ s64comp : stabstring := strpnew('r'+
tstoreddef(s32bittype.def).numberstring+';-'+tostr(savesize)+';0;'); tstoreddef(s32bittype.def).numberstring+';-'+tostr(savesize)+';0;');
{ under dos at least you must give a size of twelve instead of 10 !! } { under dos at least you must give a size of twelve instead of 10 !! }
@ -1954,7 +1956,7 @@ implementation
const const
{tfloattype = (s32real,s64real,s80real,s64bit);} {tfloattype = (s32real,s64real,s80real,s64bit);}
translate : array[tfloattype] of byte = translate : array[tfloattype] of byte =
(ftSingle,ftDouble,ftExtended,ftComp); (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
begin begin
rttiList.concat(Tai_const.Create_8bit(tkFloat)); rttiList.concat(Tai_const.Create_8bit(tkFloat));
write_rtti_name; write_rtti_name;
@ -1971,7 +1973,7 @@ implementation
const const
names : array[tfloattype] of string[20] = ( names : array[tfloattype] of string[20] = (
'Single','Double','Extended','Comp'); 'Single','Double','Extended','Comp','Currency');
begin begin
gettypename:=names[typ]; gettypename:=names[typ];
@ -5476,7 +5478,12 @@ implementation
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.78 2002/05/16 19:46:44 carl 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 } {# Returns true, if definition is float }
function is_fpu(def : tdef) : boolean; 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 } {# Returns true if the return value can be put in accumulator }
function ret_in_acc(def : tdef) : boolean; function ret_in_acc(def : tdef) : boolean;
@ -534,7 +537,14 @@ implementation
end; 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 begin
{ generate a unsigned range if high<0 and low>=0 } { generate a unsigned range if high<0 and low>=0 }
if (low>=0) and (high<0) then if (low>=0) and (high<0) then
@ -1970,7 +1980,12 @@ implementation
end. end.
{ {
$Log$ $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 * readded missing revisions
Revision 1.72 2002/05/16 19:46:47 carl Revision 1.72 2002/05/16 19:46:47 carl