paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-27 11:29:18 +02:00
Code Issues Packages Projects Releases Wiki Activity
f2da32cd91
fpc/compiler/cg68k.pas

5533 lines
240 KiB
ObjectPascal
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
$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,comphook,systems,globals,tree,
symtable,types,strings,pass_1,hcodegen,temp_gen,
aasm,m68k,tgen68k,files,cga68k,cg68k2,link
{$ifdef GDB}
,gdb
{$endif}
;
{ 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
{***************************************************************************}
uses
scanner;
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 secondstatement(var p : ptree);
var
hp : ptree;
begin
hp:=p;
while assigned(hp) do
begin
{ assignments could be distance optimized }
if assigned(hp^.right) then
begin
cleartempgen;
secondpass(hp^.right);
end;
hp:=hp^.left;
end;
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;
hl1: plabel;
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)))
else
Begin
{ optimize using ADDQ if possible! }
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)));
end;
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 (aktoptprocessor = MC68020) then
begin
{ Check if divisor is ZERO - if so call HALT_ERROR }
{ with d0 = 200 (Division by zero!) }
getlabel(hl1);
exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D1)));
{ if not zero then simply continue on }
emitl(A_BNE,hl1);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,200,R_D0)));
emitcall('HALT_ERROR',true);
emitl(A_LABEL,hl1);
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 aktmoduleswitches 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_FX,
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 aktmoduleswitches 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_FX,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 (aktoptprocessor = 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_regalloc in aktglobalswitches) 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_check_range in aktlocalswitches 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_check_range in aktlocalswitches) and
{ with $R+ explicit type conversations in TP aren't range checked! }
(not(p^.explizit) or not(cs_tp_compatible in aktmoduleswitches)) and
((porddef(p1)^.low>porddef(p2)^.low) or
(porddef(p1)^.high<porddef(p2)^.high) 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 aktoptprocessor = 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 aktoptprocessor = 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)^.low>porddef(p1)^.high 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)^.low>porddef(p1)^.high 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 aktoptprocessor = MC68020 then
exprasmlist^.concat(new(pai68k,op_reg
(A_EXTB,S_L,hregister)))
else { else if aktoptprocessor }
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 (aktoptprocessor = 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_IQ,r)))
+ else}
p^.location.loc := LOC_FPU;
{ get floating point register. }
if (cs_fp_emulation in aktmoduleswitches) 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 aktmoduleswitches) 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 aktmoduleswitches) 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 aktmoduleswitches) 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 aktoptprocessor = 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 !! }
{ with $R+ explicit type conversations in TP aren't range checked! }
if (p^.resulttype^.deftype=orddef) and
(hp^.resulttype^.deftype=orddef) and
((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or
(porddef(p^.resulttype)^.high<porddef(hp^.resulttype)^.high)) then
begin
if (cs_check_range in aktlocalswitches) and
(not(p^.explizit) or not(cs_tp_compatible in aktmoduleswitches)) then
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);
if (cs_check_range in aktlocalswitches) and
(not(p^.explizit) or not(cs_tp_compatible in aktmoduleswitches)) then
Begin
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
emit_bounds_check(hpp^, hregister);
end;
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_int(p,hp : ptree;convtyp : tconverttype);
var
oldtruelabel,oldfalselabel,hlabel : plabel;
hregister : tregister;
newsize,
opsize : topsize;
op : tasmop;
begin
oldtruelabel:=truelabel;
oldfalselabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(hp);
p^.location.loc:=LOC_REGISTER;
del_reference(hp^.location.reference);
hregister:=getregister32;
case porddef(hp^.resulttype)^.typ of
bool8bit : begin
case porddef(p^.resulttype)^.typ of
u8bit,s8bit,
bool8bit : opsize:=S_B;
u16bit,s16bit,
bool16bit : opsize:=S_BW;
u32bit,s32bit,
bool32bit : opsize:=S_BL;
end;
end;
bool16bit : begin
case porddef(p^.resulttype)^.typ of
u8bit,s8bit,
bool8bit : opsize:=S_B;
u16bit,s16bit,
bool16bit : opsize:=S_W;
u32bit,s32bit,
bool32bit : opsize:=S_WL;
end;
end;
bool32bit : begin
case porddef(p^.resulttype)^.typ of
u8bit,s8bit,
bool8bit : opsize:=S_B;
u16bit,s16bit,
bool16bit : opsize:=S_W;
u32bit,s32bit,
bool32bit : opsize:=S_L;
end;
end;
end;
op:=A_MOVE;
{ if opsize in [S_B,S_W,S_L] then
op:=A_MOVE
else
if (porddef(p^.resulttype)^.typ in [s8bit,s16bit,s32bit]) then
op:=A_MOVSX
else
op:=A_MOVZX; }
case porddef(p^.resulttype)^.typ of
bool8bit,u8bit,s8bit : begin
p^.location.register:=hregister;
newsize:=S_B;
end;
bool16bit,u16bit,s16bit : begin
p^.location.register:=hregister;
newsize:=S_W;
end;
bool32bit,u32bit,s32bit : begin
p^.location.register:=hregister;
newsize:=S_L;
end;
else
internalerror(10060);
end;
case hp^.location.loc of
LOC_MEM,
LOC_REFERENCE : exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize,
newreference(hp^.location.reference),p^.location.register)));
LOC_REGISTER,
LOC_CREGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(op,opsize,
hp^.location.register,p^.location.register)));
LOC_FLAGS : begin
{ hregister:=reg32toreg8(hregister); }
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
{ !!!!!!!!
case porddef(p^.resulttype)^.typ of
bool16bit,
u16bit,s16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
bool32bit,
u32bit,s32bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
end; }
end;
LOC_JUMP : begin
getlabel(hlabel);
emitl(A_LABEL,truelabel);
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,newsize,1,hregister)));
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
exprasmlist^.concat(new(pai68k,op_reg(A_CLR,newsize,hregister)));
emitl(A_LABEL,hlabel);
end;
else
internalerror(10061);
end;
truelabel:=oldtruelabel;
falselabel:=oldfalselabel;
end;
procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype);
var
hregister : tregister;
begin
p^.location.loc:=LOC_REGISTER;
del_reference(hp^.location.reference);
case hp^.location.loc of
LOC_MEM,LOC_REFERENCE :
begin
hregister:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(hp^.location.reference),hregister)));
end;
LOC_REGISTER,LOC_CREGISTER :
begin
hregister:=hp^.location.register;
end;
else
internalerror(10062);
end;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_OR,S_L,hregister,hregister)));
{ hregister:=reg32toreg8(hregister); }
exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
case porddef(p^.resulttype)^.typ of
bool8bit : p^.location.register:=hregister;
{ !!!!!!!!!!!
bool16bit : begin
p^.location.register:=reg8toreg16(hregister);
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
end;
bool32bit : begin
p^.location.register:=reg16toreg32(hregister);
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
end; }
else
internalerror(10064);
end;
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_smaller,second_smaller,
second_smaller,second_smaller,
second_bool_to_int,second_int_to_bool,
second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,
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_int, 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_int then
begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
end;
if (p^.convtyp<>tc_equal) and (p^.convtyp<>tc_not_possible) 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;
reg: tregister;
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
{ HERE IS A BIG PROBLEM }
{ --> We *MUST* know the data size to push }
{ for the moment, we can say that the savesize }
{ indicates the parameter size to push, but }
{ that is CERTAINLY NOT TRUE! }
{ CAN WE USE LIKE LOC_MEM OR LOC_REFERENCE?? }
case integer(p^.left^.resulttype^.savesize) of
1 : Begin
{ A byte sized value normally increments }
{ the SP by 2, BUT because how memory has }
{ been setup OR because of GAS, a byte sized }
{ push CRASHES the Amiga, therefore, we do it }
{ by hand instead. }
{ PUSH A WORD SHIFTED LEFT 8 }
reg := getregister32;
emit_reg_reg(A_MOVE, S_B, p^.left^.location.register, reg);
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_W,
8, reg)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,
reg,R_SPPUSH)));
{ offset will be TWO greater }
inc(pushedparasize,2);
ungetregister32(reg);
ungetregister32(p^.left^.location.register);
end;
2 :
Begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,
p^.left^.location.register,R_SPPUSH)));
inc(pushedparasize,2);
ungetregister32(p^.left^.location.register);
end;
4 : 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;
else
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;
end; { end case }
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 aktmoduleswitches) or (s=S_FS) 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:
Begin
{ We push a BUT, the SP is incremented by 2 }
{ as specified in the Motorola Prog's Ref Manual }
{ Therefore offet increments BY 2!!! }
{ BUG??? ... }
{ SWAP OPERANDS: }
if tempreference.isintvalue then
Begin
exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,
tempreference.offset shl 8,R_SPPUSH)));
end
else
Begin
{ A byte sized value normally increments }
{ the SP by 2, BUT because how memory has }
{ been setup OR because of GAS, a byte sized }
{ push CRASHES the Amiga, therefore, we do it }
{ by hand instead. }
{ PUSH A WORD SHIFTED LEFT 8 }
reg:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
newreference(tempreference),reg)));
exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_W,
8, reg)));
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,
reg,R_SPPUSH)));
ungetregister32(reg);
{ exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
newreference(tempreference),R_SPPUSH))); }
end;
inc(pushedparasize,2);
end;
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_check_io in aktlocalswitches) 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(A_PEA,
S_L,newcsymbol(pobjectdef(p^.methodpointer^.
resulttype)^.vmt_mangledname,0))));
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(A_PEA,S_L,
newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
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(A_PEA,S_L,
newcsymbol(pobjectdef
(p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
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
Begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(p^.methodpointer^.location.reference),R_A5)));
end;
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(A_PEA,S_L,
newcsymbol(pobjectdef(
p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
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_check_range in aktlocalswitches) then
begin
{ If the base is already A0, the no instruction will }
{ be emitted! }
emit_reg_reg(A_MOVE,S_L,r^.base,R_A0);
emitcall('CHECK_OBJECT',true);
end;
{ This was wrong we must then load the address into the }
{ register a0 and/or a5 }
{ Because doing an indirect call with offset is NOT }
{ allowed on the m68k! }
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r^),R_A0)));
{ clear the reference }
reset_reference(r^);
r^.base := R_A0;
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_MOVE,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
begin
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,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;
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 : Begin
p^.location.loc:=LOC_FPU;
hregister:=getregister32;
emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
p^.location.fpureg:=hregister;
end;
s64bit,s64real,s80real: begin
if cs_fp_emulation in aktmoduleswitches 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(A_PEA,S_L,newcsymbol(lab2str(iolabel),0))));
{ 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
{$ifdef OLDINC}
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);
{$endif}
{ 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');
addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADDQ,A_SUBQ);
var
opsize: topsize;
asmop: tasmop;
aktfile : treference;
ft : tfiletype;
pushed : tpushed;
dummycoll : tdefcoll;
procedure handlereadwrite(doread,doln : boolean);
{ produces code for READ(LN) and WRITE(LN) }
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 not (cs_compilesystem in aktmoduleswitches) 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;
has_length : boolean;
dummycoll : tdefcoll;
iolabel : plabel;
npara : longint;
begin
{ I/O check }
if cs_check_io in aktlocalswitches then
begin
getlabel(iolabel);
emitl(A_LABEL,iolabel);
end
else iolabel:=nil;
{ 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
{ 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
{ load stdin/stdout stream }
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
else
{ an WRITE Call by "Const" }
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
begin
{ push maximum string length }
push_int(pstringdef(pararesult)^.len);
case pstringdef(pararesult)^.string_typ of
st_shortstring: emitcall ('READ_TEXT_STRING',true);
st_ansistring : emitcall ('READ_TEXT_ANSISTRING',true);
st_longstring : emitcall ('READ_TEXT_LONGSTRING',true);
st_widestring : emitcall ('READ_TEXT_ANSISTRING',true);
end
end
else
Case pstringdef(Pararesult)^.string_typ of
st_shortstring: emitcall ('WRITE_TEXT_STRING',true);
st_ansistring : emitcall ('WRITE_TEXT_ANSISTRING',true);
st_longstring : emitcall ('WRITE_TEXT_LONGSTRING',true);
st_widestring : emitcall ('WRITE_TEXT_ANSISTRING',true);
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_'+float_name[pfloatdef(pararesult)^.typ],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,
bool16bit,
bool32bit : 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;
{ Insert end of writing for textfiles }
if ft=ft_text then
begin
pushusedregisters(pushed,$ffff);
emit_push_mem(aktfile);
if doread then
begin
if doln then
emitcall('READLN_END',true)
else
emitcall('READ_END',true);
end
else
begin
if doln then
emitcall('WRITELN_END',true)
else
emitcall('WRITE_END',true);
end;
popusedregisters(pushed);
maybe_loada5;
end;
{ Insert IOCheck if set }
if iolabel<>nil then
begin
{ registers are saved in the procedure }
exprasmlist^.concat(new(pai68k,op_csymbol(A_PEA,S_L,newcsymbol(lab2str(iolabel),0))));
emitcall('IOCHECK',true);
end;
{ Freeup all used temps }
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;
{inc/dec}
addconstant : boolean;
addvalue : longint;
hregister : tregister;
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;
in_length_string :
begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
end;
in_dec_x,
in_inc_x :
begin
{ set defaults }
addvalue:=1;
addconstant:=true;
{ load first parameter, must be a reference }
secondpass(p^.left^.left);
case p^.left^.left^.resulttype^.deftype of
orddef,
enumdef : begin
case p^.left^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
end;
pointerdef : begin
opsize:=S_L;
addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.savesize;
end;
else
internalerror(10081);
end;
{ second argument specified?, must be a s32bit in register }
if assigned(p^.left^.right) then
begin
secondpass(p^.left^.right^.left);
{ when constant, just multiply the addvalue }
if is_constintnode(p^.left^.right^.left) then
addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left)
else
begin
case p^.left^.right^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register;
LOC_MEM,
LOC_REFERENCE : begin
hregister:=getregister32;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
newreference(p^.left^.right^.left^.location.reference),hregister)));
end;
else
internalerror(10082);
end;
{ insert multiply with addvalue if its >1 }
if addvalue>1 then
exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,opsize,
addvalue,hregister)));
addconstant:=false;
end;
end;
{ write the add instruction }
if addconstant then
begin
exprasmlist^.concat(new(pai68k,op_const_ref(addsubop[p^.inlinenumber],opsize,
addvalue,newreference(p^.left^.left^.location.reference))));
end
else
begin
exprasmlist^.concat(new(pai68k,op_reg_ref(addsubop[p^.inlinenumber],opsize,
hregister,newreference(p^.left^.left^.location.reference))));
ungetregister32(hregister);
end;
emitoverflowcheck(p^.left^.left);
end;
{$ifdef OLDINC}
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;
{$endif}
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_const_reg(asmop,opsize,1,
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 :
handlereadwrite(true,true);
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.base:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
p^.left^.location.register,
p^.location.reference.base)));
end;
LOC_MEM,LOC_REFERENCE :
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;
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;
j: byte;
begin
{ this should be reimplemented for smallsets }
{ differently (PM) }
{ produce constant part }
j:=0;
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 div 4) do
Begin
{ This is required because of the ENDIAN of m68k machines }
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+3])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+2])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+1])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j])));
Inc(j,4);
{ datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));}
end;
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;
loadsetelement(hp^.left);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
newreference(sref),R_A0)));;
{ 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;
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 aktmoduleswitches 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_FS,
p^.left^.location.fpureg,R_D0)));
end;
end;
end
else
Begin
{ 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;
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 aktglobalswitches^ ) 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 aktglobalswitches^ ) 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 aktglobalswitches 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 aktglobalswitches 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 secondon(var p : ptree);
var
nextonlabel,myendexceptlabel : plabel;
ref : treference;
begin
{ !!!!!!!!!!!!!!! }
(* getlabel(nextonlabel);
{ push the vmt }
exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,
newcsymbol(p^.excepttype^.vmt_mangledname,0))));
maybe_concat_external(p^.excepttype^.owner,
p^.excepttype^.vmt_mangledname);
emitcall('FPC_CATCHES',true);
exprasmlist^.concat(new(pai386,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitl(A_JE,nextonlabel);
ref.symbol:=nil;
gettempofsizereference(4,ref);
{ what a hack ! }
if assigned(p^.exceptsymtable) then
pvarsym(p^.exceptsymtable^.root)^.address:=ref.offset;
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EAX,newreference(ref))));
if assigned(p^.right) then
secondpass(p^.right);
{ clear some stuff }
ungetiftemp(ref);
emitl(A_JMP,endexceptlabel);
emitl(A_LABEL,nextonlabel);
{ next on node }
if assigned(p^.left) then
secondpass(p^.left); *)
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 secondprocinline(var p:ptree);
begin
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,
secondstatement,secondnothing,secondifn,secondbreakn,
secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
secondexitn,secondwith,secondcase,secondlabel,
secondgoto,secondsimplenewdispose,secondtryexcept,
secondraise,
secondnothing,secondtryfinally,secondon,secondis,
secondas,seconderror,
secondfail,secondadd,secondprocinline,
secondnothing,secondloadvmt);
var
oldcodegenerror : boolean;
oldlocalswitches : tlocalswitches;
oldpos : tfileposinfo;
begin
oldcodegenerror:=codegenerror;
oldlocalswitches:=aktlocalswitches;
oldpos:=aktfilepos;
aktfilepos:=p^.fileinfo;
aktlocalswitches:=p^.localswitches;
if not(p^.error) then
begin
codegenerror:=false;
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else
codegenerror:=true;
aktlocalswitches:=oldlocalswitches;
aktfilepos:=oldpos;
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)^.var_options and vo_regable)<>0) 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 aktglobalswitches 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
i : longint;
regsize : topsize;
regi : tregister;
hr : preference;
label
nextreg;
begin
cleartempgen;
{ when size optimization only count occurrence }
if cs_littlesize in aktglobalswitches 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_regalloc in aktglobalswitches) 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 (status.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);
end;
end.
{
$Log$
Revision 1.14 1998-08-19 16:07:39 jonas
* changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
Revision 1.13 1998/08/10 14:43:14 peter
* string type st_ fixed
Revision 1.12 1998/07/15 16:41:01 jonas
* fixed bug that caused the stackframe never to be omitted
Revision 1.11 1998/07/14 14:46:43 peter
* released NEWINPUT
Revision 1.10 1998/07/10 10:50:57 peter
* m68k updates
Revision 1.9 1998/07/06 15:51:16 michael
Added length checking for string reading
Revision 1.8 1998/06/12 10:32:22 pierre
* column problem hopefully solved
+ C vars declaration changed
Revision 1.7 1998/06/09 16:01:36 pierre
+ added procedure directive parsing for procvars
(accepted are popstack cdecl and pascal)
+ added C vars with the following syntax
var C calias 'true_c_name';(can be followed by external)
reason is that you must add the Cprefix
which is target dependent
Revision 1.6 1998/06/08 13:13:36 pierre
+ temporary variables now in temp_gen.pas unit
because it is processor independent
* mppc68k.bat modified to undefine i386 and support_mmx
(which are defaults for i386)
Revision 1.5 1998/06/04 23:51:34 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32
Revision 1.4 1998/04/29 10:33:44 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.3 1998/04/07 22:45:03 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
}
Reference in New Issue View Git Blame Copy Permalink