diff --git a/compiler/cg64f32.pas b/compiler/cg64f32.pas index 8c600d9efb..6d330c42c4 100644 --- a/compiler/cg64f32.pas +++ b/compiler/cg64f32.pas @@ -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 diff --git a/compiler/cg64f64.pas b/compiler/cg64f64.pas index ef8a3338a7..38ca828656 100644 --- a/compiler/cg64f64.pas +++ b/compiler/cg64f64.pas @@ -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 } \ No newline at end of file diff --git a/compiler/cginfo.pas b/compiler/cginfo.pas index c1fe33dfcf..a437460269 100644 --- a/compiler/cginfo.pas +++ b/compiler/cginfo.pas @@ -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 diff --git a/compiler/cgobj.pas b/compiler/cgobj.pas index c1a22de4d8..7188b12cd2 100644 --- a/compiler/cgobj.pas +++ b/compiler/cgobj.pas @@ -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) diff --git a/compiler/cstreams.pas b/compiler/cstreams.pas index ee822a1536..393b3667e1 100644 --- a/compiler/cstreams.pas +++ b/compiler/cstreams.pas @@ -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 diff --git a/compiler/globals.pas b/compiler/globals.pas index 76bee12e70..75a1d99ec3 100644 --- a/compiler/globals.pas +++ b/compiler/globals.pas @@ -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 diff --git a/compiler/i386/cgcpu.pas b/compiler/i386/cgcpu.pas index f295a54b7a..1e4ef0464c 100644 --- a/compiler/i386/cgcpu.pas +++ b/compiler/i386/cgcpu.pas @@ -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 diff --git a/compiler/i386/cpubase.pas b/compiler/i386/cpubase.pas index 769bc02a3a..066b7264d4 100644 --- a/compiler/i386/cpubase.pas +++ b/compiler/i386/cpubase.pas @@ -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 diff --git a/compiler/i386/n386add.pas b/compiler/i386/n386add.pas index ca69d9ec87..5565e1b155 100644 --- a/compiler/i386/n386add.pas +++ b/compiler/i386/n386add.pas @@ -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 diff --git a/compiler/i386/n386cal.pas b/compiler/i386/n386cal.pas index d940a2e1fd..921606d1c9 100644 --- a/compiler/i386/n386cal.pas +++ b/compiler/i386/n386cal.pas @@ -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 diff --git a/compiler/i386/n386inl.pas b/compiler/i386/n386inl.pas index 75788a9cee..9679de8820 100644 --- a/compiler/i386/n386inl.pas +++ b/compiler/i386/n386inl.pas @@ -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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index b9104a4184..e3d0aac464 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -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 diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas index eb074cd759..1c0a6ed658 100644 --- a/compiler/ncgcnv.pas +++ b/compiler/ncgcnv.pas @@ -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 diff --git a/compiler/ncgcon.pas b/compiler/ncgcon.pas index 7a2deed76c..e08fc6c399 100644 --- a/compiler/ncgcon.pas +++ b/compiler/ncgcon.pas @@ -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 diff --git a/compiler/ncgflw.pas b/compiler/ncgflw.pas index f9619947b0..bc985b8152 100644 --- a/compiler/ncgflw.pas +++ b/compiler/ncgflw.pas @@ -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 diff --git a/compiler/ncgld.pas b/compiler/ncgld.pas index 4df060076f..e65d6a8274 100644 --- a/compiler/ncgld.pas +++ b/compiler/ncgld.pas @@ -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 diff --git a/compiler/ncgmem.pas b/compiler/ncgmem.pas index 1c3d212bea..7f53cabd3a 100644 --- a/compiler/ncgmem.pas +++ b/compiler/ncgmem.pas @@ -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 diff --git a/compiler/ncgset.pas b/compiler/ncgset.pas index 75b1929eb8..cc76ba4650 100644 --- a/compiler/ncgset.pas +++ b/compiler/ncgset.pas @@ -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 } diff --git a/compiler/ncgutil.pas b/compiler/ncgutil.pas index 6b3e2b4766..9d846ee15d 100644 --- a/compiler/ncgutil.pas +++ b/compiler/ncgutil.pas @@ -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 diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 425109f9a5..abd2fcbc3b 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -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 diff --git a/compiler/options.pas b/compiler/options.pas index abb5d5156b..f26f03c04d 100644 --- a/compiler/options.pas +++ b/compiler/options.pas @@ -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 diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas index a164d06a2d..c6401399fb 100644 --- a/compiler/pdecobj.pas +++ b/compiler/pdecobj.pas @@ -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 diff --git a/compiler/psystem.pas b/compiler/psystem.pas index 93298b3ff4..11cc928358 100644 --- a/compiler/psystem.pas +++ b/compiler/psystem.pas @@ -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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index 4ed060c8b1..f43670fbdf 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -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 diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 77d4c84de9..25bd5df9e3 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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 diff --git a/compiler/types.pas b/compiler/types.pas index 4075ad10bd..346bfe64c6 100644 --- a/compiler/types.pas +++ b/compiler/types.pas @@ -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