paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 19:28:38 +02:00
Code Issues Packages Projects Releases Wiki Activity
2d790e0158
fpc/compiler/cg68k.pas
florian 2d790e0158 * secondin bugfix (m68k and i386) 
* overflow checking bugfix (m68k and i386) -- pretty useless in
    secondadd, since everything is done using 32-bit
  * loading pointer to routines hopefully fixed (m68k)
  * flags problem with calls to RTL internal routines fixed (still strcmp
    to fix) (m68k)
  * #ELSE was still incorrect (didn't take care of the previous level)
  * problem with filenames in the command line solved
  * problem with mangledname solved
  * linking name problem solved (was case insensitive)
  * double id problem and potential crash solved
  * stop after first error
  * and=>test problem removed
  * correct read for all float types
  * 2 sigsegv fixes and a cosmetic fix for Internal Error
  * push/pop is now correct optimized (=> mov (%esp),reg)
1998-03-28 23:09:53 +00:00

5390 lines
231 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1993,98 by Florian Klaempfl, Carl Eric Codere
This unit generates 68000 (or better) assembler from the parse tree
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
{$ifdef tp}
{$E+,F+,N+,D+,L+,Y+}
{$endif}
{---------------------------------------------------------------------------}
{ LEFT TO DO IN CG68k AND CG68k2 }
{---------------------------------------------------------------------------}
{ o Test and correct problems with extended support. }
{ o Optimize secondmoddiv when doing a constant modulo. }
{ o Add emulation support for Cardinal under MC68000. }
{---------------------------------------------------------------------------}
unit cg68k;
{***************************************************************************}
interface
{***************************************************************************}
uses objects,verbose,cobjects,systems,globals,tree,
symtable,types,strings,pass_1,hcodegen,
aasm,m68k,tgen68k,files,cga68k,cg68k2,gdb,link;
{ produces assembler for the expression in variable p }
{ and produces an assembler node at the end }
procedure generatecode(var p : ptree);
{ produces the actual code }
function do_secondpass(var p : ptree) : boolean;
procedure secondpass(var p : ptree);
{$ifdef test_dest_loc}
const { used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var dest_loc : tlocation;
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{$endif test_dest_loc}
{***************************************************************************}
implementation
{***************************************************************************}
const
never_copy_const_param : boolean = false;
bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
{ used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var
{ this is for open arrays and strings }
{ but be careful, this data is in the }
{ generated code destroyed quick, and also }
{ the next call of secondload destroys this }
{ data }
{ So be careful using the informations }
{ provided by this variables }
highframepointer : tregister;
highoffset : longint;
dest_loc : tlocation;
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
begin
if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
begin
emit_reg_reg(A_MOVE,s,reg,dest_loc.register);
p^.location:=dest_loc;
in_dest_loc:=true;
end
else
if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
begin
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,s,reg,newreference(dest_loc.reference))));
p^.location:=dest_loc;
in_dest_loc:=true;
end
else
internalerror(20080);
end;
procedure error(const t : tmsgconst);
begin
if not(codegenerror) then
verbose.Message(t);
codegenerror:=true;
end;
type
secondpassproc = procedure(var p : ptree);
procedure seconderror(var p : ptree);
begin
p^.error:=true;
codegenerror:=true;
end;
procedure secondload(var p : ptree);
var
hregister : tregister;
i : longint;
symtabletype: tsymtabletype;
hp : preference;
begin
simple_loadn:=true;
reset_reference(p^.location.reference);
case p^.symtableentry^.typ of
{ this is only for toasm and toaddr }
absolutesym :
begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if p^.symtableentry^.owner^.symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end;
varsym :
begin
hregister:=R_NO;
symtabletype:=p^.symtable^.symtabletype;
{ in case it is a register variable: }
{ we simply set the location to the }
{ correct register. }
if pvarsym(p^.symtableentry)^.reg<>R_NO then
begin
p^.location.loc:=LOC_CREGISTER;
p^.location.register:=pvarsym(p^.symtableentry)^.reg;
unused:=unused-[pvarsym(p^.symtableentry)^.reg];
end
else
begin
{ --------------------- LOCAL AND TEMP VARIABLES ------------- }
if (symtabletype=parasymtable) or (symtabletype=localsymtable) then
begin
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
if (symtabletype=localsymtable) then
p^.location.reference.offset:=-p^.location.reference.offset;
if (symtabletype=parasymtable) then
inc(p^.location.reference.offset,p^.symtable^.call_offset);
if (lexlevel>(p^.symtable^.symtablelevel)) then
begin
hregister:=getaddressreg;
{ make a reference }
new(hp);
reset_reference(hp^);
hp^.offset:=procinfo.framepointer_offset;
hp^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
simple_loadn:=false;
i:=lexlevel-1;
while i>(p^.symtable^.symtablelevel) do
begin
{ make a reference }
new(hp);
reset_reference(hp^);
hp^.offset:=8;
hp^.base:=hregister;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
dec(i);
end;
p^.location.reference.base:=hregister;
end;
end
{ --------------------- END OF LOCAL AND TEMP VARS ---------------- }
else
case symtabletype of
unitsymtable,globalsymtable,
staticsymtable : begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end;
objectsymtable : begin
if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end
else
begin
p^.location.reference.base:=R_A5;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
end;
end;
withsymtable : begin
hregister:=getaddressreg;
p^.location.reference.base:=hregister;
{ make a reference }
new(hp);
reset_reference(hp^);
hp^.offset:=p^.symtable^.datasize;
hp^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
p^.location.reference.offset:=
pvarsym(p^.symtableentry)^.address;
end;
end;
{ in case call by reference, then calculate: }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getaddressreg;
{ ADDED FOR OPEN ARRAY SUPPORT. }
if (p^.location.reference.base=procinfo.framepointer) then
begin
highframepointer:=p^.location.reference.base;
highoffset:=p^.location.reference.offset;
end
else
begin
highframepointer:=R_A1;
highoffset:=p^.location.reference.offset;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.location.reference.base,R_A1)));
end;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
hregister)));
{ END ADDITION }
clear_reference(p^.location.reference);
p^.location.reference.base:=hregister;
end;
{ should be dereferenced later (FK)
if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
hregister)));
clear_reference(p^.location.reference);
p^.location.reference.base:=hregister;
end;
}
end;
end;
procsym:
begin
{!!!!! Be aware, work on virtual methods too }
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=
stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
if p^.symtable^.symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end;
typedconstsym :
begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if p^.symtable^.symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end;
else internalerror(4);
end;
end;
{ D0 and D1 used as temp (ok) }
procedure secondmoddiv(var p : ptree);
var
hreg1 : tregister;
power : longint;
hl : plabel;
reg: tregister;
pushed: boolean;
begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ put numerator in register }
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
hreg1:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1);
end
else
begin
del_reference(p^.left^.location.reference);
hreg1:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
hreg1)));
end;
p^.left^.location.loc:=LOC_REGISTER;
p^.left^.location.register:=hreg1;
end
else hreg1:=p^.left^.location.register;
if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
ispowerof2(p^.right^.value,power) then
begin
exprasmlist^.concat(new(pai68k, op_reg(A_TST, S_L, hreg1)));
getlabel(hl);
emitl(A_BPL,hl);
if (power = 1) then
exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,1, hreg1)));
if (p^.right^.value-1) < 9 then
exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1)))
else
exprasmlist^.concat(new(pai68k, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1)));
emitl(A_LABEL, hl);
if (power > 0) and (power < 9) then
exprasmlist^.concat(new(pai68k, op_const_reg(A_ASR, S_L,power, hreg1)))
else
begin
exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,power, R_D0)));
exprasmlist^.concat(new(pai68k, op_reg_reg(A_ASR,S_L,R_D0, hreg1)));
end;
end
else
begin
{ bring denominator to D1 }
{ D1 is always free, it's }
{ only used for temporary }
{ purposes }
if (p^.right^.location.loc<>LOC_REGISTER) and
(p^.right^.location.loc<>LOC_CREGISTER) then
begin
del_reference(p^.right^.location.reference);
p^.left^.location.loc:=LOC_REGISTER;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1)));
end
else
begin
ungetregister32(p^.right^.location.register);
emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
end;
{ on entering this section D1 should contain the divisor }
if (opt_processors = MC68020) then
begin
if (p^.treetype = modn) then
Begin
reg := getregister32;
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,reg)));
getlabel(hl);
{ here what we do is prepare the high register with the }
{ correct sign. i.e we clear it, check if the low dword reg }
{ which will participate in the division is signed, if so we}
{ we extend the sign to the high doword register by inverting }
{ all the bits. }
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hreg1)));
emitl(A_BPL,hl);
exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,reg)));
emitl(A_LABEL,hl);
{ reg:hreg1 / d1 }
exprasmlist^.concat(new(pai68k,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1)));
{ hreg1 already contains quotient }
{ looking for remainder }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg,hreg1)));
ungetregister32(reg);
end
else
{ simple division... }
Begin
{ reg:hreg1 / d1 }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_DIVS,S_L,R_D1,hreg1)));
end;
end
else { MC68000 operations }
begin
{ put numerator in d0 }
emit_reg_reg(A_MOVE,S_L,hreg1,R_D0);
{ operation to perform on entry to both }
{ routines... d0/d1 }
{ return result in d0 }
if p^.treetype = divn then
emitcall('LONGDIV',true)
else
emitcall('LONGMOD',true);
emit_reg_reg(A_MOVE,S_L,R_D0,hreg1);
end; { endif }
end;
{ this registers are always used when div/mod are present }
usedinproc:=usedinproc or ($800 shr word(R_D1));
usedinproc:=usedinproc or ($800 shr word(R_D0));
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hreg1;
end;
{ D6 used as scratch (ok) }
procedure secondshlshr(var p : ptree);
var
hregister1,hregister2,hregister3 : tregister;
op : tasmop;
pushed : boolean;
begin
secondpass(p^.left);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ load left operators in a register }
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
hregister1:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
hregister1);
end
else
begin
del_reference(p^.left^.location.reference);
hregister1:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
hregister1)));
end;
end
else hregister1:=p^.left^.location.register;
{ determine operator }
if p^.treetype=shln then
op:=A_LSL
else
op:=A_LSR;
{ shifting by a constant directly decode: }
if (p^.right^.treetype=ordconstn) then
begin
if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then
exprasmlist^.concat(new(pai68k,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31,
hregister1)))
else
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31,
R_D6)));
exprasmlist^.concat(new(pai68k,op_reg_reg(op,S_L,R_D6,hregister1)));
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister1;
end
else
begin
{ load right operators in a register }
if p^.right^.location.loc<>LOC_REGISTER then
begin
if p^.right^.location.loc=LOC_CREGISTER then
begin
hregister2:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,
hregister2);
end
else
begin
del_reference(p^.right^.location.reference);
hregister2:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
hregister2)));
end;
end
else hregister2:=p^.right^.location.register;
emit_reg_reg(op,S_L,hregister2,hregister1);
p^.location.register:=hregister1;
end;
{ this register is always used when shl/shr are present }
usedinproc:=usedinproc or ($800 shr byte(R_D6));
end;
procedure secondrealconst(var p : ptree);
var
hp1 : pai;
lastlabel : plabel;
found : boolean;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
found:=false;
{ const already used ? }
if p^.labnumber=-1 then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
while assigned(hp1) do
begin
if hp1^.typ=ait_label then
lastlabel:=pai_label(hp1)^.l
else
begin
if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
begin
{ Florian this caused a internalerror(10)=> no free reg !! }
{if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then }
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then
found:=true;
if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
found:=true;
if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then
found:=true;
if found then
begin
{ found! }
p^.labnumber:=lastlabel^.nb;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labnumber=-1 then
begin
getlabel(lastlabel);
p^.labnumber:=lastlabel^.nb;
case p^.realtyp of
ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued)));
ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued)));
ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued)));
else
internalerror(10120);
end;
consts^.insert(new(pai_label,init(lastlabel)));
end;
end;
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
end;
procedure secondfixconst(var p : ptree);
begin
{ an fix comma const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.valuef;
end;
procedure secondordconst(var p : ptree);
begin
{ an integer const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.value;
end;
procedure secondniln(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=0;
end;
procedure secondstringconst(var p : ptree);
var
hp1 : pai;
lastlabel : plabel;
pc : pchar;
same_string : boolean;
i : word;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
{ const already used ? }
if p^.labstrnumber=-1 then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
while assigned(hp1) do
begin
if hp1^.typ=ait_label then
lastlabel:=pai_label(hp1)^.l
else
begin
if (hp1^.typ=ait_string) and (lastlabel<>nil) and
(pai_string(hp1)^.len=length(p^.values^)+2) then
begin
same_string:=true;
for i:=1 to length(p^.values^) do
if pai_string(hp1)^.str[i]<>p^.values^[i] then
begin
same_string:=false;
break;
end;
if same_string then
begin
{ found! }
p^.labstrnumber:=lastlabel^.nb;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labstrnumber=-1 then
begin
getlabel(lastlabel);
p^.labstrnumber:=lastlabel^.nb;
getmem(pc,length(p^.values^)+3);
move(p^.values^,pc^,length(p^.values^)+1);
pc[length(p^.values^)+1]:=#0;
{ we still will have a problem if there is a #0 inside the pchar }
consts^.insert(new(pai_string,init_pchar(pc)));
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
pai_string(consts^.first)^.len:=length(p^.values^)+2;
consts^.insert(new(pai_label,init(lastlabel)));
end;
end;
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
p^.location.loc := LOC_MEM;
end;
procedure secondumminus(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
case p^.left^.location.loc of
LOC_REGISTER : begin
p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
end;
LOC_CREGISTER : begin
p^.location.register:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.location.register,
p^.location.register);
exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
end;
LOC_REFERENCE,LOC_MEM :
begin
del_reference(p^.left^.location.reference);
{ change sign of a floating point }
{ in the case of emulation, get }
{ a free register, and change sign }
{ manually. }
{ otherwise simply load into an FPU}
{ register. }
if (p^.left^.resulttype^.deftype=floatdef) and
(pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
begin
{ move to FPU }
floatload(pfloatdef(p^.left^.resulttype)^.typ,
p^.left^.location.reference,p^.location);
if (cs_fp_emulation) in aktswitches then
{ if in emulation mode change sign manually }
exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,
p^.location.fpureg)))
else
exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_X,
p^.location.fpureg)));
end
else
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
end;
end;
LOC_FPU : begin
p^.location.loc:=LOC_FPU;
p^.location.fpureg := p^.left^.location.fpureg;
if (cs_fp_emulation) in aktswitches then
exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg)))
else
exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_X,p^.location.fpureg)));
end;
end;
{ emitoverflowcheck;}
end;
{ use of A6 is required only temp (ok) }
procedure secondaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
{@ on a procvar means returning an address to the procedure that
is stored in it.}
{ yes but p^.left^.symtableentry can be nil
for example on @self !! }
{ symtableentry can be also invalid, if left is no tree node }
if (p^.left^.treetype=loadn) and
assigned(p^.left^.symtableentry) and
(p^.left^.symtableentry^.typ=varsym) and
(Pvarsym(p^.left^.symtableentry)^.definition^.deftype=
procvardef) then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),
p^.location.register)))
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),R_A0)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
R_A0,p^.location.register)));
end;
{ for use of other segments }
{ if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
p^.location.segment:=p^.left^.location.reference.segment;
}
del_reference(p^.left^.location.reference);
end;
{ register a6 used as scratch }
procedure seconddoubleaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),R_A0)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
R_A0,p^.location.register)));
end;
procedure secondnot(var p : ptree);
const
flagsinvers : array[F_E..F_BE] of tresflags =
(F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
F_A,F_AE,F_B,F_BE);
var
hl : plabel;
begin
if (p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ=bool8bit) then
begin
case p^.location.loc of
LOC_JUMP : begin
hl:=truelabel;
truelabel:=falselabel;
falselabel:=hl;
secondpass(p^.left);
maketojumpbool(p^.left);
hl:=truelabel;
truelabel:=falselabel;
falselabel:=hl;
end;
LOC_FLAGS : begin
secondpass(p^.left);
p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
end;
LOC_REGISTER : begin
secondpass(p^.left);
p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
end;
LOC_CREGISTER : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
p^.location.register);
exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
end;
LOC_REFERENCE,LOC_MEM : begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
if p^.left^.location.loc=LOC_CREGISTER then
emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
p^.location.register)
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
newreference(p^.left^.location.reference),
p^.location.register)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
end;
end;
end
else
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
case p^.left^.location.loc of
LOC_REGISTER : begin
p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
end;
LOC_CREGISTER : begin
p^.location.register:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
p^.location.register);
exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
end;
LOC_REFERENCE,LOC_MEM :
begin
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
end;
end;
{if p^.left^.location.loc=loc_register then
p^.location.register:=p^.left^.location.register
else
begin
del_locref(p^.left^.location);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_loc_reg(A_MOV,S_L,
p^.left^.location,
p^.location.register)));
end;
exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));}
end;
end;
procedure secondnothing(var p : ptree);
begin
end;
procedure secondassignment(var p : ptree);
var
opsize : topsize;
withresult : boolean;
otlabel,hlabel,oflabel : plabel;
hregister : tregister;
loc : tloc;
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
withresult:=false;
{ calculate left sides }
secondpass(p^.left);
case p^.left^.location.loc of
LOC_REFERENCE : begin
{ in case left operator uses too many registers }
{ but to few are free then LEA }
if (p^.left^.location.reference.base<>R_NO) and
(p^.left^.location.reference.index<>R_NO) and
(usablereg32<p^.right^.registers32) then
begin
del_reference(p^.left^.location.reference);
hregister:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(
p^.left^.location.reference),
hregister)));
clear_reference(p^.left^.location.reference);
p^.left^.location.reference.base:=hregister;
p^.left^.location.reference.index:=R_NO;
end;
loc:=LOC_REFERENCE;
end;
LOC_CREGISTER : loc:=LOC_CREGISTER;
else
begin
Message(cg_e_illegal_expression);
exit;
end;
end;
{ lets try to optimize this (PM) }
{ define a dest_loc that is the location }
{ and a ptree to verify that it is the right }
{ place to insert it }
{$ifdef test_dest_loc}
if (aktexprlevel<4) then
begin
dest_loc_known:=true;
dest_loc:=p^.left^.location;
dest_loc_tree:=p^.right;
end;
{$endif test_dest_loc}
if (p^.right^.treetype=realconstn) then
begin
if p^.left^.resulttype^.deftype=floatdef then
begin
case pfloatdef(p^.left^.resulttype)^.typ of
s32real : p^.right^.realtyp:=ait_real_32bit;
s64real : p^.right^.realtyp:=ait_real_64bit;
s80real : p^.right^.realtyp:=ait_real_extended;
{ what about f32bit and s64bit }
end;
end;
end;
secondpass(p^.right);
{$ifdef test_dest_loc}
dest_loc_known:=false;
if in_dest_loc then
begin
truelabel:=otlabel;
falselabel:=oflabel;
in_dest_loc:=false;
exit;
end;
{$endif test_dest_loc}
if p^.left^.resulttype^.deftype=stringdef then
begin
{ we do not need destination anymore }
del_reference(p^.left^.location.reference);
{ only source if withresult is set }
if not(withresult) then
del_reference(p^.right^.location.reference);
loadstring(p);
ungetiftemp(p^.right^.location.reference);
end
else case p^.right^.location.loc of
LOC_REFERENCE,
LOC_MEM : begin
{ handle ordinal constants trimmed }
if (p^.right^.treetype in [ordconstn,fixconstn]) or
(loc=LOC_CREGISTER) then
begin
case p^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
newreference(p^.right^.location.reference),
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,opsize,
p^.right^.location.reference.offset,
newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,opsize,
p^.right^.location.reference.offset,
p^.left^.location)));}
end
else
begin
concatcopy(p^.right^.location.reference,
p^.left^.location.reference,p^.left^.resulttype^.size,
withresult);
ungetiftemp(p^.right^.location.reference);
end;
end;
LOC_REGISTER,
LOC_CREGISTER : begin
case p^.right^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
{ simplified with op_reg_loc }
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,opsize,
p^.right^.location.register,
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,opsize,
p^.right^.location.register,
newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai68k,op_reg_loc(A_MOV,opsize,
p^.right^.location.register,
p^.left^.location))); }
end;
LOC_FPU : begin
if loc<>LOC_REFERENCE then
internalerror(10010)
else
floatstore(pfloatdef(p^.left^.resulttype)^.typ,
p^.right^.location,p^.left^.location.reference);
end;
LOC_JUMP : begin
getlabel(hlabel);
emitl(A_LABEL,truelabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
1,p^.left^.location.register)))
else
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
1,newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,S_B,
1,p^.left^.location)));}
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
0,newreference(p^.left^.location.reference))));
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS : begin
if loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
p^.left^.location.register)));
exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_B,p^.left^.location.register)));
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
newreference(p^.left^.location.reference))));
exprasmlist^.concat(new(pai68k,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference))));
end;
end;
end;
truelabel:=otlabel;
falselabel:=oflabel;
end;
procedure secondderef(var p : ptree);
var
hr : tregister;
begin
secondpass(p^.left);
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER : Begin
hr := getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
ungetregister(p^.left^.location.register);
end;
LOC_CREGISTER : begin
{ ... and reserve one for the pointer }
hr:=getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
{ LOC_REGISTER indicates that this is a
variable register which should not be freed. }
{ ungetregister(p^.left^.location.register); }
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ...and reserve one for the pointer }
hr:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(
A_MOVE,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end;
{ used D0, D1 as scratch (ok) }
{ arrays ... }
{ Sets up the array and string }
{ references . }
procedure secondvecn(var p : ptree);
var
pushed : boolean;
ind : tregister;
_p : ptree;
procedure calc_emit_mul;
var
l1,l2 : longint;
begin
l1:=p^.resulttype^.size;
case l1 of
1 : p^.location.reference.scalefactor:=l1;
2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,ind)));
4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,ind)));
8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,ind)));
else
begin
if ispowerof2(l1,l2) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,l2,ind)))
else
begin
{ use normal MC68000 signed multiply }
if (l1 >= -32768) and (l1 <= 32767) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_W,l1,ind)))
else
{ use long MC68020 long multiply }
if (opt_processors = MC68020) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_L,l1,ind)))
else
{ MC68000 long multiply }
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l1,R_D0)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ind,R_D1)));
emitcall('LONGMUL',true);
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,ind)));
end;
end;
end; { else case }
end; { end case }
end; { calc_emit_mul }
var
extraoffset : longint;
t : ptree;
hp : preference;
tai:pai68k;
reg: tregister;
begin
secondpass(p^.left);
{ RESULT IS IN p^.location.reference }
set_location(p^.location,p^.left^.location);
{ offset can only differ from 0 if arraydef }
if p^.left^.resulttype^.deftype=arraydef then
dec(p^.location.reference.offset,
p^.resulttype^.size*
parraydef(p^.left^.resulttype)^.lowrange);
if p^.right^.treetype=ordconstn then
begin
{ offset can only differ from 0 if arraydef }
if (p^.left^.resulttype^.deftype=arraydef) then
begin
if not(is_open_array(p^.left^.resulttype)) then
begin
if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
(p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
Message(parser_e_range_check_error);
dec(p^.left^.location.reference.offset,
p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
end
else
begin
{ range checking for open arrays }
end;
end;
inc(p^.left^.location.reference.offset,
p^.right^.value*p^.resulttype^.size);
p^.left^.resulttype:=p^.resulttype;
disposetree(p^.right);
_p:=p^.left;
putnode(p);
p:=_p;
end
else
begin
{ quick hack, to overcome Delphi 2 }
if (cs_maxoptimieren in aktswitches) and
(p^.left^.resulttype^.deftype=arraydef) then
begin
extraoffset:=0;
if (p^.right^.treetype=addn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end
else if (p^.right^.treetype=subn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end;
inc(p^.location.reference.offset,
p^.resulttype^.size*extraoffset);
end;
{ calculate from left to right }
if (p^.location.loc<>LOC_REFERENCE) and
(p^.location.loc<>LOC_MEM) then
Message(cg_e_illegal_expression);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
case p^.right^.location.loc of
LOC_REGISTER : begin
ind:=p^.right^.location.register;
case p^.right^.resulttype^.size of
1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ff,ind)));
2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ffff,ind)));
end;
end;
LOC_CREGISTER : begin
ind:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind);
case p^.right^.resulttype^.size of
1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ff,ind)));
2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ffff,ind)));
end;
end;
LOC_FLAGS:
begin
ind:=getregister32;
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,ind)));
end
else { else outer case }
begin
del_reference(p^.right^.location.reference);
ind:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.right^.location.reference),ind)));
{Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct.}
case p^.right^.resulttype^.size of
1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ff,ind)));
2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
$ffff,ind)));
end; { end case }
end; { end else begin }
end;
{ produce possible range check code: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
new(hp);
reset_reference(hp^);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
emit_bounds_check(hp^,ind);
end;
end;
{ ------------------------ HANDLE INDEXING ----------------------- }
{ In Motorola 680x0 mode, displacement can only be of 64K max. }
{ Therefore instead of doing a direct displacement, we must first }
{ load the new address into an address register. Therefore the }
{ symbol is not used. }
if assigned(p^.location.reference.symbol) then
begin
if p^.location.reference.base <> R_NO then
Message(cg_f_secondvecn_base_defined_twice);
p^.location.reference.base:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0),
p^.location.reference.base)));
stringdispose(p^.location.reference.symbol);
end;
if (p^.location.reference.index=R_NO) then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
{ here we must check for the offset }
{ and if out of bounds for the motorola }
{ eg: out of signed d8 then reload index }
{ with correct value. }
if p^.location.reference.offset > 127 then
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind)));
p^.location.reference.offset := 0;
end
else
if p^.location.reference.offset < -128 then
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind)));
p^.location.reference.offset := 0;
end;
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
{ we must use address register to put index in base }
{ compare with cgi386.pas }
reg := getaddressreg;
p^.location.reference.base := reg;
emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg);
ungetregister(p^.location.reference.index);
p^.location.reference.index:=ind;
end
else
begin
reg := getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
reg)));
ungetregister(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
stringdispose(p^.location.reference.symbol);
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=reg;
ungetregister32(p^.location.reference.index);
p^.location.reference.index:=ind;
end;
end;
end;
end;
{ *************** Converting Types **************** }
{ produces if necessary rangecheckcode }
procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
var
hp : preference;
hregister : tregister;
neglabel,poslabel : plabel;
begin
{ convert from p2 to p1 }
{ range check from enums is not made yet !!}
{ and its probably not easy }
if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
exit;
{ range checking is different for u32bit }
{ lets try to generate it allways }
if (cs_rangechecking in aktswitches) and
{ with $R+ explicit type conversations in TP aren't range checked! }
(not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
((porddef(p1)^.von>porddef(p2)^.von) or
(porddef(p1)^.bis<porddef(p2)^.bis) or
(porddef(p1)^.typ=u32bit) or
(porddef(p2)^.typ=u32bit)) then
begin
porddef(p1)^.genrangecheck;
if porddef(p2)^.typ=u8bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
end;
hregister:=R_D6;
end
else if porddef(p2)^.typ=s8bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
{ byte to long }
if opt_processors = MC68020 then
exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
else
begin
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
end;
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
{ byte to long }
if opt_processors = MC68020 then
exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
else
begin
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
end;
end; { end outermost else }
hregister:=R_D6;
end
{ rangechecking for u32bit ?? !!!!!!}
{ lets try }
else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit) then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
hregister:=p^.location.register
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),R_D6)));
hregister:=R_D6;
end;
end
{ rangechecking for u32bit ?? !!!!!!}
else if porddef(p2)^.typ=u16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
{ unisgned extend }
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FFFF,R_D6)));
hregister:=R_D6;
end
else if porddef(p2)^.typ=s16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
{ sign extend }
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
hregister:=R_D6;
end
else internalerror(6);
new(hp);
reset_reference(hp^);
hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
if porddef(p1)^.von>porddef(p1)^.bis then
begin
getlabel(neglabel);
getlabel(poslabel);
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hregister)));
emitl(A_BLT,neglabel);
end;
emit_bounds_check(hp^,hregister);
if porddef(p1)^.von>porddef(p1)^.bis then
begin
new(hp);
reset_reference(hp^);
hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
emitl(A_JMP,poslabel);
emitl(A_LABEL,neglabel);
emit_bounds_check(hp^,hregister);
emitl(A_LABEL,poslabel);
end;
end;
end;
type
tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
begin
end;
procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
begin
maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
end;
procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
var
hregister : tregister;
opsize : topsize;
op : tasmop;
is_register : boolean;
begin
is_register:=p^.left^.location.loc=LOC_REGISTER;
if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
begin
del_reference(p^.left^.location.reference);
{ we can do this here as we need no temp inside second_bigger }
ungetiftemp(p^.left^.location.reference);
end;
{ this is wrong !!!
gives me movl (%eax),%eax
for the length(string !!!
use only for constant values }
{Constanst cannot be loaded into registers using MOVZX!}
if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
case convtyp of
tc_u8bit_2_s32bit,
tc_u8bit_2_u32bit,
tc_s8bit_2_u32bit,
tc_s8bit_2_s16bit,
tc_s8bit_2_s32bit,
tc_u8bit_2_u16bit,
tc_s8bit_2_u16bit,
tc_u8bit_2_s16bit: begin
if is_register then
hregister := p^.left^.location.register
else
hregister := getregister32;
if is_register then
emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister)
else
begin
if p^.left^.location.loc = LOC_CREGISTER then
emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister)
else
exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
newreference(P^.left^.location.reference), hregister)));
end;
case convtyp of
tc_u8bit_2_s32bit,
tc_u8bit_2_u32bit:
exprasmlist^.concat(new(pai68k, op_const_reg(
A_AND,S_L,$FF,hregister)));
tc_s8bit_2_u32bit,
tc_s8bit_2_s32bit:
begin
if opt_processors = MC68020 then
exprasmlist^.concat(new(pai68k,op_reg
(A_EXTB,S_L,hregister)))
else { else if opt_processors }
begin
{ byte to word }
exprasmlist^.concat(new(pai68k,op_reg
(A_EXT,S_W,hregister)));
{ word to long }
exprasmlist^.concat(new(pai68k,op_reg
(A_EXT,S_L,hregister)));
end;
end;
tc_s8bit_2_u16bit,
tc_u8bit_2_s16bit,
tc_u8bit_2_u16bit:
exprasmlist^.concat(new(pai68k, op_const_reg(
A_AND,S_W,$FF,hregister)));
tc_s8bit_2_s16bit:
exprasmlist^.concat(new(pai68k, op_reg(
A_EXT, S_W, hregister)));
end; { inner case }
end;
tc_u16bit_2_u32bit,
tc_u16bit_2_s32bit,
tc_s16bit_2_u32bit,
tc_s16bit_2_s32bit: begin
if is_register then
hregister := p^.left^.location.register
else
hregister := getregister32;
if is_register then
emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister)
else
begin
if p^.left^.location.loc = LOC_CREGISTER then
emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister)
else
exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_W,
newreference(P^.left^.location.reference), hregister)));
end;
if (convtyp = tc_u16bit_2_s32bit) or
(convtyp = tc_u16bit_2_u32bit) then
exprasmlist^.concat(new(pai68k, op_const_reg(
A_AND, S_L, $ffff, hregister)))
else { tc_s16bit_2_s32bit }
{ tc_s16bit_2_u32bit }
exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,
hregister)));
end;
end { end case }
else
begin
case convtyp of
tc_u8bit_2_s32bit,
tc_s8bit_2_s32bit,
tc_u16bit_2_s32bit,
tc_s16bit_2_s32bit,
tc_u8bit_2_u32bit,
tc_s8bit_2_u32bit,
tc_u16bit_2_u32bit,
tc_s16bit_2_u32bit:
begin
hregister:=getregister32;
op:=A_MOVE;
opsize:=S_L;
end;
tc_s8bit_2_u16bit,
tc_s8bit_2_s16bit,
tc_u8bit_2_s16bit,
tc_u8bit_2_u16bit:
begin
hregister:=getregister32;
op:=A_MOVE;
opsize:=S_W;
end;
end;
if is_register then
begin
emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
end
else
begin
if p^.left^.location.loc=LOC_CREGISTER then
emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
else exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize,
newreference(p^.left^.location.reference),hregister)));
end;
end; { end elseif }
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
end;
procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
var
pushedregs : tpushed;
begin
stringdispose(p^.location.reference.symbol);
gettempofsizereference(p^.resulttype^.size,p^.location.reference);
del_reference(p^.left^.location.reference);
copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
ungetiftemp(p^.left^.location.reference);
end;
procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
begin
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
inc(p^.left^.location.reference.offset);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
R_A0)));
emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
end;
procedure second_cchar_charpointer(p,hp : ptree;convtyp : tconverttype);
begin
{!!!!}
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
inc(p^.left^.location.reference.offset);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
R_A0)));
emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
end;
procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
begin
inc(p^.location.reference.offset);
end;
procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
begin
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
R_A0)));
emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register);
end;
procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
var
reg: tregister;
begin
p^.location.loc:=LOC_REFERENCE;
clear_reference(p^.location.reference);
{ here, after doing some arithmetic on the pointer }
{ we put it back in an address register }
if p^.left^.location.loc=LOC_REGISTER then
begin
reg := getaddressreg;
{ move the pointer in a data register back into }
{ an address register. }
emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg);
p^.location.reference.base:=reg;
ungetregister32(p^.left^.location.register);
end
else
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.reference.base:=getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
p^.location.reference.base);
end
else
begin
del_reference(p^.left^.location.reference);
p^.location.reference.base:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
p^.location.reference.base)));
end;
end;
end;
{ generates the code for the type conversion from an array of char }
{ to a string }
procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
var
l : longint;
begin
{ this is a type conversion which copies the data, so we can't }
{ return a reference }
p^.location.loc:=LOC_MEM;
{ first get the memory for the string }
stringdispose(p^.location.reference.symbol);
gettempofsizereference(256,p^.location.reference);
{ calc the length of the array }
l:=parraydef(p^.left^.resulttype)^.highrange-
parraydef(p^.left^.resulttype)^.lowrange+1;
if l>255 then
Message(sym_e_type_mismatch);
{ write the length }
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,l,
newreference(p^.location.reference))));
{ copy to first char of string }
inc(p^.location.reference.offset);
{ generates the copy code }
{ and we need the source never }
concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
{ correct the string location }
dec(p^.location.reference.offset);
end;
(* procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
begin
stringdispose(p^.location.reference.symbol);
gettempofsizereference(256,p^.location.reference);
{ is it a char const ? }
if p^.left^.treetype=ordconstn then
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,p^.left^.value*256+1,newreference(p^.location.reference))))
else
begin
{ not so elegant (goes better with extra register }
{ Here the conversion is done in one shot }
{ i.e we convert to a string with a single word which }
{ will be stored, the length followed by the char }
{ This is of course, endian specific. }
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D6)));
exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
ungetregister32(p^.left^.location.register);
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),R_D6)));
exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
del_reference(p^.left^.location.reference);
end;
if (opt_processors = MC68020) then
{ alignment is not a problem on the 68020 and higher processors }
Begin
{ add length of string to word }
exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_W,$0100,R_D6)));
{ put back into mem ... }
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,R_D6,newreference(p^.location.reference))));
end
else
Begin
{ alignment can cause problems }
{ add length of string to ref }
exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,newreference(p^.location.reference))));
if abs(p^.location.reference.offset) >= 1 then
Begin
{ temporarily decrease offset }
Inc(p^.location.reference.offset);
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D6,newreference(p^.location.reference))));
Dec(p^.location.reference.offset);
{ restore offset }
end
else
Begin
Comment(V_Debug,'SecondChar2String() internal error.');
internalerror(34);
end;
end;
end;
end;*)
procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
begin
stringdispose(p^.location.reference.symbol);
gettempofsizereference(256,p^.location.reference);
{ call loadstring with correct left and right }
p^.right:=p^.left;
p^.left:=p;
loadstring(p);
p^.left:=nil; { reset left tree, which is empty }
end;
procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
var
r : preference;
reg:tregister;
begin
emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true);
ungetiftemp(p^.left^.location.reference);
if porddef(p^.left^.resulttype)^.typ=u32bit then
push_int(0);
emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH);
new(r);
reset_reference(r^);
r^.base := R_SP;
{ no emulation }
{ for u32bit a solution would be to push $0 and to load a
+ comp
+ if porddef(p^.left^.resulttype)^.typ=u32bit then
+ exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_Q,r)))
+ else}
p^.location.loc := LOC_FPU;
{ get floating point register. }
if (cs_fp_emulation in aktswitches) then
begin
p^.location.fpureg := getregister32;
exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE, S_L, r, R_D0)));
emitcall('LONG2SINGLE',true);
emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg);
end
else
begin
p^.location.fpureg := getfloatreg;
exprasmlist^.concat(new(pai68k, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg)))
end;
if porddef(p^.left^.resulttype)^.typ=u32bit then
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,8,R_SP)))
else
{ restore the stack to the previous address }
exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L, 4, R_SP)));
end;
procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
var
{hs : string;}
rreg : tregister;
ref : treference;
begin
rreg:=getregister32;
{ Are we in a LOC_FPU, if not then use scratch registers }
{ instead of allocating reserved registers. }
if (p^.left^.location.loc<>LOC_FPU) then
begin
if (cs_fp_emulation in aktswitches) then
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
emitcall('LONGMUL',true);
emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,R_FP0)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg)));
end;
end
else
begin
if (cs_fp_emulation in aktswitches) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
emitcall('LONGMUL',true);
emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
end
else
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg)));
end;
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=rreg;
end;
procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
begin
case p^.left^.location.loc of
LOC_FPU : begin
{ reload }
p^.location.loc := LOC_FPU;
p^.location.fpureg := p^.left^.location.fpureg;
end;
LOC_MEM,
LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ,
p^.left^.location.reference,p^.location);
end;
{ ALREADY HANDLED BY FLOATLOAD }
{ p^.location.loc:=LOC_FPU; }
end;
procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
var
startreg : tregister;
hl : plabel;
r : treference;
reg1: tregister;
hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: plabel;
begin
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
startreg:=p^.left^.location.register;
ungetregister(startreg);
{ move d0,d0 is removed by emit_reg_reg }
emit_reg_reg(A_MOVE,S_L,startreg,R_D0);
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(
p^.left^.location.reference),R_D0)));
del_reference(p^.left^.location.reference);
startreg:=R_NO;
end;
reg1 := getregister32;
{ Motorola 68000 equivalent of CDQ }
{ we choose d1:d0 pair for quad word }
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0)));
getlabel(hl1);
emitl(A_BPL,hl1);
{ we copy all bits (-ve number) }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1)));
getlabel(hl2);
emitl(A_BRA,hl2);
emitl(A_LABEL,hl1);
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D0)));
emitl(A_LABEL,hl2);
{ end CDQ }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_EOR,S_L,R_D1,R_D0)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,reg1)));
getlabel(hl3);
emitl(A_BEQ,hl3);
{ Motorola 68000 equivalent of RCL }
getlabel(hl4);
emitl(A_BCC,hl4);
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_L,1,reg1)));
getlabel(hl5);
emitl(A_BRA,hl5);
emitl(A_LABEL,hl4);
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
emitl(A_LABEL,hl5);
{ end RCL }
{ Motorola 68000 equivalent of BSR }
{ save register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_D6)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,31,R_D0)));
getlabel(hl6);
emitl(A_LABEL,hl6);
exprasmlist^.concat(new(pai68k,op_reg_reg(A_BTST,S_L,R_D0,R_D1)));
getlabel(hl7);
emitl(A_BNE,hl7);
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D0)));
emitl(A_BPL,hl6);
{ restore register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_D0)));
emitl(A_LABEL,hl7);
{ end BSR }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,32,R_D6)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_B,R_D1,R_D6)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D6,R_D0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_W,1007,R_D1)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,5,R_D1)));
{ Motorola 68000 equivalent of SHLD }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,11,R_D6)));
{ save register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D1,R_A0)));
getlabel(hl8);
emitl(A_LABEL,hl8);
exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D1)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
emitl(A_BNE,hl8);
{ restore register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D1)));
{ end Motorola equivalent of SHLD }
{ Motorola 68000 equivalent of SHLD }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,20,R_D6)));
{ save register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_A0)));
getlabel(hl9);
emitl(A_LABEL,hl9);
exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
emitl(A_BNE,hl9);
{ restore register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D0)));
{ end Motorola equivalent of SHLD }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,20,R_D6)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_L,R_D6,R_D0)));
emitl(A_LABEL, hl3);
{ create temp values and put on stack }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH)));
reset_reference(r);
r.base:=R_SP;
if (cs_fp_emulation in aktswitches) then
begin
p^.location.loc:=LOC_FPU;
p^.location.fpureg := getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r),
p^.left^.location.fpureg)))
end
else
begin
p^.location.loc:=LOC_FPU;
p^.location.fpureg := getfloatreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(r),
p^.left^.location.fpureg)))
end;
{ clear temporary space }
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,8,R_SP)));
ungetregister32(reg1);
{ Alreadu handled above... }
{ p^.location.loc:=LOC_FPU; }
end;
procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
var
{hs : string;}
hregister : tregister;
begin
if (p^.left^.location.loc=LOC_REGISTER) then
hregister:=p^.left^.location.register
else if (p^.left^.location.loc=LOC_CREGISTER) then
hregister:=getregister32
else
begin
del_reference(p^.left^.location.reference);
hregister:=getregister32;
case porddef(p^.left^.resulttype)^.typ of
s8bit : begin
exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
newreference(p^.left^.location.reference),hregister)));
if opt_processors = MC68020 then
exprasmlist^.concat(new(pai68k, op_reg(A_EXTB,S_L,hregister)))
else
begin
exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_W,hregister)));
exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,hregister)));
end;
end;
u8bit : begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),
hregister)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
end;
s16bit :begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
hregister)));
exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,hregister)));
end;
u16bit : begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
hregister)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
end;
s32bit,u32bit : exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
hregister)));
{!!!! u32bit }
end;
end;
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,16,R_D1)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D1,hregister)));
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
end;
procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
var
hregister,destregister : tregister;
{opsize : topsize;}
ref : boolean;
hpp : preference;
begin
{ !!!!!!!! Rangechecking }
ref:=false;
{ problems with enums !! }
if (cs_rangechecking in aktswitches) and
{ with $R+ explicit type conversations in TP aren't range checked! }
(not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
(p^.resulttype^.deftype=orddef) and
(hp^.resulttype^.deftype=orddef) and
((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or
(porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
begin
porddef(p^.resulttype)^.genrangecheck;
if porddef(hp^.resulttype)^.typ=s32bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
hregister:=p^.location.register
else
begin
hregister:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hregister)));
end;
end
{ rangechecking for u32bit ?? !!!!!!}
else if porddef(hp^.resulttype)^.typ=u16bit then
begin
hregister:=getregister32;
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)));
end
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
{ clear unused bits i.e unsigned extend}
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $FFFF, hregister)));
end
else if porddef(hp^.resulttype)^.typ=s16bit then
begin
hregister:=getregister32;
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)))
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
{ sign extend }
exprasmlist^.concat(new(pai68k,op_reg(A_EXT, S_L, hregister)));
end
else internalerror(6);
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
emit_bounds_check(hpp^, hregister);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
exit;
end;
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
{ handled by secondpas by called routine ??? }
{ p^.location.loc:=p^.left^.location.loc; }
p^.location.register:=p^.left^.location.register;
end;
end;
procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);far;
begin
secondpass(hp);
p^.location.loc:=LOC_REGISTER;
del_reference(hp^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(hp^.location.reference),R_A0)));
emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register);
end;
procedure second_bool_to_byte(p,hp : ptree;convtyp : tconverttype);
var
oldtruelabel,oldfalselabel,hlabel : plabel;
begin
oldtruelabel:=truelabel;
oldfalselabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(hp);
p^.location.loc:=LOC_REGISTER;
del_reference(hp^.location.reference);
p^.location.register:=getregister32;
case hp^.location.loc of
LOC_MEM,LOC_REFERENCE :
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
newreference(hp^.location.reference),p^.location.register)));
LOC_REGISTER,LOC_CREGISTER :
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,
hp^.location.register,p^.location.register)));
LOC_FLAGS:
begin
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[hp^.location.resflags],S_NO,
p^.location.register)))
end;
LOC_JUMP:
begin
getlabel(hlabel);
emitl(A_LABEL,truelabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
1,p^.location.register)));
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,p^.location.register)));
emitl(A_LABEL,hlabel);
end;
else
internalerror(10060);
end;
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
end;
procedure secondtypeconv(var p : ptree);
const
secondconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
tsecondconvproc = (second_bigger,second_only_rangecheck,
second_bigger,second_bigger,second_bigger,
second_smaller,second_smaller,
second_smaller,second_string_string,
second_cstring_charpointer,second_string_chararray,
second_array_to_pointer,second_pointer_to_array,
second_char_to_string,second_bigger,
second_bigger,second_bigger,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_bigger,second_smaller,
second_only_rangecheck,second_bigger,
second_bigger,second_bigger,
second_bigger,second_only_rangecheck,
second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,second_bool_to_byte,
second_proc_to_procvar,
{ is constant char to pchar, is done by firstpass }
second_nothing);
begin
{ this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
{ type conversion (FK) }
{ this is necessary, because second_bool_byte, have to change }
{ true- and false label before calling secondpass }
if p^.convtyp<>tc_bool_2_u8bit then
begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
end;
if p^.convtyp<>tc_equal then
{the second argument only is for maybe_range_checking !}
secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
end;
{ save the size of pushed parameter }
var
pushedparasize : longint;
procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
push_from_left_to_right : boolean);
var
size : longint;
stackref : treference;
otlabel,hlabel,oflabel : plabel;
{ temporary variables: }
tempdeftype : tdeftype;
tempreference : treference;
r : preference;
s : topsize;
op : tasmop;
begin
{ push from left to right if specified }
if push_from_left_to_right and assigned(p^.right) then
secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(p^.left);
{ in codegen.handleread.. defcoll^.data is set to nil }
if assigned(defcoll^.data) and
(defcoll^.data^.deftype=formaldef) then
begin
{ allow @var }
if p^.left^.treetype=addrn then
begin
{ allways a register }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH)));
ungetregister32(p^.left^.location.register);
end
else
begin
if (p^.left^.location.loc<>LOC_REFERENCE) and
(p^.left^.location.loc<>LOC_MEM) then
Message(sym_e_type_mismatch)
else
begin
emitpushreferenceaddr(p^.left^.location.reference);
del_reference(p^.left^.location.reference);
end;
end;
inc(pushedparasize,4);
end
{ handle call by reference parameter }
else if (defcoll^.paratyp=vs_var) then
begin
if (p^.left^.location.loc<>LOC_REFERENCE) then
Message(cg_e_var_must_be_reference);
{ open array ? }
{ defcoll^.data can be nil for read/write }
if assigned(defcoll^.data) and
is_open_array(defcoll^.data) then
begin
{ push high }
if is_open_array(p^.left^.resulttype) then
begin
new(r);
reset_reference(r^);
r^.base:=highframepointer;
r^.offset:=highoffset+4;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)));
end
else
push_int(parraydef(p^.left^.resulttype)^.highrange-
parraydef(p^.left^.resulttype)^.lowrange);
inc(pushedparasize,4);
end;
emitpushreferenceaddr(p^.left^.location.reference);
del_reference(p^.left^.location.reference);
inc(pushedparasize,4);
end
else
begin
tempdeftype:=p^.resulttype^.deftype;
if tempdeftype=filedef then
Message(cg_e_file_must_call_by_reference);
if (defcoll^.paratyp=vs_const) and
dont_copy_const_param(p^.resulttype) then
begin
emitpushreferenceaddr(p^.left^.location.reference);
del_reference(p^.left^.location.reference);
inc(pushedparasize,4);
end
else
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.left^.location.register,R_SPPUSH)));
inc(pushedparasize,4);
ungetregister32(p^.left^.location.register);
end;
LOC_FPU : begin
size:=pfloatdef(p^.left^.resulttype)^.size;
inc(pushedparasize,size);
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)));
new(r);
reset_reference(r^);
r^.base:=R_SP;
s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ);
if (cs_fp_emulation in aktswitches) then
begin
{ when in emulation mode... }
{ only single supported!!! }
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
p^.left^.location.fpureg,r)));
end
else
{ convert back from extended to normal type }
exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,
p^.left^.location.fpureg,r)));
end;
LOC_REFERENCE,LOC_MEM :
begin
tempreference:=p^.left^.location.reference;
del_reference(p^.left^.location.reference);
case p^.resulttype^.deftype of
orddef : begin
case porddef(p^.resulttype)^.typ of
s32bit,u32bit :
begin
emit_push_mem(tempreference);
inc(pushedparasize,4);
end;
s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
newreference(tempreference),R_SPPUSH)));
inc(pushedparasize,2);
end;
end;
end;
floatdef : begin
case pfloatdef(p^.resulttype)^.typ of
f32bit,
s32real :
begin
emit_push_mem(tempreference);
inc(pushedparasize,4);
end;
s64real:
{s64bit }
begin
inc(tempreference.offset,4);
emit_push_mem(tempreference);
dec(tempreference.offset,4);
emit_push_mem(tempreference);
inc(pushedparasize,8);
end;
{$ifdef use48}
s48real : begin
end;
{$endif}
s80real : begin
Message(cg_f_extended_cg68k_not_supported);
{ inc(tempreference.offset,6);
emit_push_mem(tempreference);
dec(tempreference.offset,4);
emit_push_mem(tempreference);
dec(tempreference.offset,2);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
newreference(tempreference),R_SPPUSH)));
inc(pushedparasize,extended_size);}
end;
end;
end;
pointerdef,procvardef,
enumdef,classrefdef: begin
emit_push_mem(tempreference);
inc(pushedparasize,4);
end;
arraydef,recorddef,stringdef,setdef,objectdef :
begin
if ((p^.resulttype^.deftype=setdef) and
(psetdef(p^.resulttype)^.settype=smallset)) then
begin
emit_push_mem(tempreference);
inc(pushedparasize,4);
end
else
begin
size:=p^.resulttype^.size;
{ Alignment }
{
if (size>=4) and ((size and 3)<>0) then
inc(size,4-(size and 3))
else if (size>=2) and ((size and 1)<>0) then
inc(size,2-(size and 1))
else
if size=1 then size:=2;
}
{ create stack space }
if (size > 0) and (size < 9) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)))
else
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBA,
S_L,size,R_SP)));
inc(pushedparasize,size);
{ create stack reference }
stackref.symbol := nil;
clear_reference(stackref);
stackref.base:=R_SP;
{ produce copy }
if p^.resulttype^.deftype=stringdef then
begin
copystring(stackref,p^.left^.location.reference,
pstringdef(p^.resulttype)^.len);
end
else
begin
concatcopy(p^.left^.location.reference,
stackref,p^.resulttype^.size,true);
end;
end;
end;
else Message(cg_e_illegal_expression);
end;
end;
LOC_JUMP : begin
getlabel(hlabel);
inc(pushedparasize,2);
emitl(A_LABEL,truelabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,1,R_SPPUSH)));
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,0,R_SPPUSH)));
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS : begin
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_B,
R_D0)));
exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_W,$ff, R_D0)));
inc(pushedparasize,2);
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH)));
end;
end;
end;
truelabel:=otlabel;
falselabel:=oflabel;
{ push from right to left }
if not push_from_left_to_right and assigned(p^.right) then
secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
end;
procedure secondcalln(var p : ptree);
var
unusedregisters : tregisterset;
pushed : tpushed;
funcretref : treference;
hregister : tregister;
oldpushedparasize : longint;
{ true if a5 must be loaded again after the subroutine }
loada5 : boolean;
{ true if a virtual method must be called directly }
no_virtual_call : boolean;
{ true if we produce a con- or destrutor in a call }
is_con_or_destructor : boolean;
{ true if a constructor is called again }
extended_new : boolean;
{ adress returned from an I/O-error }
iolabel : plabel;
{ lexlevel count }
i : longint;
{ help reference pointer }
r : preference;
pp,params : ptree;
{ temp register allocation }
reg: tregister;
{ help reference pointer }
ref: preference;
label
dont_call;
begin
extended_new:=false;
iolabel:=nil;
loada5:=true;
no_virtual_call:=false;
unusedregisters:=unused;
if not assigned(p^.procdefinition) then
exit;
{ only if no proc var }
if not(assigned(p^.right)) then
is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0)
or ((p^.procdefinition^.options and podestructor)<>0);
{ proc variables destroy all registers }
if (p^.right=nil) and
{ virtual methods too }
((p^.procdefinition^.options and povirtualmethod)=0) then
begin
if ((p^.procdefinition^.options and poiocheck)<>0)
and (cs_iocheck in aktswitches) then
begin
getlabel(iolabel);
emitl(A_LABEL,iolabel);
end
else iolabel:=nil;
{ save all used registers }
pushusedregisters(pushed,p^.procdefinition^.usedregisters);
{ give used registers through }
usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
end
else
begin
pushusedregisters(pushed,$ffff);
usedinproc:=$ffff;
{ no IO check for methods and procedure variables }
iolabel:=nil;
end;
{ generate the code for the parameter and push them }
oldpushedparasize:=pushedparasize;
pushedparasize:=0;
if (p^.resulttype<>pdef(voiddef)) and
ret_in_param(p^.resulttype) then
begin
funcretref.symbol:=nil;
{$ifdef test_dest_loc}
if dest_loc_known and (dest_loc_tree=p) and
(dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
begin
funcretref:=dest_loc.reference;
if assigned(dest_loc.reference.symbol) then
funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
in_dest_loc:=true;
end
else
{$endif test_dest_loc}
gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref);
end;
if assigned(p^.left) then
begin
pushedparasize:=0;
{ be found elsewhere }
if assigned(p^.right) then
secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
(p^.procdefinition^.options and poleftright)<>0)
else
secondcallparan(p^.left,p^.procdefinition^.para1,
(p^.procdefinition^.options and poleftright)<>0);
end;
params:=p^.left;
p^.left:=nil;
if ret_in_param(p^.resulttype) then
begin
emitpushreferenceaddr(funcretref);
inc(pushedparasize,4);
end;
{ overloaded operator have no symtable }
if (p^.right=nil) then
begin
{ push self }
if assigned(p^.symtable) and
(p^.symtable^.symtabletype=withsymtable) then
begin
{ dirty trick to avoid the secondcall below }
p^.methodpointer:=genzeronode(callparan);
p^.methodpointer^.location.loc:=LOC_REGISTER;
p^.methodpointer^.location.register:=R_A5;
{ make a reference }
new(r);
reset_reference(r^);
r^.offset:=p^.symtable^.datasize;
r^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
end;
{ push self }
if assigned(p^.symtable) and
((p^.symtable^.symtabletype=objectsymtable) or
(p^.symtable^.symtabletype=withsymtable)) then
begin
if assigned(p^.methodpointer) then
begin
case p^.methodpointer^.treetype of
typen : begin
{ direct call to inherited method }
if (p^.procdefinition^.options and poabstractmethod)<>0 then
begin
Message(cg_e_cant_call_abstract_method);
goto dont_call;
end;
{ generate no virtual call }
no_virtual_call:=true;
if (p^.symtableprocentry^.properties and sp_static)<>0 then
begin
{ well lets put the VMT address directly into a5 }
{ it is kind of dirty but that is the simplest }
{ way to accept virtual static functions (PM) }
loada5:=true;
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5)));
concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
end
else
{ this is a member call, so A5 isn't modfied }
loada5:=false;
if not(is_con_or_destructor and
pobjectdef(p^.methodpointer^.resulttype)^.isclass and
assigned(aktprocsym) and
((aktprocsym^.definition^.options and
(poconstructor or podestructor))<>0)) then
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
{ if an inherited con- or destructor should be }
{ called in a con- or destructor then a warning }
{ will be made }
{ con- and destructors need a pointer to the vmt }
if is_con_or_destructor and
((pobjectdef(p^.methodpointer^.resulttype)^.options and oois_class)=0) and
assigned(aktprocsym) then
begin
if not ((aktprocsym^.definition^.options
and (poconstructor or podestructor))<>0) then
Message(cg_w_member_cd_call_from_method);
end;
{ con- and destructors need a pointer to the vmt }
if is_con_or_destructor then
begin
{ classes need the mem ! }
if ((pobjectdef(p^.methodpointer^.resulttype)^.options and
oois_class)=0) then
push_int(0)
else
begin
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
S_L,newcsymbol(pobjectdef(p^.methodpointer^.
resulttype)^.vmt_mangledname,0),R_SPPUSH)));
concat_external(pobjectdef(p^.methodpointer^.resulttype)^.
vmt_mangledname,EXT_NEAR);
end;
end;
end;
hnewn : begin
{ extended syntax of new }
{ A5 must be zero }
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,0,R_A5)));
emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH);
{ insert the vmt }
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
extended_new:=true;
end;
hdisposen : begin
secondpass(p^.methodpointer);
{ destructor with extended syntax called from dispose }
{ hdisposen always deliver LOC_REFRENZ }
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.methodpointer^.location.reference),R_A5)));
del_reference(p^.methodpointer^.location.reference);
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
newcsymbol(pobjectdef
(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
end;
else
begin
{ call to a instance member }
if (p^.symtable^.symtabletype<>withsymtable) then
begin
secondpass(p^.methodpointer);
case p^.methodpointer^.location.loc of
LOC_REGISTER :
begin
ungetregister32(p^.methodpointer^.location.register);
emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5);
end;
else
begin
if (p^.methodpointer^.resulttype^.deftype=objectdef) and
pobjectdef(p^.methodpointer^.resulttype)^.isclass then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.methodpointer^.location.reference),R_A5)))
else
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.methodpointer^.location.reference),R_A5)));
del_reference(p^.methodpointer^.location.reference);
end;
end;
end;
{ when calling a class method, we have
to load ESI with the VMT !
But that's wrong, if we call a class method via self
}
if ((p^.procdefinition^.options and poclassmethod)<>0)
and not(p^.methodpointer^.treetype=selfn) then
begin
{ class method needs current VMT }
new(r);
reset_reference(r^);
r^.base:=R_A5;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
end;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
if is_con_or_destructor then
begin
{ classes don't get a VMT pointer pushed }
if (p^.methodpointer^.resulttype^.deftype=objectdef) and
not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
begin
if ((p^.procdefinition^.options and poconstructor)<>0) then
begin
{ it's no bad idea, to insert the VMT }
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
newcsymbol(pobjectdef(
p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
concat_external(pobjectdef(
p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
end
{ destructors haven't to dispose the instance, if this is }
{ a direct call }
else
push_int(0);
end;
end;
end;
end;
end
else
begin
if ((p^.procdefinition^.options and poclassmethod)<>0) and
not(
assigned(aktprocsym) and
((aktprocsym^.definition^.options and poclassmethod)<>0)
) then
begin
{ class method needs current VMT }
new(r);
reset_reference(r^);
r^.base:=R_A5;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
end
else
begin
{ member call, A5 isn't modified }
loada5:=false;
end;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
{ but a con- or destructor here would probably almost }
{ always be placed wrong }
if is_con_or_destructor then
begin
Message(cg_w_member_cd_call_from_method);
{ not insert VMT pointer } { VMT-Zeiger nicht eintragen }
push_int(0);
end;
end;
end;
{ push base pointer ?}
if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and
((p^.procdefinition^.parast^.symtablelevel)>2) then
begin
{ if we call a nested function in a method, we must }
{ push also SELF! }
{ THAT'S NOT TRUE, we have to load ESI via frame pointer }
{ access }
{
begin
loadesi:=false;
exprasmlist^.concat(new(pai68k,op_reg(A_PUSH,S_L,R_ESI)));
end;
}
if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then
begin
new(r);
reset_reference(r^);
r^.offset:=procinfo.framepointer_offset;
r^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)))
end
{ this is only true if the difference is one !!
but it cannot be more !! }
else if lexlevel=(p^.procdefinition^.parast^.symtablelevel)-1 then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,procinfo.framepointer,R_SPPUSH)))
end
else if lexlevel>(p^.procdefinition^.parast^.symtablelevel) then
begin
hregister:=getaddressreg;
new(r);
reset_reference(r^);
r^.offset:=procinfo.framepointer_offset;
r^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do
begin
new(r);
reset_reference(r^);
{we should get the correct frame_pointer_offset at each level
how can we do this !!! }
r^.offset:=procinfo.framepointer_offset;
r^.base:=hregister;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
end;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH)));
ungetregister32(hregister);
end
else
internalerror(25000);
end;
{ exported methods should be never called direct }
if (p^.procdefinition^.options and poexports)<>0 then
Message(cg_e_dont_call_exported_direct);
if ((p^.procdefinition^.options and povirtualmethod)<>0) and
not(no_virtual_call) then
begin
{ static functions contain the vmt_address in ESI }
{ also class methods }
if assigned(aktprocsym) then
begin
if ((aktprocsym^.properties and sp_static)<>0) or
((aktprocsym^.definition^.options and poclassmethod)<>0) or
((p^.procdefinition^.options and postaticmethod)<>0) or
{ A5 is already loaded }
((p^.procdefinition^.options and poclassmethod)<>0)then
begin
new(r);
reset_reference(r^);
r^.base:=R_a5;
end
else
begin
new(r);
reset_reference(r^);
r^.base:=R_a5;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
new(r);
reset_reference(r^);
r^.base:=R_a0;
end;
end
else
begin
new(r);
reset_reference(r^);
r^.base:=R_a5;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
new(r);
reset_reference(r^);
r^.base:=R_a0;
end;
if p^.procdefinition^.extnumber=-1 then
internalerror($Da);
r^.offset:=p^.procdefinition^.extnumber*4+12;
if (cs_rangechecking in aktswitches) then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,r^.base,R_SPPUSH)));
emitcall('CHECK_OBJECT',true);
end;
exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,r)));
end
else
emitcall(p^.procdefinition^.mangledname,
p^.symtableproc^.symtabletype=unitsymtable);
if ((p^.procdefinition^.options and poclearstack)<>0) then
begin
if (pushedparasize > 0) and (pushedparasize < 9) then
{ restore the stack, to its initial value }
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP)))
else
{ restore the stack, to its initial value }
exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP)));
end;
end
else
begin
secondpass(p^.right);
case p^.right^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
if p^.right^.location.register in [R_D0..R_D7] then
begin
reg := getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg);
new(ref);
reset_reference(ref^);
ref^.base := reg;
exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
ungetregister(reg);
end
else
begin
new(ref);
reset_reference(ref^);
ref^.base := p^.right^.location.register;
exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
end;
ungetregister32(p^.right^.location.register);
end
else
begin
if assigned(p^.right^.location.reference.symbol) then
{ Here we have a symbolic name to the routine, so solve }
{ problem by loading the address first, and then emitting }
{ the call. }
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.right^.location.reference),R_A1)));
new(ref);
reset_reference(ref^);
ref^.base := R_A1;
exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(ref^))));
end
else
exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end;
end;
end;
dont_call:
pushedparasize:=oldpushedparasize;
unused:=unusedregisters;
{ handle function results }
if p^.resulttype<>pdef(voiddef) then
begin
{ a contructor could be a function with boolean result }
if (p^.right=nil) and
((p^.procdefinition^.options and poconstructor)<>0) and
{ quick'n'dirty check if it is a class or an object }
(p^.resulttype^.deftype=orddef) then
begin
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_NE;
if extended_new then
begin
{$ifdef test_dest_loc}
if dest_loc_known and (dest_loc_tree=p) then
mov_reg_to_dest(p,S_L,R_EAX)
else
{$endif test_dest_loc}
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.register:=hregister;
end;
end
{ structed results are easy to handle.... }
else if ret_in_param(p^.resulttype) then
begin
p^.location.loc:=LOC_MEM;
stringdispose(p^.location.reference.symbol);
p^.location.reference:=funcretref;
end
else
begin
if (p^.resulttype^.deftype=orddef) then
begin
p^.location.loc:=LOC_REGISTER;
case porddef(p^.resulttype)^.typ of
s32bit,u32bit :
begin
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.register:=hregister;
end;
uchar,u8bit,bool8bit,s8bit :
begin
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_B,R_D0,hregister);
p^.location.register:=hregister;
end;
s16bit,u16bit :
begin
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.register:=hregister;
end;
else internalerror(7);
end
end
else if (p^.resulttype^.deftype=floatdef) then
case pfloatdef(p^.resulttype)^.typ of
f32bit :
begin
p^.location.loc:=LOC_REGISTER;
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.register:=hregister;
end;
s32real,s64bit,s64real,s80real: begin
if cs_fp_emulation in aktswitches then
begin
p^.location.loc:=LOC_FPU;
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.fpureg:=hregister;
end
else
begin
{ TRUE FPU mode }
p^.location.loc:=LOC_FPU;
{ on exit of function result in R_FP0 }
p^.location.fpureg:=R_FP0;
end;
end;
else
begin
p^.location.loc:=LOC_FPU;
p^.location.fpureg:=R_FP0;
end;
end {end case }
else
begin
p^.location.loc:=LOC_REGISTER;
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.register:=hregister;
end;
end;
end;
{ perhaps i/o check ? }
if iolabel<>nil then
begin
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
{ this was wrong, probably an error due to diff3
emitcall(p^.procdefinition^.mangledname);}
emitcall('IOCHECK',true);
end;
{ restore registers }
popusedregisters(pushed);
{ at last, restore instance pointer (SELF) }
if loada5 then
maybe_loada5;
pp:=params;
while assigned(pp) do
begin
if assigned(pp^.left) then
if (pp^.left^.location.loc=LOC_REFERENCE) or
(pp^.left^.location.loc=LOC_MEM) then
ungetiftemp(pp^.left^.location.reference);
pp:=pp^.right;
end;
disposetree(params);
end;
{ reverts the parameter list }
var nb_para : integer;
function reversparameter(p : ptree) : ptree;
var
hp1,hp2 : ptree;
begin
hp1:=nil;
nb_para := 0;
while assigned(p) do
begin
{ pull out }
hp2:=p;
p:=p^.right;
inc(nb_para);
{ pull in }
hp2^.right:=hp1;
hp1:=hp2;
end;
reversparameter:=hp1;
end;
procedure secondloadvmt(var p : ptree);
begin
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
p^.location.register)));
end;
procedure secondinline(var p : ptree);
const in2size:array[in_inc_byte..in_dec_dword] of Topsize=
(S_B,S_W,S_L,S_B,S_W,S_L);
in2instr:array[in_inc_byte..in_dec_dword] of Tasmop=
(A_ADDQ,A_ADDQ,A_ADDQ,A_SUBQ,A_SUBQ,A_SUBQ);
{ tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
float_name: array[tfloattype] of string[8]=
{ ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED'); }
{ Since we only support the REAL (SINGLE IEEE) FLOAT }
{ type, here is what we do... }
('FIXED','REAL','REAL','REAL','COMP','FIXED');
var
opsize: topsize;
asmop: tasmop;
aktfile : treference;
ft : tfiletype;
pushed : tpushed;
dummycoll : tdefcoll;
{ produces code for READ(LN) and WRITE(LN) }
procedure handlereadwrite(doread,callwriteln : boolean);
procedure loadstream;
const io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
var r : preference;
begin
new(r);
reset_reference(r^);
r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]);
if assem_need_external_list and not (cs_compilesystem in aktswitches) then
concat_external(r^.symbol^,EXT_NEAR);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,r,R_A0)))
end;
var
node,hp : ptree;
typedtyp,pararesult : pdef;
doflush,has_length : boolean;
dummycoll : tdefcoll;
iolabel : plabel;
npara : longint;
begin
{ I/O check }
if cs_iocheck in aktswitches then
begin
getlabel(iolabel);
emitl(A_LABEL,iolabel);
end
else iolabel:=nil;
{ no automatic call from flush }
doflush:=false;
{ for write of real with the length specified }
has_length:=false;
hp:=nil;
{ reserve temporary pointer to data variable }
aktfile.symbol:=nil;
gettempofsizereference(4,aktfile);
{ first state text data }
ft:=ft_text;
{ and state a parameter ? }
if p^.left=nil then
begin
{ state screen address}
doflush:=true;
{ the following instructions are for "writeln;" }
loadstream;
{ save @Dateivarible in temporary variable }
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
end
else
begin
{ revers paramters }
node:=reversparameter(p^.left);
p^.left := node;
npara := nb_para;
{ calculate data variable }
{ is first parameter a file type ? }
if node^.left^.resulttype^.deftype=filedef then
begin
ft:=pfiledef(node^.left^.resulttype)^.filetype;
if ft=ft_typed then
typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
secondpass(node^.left);
if codegenerror then
exit;
{ save reference in temporary variables } { reference in tempor<6F>re Variable retten }
if node^.left^.location.loc<>LOC_REFERENCE then
begin
Message(cg_e_illegal_expression);
exit;
end;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0)));
{ skip to the next parameter }
node:=node^.right;
end
else
begin
{ if we write to stdout/in then flush after the write(ln) }
doflush:=true;
loadstream;
end;
{ save @Dateivarible in temporary variable }
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
if doread then
{ parameter by READ gives call by reference }
dummycoll.paratyp:=vs_var
{ an WRITE Call by "Const" }
else dummycoll.paratyp:=vs_const;
{ because of secondcallparan, which otherwise attaches }
if ft=ft_typed then
begin
{ this is to avoid copy of simple const parameters }
dummycoll.data:=new(pformaldef,init);
{ use var for write also }
{ avoids problems with const passed by value }
{ but will not accept untyped const }
{ dummycoll.paratyp:=vs_var; }
end
else
{ I think, this isn't a good solution (FK) }
dummycoll.data:=nil;
while assigned(node) do
begin
pushusedregisters(pushed,$ffff);
hp:=node;
node:=node^.right;
hp^.right:=nil;
if hp^.is_colon_para then
Message(parser_e_illegal_colon_qualifier);
if hp^.is_colon_para then
Message(parser_e_illegal_colon_qualifier);
if ft=ft_typed then
never_copy_const_param:=true;
secondcallparan(hp,@dummycoll,false);
if ft=ft_typed then
never_copy_const_param:=false;
hp^.right:=node;
if codegenerror then
exit;
emit_push_mem(aktfile);
if (ft=ft_typed) then
begin
{ OK let's try this }
{ first we must only allow the right type }
{ we have to call blockread or blockwrite }
{ but the real problem is that }
{ reset and rewrite should have set }
{ the type size }
{ as recordsize for that file !!!! }
{ how can we make that }
{ I think that is only possible by adding }
{ reset and rewrite to the inline list a call }
{ allways read only one record by element }
push_int(typedtyp^.size);
if doread then
emitcall('TYPED_READ',true)
else
emitcall('TYPED_WRITE',true)
{!!!!!!!}
end
else
begin
{ save current position }
pararesult:=hp^.left^.resulttype;
{ handle possible field width }
{ of course only for write(ln) }
if not doread then
begin
{ handle total width parameter }
if assigned(node) and node^.is_colon_para then
begin
hp:=node;
node:=node^.right;
hp^.right:=nil;
secondcallparan(hp,@dummycoll,false);
hp^.right:=node;
if codegenerror then
exit;
has_length:=true;
end
else
if pararesult^.deftype<>floatdef then
push_int(0)
else
push_int(-32767);
{ a second colon para for a float ? }
if assigned(node) and node^.is_colon_para then
begin
hp:=node;
node:=node^.right;
hp^.right:=nil;
secondcallparan(hp,@dummycoll,false);
hp^.right:=node;
if pararesult^.deftype<>floatdef then
Message(parser_e_illegal_colon_qualifier);
if codegenerror then
exit;
end
else
begin
if hp^.left^.resulttype^.deftype=floatdef then
push_int(-1);
end;
end;
case pararesult^.deftype of
stringdef : begin
if doread then
emitcall('READ_TEXT_STRING',true)
else
begin
emitcall('WRITE_TEXT_STRING',true);
{ungetiftemp(hp^.left^.location.reference);}
end;
end;
pointerdef : begin
if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
begin
if doread then
emitcall('READ_TEXT_PCHAR_AS_POINTER',true)
else
emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true);
end
else Message(parser_e_illegal_parameter_list);
end;
arraydef : begin
if (parraydef(pararesult)^.lowrange=0)
and is_equal(parraydef(pararesult)^.definition,cchardef) then
begin
if doread then
emitcall('READ_TEXT_PCHAR_AS_ARRAY',true)
else
emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true);
end
else Message(parser_e_illegal_parameter_list);
end;
floatdef : begin
if doread then
emitcall('READ_TEXT_REAL',true)
else
emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true);
end;
orddef : begin
case porddef(pararesult)^.typ of
u8bit : if doread then
emitcall('READ_TEXT_BYTE',true);
s8bit : if doread then
emitcall('READ_TEXT_SHORTINT',true);
u16bit : if doread then
emitcall('READ_TEXT_WORD',true);
s16bit : if doread then
emitcall('READ_TEXT_INTEGER',true);
s32bit : if doread then
emitcall('READ_TEXT_LONGINT',true)
else
emitcall('WRITE_TEXT_LONGINT',true);
u32bit : if doread then
emitcall('READ_TEXT_CARDINAL',true)
else
emitcall('WRITE_TEXT_CARDINAL',true);
uchar : if doread then
emitcall('READ_TEXT_CHAR',true)
else
emitcall('WRITE_TEXT_CHAR',true);
bool8bit : if doread then
{ emitcall('READ_TEXT_BOOLEAN',true) }
Message(parser_e_illegal_parameter_list)
else
emitcall('WRITE_TEXT_BOOLEAN',true);
else Message(parser_e_illegal_parameter_list);
end;
end;
else Message(parser_e_illegal_parameter_list);
end;
end;
{ load A5 in methods again }
popusedregisters(pushed);
maybe_loada5;
end;
end;
if callwriteln then
begin
pushusedregisters(pushed,$ffff);
emit_push_mem(aktfile);
{ pushexceptlabel; }
if ft<>ft_text then
Message(parser_e_illegal_parameter_list);
emitcall('WRITELN_TEXT',true);
popusedregisters(pushed);
maybe_loada5;
end;
if doflush and not(doread) then
begin
pushusedregisters(pushed,$ffff);
{ pushexceptlabel; }
emitcall('FLUSH_STDOUT',true);
popusedregisters(pushed);
maybe_loada5;
end;
if iolabel<>nil then
begin
{ registers are saved in the procedure }
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
emitcall('IOCHECK',true);
end;
ungetiftemp(aktfile);
if assigned(p^.left) then
begin
p^.left:=reversparameter(p^.left);
if npara<>nb_para then
Message(cg_f_internal_error_in_secondinline);
hp:=p^.left;
while assigned(hp) do
begin
if assigned(hp^.left) then
if (hp^.left^.location.loc=LOC_REFERENCE) or
(hp^.left^.location.loc=LOC_MEM) then
ungetiftemp(hp^.left^.location.reference);
hp:=hp^.right;
end;
end;
end;
procedure handle_str;
var
hp,node,lentree,paratree : ptree;
dummycoll : tdefcoll;
is_real,has_length : boolean;
real_type : byte;
begin
pushusedregisters(pushed,$ffff);
node:=p^.left;
is_real:=false;
has_length:=false;
while assigned(node^.right) do node:=node^.right;
{ if a real parameter somewhere then call REALSTR }
if (node^.left^.resulttype^.deftype=floatdef) then
is_real:=true;
node:=p^.left;
{ we have at least two args }
{ with at max 2 colon_para in between }
{ first arg longint or float }
hp:=node;
node:=node^.right;
hp^.right:=nil;
dummycoll.data:=hp^.resulttype;
{ string arg }
dummycoll.paratyp:=vs_var;
secondcallparan(hp,@dummycoll,false);
if codegenerror then
exit;
dummycoll.paratyp:=vs_const;
{ second arg }
hp:=node;
node:=node^.right;
hp^.right:=nil;
{ frac para }
if hp^.is_colon_para and assigned(node) and
node^.is_colon_para then
begin
dummycoll.data:=hp^.resulttype;
secondcallparan(hp,@dummycoll,false);
if codegenerror then
exit;
hp:=node;
node:=node^.right;
hp^.right:=nil;
has_length:=true;
end
else
if is_real then
push_int(-1);
{ third arg, length only if is_real }
if hp^.is_colon_para then
begin
dummycoll.data:=hp^.resulttype;
secondcallparan(hp,@dummycoll,false);
if codegenerror then
exit;
hp:=node;
node:=node^.right;
hp^.right:=nil;
end
else
if is_real then
push_int(-32767)
else
push_int(-1);
{ last arg longint or real }
secondcallparan(hp,@dummycoll,false);
if codegenerror then
exit;
if is_real then
emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true)
else if porddef(hp^.resulttype)^.typ=u32bit then
emitcall('STR_CARDINAL',true)
else
emitcall('STR_LONGINT',true);
popusedregisters(pushed);
end;
var
r : preference;
begin
case p^.inlinenumber of
in_lo_word,
in_hi_word : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.register:=getregister32;
emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,
p^.location.register);
end
else
begin
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
end
else p^.location.register:=p^.left^.location.register;
if p^.inlinenumber=in_hi_word then
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSR,S_W,8,p^.location.register)));
p^.location.register:=p^.location.register;
end;
in_high_x :
begin
if is_open_array(p^.left^.resulttype) then
begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
new(r);
reset_reference(r^);
r^.base:=highframepointer;
r^.offset:=highoffset+4;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
r,p^.location.register)));
end
end;
in_sizeof_x,
in_typeof_x:
begin
{ load vmt }
if p^.left^.treetype=typen then
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0),
p^.location.register)));
end
else
begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
{ load VMT pointer }
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
{ in sizeof load size }
if p^.inlinenumber=in_sizeof_x then
begin
new(r);
reset_reference(r^);
{ load the address in A0 }
{ because now supposedly p^.location.register is an }
{ address. }
emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0);
r^.base:=R_A0;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,
p^.location.register)));
end;
end;
in_lo_long,
in_hi_long : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.register:=getregister32;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
p^.location.register);
end
else
begin
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
end
else p^.location.register:=p^.left^.location.register;
if p^.inlinenumber=in_hi_long then
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ, S_L, 16, R_D1)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register)));
end;
p^.location.register:=p^.location.register;
end;
{We can now comment them out, as they are handled as typecast.
Saves an incredible amount of 8 bytes code.
I'am not lucky about this, because it's _not_ a type cast (FK) }
{ in_ord_char,
in_chr_byte,}
in_length_string : begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
end;
in_inc_byte..in_dec_dword:
begin
secondpass(p^.left);
exprasmlist^.concat(new(pai68k,op_const_ref(in2instr[p^.inlinenumber],
in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference))));
emitoverflowcheck(p^.left);
end;
in_pred_x,
in_succ_x:
begin
secondpass(p^.left);
if p^.inlinenumber=in_pred_x then
asmop:=A_SUB
else
asmop:=A_ADD;
case p^.resulttype^.size of
4 : opsize:=S_L;
2 : opsize:=S_W;
1 : opsize:=S_B;
else
internalerror(10080);
end;
p^.location.loc:=LOC_REGISTER;
if p^.left^.location.loc<>LOC_REGISTER then
begin
p^.location.register:=getregister32;
if p^.left^.location.loc=LOC_CREGISTER then
emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
p^.location.register)
else
if p^.left^.location.loc=LOC_FLAGS then
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
p^.location.register)))
else
begin
del_reference(p^.left^.location.reference);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference),
p^.location.register)));
end;
end
else p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai68k,op_reg(asmop,opsize,
p^.location.register)))
{ here we should insert bounds check ? }
{ and direct call to bounds will crash the program }
{ if we are at the limit }
{ we could also simply say that pred(first)=first and succ(last)=last }
{ could this be usefull I don't think so (PM)
emitoverflowcheck;}
end;
in_assigned_x:
begin
secondpass(p^.left^.left);
p^.location.loc:=LOC_FLAGS;
if (p^.left^.left^.location.loc=LOC_REGISTER) or
(p^.left^.left^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,
p^.left^.left^.location.register)));
ungetregister32(p^.left^.left^.location.register);
end
else
begin
exprasmlist^.concat(new(pai68k,op_ref(A_TST,S_L,
newreference(p^.left^.left^.location.reference))));
del_reference(p^.left^.left^.location.reference);
end;
p^.location.resflags:=F_NE;
end;
in_reset_typedfile,in_rewrite_typedfile :
begin
pushusedregisters(pushed,$ffff);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,
pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH)));
secondload(p^.left);
emitpushreferenceaddr(p^.left^.location.reference);
if p^.inlinenumber=in_reset_typedfile then
emitcall('RESET_TYPED',true)
else
emitcall('REWRITE_TYPED',true);
popusedregisters(pushed);
end;
in_write_x :
handlereadwrite(false,false);
in_writeln_x :
handlereadwrite(false,true);
in_read_x :
handlereadwrite(true,false);
in_readln_x :
begin
handlereadwrite(true,false);
pushusedregisters(pushed,$ffff);
emit_push_mem(aktfile);
{ pushexceptlabel; }
if ft<>ft_text then
Message(parser_e_illegal_parameter_list);
emitcall('READLN_TEXT',true);
popusedregisters(pushed);
maybe_loada5;
end;
in_str_x_string : begin
handle_str;
maybe_loada5;
end;
else internalerror(9);
end;
end;
procedure secondsubscriptn(var p : ptree);
var
hr: tregister;
begin
secondpass(p^.left);
if codegenerror then
exit;
{ classes must be dereferenced implicit }
if (p^.left^.resulttype^.deftype=objectdef) and
pobjectdef(p^.left^.resulttype)^.isclass then
begin
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER:
begin
{ move it to an address register...}
hr:=getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
{ free register }
ungetregister(p^.left^.location.register);
end;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getaddressreg;
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ... and reserve one for the pointer }
hr:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(
A_MOVE,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end
else
set_location(p^.location,p^.left^.location);
inc(p^.location.reference.offset,p^.vs^.address);
end;
procedure secondselfn(var p : ptree);
begin
clear_reference(p^.location.reference);
p^.location.reference.base:=R_A5;
end;
procedure secondhdisposen(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.left^.location.register,
p^.location.reference.index)));
end;
LOC_MEM,LOC_REFERENCE :
begin
del_reference(p^.left^.location.reference);
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
p^.location.reference.index)));
end;
end;
end;
procedure secondhnewn(var p : ptree);
begin
end;
procedure secondnewn(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
p^.location.register:=p^.left^.location.register;
end;
procedure secondsimplenewdispose(var p : ptree);
var
pushed : tpushed;
begin
secondpass(p^.left);
if codegenerror then
exit;
pushusedregisters(pushed,$ffff);
{ determines the size of the mem block }
push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
{ push pointer adress }
case p^.left^.location.loc of
LOC_CREGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.left^.location.register,R_SPPUSH)));
LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
end;
{ call the mem handling procedures }
case p^.treetype of
simpledisposen :
emitcall('FREEMEM',true);
simplenewn :
emitcall('GETMEM',true);
end;
popusedregisters(pushed);
{ may be load ESI }
maybe_loada5;
end;
procedure secondsetcons(var p : ptree);
var
l : plabel;
i,smallsetvalue : longint;
hp : ptree;
href,sref : treference;
hl1,hl2: plabel;
begin
{ this should be reimplemented for smallsets }
{ differently (PM) }
{ produce constant part }
href.symbol := Nil;
clear_reference(href);
getlabel(l);
href.symbol:=stringdup(lab2str(l));
stringdispose(p^.location.reference.symbol);
datasegment^.concat(new(pai_label,init(l)));
{if psetdef(p^.resulttype)=smallset then
begin
smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1];
datasegment^.concat(new(pai_const,init_32bit(smallsetvalue)));
hp:=p^.left;
if assigned(hp) then
begin
sref.symbol:=nil;
gettempofsizereference(32,sref);
concatcopy(href,sref,32,false);
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
pushsetelement(hp^.left);
emitpushreferenceaddr(sref);
register is save in subroutine
emitcall('SET_SET_BYTE',true);
hp:=hp^.right;
end;
p^.location.reference:=sref;
end
else p^.location.reference:=href;
end
else }
begin
for i:=0 to 31 do
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));
hp:=p^.left;
if assigned(hp) then
begin
sref.symbol:=nil;
gettempofsizereference(32,sref);
concatcopy(href,sref,32,false);
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
pushsetelement(hp^.left);
emitpushreferenceaddr(sref);
{ register is save in subroutine }
emitcall('SET_SET_BYTE',true);
{ here we must set the flags manually }
{ on returne from the routine, because }
{ falgs are corrupt when restoring the }
{ stack }
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0)));
getlabel(hl1);
emitl(A_BEQ,hl1);
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_B,
$fe,R_CCR)));
getlabel(hl2);
emitl(A_BRA,hl2);
emitl(A_LABEL,hl1);
exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_B,
$01,R_CCR)));
emitl(A_LABEL,hl2);
hp:=hp^.right;
end;
p^.location.reference:=sref;
end
else p^.location.reference:=href;
end;
end;
procedure secondcontinuen(var p : ptree);
begin
if aktcontinuelabel<>nil then
emitl(A_JMP,aktcontinuelabel)
else
Message(cg_e_continue_not_allowed);
end;
{ var
hs : string; }
procedure secondexitn(var p : ptree);
var
is_mem : boolean;
{op : tasmop;
s : topsize;}
otlabel,oflabel : plabel;
label
do_jmp;
begin
if assigned(p^.left) then
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(p^.left);
case p^.left^.location.loc of
LOC_FPU : goto do_jmp;
LOC_MEM,LOC_REFERENCE : is_mem:=true;
LOC_CREGISTER,
LOC_REGISTER : is_mem:=false;
LOC_FLAGS : begin
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0)));
exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
goto do_jmp;
end;
LOC_JUMP : begin
emitl(A_LABEL,truelabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,1,R_D0)));
emitl(A_JMP,aktexit2label);
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,R_D0)));
goto do_jmp;
end;
else internalerror(2001);
end;
if (procinfo.retdef^.deftype=orddef) then
begin
case porddef(procinfo.retdef)^.typ of
s32bit,u32bit : if is_mem then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),R_D0)))
else
emit_reg_reg(A_MOVE,S_L,
p^.left^.location.register,R_D0);
u8bit,s8bit,uchar,bool8bit : if is_mem then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
newreference(p^.left^.location.reference),R_D0)))
else
emit_reg_reg(A_MOVE,S_B,
p^.left^.location.register,R_D0);
s16bit,u16bit : if is_mem then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
newreference(p^.left^.location.reference),R_D0)))
else
emit_reg_reg(A_MOVE,S_W,
p^.left^.location.register,R_D0);
end;
end
else
if (procinfo.retdef^.deftype in
[pointerdef,enumdef,procvardef]) then
begin
if is_mem then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),R_D0)))
else
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.left^.location.register,R_D0)));
end
else
if (procinfo.retdef^.deftype=floatdef) then
{ floating point return values .... }
{ single are returned in d0 }
begin
if (pfloatdef(procinfo.retdef)^.typ=f32bit) or
(pfloatdef(procinfo.retdef)^.typ=s32real) then
begin
if is_mem then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.location.reference),R_D0)))
else
begin
if pfloatdef(procinfo.retdef)^.typ=f32bit then
emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0)
else
begin
{ single values are in the floating point registers }
if cs_fp_emulation in aktswitches then
emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)
else
exprasmlist^.concat(
new(pai68k,op_reg_reg(A_FMOVE,S_S,p^.left^.location.fpureg,R_D0)));
end;
end;
end
else
{ this is only possible in real non emulation mode }
{ LOC_MEM,LOC_REFERENCE }
if is_mem then
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,
getfloatsize(pfloatdef(procinfo.retdef)^.typ),newreference(p^.left^.location.reference),R_FP0)));
end
else
{ LOC_FPU }
begin
{ convert from extended to correct type }
{ when storing }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,
getfloatsize(pfloatdef(procinfo.retdef)^.typ),p^.left^.location.fpureg,R_FP0)));
end;
end;
do_jmp:
truelabel:=otlabel;
falselabel:=oflabel;
emitl(A_JMP,aktexit2label);
end
else
begin
emitl(A_JMP,aktexitlabel);
end;
end;
procedure secondgoto(var p : ptree);
begin
emitl(A_JMP,p^.labelnr);
end;
procedure secondlabel(var p : ptree);
begin
emitl(A_LABEL,p^.labelnr);
cleartempgen;
secondpass(p^.left);
end;
procedure secondasm(var p : ptree);
begin
exprasmlist^.concatlist(p^.p_asm);
end;
procedure secondcase(var p : ptree);
var
with_sign : boolean;
opsize : topsize;
jmp_gt,jmp_le,jmp_lee : tasmop;
hp : ptree;
{ register with case expression }
hregister : tregister;
endlabel,elselabel : plabel;
{ true, if we can omit the range check of the jump table }
jumptable_no_range : boolean;
procedure gentreejmp(p : pcaserecord);
var
lesslabel,greaterlabel : plabel;
begin
emitl(A_LABEL,p^._at);
{ calculate labels for left and right }
if (p^.less=nil) then
lesslabel:=elselabel
else
lesslabel:=p^.less^._at;
if (p^.greater=nil) then
greaterlabel:=elselabel
else
greaterlabel:=p^.greater^._at;
{ calculate labels for left and right }
{ no range label: }
if p^._low=p^._high then
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
if greaterlabel=lesslabel then
begin
emitl(A_BNE,lesslabel);
end
else
begin
emitl(jmp_le,lesslabel);
emitl(jmp_gt,greaterlabel);
end;
emitl(A_JMP,p^.statement);
end
else
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
emitl(jmp_le,lesslabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._high,hregister)));
emitl(jmp_gt,greaterlabel);
emitl(A_JMP,p^.statement);
end;
if assigned(p^.less) then
gentreejmp(p^.less);
if assigned(p^.greater) then
gentreejmp(p^.greater);
end;
procedure genlinearlist(hp : pcaserecord);
var
first : boolean;
last : longint;
procedure genitem(t : pcaserecord);
begin
if assigned(t^.less) then
genitem(t^.less);
if t^._low=t^._high then
begin
if (t^._low-last > 0) and (t^._low-last < 9) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister)))
else
if (t^._low-last = 0) then
exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
else
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
last:=t^._low;
emitl(A_BEQ,t^.statement);
end
else
begin
{ it begins with the smallest label, if the value }
{ is even smaller then jump immediately to the }
{ ELSE-label }
if first then
begin
if (t^._low-1 > 0) and (t^._low < 9) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister)))
else
if t^._low-1=0 then
exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
else
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-1,hregister)));
if t^._low = 0 then
emitl(A_BLE,elselabel)
else
emitl(jmp_lee,elselabel);
end
{ if there is no unused label between the last and the }
{ present label then the lower limit can be checked }
{ immediately. else check the range in between: }
else if (t^._low-last>1)then
begin
if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister)))
else
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
emitl(jmp_lee,elselabel);
end;
exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
emitl(jmp_lee,t^.statement);
last:=t^._high;
end;
first:=false;
if assigned(t^.greater) then
genitem(t^.greater);
end;
var
hr : tregister;
begin
{ case register is modified by the list evalution }
if (p^.left^.location.loc=LOC_CREGISTER) then
begin
hr:=getregister32;
end;
last:=0;
first:=true;
genitem(hp);
emitl(A_JMP,elselabel);
end;
procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
var
table : plabel;
last : longint;
hr : preference;
procedure genitem(t : pcaserecord);
var
i : longint;
begin
if assigned(t^.less) then
genitem(t^.less);
{ fill possible hole }
for i:=last+1 to t^._low-1 do
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(elselabel)))));
for i:=t^._low to t^._high do
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(t^.statement)))));
last:=t^._high;
if assigned(t^.greater) then
genitem(t^.greater);
end;
begin
if not(jumptable_no_range) then
begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,min_,hregister)));
{ case expr less than min_ => goto elselabel }
emitl(jmp_le,elselabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,max_,hregister)));
emitl(jmp_gt,elselabel);
end;
getlabel(table);
{ extend with sign }
if opsize=S_W then
begin
{ word to long - unsigned }
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
end
else if opsize=S_B then
begin
{ byte to long - unsigned }
exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
end;
new(hr);
reset_reference(hr^);
hr^.symbol:=stringdup(lab2str(table));
hr^.offset:=(-min_)*4;
{ add scalefactor *4 to index }
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,hregister)));
{ hr^.scalefactor:=4; }
hr^.base:=getaddressreg;
emit_reg_reg(A_MOVE,S_L,hregister,hr^.base);
exprasmlist^.concat(new(pai68k,op_ref(A_JMP,S_NO,hr)));
{ if not(cs_littlesize in aktswitches^ ) then
datasegment^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4))); }
datasegment^.concat(new(pai_label,init(table)));
last:=min_;
genitem(hp);
if hr^.base <> R_NO then ungetregister(hr^.base);
{ !!!!!!!
if not(cs_littlesize in aktswitches^ ) then
exprasmlist^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4)));
}
end;
var
lv,hv,min_label,max_label,labels : longint;
max_linear_list : longint;
begin
getlabel(endlabel);
getlabel(elselabel);
with_sign:=is_signed(p^.left^.resulttype);
if with_sign then
begin
jmp_gt:=A_BGT;
jmp_le:=A_BLT;
jmp_lee:=A_BLE;
end
else
begin
jmp_gt:=A_BHI;
jmp_le:=A_BCS;
jmp_lee:=A_BLS;
end;
cleartempgen;
secondpass(p^.left);
{ determines the size of the operand }
{ determines the size of the operand }
opsize:=bytes2Sxx[p^.left^.resulttype^.size];
{ copy the case expression to a register }
{ copy the case expression to a register }
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : hregister:=p^.left^.location.register;
LOC_MEM,LOC_REFERENCE : begin
del_reference(p^.left^.location.reference);
hregister:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(
p^.left^.location.reference),hregister)));
end;
else internalerror(2002);
end;
{ now generate the jumps }
if cs_optimize in aktswitches then
begin
{ procedures are empirically passed on }
{ consumption can also be calculated }
{ but does it pay on the different }
{ processors? }
{ moreover can the size only be appro- }
{ ximated as it is not known if rel8, }
{ rel16 or rel32 jumps are used }
min_label:=case_get_min(p^.nodes);
max_label:=case_get_max(p^.nodes);
labels:=case_count_labels(p^.nodes);
{ can we omit the range check of the jump table }
getrange(p^.left^.resulttype,lv,hv);
jumptable_no_range:=(lv=min_label) and (hv=max_label);
{ optimize for size ? }
if cs_littlesize in aktswitches then
begin
if (labels<=2) or ((max_label-min_label)>3*labels) then
{ a linear list is always smaller than a jump tree }
genlinearlist(p^.nodes)
else
{ if the labels less or more a continuum then }
genjumptable(p^.nodes,min_label,max_label);
end
else
begin
if jumptable_no_range then
max_linear_list:=4
else
max_linear_list:=2;
if (labels<=max_linear_list) then
genlinearlist(p^.nodes)
else
begin
if ((max_label-min_label)>4*labels) then
begin
if labels>16 then
gentreejmp(p^.nodes)
else
genlinearlist(p^.nodes);
end
else
genjumptable(p^.nodes,min_label,max_label);
end;
end;
end
else
{ it's always not bad }
genlinearlist(p^.nodes);
{ now generate the instructions }
hp:=p^.right;
while assigned(hp) do
begin
cleartempgen;
secondpass(hp^.right);
emitl(A_JMP,endlabel);
hp:=hp^.left;
end;
emitl(A_LABEL,elselabel);
{ ... and the else block }
if assigned(p^.elseblock) then
begin
cleartempgen;
secondpass(p^.elseblock);
end;
emitl(A_LABEL,endlabel);
end;
procedure secondtryexcept(var p : ptree);
begin
end;
procedure secondtryfinally(var p : ptree);
begin
end;
procedure secondfail(var p : ptree);
var hp : preference;
begin
{if procinfo.exceptions then
aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
else }
{ we should know if the constructor is called with a new or not,
how can we do that ???
exprasmlist^.concat(new(pai68k,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0))));
}
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_A5)));
{ also reset to zero in the stack }
new(hp);
reset_reference(hp^);
hp^.offset:=procinfo.ESI_offset;
hp^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A5,hp)));
exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
end;
procedure secondas(var p : ptree);
var
pushed : tpushed;
begin
set_location(p^.location,p^.left^.location);
{ save all used registers }
pushusedregisters(pushed,$ffff);
{ push the vmt of the class }
exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
concat_external(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,EXT_NEAR);
emitpushreferenceaddr(p^.location.reference);
emitcall('DO_AS',true);
popusedregisters(pushed);
end;
procedure secondis(var p : ptree);
var
pushed : tpushed;
begin
{ save all used registers }
pushusedregisters(pushed,$ffff);
secondpass(p^.left);
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_NE;
{ push instance to check: }
case p^.left^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
S_L,p^.left^.location.register,R_SPPUSH)));
ungetregister32(p^.left^.location.register);
end;
LOC_MEM,LOC_REFERENCE:
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
del_reference(p^.left^.location.reference);
end;
else internalerror(100);
end;
{ generate type checking }
secondpass(p^.right);
case p^.right^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
S_L,p^.right^.location.register,R_SPPUSH)));
ungetregister32(p^.right^.location.register);
end;
LOC_MEM,LOC_REFERENCE:
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
del_reference(p^.right^.location.reference);
end;
else internalerror(100);
end;
emitcall('DO_IS',true);
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0)));
popusedregisters(pushed);
end;
procedure secondwith(var p : ptree);
var
ref : treference;
symtable : psymtable;
i : longint;
begin
if assigned(p^.left) then
begin
secondpass(p^.left);
ref.symbol:=nil;
gettempofsizereference(4,ref);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),R_A0)));
exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
R_A0,newreference(ref))));
del_reference(p^.left^.location.reference);
{ the offset relative to (%ebp) is only needed here! }
symtable:=p^.withsymtable;
for i:=1 to p^.tablecount do
begin
symtable^.datasize:=ref.offset;
symtable:=symtable^.next;
end;
{ p^.right can be optimize out !!! }
if p^.right<>nil then
secondpass(p^.right);
{ clear some stuff }
ungetiftemp(ref);
end;
end;
procedure secondpass(var p : ptree);
const
procedures : array[ttreetyp] of secondpassproc =
(secondadd,secondadd,secondadd,secondmoddiv,secondadd,
secondmoddiv,secondassignment,secondload,secondnothing,
secondadd,secondadd,secondadd,secondadd,
secondadd,secondadd,secondin,secondadd,
secondadd,secondshlshr,secondshlshr,secondadd,
secondadd,secondsubscriptn,secondderef,secondaddr,
seconddoubleaddr,
secondordconst,secondtypeconv,secondcalln,secondnothing,
secondrealconst,secondfixconst,secondumminus,
secondasm,secondvecn,
secondstringconst,secondfuncret,secondselfn,
secondnot,secondinline,secondniln,seconderror,
secondnothing,secondhnewn,secondhdisposen,secondnewn,
secondsimplenewdispose,secondnothing,secondsetcons,secondblockn,
secondnothing,secondnothing,secondifn,secondbreakn,
secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
secondexitn,secondwith,secondcase,secondlabel,
secondgoto,secondsimplenewdispose,secondtryexcept,secondraise,
secondnothing,secondtryfinally,secondis,secondas,seconderror,
secondfail,
secondnothing,secondloadvmt);
var
oldcodegenerror : boolean;
oldswitches : Tcswitches;
oldis : pinputfile;
oldnr : longint;
begin
oldcodegenerror:=codegenerror;
oldswitches:=aktswitches;
oldis:=current_module^.current_inputfile;
oldnr:=current_module^.current_inputfile^.line_no;
codegenerror:=false;
current_module^.current_inputfile:=p^.inputfile;
current_module^.current_inputfile^.line_no:=p^.line;
aktswitches:=p^.pragmas;
if not(p^.error) then
begin
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else codegenerror:=true;
aktswitches:=oldswitches;
current_module^.current_inputfile:=oldis;
current_module^.current_inputfile^.line_no:=oldnr;
end;
function do_secondpass(var p : ptree) : boolean;
begin
codegenerror:=false;
if not(p^.error) then
secondpass(p);
do_secondpass:=codegenerror;
end;
var
regvars : array[1..maxvarregs] of pvarsym;
regvars_para : array[1..maxvarregs] of boolean;
regvars_refs : array[1..maxvarregs] of longint;
parasym : boolean;
procedure searchregvars(p : psym);
var
i,j,k : longint;
begin
if (p^.typ=varsym) and (pvarsym(p)^.regable) then
begin
{ walk through all momentary register variables }
for i:=1 to maxvarregs do
begin
{ free register ? }
if regvars[i]=nil then
begin
regvars[i]:=pvarsym(p);
regvars_para[i]:=parasym;
break;
end;
{ else throw out a variable ? }
j:=pvarsym(p)^.refs;
{ parameter get a less value }
if parasym then
begin
if cs_littlesize in aktswitches then
dec(j,1)
else
dec(j,100);
end;
if (j>regvars_refs[i]) and (j>0) then
begin
for k:=maxvarregs-1 downto i do
begin
regvars[k+1]:=regvars[k];
regvars_para[k+1]:=regvars_para[k];
end;
{ calc the new refs
pvarsym(p)^.refs:=j; }
regvars[i]:=pvarsym(p);
regvars_para[i]:=parasym;
regvars_refs[i]:=j;
break;
end;
end;
end;
end;
procedure generatecode(var p : ptree);
var
{ *pass modifies with every node aktlinenr and current_module^.current_inputfile, }
{ to constantly contain the right line numbers }
oldis : pinputfile;
oldnr,i : longint;
regsize : topsize;
regi : tregister;
hr : preference;
label
nextreg;
begin
cleartempgen;
oldis:=current_module^.current_inputfile;
oldnr:=current_module^.current_inputfile^.line_no;
{ when size optimization only count occurrence }
if cs_littlesize in aktswitches then
t_times:=1
else
{ reference for repetition is 100 }
t_times:=100;
{ clear register count }
for regi:=R_D0 to R_A6 do
begin
reg_pushes[regi]:=0;
is_reg_var[regi]:=false;
end;
use_esp_stackframe:=false;
if not(do_firstpass(p)) then
begin
{ max. optimizations }
{ only if no asm is used }
if (cs_maxoptimieren in aktswitches) and
((procinfo.flags and pi_uses_asm)=0) then
begin
{ can we omit the stack frame ? }
{ conditions:
1. procedure (not main block)
2. no constructor or destructor
3. no call to other procedures
4. no interrupt handler
}
if assigned(aktprocsym) then
begin
if (aktprocsym^.definition^.options and poconstructor+podestructor+poinline+pointerrupt=0) and
((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then
begin
{ use ESP as frame pointer }
procinfo.framepointer:=R_SP;
use_esp_stackframe:=true;
{ calc parameter distance new }
dec(procinfo.framepointer_offset,4);
dec(procinfo.ESI_offset,4);
dec(procinfo.retoffset,4);
dec(procinfo.call_offset,4);
aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset;
end;
end; { endif assigned }
if (p^.registers32<4) then
begin
for i:=1 to maxvarregs do
regvars[i]:=nil;
parasym:=false;
{$ifdef tp}
symtablestack^.foreach(searchregvars);
{$else}
symtablestack^.foreach(@searchregvars);
{$endif}
{ copy parameter into a register ? }
parasym:=true;
{$ifdef tp}
symtablestack^.next^.foreach(searchregvars);
{$else}
symtablestack^.next^.foreach(@searchregvars);
{$endif}
{ hold needed registers free }
for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
regvars[i]:=nil;
{ now assign register }
for i:=1 to maxvarregs do
begin
if assigned(regvars[i]) then
begin
{ it is nonsens, to copy the variable to }
{ a register because we need then much }
{ pushes ? }
if reg_pushes[varregs[i]]>=regvars[i]^.refs then
begin
regvars[i]:=nil;
goto nextreg;
end;
{ register is no longer available for }
{ expressions }
{ search the register which is the most }
{ unused }
usableregs:=usableregs-[varregs[i]];
is_reg_var[varregs[i]]:=true;
dec(c_usableregs);
{ possibly no 32 bit register are needed }
if (regvars[i]^.definition^.deftype=orddef) and
(
(porddef(regvars[i]^.definition)^.typ=bool8bit) or
(porddef(regvars[i]^.definition)^.typ=uchar) or
(porddef(regvars[i]^.definition)^.typ=u8bit) or
(porddef(regvars[i]^.definition)^.typ=s8bit)
) then
begin
regvars[i]^.reg:=varregs[i];
regsize:=S_B;
end
else if (regvars[i]^.definition^.deftype=orddef) and
(
(porddef(regvars[i]^.definition)^.typ=u16bit) or
(porddef(regvars[i]^.definition)^.typ=s16bit)
) then
begin
regvars[i]^.reg:=varregs[i];
regsize:=S_W;
end
else
begin
regvars[i]^.reg:=varregs[i];
regsize:=S_L;
end;
{ parameter must be load }
if regvars_para[i] then
begin
{ procinfo is there actual, }
{ because we can't never be in a }
{ nested procedure }
{ when loading parameter to reg }
new(hr);
reset_reference(hr^);
hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset;
hr^.base:=procinfo.framepointer;
procinfo.aktentrycode^.concat(new(pai68k,op_ref_reg(A_MOVE,regsize,
hr,regvars[i]^.reg)));
unused:=unused - [regvars[i]^.reg];
end;
{ procedure uses this register }
usedinproc:=usedinproc or ($800 shr word(varregs[i]));
end;
nextreg:
{ dummy }
regsize:=S_W;
end;
if (verbosity and v_debug)=v_debug then
begin
for i:=1 to maxvarregs do
begin
if assigned(regvars[i]) then
Message3(cg_d_register_weight,reg2str(regvars[i]^.reg),
tostr(regvars[i]^.refs),regvars[i]^.name);
end;
end;
end;
end;
do_secondpass(p);
{ all registers can be used again }
{ contains both information on Address registers and data registers }
{ even if they are allocated separately. }
usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4,
R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7];
c_usableregs:=4;
end;
procinfo.aktproccode^.concatlist(exprasmlist);
current_module^.current_inputfile:=oldis;
current_module^.current_inputfile^.line_no:=oldnr;
end;
end.
{
$Log$
Revision 1.2 1998-03-28 23:09:54 florian
* secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit
* loading pointer to routines hopefully fixed (m68k)
* flags problem with calls to RTL internal routines fixed (still strcmp
to fix) (m68k)
* #ELSE was still incorrect (didn't take care of the previous level)
* problem with filenames in the command line solved
* problem with mangledname solved
* linking name problem solved (was case insensitive)
* double id problem and potential crash solved
* stop after first error
* and=>test problem removed
* correct read for all float types
* 2 sigsegv fixes and a cosmetic fix for Internal Error
* push/pop is now correct optimized (=> mov (%esp),reg)
Revision 1.1.1.1 1998/03/25 11:18:16 root
* Restored version
Revision 1.51 1998/03/22 12:45:37 florian
* changes of Carl-Eric to m68k target commit:
- wrong nodes because of the new string cg in intel, I had to create
this under m68k also ... had to work it out to fix potential alignment
problems --> this removes the crash of the m68k compiler.
- added absolute addressing in m68k assembler (required for Amiga startup)
- fixed alignment problems (because of byte return values, alignment
would not be always valid) -- is this ok if i change the offset if odd in
setfirsttemp ?? -- it seems ok...
Revision 1.50 2036/02/07 09:29:32 florian
* patch of Carl applied
Revision 1.49 1998/03/10 16:27:36 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.48 1998/03/10 15:25:31 carl
+ put back $L switch for debugging
Revision 1.47 1998/03/10 04:19:24 carl
- removed string:=char optimization because would give A LOT of
register problems
Revision 1.46 1998/03/10 01:17:15 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.45 1998/03/09 10:44:33 peter
+ string='', string<>'', string:='', string:=char optimizes (the first 2
were already in cg68k2)
Revision 1.44 1998/03/06 00:51:57 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.43 1998/03/05 04:37:46 carl
+ small optimization
Revision 1.42 1998/03/03 04:13:31 carl
- removed generate_xxxx and put them in cga68k
Revision 1.41 1998/03/03 01:08:17 florian
* bug0105 and bug0106 problem solved
Revision 1.40 1998/03/02 16:25:25 carl
* bugfix #95
Revision 1.39 1998/03/02 01:48:11 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.38 1998/02/25 02:36:29 carl
* small bugfix with range checking
Revision 1.37 1998/02/24 16:49:48 peter
* stackframe ommiting generated 'ret $-4'
+ timer.pp bp7 version
* innr.inc are now the same files
Revision 1.36 1998/02/24 16:42:49 carl
+ reinstated __EXIT
Revision 1.35 1998/02/23 02:56:38 carl
* bugfix of writing real type values qith m68k target
Revision 1.34 1998/02/22 23:03:05 peter
* renamed msource->mainsource and name->unitname
* optimized filename handling, filename is not seperate anymore with
path+name+ext, this saves stackspace and a lot of fsplit()'s
* recompiling of some units in libraries fixed
* shared libraries are working again
+ $LINKLIB <lib> to support automatic linking to libraries
+ libraries are saved/read from the ppufile, also allows more libraries
per ppufile
Revision 1.33 1998/02/22 18:50:12 carl
* bugfix of stupid diffs!!!!! Recursive crash fix!
Revision 1.30 1998/02/19 12:22:29 daniel
* Optimized a statement that did pain to my eyes.
Revision 1.29 1998/02/17 21:20:31 peter
+ Script unit
+ __EXIT is called again to exit a program
- target_info.link/assembler calls
* linking works again for dos
* optimized a few filehandling functions
* fixed stabs generation for procedures
Revision 1.28 1998/02/15 21:16:04 peter
* all assembler outputs supported by assemblerobject
* cleanup with assembleroutputs, better .ascii generation
* help_constructor/destructor are now added to the externals
- generation of asmresponse is not outputformat depended
Revision 1.27 1998/02/14 05:06:47 carl
+ now works with TP with overlays
Revision 1.26 1998/02/14 01:45:06 peter
* more fixes
- pmode target is removed
- search_as_ld is removed, this is done in the link.pas/assemble.pas
+ findexe() to search for an executable (linker,assembler,binder)
Revision 1.25 1998/02/13 10:34:40 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.24 1998/02/12 11:49:45 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.23 1998/02/07 18:00:45 carl
* bugfix in secondin (from Peter Vreman a while ago)
Revision 1.21 1998/02/05 00:58:05 carl
+ secondas and secondis now work as expected.
- moved secondas to cg68k2, otherwise problems with symbols
Revision 1.20 1998/02/01 19:38:41 florian
* bug0029 fixed, Carl please check it !!!
Revision 1.19 1998/01/24 21:05:41 carl
* nested comment bugfix
Revision 1.18 1998/01/24 00:37:47 florian
* small fix for DOM
Revision 1.17 1998/01/21 21:29:46 florian
* some fixes for Delphi classes
Revision 1.16 1998/01/20 23:51:59 carl
* bugfix 74 (FINAL, Pierre's one was incomplete under BP)
Revision 1.15 1998/01/19 10:25:21 pierre
* bug in object function call in main program or unit init fixed
Revision 1.14 1998/01/16 22:34:23 michael
* Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
in this compiler :)
Revision 1.13 1998/01/16 02:18:25 carl
* second_char_to_string align problem fix (N/A for MC68020 target)
Revision 1.12 1998/01/13 23:11:02 florian
+ class methods
Revision 1.11 1998/01/11 03:36:14 carl
* fixed indexing problem with stack
* reference on stack bugfix
* second_bigger sign extension bugfix
* array scaling bugfix
* secondderef bugfix
* bugfix with MOVEQ opcode
* bugfix of linear list generation
Revision 1.6 1997/12/10 23:07:12 florian
* bugs fixed: 12,38 (also m68k),39,40,41
+ warning if a system unit is without -Us compiled
+ warning if a method is virtual and private (was an error)
* some indentions changed
+ factor does a better error recovering (omit some crashes)
+ problem with @type(x) removed (crashed the compiler)
Revision 1.5 1997/12/09 13:28:48 carl
+ added s80 real (will presently stop the compiler though)
+ renamed some stuff
* some bugfixes (can't remember what exactly..)
Revision 1.4 1997/12/05 14:51:09 carl
* bugfix of secondfor
cmpreg was never initialized.
one of the jump conditionals was wrong (downto would not work)
Revision 1.3 1997/12/04 14:47:05 carl
+ updated tov09...
Revision 1.2 1997/11/28 18:14:20 pierre
working version with several bug fixes
Revision 1.1.1.1 1997/11/27 08:32:51 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History (started with version 0.9.0):
23th october 1996:
+ some emit calls replaced (FK)
24th october 1996:
* for bug fixed (FK)
26th october 1996:
* english comments (FK)
5th november 1996:
* new init and terminate code (FK)
...... some items missed
19th september 1997:
* a call to a function procedure a;[ C ]; doesn't crash the stack
furthermore (FK)
22th september 1997:
* stack layout for nested procedures in methods modified:
ESI is no more pushed (must be loaded via framepointer) (FK)
27th september 1997:
+ Start of conversion to motorola MC68000 (CEC)
29th september 1997:
+ Updated to version 0.9.4 of Intel code generator (CEC)
3th october 1997:
+ function second_bool_to_byte for ord(boolean) (PM)
4th october 1997: (CEC)
+ first compilation
5th octover 1997:
check floating point negate when i can test everything,
to see if it makes any sense , according SINGLE_NEG from
sozobon, it does not.??
8th october 1997:
+ ord(x) support (FK)
+ some stuff for typed file support (FK)
9 october 1997:
+ converted code to motorola for v096 (CEC)
18 october 1997:
+* removed bugs relating to floating point condition codes. (CEC).
(in secondadd).
+ had to put secondadd in another routine to compile in tp. (CEC).
+ updated second_bool_to_byte,secondtypeconv and secondinline, secondvecn to v097 (CEC)
+ updated secondload and secondstringconst (merging duplicate strings),secondfor to v95/v97 (CEC).
+ finally converted second_fix_real (very difficult and untested!). (CEC)
23 october 1997:
* bugfix of address register in usableregs set. (They were not defined...) (CEC).
24 october 1997:
* bugfix of scalefactor, allowed unrolled using lsl. (CEC).
27th october 1997:
+ now all general purpose registers are in the unused list, so this fixes problems
regarding pushing registers (such as d0) which were actually never used. (CEC)
+ added secondin (FK) (all credit goes to him).
+ converted second_real_fix thanks to Daniel Mantione for the information
he gave me on the fixed format. Thanks to W. Metzenthen who did WMEmu
(which in turn gave me information on the control word of the intel fpu). (CEC)
23rd november 1997:
+ changed second_int_real to apply correct calling conventions of rtl.
26th november 1997:
+ changed secondmoddiv to apply correct calling conventions of rtl
and also optimized it a bit.
}
Reference in New Issue View Git Blame Copy Permalink