ORCA-C/Gen.pas
Stephen Heumann 05ecf5eef3 Add option to use the declared type for float/double/comp params.
This differs from the usual ORCA/C behavior of treating all floating-point parameters as extended. With the option enabled, they will still be passed in the extended format, but will be converted to their declared type at the start of the function. This is needed for strict standards conformance, because you should be able to take the address of a parameter and get a usable pointer to its declared type. The difference in types can also affect the behavior of _Generic expressions.

The implementation of this is based on ORCA/Pascal, which already did the same thing (unconditionally) with real/double/comp parameters.
2022-09-18 21:16:46 -05:00

7640 lines
247 KiB
ObjectPascal

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Gen }
{ }
{ Generates native code from intermediate code instructions. }
{ }
{---------------------------------------------------------------}
unit Gen;
interface
{$segment 'gen'}
{$LibPrefix '0/obj/'}
uses CCommon, CGI, CGC, ObjOut, Native;
{---------------------------------------------------------------}
function LabelToDisp (lab: integer): integer;
{ convert a local label number to a stack frame displacement }
{ }
{ parameters: }
{ lab - label number }
procedure Gen (blk: blockPtr);
{ Generates native code for a list of blocks }
{ }
{ parameters: }
{ blk - first of the list of blocks }
{---------------------------------------------------------------}
implementation
const
{longword/quadword locations}
A_X = 1; {longword only}
onStack = 2;
inPointer = 4;
localAddress = 8;
globalLabel = 16;
constant = 32;
nowhere = 64;
inStackLoc = 128;
{stack frame locations}
{---------------------}
returnSize = 3; {size of return address}
type
{possible locations for 4 byte values}
longType = record {description of current four byte value}
preference: integer; {where you want the value (bitmask)}
where: integer; {where the value is at}
fixedDisp: boolean; {is the displacement a fixed value?}
isLong: boolean; {is long addr required for named labs?}
disp: integer; {fixed displacement/local addr}
lval: longint; {value}
lab: stringPtr; {global label name}
end;
{possible locations for 8 byte values}
{note: these always have fixed disp}
quadType = record {description of current 8 byte value}
preference: integer; {where you want the value (single value)}
where: integer; {where the value is at}
disp: integer; {fixed displacement/local addr}
lval: longlong; {value}
lab: stringPtr; {global label name}
end;
var
gLong: longType; {info about last long value}
gQuad: quadType; {info about last quad value}
namePushed: boolean; {has a name been pushed in this proc?}
skipLoad: boolean; {skip load for a pc_lli, etc?}
stackSaveDepth: integer; {nesting depth of saved stack positions}
argsSize: integer; {total size of argument to a function}
isQuadFunction: boolean; {is the return type cg(U)Quad?}
{stack frame locations}
{---------------------}
bankLoc: integer; {disp in dp where bank reg is stored}
dworkLoc: integer; {disp in dp of 4 byte work spage for cg}
funLoc: integer; {loc of fn ret value in stack frame}
localSize: integer; {local space for current proc}
parameterSize: integer; {# bytes of parameters for current proc}
stackLoc: integer; {disp in dp where stack reg is stored}
{---------------------------------------------------------------}
procedure GenTree (op: icptr); forward;
procedure OperA (mop: integer; op: icptr);
{ Do an operation on op that has addr modes equivalent to STA }
{ }
{ parameters: }
{ op - node to generate the leaf for }
{ mop - operation }
var
loc: integer; {stack frame position}
opcode: pcodes; {temp storage}
begin {OperA}
opcode := op^.opcode;
case opcode of
pc_ldo,pc_gil,pc_gli,pc_gdl,pc_gld: begin
case mop of
m_cmp_imm: mop := m_cmp_abs;
m_adc_imm: mop := m_adc_abs;
m_and_imm: mop := m_and_abs;
m_ora_imm: mop := m_ora_abs;
m_sbc_imm: mop := m_sbc_abs;
m_eor_imm: mop := m_eor_abs;
otherwise: Error(cge1);
end; {case}
if opcode = pc_gil then
GenNative(m_inc_abs, absolute, op^.q, op^.lab, 0)
else if opcode = pc_gdl then
GenNative(m_dec_abs, absolute, op^.q, op^.lab, 0);
if smallMemoryModel then
GenNative(mop, absolute, op^.q, op^.lab, 0)
else
GenNative(mop+2, longAbs, op^.q, op^.lab, 0);
if opcode in [pc_gli,pc_gld] then begin
if mop in [m_sbc_dir,m_cmp_dir] then
GenImplied(m_php);
if opcode = pc_gli then
GenNative(m_inc_abs, absolute, op^.q, op^.lab, 0)
else {if opcode = pc_gld then}
GenNative(m_dec_abs, absolute, op^.q, op^.lab, 0);
if mop in [m_sbc_dir,m_cmp_dir] then
GenImplied(m_plp);
end; {else}
end; {case pc_ldo,pc_gil,pc_gli,pc_gdl,pc_gld}
pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl: begin
case mop of
m_cmp_imm: mop := m_cmp_dir;
m_adc_imm: mop := m_adc_dir;
m_and_imm: mop := m_and_dir;
m_ora_imm: mop := m_ora_dir;
m_sbc_imm: mop := m_sbc_dir;
m_eor_imm: mop := m_eor_dir;
otherwise: Error(cge1);
end; {case}
loc := LabelToDisp(op^.r);
if opcode = pc_lod then
loc := loc + op^.q;
if opcode = pc_lil then
GenNative(m_inc_dir, direct, loc, nil, 0)
else if opcode = pc_ldl then
GenNative(m_dec_dir, direct, loc, nil, 0);
GenNative(mop, direct, loc, nil, 0);
if opcode in [pc_lli,pc_lld] then begin
if mop in [m_sbc_dir,m_cmp_dir] then
GenImplied(m_php);
if opcode = pc_lli then
GenNative(m_inc_dir, direct, loc, nil, 0)
else {if opc = pc_lld then}
GenNative(m_dec_dir, direct, loc, nil, 0);
if mop in [m_sbc_dir,m_cmp_dir] then
GenImplied(m_plp);
end; {else}
end; {case pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl}
pc_ldc:
GenNative(mop, immediate, op^.q, nil, 0);
otherwise:
Error(cge1);
end; {case}
end; {OperA}
function Complex (op: icptr): boolean;
{ determine if loading the intermediate code involves anything }
{ but one reg }
{ }
{ parameters: }
{ code - intermediate code to check }
{ }
{ NOTE: for one and two byte values only!!! }
begin {Complex}
Complex := true;
if op^.opcode in [pc_ldo,pc_ldc] then
Complex := false
else if op^.opcode in [pc_gil,pc_gli,pc_gdl,pc_gld] then
Complex := smallMemoryModel
else if op^.opcode = pc_lod then
if LabelToDisp(op^.r) + op^.q < 256 then
Complex := false
else if op^.opcode in [pc_lli,pc_lil,pc_ldl,pc_lld] then
if LabelToDisp(op^.r) < 256 then
Complex := false;
if op^.optype in [cgByte,cgUByte] then
Complex := true;
end; {Complex}
procedure DoOp(op_imm, op_abs, op_dir: integer; icode: icptr; disp: integer);
{ Do an operation. }
{ }
{ Parameters: }
{ op_imm,op_abs,op_dir - op codes for the various }
{ addressing modes }
{ icode - intermediate code record }
{ disp - disp past the location (1 or 2) }
var
val: integer; {value for immediate operations}
lval: longint; {long value for immediate operations}
begin {DoOp}
if icode^.opcode = pc_ldc then begin
lval := icode^.lval;
if disp = 0 then
val := long(lval).lsw
else
val := long(lval).msw;
GenNative(op_imm, immediate, val, nil, 0);
end {if}
else if icode^.opcode in [pc_lod,pc_str] then
GenNative(op_dir, direct, LabelToDisp(icode^.r) + icode^.q + disp, nil, 0)
else {if icode^.opcode in [pc_ldo, pc_sro] then}
GenNative(op_abs, absolute, icode^.q + disp, icode^.lab, 0);
end; {DoOp}
procedure OpOnWordOfQuad (mop: integer; op: icptr; offset: integer);
{ Do an operation that has addr modes equivalent to LDA on the }
{ subword at specified offset of the location specified by op. }
{ }
{ The generated code may modify X, and may set Y to offset. }
{ }
{ parameters: }
{ mop - machine opcode }
{ op - node to generate the leaf for }
{ offset - offset of the word to access (0, 2, 4, or 6) }
var
loc: integer; {stack frame position}
val: integer; {immediate value}
begin {OpOnWordOfQuad}
case op^.opcode of
pc_ldo: begin
case mop of
m_lda_imm: mop := m_lda_abs;
m_cmp_imm: mop := m_cmp_abs;
m_adc_imm: mop := m_adc_abs;
m_and_imm: mop := m_and_abs;
m_ora_imm: mop := m_ora_abs;
m_sbc_imm: mop := m_sbc_abs;
m_eor_imm: mop := m_eor_abs;
otherwise: Error(cge1);
end; {case}
if smallMemoryModel then
GenNative(mop, absolute, op^.q+offset, op^.lab, 0)
else
GenNative(mop+2, longAbs, op^.q+offset, op^.lab, 0);
end; {case pc_ldo}
pc_lod: begin
case mop of
m_lda_imm: mop := m_lda_dir;
m_cmp_imm: mop := m_cmp_dir;
m_adc_imm: mop := m_adc_dir;
m_and_imm: mop := m_and_dir;
m_ora_imm: mop := m_ora_dir;
m_sbc_imm: mop := m_sbc_dir;
m_eor_imm: mop := m_eor_dir;
otherwise: Error(cge1);
end; {case}
loc := LabelToDisp(op^.r) + op^.q + offset;
if loc < 256 then
GenNative(mop, direct, loc, nil, 0)
else begin
GenNative(m_ldx_imm, immediate, loc, nil, 0);
GenNative(mop+$10, direct, 0, nil, 0);
end; {else}
end; {case pc_lod}
pc_ldc: begin
case offset of
0: val := long(op^.qval.lo).lsw;
2: val := long(op^.qval.lo).msw;
4: val := long(op^.qval.hi).lsw;
6: val := long(op^.qval.hi).msw;
otherwise: Error(cge1);
end; {case}
GenNative(mop, immediate, val, nil, 0);
end; {case pc_ldc}
pc_ind: begin
case mop of
m_lda_imm: mop := m_lda_indl;
m_cmp_imm: mop := m_cmp_indl;
m_adc_imm: mop := m_adc_indl;
m_and_imm: mop := m_and_indl;
m_ora_imm: mop := m_ora_indl;
m_sbc_imm: mop := m_sbc_indl;
m_eor_imm: mop := m_eor_indl;
otherwise: Error(cge1);
end; {case}
if op^.left^.opcode = pc_lod then
loc := LabelToDisp(op^.left^.r) + op^.left^.q;
if (op^.left^.opcode <> pc_lod) or (loc > 255) then
Error(cge1);
if offset = 0 then
GenNative(mop, direct, loc, nil, 0)
else begin
GenNative(m_ldy_imm, immediate, offset, nil, 0);
GenNative(mop+$10, direct, loc, nil, 0);
end; {else}
end; {case pc_ind}
otherwise:
Error(cge1);
end; {case}
end; {OpOnWordOfQuad}
function SimpleQuadLoad(op: icptr): boolean;
{ Is op a simple load operation on a cg(U)Quad, which can be }
{ broken up into word operations handled by OpOnWordOfQuad? }
{ }
{ parameters: }
{ op - node to check }
begin {SimpleQuadLoad}
case op^.opcode of
pc_ldo,pc_lod,pc_ldc:
SimpleQuadLoad := true;
pc_ind:
SimpleQuadLoad :=
(op^.left^.opcode = pc_lod)
and (LabelToDisp(op^.left^.r) + op^.left^.q < 256);
otherwise:
SimpleQuadLoad := false;
end; {case}
end; {SimpleQuadLoad}
function SimplestQuadLoad(op: icptr): boolean;
{ Is op a simple load operation on a cg(U)Quad, which can be }
{ broken up into word operations handled by OpOnWordOfQuad }
{ and for which those operations will not modify X or Y. }
{ }
{ parameters: }
{ op - node to check }
begin {SimplestQuadLoad}
case op^.opcode of
pc_ldo,pc_ldc:
SimplestQuadLoad := true;
pc_lod:
SimplestQuadLoad := LabelToDisp(op^.r) + op^.q < 250;
pc_ind,otherwise:
SimplestQuadLoad := false;
end; {case}
end; {SimplestQuadLoad}
procedure StoreWordOfQuad(offset: integer);
{ Store one word of a quad value to the location specified by }
{ gQuad.preference. The word value to store must be in A. }
{ }
{ The generated code may modify X, and may set Y to offset. }
{ It does not modify A or the carry flag. }
{ }
{ parameters: }
{ offset - offset of the word to store (0, 2, 4, or 6) }
{ }
{ Note: If gQuad.preference is onStack, this just generates a }
{ PHA. That is suitable if storing a value starting from }
{ the most significant word, but not in other cases. For }
{ other gQuad.preference values, any order is okay. }
begin {StoreWordOfQuad}
case gQuad.preference of
localAddress: begin
if gQuad.disp+offset <= 255 then
GenNative(m_sta_dir, direct, gQuad.disp+offset, nil, 0)
else begin
GenNative(m_ldx_imm, immediate, gQuad.disp+offset, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
end; {else}
end;
globalLabel: begin
if smallMemoryModel then
GenNative(m_sta_abs, absolute, gQuad.disp+offset, gQuad.lab, 0)
else
GenNative(m_sta_long, longabsolute, gQuad.disp+offset, gQuad.lab, 0);
end;
inPointer: begin
if (gQuad.disp > 255) or (gQuad.disp < 0) then
Error(cge1);
if offset = 0 then
GenNative(m_sta_indl, direct, gQuad.disp, nil, 0)
else begin
GenNative(m_ldy_imm, immediate, offset, nil, 0);
GenNative(m_sta_indly, direct, gQuad.disp, nil, 0);
end; {else}
end;
inStackLoc:
GenNative(m_sta_s, direct, gQuad.disp+offset, nil, 0);
onStack:
GenImplied(m_pha);
nowhere: ; {discard the value}
otherwise: Error(cge1);
end; {case}
end; {StoreWordOfQuad}
procedure GetPointer (op: icptr);
{ convert a tree into a usable pointer for indirect }
{ loads/stores }
{ }
{ parameters: }
{ op - pointer tree }
begin {GetPointer}
gLong.preference := A_X+inPointer+localAddress+globalLabel;
GenTree(op);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
gLong.where := A_X;
end; {if}
if gLong.where = A_X then begin
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
gLong.where := inPointer;
gLong.fixedDisp := true;
gLong.disp := dworkLoc;
end; {else if}
end; {GetPointer}
procedure IncAddr (size: integer);
{ add a two byte constant to a four byte value - generally an }
{ address }
{ }
{ parameters: }
{ size - integer to add }
var
lab1: integer; {branch point}
begin {IncAddr}
if size <> 0 then
case gLong.where of
onStack: begin
lab1 := GenLabel;
GenImplied(m_pla);
if size = 1 then begin
GenImplied(m_ina);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, size, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
GenImplied(m_plx);
GenImplied(m_inx);
GenImplied(m_phx);
GenLab(lab1);
GenImplied(m_pha);
end;
A_X: begin
lab1 := GenLabel;
if size = 1 then begin
GenImplied(m_ina);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, size, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
GenImplied(m_inx);
GenLab(lab1);
end;
inPointer:
if gLong.fixedDisp then begin
gLong.fixedDisp := false;
GenNative(m_ldy_imm, immediate, size, nil, 0);
end {if}
else if size <= 4 then begin
while size <> 0 do begin
GenImplied(m_iny);
size := size - 1;
end; {while}
end {else if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, size, nil, 0);
GenImplied(m_tay);
end; {else}
localAddress,globalLabel:
gLong.disp := gLong.disp+size;
otherwise:
Error(cge1);
end; {case}
end; {IncAddr}
procedure LoadX (op: icptr);
{ Load X with a two byte value }
{ }
{ parameters: }
{ op - value to load }
var
q, r: integer;
lab: stringPtr;
begin {LoadX}
q := op^.q;
r := op^.r;
lab := op^.lab;
case op^.opcode of
pc_lao,pc_lda:
Error(cge1);
pc_ldc:
GenNative(m_ldx_imm, immediate, q, nil, 0);
pc_ldo:
GenNative(m_ldx_abs, absolute, q, lab, 0);
pc_gli: begin
GenNative(m_ldx_abs, absolute, q, lab, 0);
GenNative(m_inc_abs, absolute, q, lab, 0);
end; {if}
pc_gil: begin
GenNative(m_inc_abs, absolute, q, lab, 0);
GenNative(m_ldx_abs, absolute, q, lab, 0);
end; {if}
pc_gld: begin
GenNative(m_ldx_abs, absolute, q, lab, 0);
GenNative(m_dec_abs, absolute, q, lab, 0);
end; {if}
pc_gdl: begin
GenNative(m_dec_abs, absolute, q, lab, 0);
GenNative(m_ldx_abs, absolute, q, lab, 0);
end; {if}
pc_lod:
GenNative(m_ldx_dir, direct, LabelToDisp(r) + q, nil, 0);
pc_lli: begin
GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0);
GenNative(m_inc_dir, direct, LabelToDisp(r), nil, 0);
end; {if}
pc_lil: begin
GenNative(m_inc_dir, direct, LabelToDisp(r), nil, 0);
GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0);
end; {if}
pc_lld: begin
GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0);
GenNative(m_dec_dir, direct, LabelToDisp(r), nil, 0);
end; {if}
pc_ldl: begin
GenNative(m_dec_dir, direct, LabelToDisp(r), nil, 0);
GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0);
end; {if}
otherwise:
Error(cge1);
end; {case}
end; {LoadX}
function NeedsCondition (opcode: pcodes): boolean;
{ See if the operation is one that doesn't set the condition }
{ code reliably }
{ }
{ Parameters: }
{ opcodes - operation to check }
{ }
{ Returns: True if the condition code is not set properly for }
{ an operand type of cgByte,cgUByte,cgWord,cgUWord, else }
{ false }
begin {NeedsCondition}
NeedsCondition := opcode in
[pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,pc_ldl,pc_lil,pc_lld,
pc_lli,pc_gil,pc_gli,pc_gdl,pc_gld,pc_iil,pc_ili,pc_idl,pc_ild,
pc_cop,pc_cpo,pc_cpi,pc_dvi,pc_mpi,pc_adi,pc_sbi,pc_mod,pc_bno,
pc_udi,pc_uim,pc_umi,pc_cnv,pc_rbo,pc_shl,pc_shr,pc_usr,pc_lbf,
pc_lbu,pc_cbf,pc_tri];
end; {NeedsCondition}
function SameLoc (load, save: icptr): boolean;
{ See if load and save represent the same location (which must }
{ be a direct page value or a global label). }
{ }
{ parameters: }
{ load - load operation }
{ save - save operation }
{ }
{ Returns: True the the same location is used, else false }
begin {SameLoc}
SameLoc := false;
if save <> nil then begin
if load^.opcode = pc_lod then begin
if LabelToDisp(load^.r) + load^.q < 254 then
if save^.opcode = pc_str then
if save^.q = load^.q then
if save^.r = load^.r then
SameLoc := true;
end {if}
else if smallMemoryModel then
if load^.opcode = pc_ldo then
if save^.opcode = pc_sro then
if load^.lab^ = save^.lab^ then
if load^.q = save^.q then
SameLoc := true;
end; {if}
end; {SameLoc}
procedure SaveRetValue (optype: baseTypeEnum);
{ save a value returned by a function }
{ }
{ parameters: }
{ optype - function type }
begin {SaveRetValue}
if optype in [cgLong,cgULong] then begin
if (A_X & gLong.preference) = 0 then begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end
else
gLong.where := A_X;
end {if}
else if optype in [cgReal,cgDouble,cgExtended,cgComp] then
GenCall(8);
end; {SaveRetValue}
procedure GenAdlSbl (op, save: icptr);
{ generate code for pc_adl, pc_sbl }
{ }
{ parameters: }
{ op - pc_adl or pc_sbl operation }
{ save - save location (pc_str or pc_sro) or nil }
var
bcc,clc,adc_imm,inc_dir,adc_abs, {for op-code insensitive code}
adc_dir,inc_abs,adc_s: integer;
disp: integer; {direct page location}
lab1: integer; {label number}
lLong: longType; {used to reserve gLong}
nd: icptr; {for swapping left/right children}
opcode: pcodes; {temp storage; for efficiency}
simpleStore: boolean; {is the store absolute or direct?}
val: longint; {long constant value}
function Simple (icode: icptr): boolean;
{ See if the intermediate code is simple; i.e., can be }
{ reached by direct page or absolute addressing. }
var
load: icptr; {left opcode}
begin {Simple}
Simple := false;
if icode^.opcode = pc_ldc then
Simple := true
else if icode^.opcode in [pc_lod,pc_str] then begin
if LabelToDisp(icode^.r) + icode^.q < 254 then
Simple := true;
end {else if}
else if icode^.opcode in [pc_ldo,pc_sro] then
Simple := smallMemoryModel;
end; {Simple}
begin {GenAdlSbl}
{determine where the result goes}
if save <> nil then
gLong.preference :=
A_X+onStack+inPointer+localAddress+globalLabel+constant;
lLong := gLong;
{set up the master instructions}
opcode := op^.opcode;
if opcode = pc_adl then begin
clc := m_clc;
bcc := m_bcc;
adc_imm := m_adc_imm;
adc_abs := m_adc_abs;
adc_dir := m_adc_dir;
adc_s := m_adc_s;
inc_dir := m_inc_dir;
inc_abs := m_inc_abs;
end {if}
else begin
clc := m_sec;
bcc := m_bcs;
adc_imm := m_sbc_imm;
adc_abs := m_sbc_abs;
adc_dir := m_sbc_dir;
adc_s := m_sbc_s;
inc_dir := m_dec_dir;
inc_abs := m_dec_abs;
end; {else}
{if the lhs is a constant, swap the nodes}
if ((op^.left^.opcode = pc_ldc) and (opcode = pc_adl)) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
{handle a constant rhs}
if op^.right^.opcode = pc_ldc then
val := op^.right^.lval
else
val := -1;
if SameLoc(op^.left, save) and (long(val).msw = 0) then begin
lab1 := GenLabel;
if val = 1 then begin
if opcode = pc_adl then begin
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
GenNative(m_bne, relative, lab1, nil, 0);
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
GenLab(lab1);
end {if}
else {if opcode = pc_sbl then} begin
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
GenNative(m_beq, relative, lab1, nil, 0);
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
GenLab(lab1);
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
end; {else}
end {if}
else begin {rhs in [2..65535]}
GenImplied(clc);
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
GenNative(adc_imm, immediate, long(val).lsw, nil, 0);
DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
GenNative(bcc, relative, lab1, nil, 0);
if opcode = pc_adl then
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2)
else
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
GenLab(lab1);
end; {else}
end {if constant rhs}
else begin
simpleStore := false;
if save <> nil then
simpleStore := Simple(save);
if (opcode = pc_adl) and Simple(op^.left) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
if simpleStore and Simple(op^.right) then begin
if Simple(op^.left) then begin
GenImplied(clc);
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
DoOp(0, m_sta_abs, m_sta_dir, save, 0);
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 2);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
DoOp(0, m_sta_abs, m_sta_dir, save, 2);
end {if}
else begin
gLong.preference := A_X;
GenTree(op^.left);
GenImplied(clc);
if gLong.where = onStack then
GenImplied(m_pla);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
DoOp(0, m_sta_abs, m_sta_dir, save, 0);
if gLong.where = onStack then
GenImplied(m_pla)
else
GenImplied(m_txa);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
DoOp(0, m_sta_abs, m_sta_dir, save, 2);
end; {else}
end {if}
else if (save = nil) and Simple(op^.right) then begin
gLong.preference := gLong.preference & A_X;
GenTree(op^.left);
GenImplied(clc);
if gLong.where = onStack then begin
GenImplied(m_pla);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
GenImplied(m_pha);
GenNative(m_lda_s, direct, 3, nil, 0);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
GenNative(m_sta_s, direct, 3, nil, 0);
end {if}
else begin
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0);
GenImplied(m_tay);
GenImplied(m_txa);
DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2);
GenImplied(m_tax);
GenImplied(m_tya);
end; {else}
end {else if}
else begin {doing it the hard way}
gLong.preference := onStack;
GenTree(op^.right);
gLong.preference := onStack;
GenTree(op^.left);
GenImplied(clc);
GenImplied(m_pla);
GenNative(adc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenImplied(m_pla);
GenNative(adc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
if save = nil then
gLong.where := onStack
else if save^.opcode = pc_str then begin
disp := LabelToDisp(save^.r) + save^.q;
if disp < 254 then begin
GenImplied(m_pla);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_dir, direct, disp+2, nil, 0);
end {else if}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_dirX, direct, 2, nil, 0);
end; {else}
end {else if}
else {if save^.opcode = pc_sro then} begin
GenImplied(m_pla);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
else
GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
GenImplied(m_pla);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, save^.q+2, save^.lab, 0)
else
GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
end; {else}
end; {else}
end; {else}
end; {GenAdlSbl}
procedure GenAdqSbq (op: icptr);
{ generate code for pc_adq, pc_sbq }
{ }
{ parameters: }
{ op - pc_adq or pc_sbq operation }
begin {GenAdqSbq}
if op^.opcode = pc_adq then begin
if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin
gQuad.where := gQuad.preference;
if gQuad.preference = onStack then begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
gQuad.preference := inStackLoc;
gQuad.disp := 1;
end; {if}
GenImplied(m_clc);
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
OpOnWordOfQuad(m_adc_imm, op^.right, 0);
StoreWordOfQuad(0);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
OpOnWordOfQuad(m_adc_imm, op^.right, 2);
StoreWordOfQuad(2);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
OpOnWordOfQuad(m_adc_imm, op^.right, 4);
StoreWordOfQuad(4);
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
OpOnWordOfQuad(m_adc_imm, op^.right, 6);
StoreWordOfQuad(6);
end {if}
else begin
gQuad.preference := onStack;
GenTree(op^.right);
gQuad.preference := onStack;
GenTree(op^.left);
GenImplied(m_clc);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
gQuad.where := onStack;
end; {else}
end {if}
else {if op^.opcode = pc_sbq then} begin
if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin
gQuad.where := gQuad.preference;
if gQuad.preference = onStack then begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
gQuad.preference := inStackLoc;
gQuad.disp := 1;
end; {if}
GenImplied(m_sec);
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
OpOnWordOfQuad(m_sbc_imm, op^.right, 0);
StoreWordOfQuad(0);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
OpOnWordOfQuad(m_sbc_imm, op^.right, 2);
StoreWordOfQuad(2);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
OpOnWordOfQuad(m_sbc_imm, op^.right, 4);
StoreWordOfQuad(4);
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
OpOnWordOfQuad(m_sbc_imm, op^.right, 6);
StoreWordOfQuad(6);
end {if}
else begin
gQuad.preference := onStack;
GenTree(op^.right);
gQuad.preference := onStack;
GenTree(op^.left);
GenImplied(m_sec);
GenImplied(m_pla);
GenNative(m_sbc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sbc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sbc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sbc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
gQuad.where := onStack;
end; {else}
end; {else}
end; {GenAdqSbq}
procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer);
{ generate code for pc_les, pc_leq, pc_grt or pc_geq }
{ }
{ parameters: }
{ op - operation }
{ rOpcode - Opcode that will use the result of the }
{ compare. If the result is used by a tjp or fjp, }
{ this procedure generated special code and does the }
{ branch internally. }
{ lb - For fjp, tjp, this is the label to branch to if }
{ the condition is satisfied. }
var
i: integer; {loop variable}
lab1,lab2,lab3,lab4: integer; {label numbers}
num: integer; {constant to compare to}
simple: boolean; {is this a simple case?}
alwaysFalse: boolean; {is the comparison always false?}
procedure Switch;
{ switch the operands }
var
nd: icptr; {used to switch nodes}
begin {Switch}
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {Switch}
begin {GenCmp}
{To reduct the number of possibilities that must be handled, pc_les }
{and pc_leq compares are reduced to their equivalent pc_grt and }
{pc_geq instructions. }
if op^.opcode = pc_les then begin
Switch;
op^.opcode := pc_grt;
end {if}
else if op^.opcode = pc_leq then begin
Switch;
op^.opcode := pc_geq;
end; {else if}
{To take advantage of shortcuts, switch operands if generating }
{for a tjp or fjp with a constant left operand. }
if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then
if op^.left^.opcode = pc_ldc then
if rOpcode in [pc_tjp,pc_fjp] then begin
if op^.opcode = pc_geq then
op^.opcode := pc_grt
else
op^.opcode := pc_geq;
if rOpcode = pc_tjp then
rOpcode := pc_fjp
else
rOpcode := pc_tjp;
Switch;
end; {if}
{Short cuts are available for single-word operands where the }
{right operand is a constant. }
if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
(op^.right^.opcode = pc_ldc) then begin
GenTree(op^.left);
num := op^.right^.q;
{Convert x > N comparisons to x >= N+1, unless N is max value }
{(in which case x > N is always false). }
alwaysFalse := false;
if op^.opcode = pc_grt then begin
if ((op^.optype in [cgByte,cgWord]) and (num = 32767))
or ((op^.optype in [cgUByte,cgUWord]) and (num = -1)) then
alwaysFalse := true
else begin
op^.opcode := pc_geq;
num := num+1;
end; {else}
end; {if}
lab1 := GenLabel;
if rOpcode = pc_fjp then begin
if alwaysFalse then
GenNative(m_brl, longrelative, lb, nil, 0)
else if op^.optype in [cgByte,cgWord] then begin
if NeedsCondition(op^.left^.opcode) then
GenImpliedForFlags(m_tax);
if (num >= 0) and (num < 3) then begin
if num <> 0 then begin
lab2 := GenLabel;
GenNative(m_bmi, relative, lab2, nil, 0);
for i := 1 to num do
GenImplied(m_dea);
end; {if}
GenNative(m_bpl, relative, lab1, nil, 0);
if num <> 0 then
GenLab(lab2);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if (num >= 0) and (num < 3)}
else begin
lab2 := GenLabel;
if num > 0 then
GenNative(m_bmi, relative, lab1, nil, 0)
else
GenNative(m_bpl, relative, lab1, nil, 0);
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcs, relative, lab2, nil, 0);
if num > 0 then begin
GenLab(lab1);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {if}
else begin
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
GenLab(lab1);
end; {else}
end; {else if}
end {if}
else {if optype in [cgUByte,cgUWord] then} begin
if num <> 0 then begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end; {if}
end; {else}
end {if rOpcode = pc_fjp}
else if rOpcode = pc_tjp then begin
if alwaysFalse then
{nothing to generate}
else if op^.optype in [cgByte,cgWord] then begin
if NeedsCondition(op^.left^.opcode) then
GenImpliedForFlags(m_tax);
if (num >= 0) and (num < 3) then begin
GenNative(m_bmi, relative, lab1, nil, 0);
if num > 0 then begin
for i := 1 to num do
GenImplied(m_dea);
GenNative(m_bmi, relative, lab1, nil, 0);
end; {if}
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if (num >= 0) and (num < 3)}
else begin
lab2 := GenLabel;
if num > 0 then
GenNative(m_bmi, relative, lab1, nil, 0)
else
GenNative(m_bpl, relative, lab1, nil, 0);
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcc, relative, lab2, nil, 0);
if num > 0 then begin
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
GenLab(lab1);
end {if}
else begin
GenLab(lab1);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end; {else}
end; {else}
end {if}
else {if optype in [cgUByte,cgUWord] then} begin
if num <> 0 then begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {if}
GenNative(m_brl, longrelative, lb, nil, 0);
if num <> 0 then
GenLab(lab1);
end; {else}
end {if rOpcode = pc_tjp}
else if alwaysFalse then
GenNative(m_lda_imm, immediate, 0, nil, 0)
else if op^.optype in [cgByte,cgWord] then begin
lab2 := GenLabel;
GenNative(m_ldx_imm, immediate, 1, nil, 0);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, num, nil, 0);
GenNative(m_bvs, relative, lab1, nil, 0);
GenNative(m_eor_imm, immediate, $8000, nil, 0);
GenLab(lab1);
GenNative(m_bmi, relative, lab2, nil, 0);
GenImplied(m_dex);
GenLab(lab2);
GenImplied(m_txa);
end {else if}
else begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenImplied(m_rol_a);
end; {else if}
end {if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
(op^.right^.opcode = pc_ldc)}
{This section of code handles the cases where the above short }
{cuts cannot be used. }
else
case op^.optype of
cgByte,cgUByte,cgWord,cgUWord: begin
if Complex(op^.right) then begin
GenTree(op^.right);
if Complex(op^.left) then begin
GenImplied(m_pha);
GenTree(op^.left);
GenImplied(m_ply);
GenNative(m_sty_dir, direct, dworkLoc, nil, 0);
end {if}
else begin
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenTree(op^.left);
end; {else}
if not (rOpcode in [pc_fjp,pc_tjp]) then
GenNative(m_ldx_imm, immediate, 1, nil, 0);
if op^.optype in [cgByte,cgWord] then begin
GenImplied(m_sec);
GenNative(m_sbc_dir, direct, dworkLoc, nil, 0);
end {if}
else
GenNative(m_cmp_dir, direct, dworkLoc, nil, 0);
end {if}
else begin
GenTree(op^.left);
if not (rOpcode in [pc_fjp,pc_tjp]) then
GenNative(m_ldx_imm, immediate, 1, nil, 0);
if op^.optype in [cgByte,cgWord] then begin
GenImplied(m_sec);
OperA(m_sbc_imm, op^.right);
if op^.right^.opcode in [pc_lld,pc_lli,pc_gli,pc_gld] then
GenImplied(m_tay);
end {if}
else
OperA(m_cmp_imm, op^.right);
end; {else}
if rOpcode = pc_fjp then begin
lab2 := GenLabel;
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
if op^.optype in [cgByte,cgWord] then begin
lab1 := GenLabel;
GenNative(m_bvs, relative, lab1, nil, 0);
GenNative(m_eor_imm, immediate, $8000, nil, 0);
GenLab(lab1);
GenNative(m_bmi, relative, lab2, nil, 0);
end {if}
else
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {if}
else if rOpcode = pc_tjp then begin
lab2 := GenLabel;
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
if op^.optype in [cgByte,cgWord] then begin
lab1 := GenLabel;
GenNative(m_bvs, relative, lab1, nil, 0);
GenNative(m_eor_imm, immediate, $8000, nil, 0);
GenLab(lab1);
GenNative(m_bpl, relative, lab2, nil, 0);
end {if}
else
GenNative(m_bcc, relative, lab2, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
if op^.opcode = pc_grt then
GenLab(lab3);
end {else if}
else begin
lab2 := GenLabel;
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
if op^.optype in [cgByte,cgWord] then begin
lab1 := GenLabel;
GenNative(m_bvs, relative, lab1, nil, 0);
GenNative(m_eor_imm, immediate, $8000, nil, 0);
GenLab(lab1);
GenNative(m_bmi, relative, lab2, nil, 0);
end {if}
else
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenImplied(m_dex);
GenLab(lab2);
GenImplied(m_txa);
end; {else}
end; {case optype of cgByte,cgUByte,cgWord,cgUWord}
cgULong: begin
gLong.preference := onStack;
GenTree(op^.right);
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_ply);
GenImplied(m_pla);
end {if}
else begin
GenImplied(m_tay);
GenImplied(m_txa);
end; {else}
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 1, nil, 0);
GenNative(m_cmp_s, direct, 3, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_tya);
GenNative(m_cmp_s, direct, 1, nil, 0);
GenLab(lab1);
lab2 := GenLabel;
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenImplied(m_dex);
GenLab(lab2);
GenImplied(m_pla);
GenImplied(m_pla);
GenImplied(m_txa);
if rOpcode = pc_fjp then begin
lab4 := GenLabel;
GenNative(m_bne, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end {if}
else if rOpcode = pc_tjp then begin
lab4 := GenLabel;
GenNative(m_beq, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end; {else if}
end;
cgReal,cgDouble,cgComp,cgExtended: begin
GenTree(op^.left);
GenTree(op^.right);
num := 31;
if op^.opcode = pc_geq then
GenCall(32)
else
GenCall(31);
if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
lab1 := GenLabel;
if rOpcode = pc_fjp then
GenNative(m_bne, relative, lab1, nil, 0)
else
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_brl,longrelative,lb,nil,0);
GenLab(lab1);
end; {if}
end; {case optype of cgReal..cgExtended}
cgLong: begin
gLong.preference := onStack;
GenTree(op^.left);
if op^.opcode = pc_geq then begin
gLong.preference := A_X;
GenTree(op^.right);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
num := 30;
end {if}
else begin
gLong.preference := onStack;
GenTree(op^.right);
num := 29;
end; {else}
GenCall(num);
if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
lab1 := GenLabel;
if rOpcode = pc_fjp then
GenNative(m_bne, relative, lab1, nil, 0)
else
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end; {if}
end; {case optype of cgLong}
cgQuad: begin
if op^.opcode = pc_geq then begin
gQuad.preference := onStack;
GenTree(op^.left);
gQuad.preference := onStack;
GenTree(op^.right);
end {if}
else {if op^.opcode = pc_grt then} begin
gQuad.preference := onStack;
GenTree(op^.right);
gQuad.preference := onStack;
GenTree(op^.left);
end; {else}
GenCall(88);
if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin
lab1 := GenLabel;
if (rOpcode = pc_fjp) <> (op^.opcode = pc_grt) then
GenNative(m_bcs, relative, lab1, nil, 0)
else
GenNative(m_bcc, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else begin
if op^.opcode = pc_geq then begin
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenImplied(m_rol_a);
end {if}
else {if op^.opcode = pc_grt then} begin
lab1 := GenLabel;
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_dea);
GenLab(lab1);
end; {else}
end; {else}
end; {case optype of cgQuad}
cgUQuad: begin
simple :=
SimplestQuadLoad(op^.left) and SimplestQuadLoad(op^.right)
and not volatile;
if not simple then begin
gQuad.preference := onStack;
GenTree(op^.left);
gQuad.preference := onStack;
GenTree(op^.right);
end; {if}
if op^.opcode = pc_geq then
GenNative(m_ldx_imm, immediate, 1, nil, 0)
else {if op^.opcode = pc_grt then}
GenNative(m_ldx_imm, immediate, 0, nil, 0);
lab1 := GenLabel;
lab2 := GenLabel;
if simple then begin
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
OpOnWordOfQuad(m_cmp_imm, op^.right, 6);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
OpOnWordOfQuad(m_cmp_imm, op^.right, 4);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
OpOnWordOfQuad(m_cmp_imm, op^.right, 2);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
OpOnWordOfQuad(m_cmp_imm, op^.right, 0);
end {if}
else begin
GenNative(m_lda_s, direct, 15, nil, 0);
GenNative(m_cmp_s, direct, 7, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_lda_s, direct, 13, nil, 0);
GenNative(m_cmp_s, direct, 5, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_lda_s, direct, 11, nil, 0);
GenNative(m_cmp_s, direct, 3, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_lda_s, direct, 9, nil, 0);
GenNative(m_cmp_s, direct, 1, nil, 0);
end; {else}
GenLab(lab1);
if op^.opcode = pc_geq then begin
GenNative(m_bcs, relative, lab2, nil, 0);
GenImplied(m_dex);
end {if}
else begin {if op^.opcode = pc_grt then}
GenNative(m_bcc, relative, lab2, nil, 0);
GenNative(m_beq, relative, lab2, nil, 0);
GenImplied(m_inx);
end; {else}
GenLab(lab2);
if not simple then begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 16, nil, 0);
GenImplied(m_tcs);
end; {if}
GenImplied(m_txa);
if rOpcode = pc_fjp then begin
lab3 := GenLabel;
GenNative(m_bne, relative, lab3, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab3);
end {if}
else if rOpcode = pc_tjp then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab3);
end; {else if}
end; {case optype of cgUQuad}
otherwise:
Error(cge1);
end; {case}
end; {GenCmp}
procedure GenCnv (op: icptr);
{ generate a pc_cnv instruction }
const {note: these constants list all legal }
{ conversions; others are ignored}
cReal = $06;
cDouble = $07;
cComp = $08;
cExtended = $09;
cVoid = $0B;
cLong = $04;
cULong = $05;
byteToWord = $02;
byteToUword = $03;
byteToLong = $04;
byteToUlong = $05;
byteToQuad = $0C;
byteToUQuad = $0D;
byteToReal = $06;
byteToDouble = $07;
ubyteToLong = $14;
ubyteToUlong = $15;
ubyteToQuad = $1C;
ubyteToUQuad = $1D;
ubyteToReal = $16;
ubyteToDouble = $17;
wordToByte = $20;
wordToUByte = $21;
wordToLong = $24;
wordToUlong = $25;
wordToQuad = $2C;
wordToUQuad = $2D;
wordToReal = $26;
wordToDouble = $27;
uwordToByte = $30;
uwordToUByte = $31;
uwordToLong = $34;
uwordToUlong = $35;
uwordToQuad = $3C;
uwordToUQuad = $3D;
uwordToReal = $36;
uwordToDouble = $37;
longTobyte = $40;
longToUbyte = $41;
longToWord = $42;
longToUword = $43;
longToQuad = $4C;
longToUQuad = $4D;
longToReal = $46;
longToDouble = $47;
longToVoid = $4B;
ulongTobyte = $50;
ulongToUbyte = $51;
ulongToWord = $52;
ulongToUword = $53;
ulongToQuad = $5C;
ulongToUQuad = $5D;
ulongToReal = $56;
ulongToDouble = $57;
ulongToVoid = $5B;
realTobyte = $60;
realToUbyte = $61;
realToWord = $62;
realToUword = $63;
realToLong = $64;
realToUlong = $65;
realToQuad = $6C;
realToUQuad = $6D;
realToVoid = $6B;
doubleTobyte = $70;
doubleToUbyte = $71;
doubleToWord = $72;
doubleToUword = $73;
doubleToLong = $74;
doubleToUlong = $75;
doubleToQuad = $7C;
doubleToUQuad = $7D;
quadToByte = $C0;
quadToUByte = $C1;
quadToWord = $C2;
quadToUword = $C3;
quadToLong = $C4;
quadToULong = $C5;
quadToReal = $C6;
quadToDouble = $C7;
quadToVoid = $CB;
uquadToByte = $D0;
uquadToUByte = $D1;
uquadToWord = $D2;
uquadToUword = $D3;
uquadToLong = $D4;
uquadToULong = $D5;
uquadToReal = $D6;
uquadToDouble = $D7;
uquadToVoid = $DB;
var
toRealType: baseTypeEnum; {real type converted to}
lab1: integer; {used for branches}
lLong: longType; {used to reserve gLong}
begin {GenCnv}
lLong := gLong;
gLong.preference := onStack+A_X+constant;
gLong.where := onStack;
if op^.q in [quadToVoid,uQuadToVoid] then
gQuad.preference := nowhere
else
gQuad.preference := onStack;
if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin
op^.q := (op^.q & $000F) | (cReal * 16);
end; {if}
if (op^.q & $000F) in [cDouble,cExtended,cComp,cReal] then begin
toRealType := baseTypeEnum(op^.q & $000F);
op^.q := (op^.q & $00F0) | cReal;
end {if}
else
toRealType := cgVoid;
GenTree(op^.left);
if op^.q in [wordToLong,wordToUlong] then begin
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenImpliedForFlags(m_tay);
GenNative(m_bpl, relative, lab1, nil, 0);
GenImplied(m_dex);
GenLab(lab1);
if (lLong.preference & A_X) <> 0 then
gLong.where := A_X
else begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
end {if}
else if op^.q in [byteToLong,byteToUlong] then begin
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenImplied(m_dex);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
if (lLong.preference & A_X) <> 0 then
gLong.where := A_X
else begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
end {else if}
else if op^.q in [byteToWord,byteToUword] then begin
lab1 := GenLabel;
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end {else if}
else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then
begin
if (lLong.preference & A_X) <> 0 then begin
gLong.where := A_X;
GenNative(m_ldx_imm, immediate, 0, nil, 0);
end {if}
else begin
gLong.where := onStack;
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_pha);
end; {else}
end {else if}
else if op^.q in [wordToUbyte,uwordToUbyte] then
GenNative(m_and_imm, immediate, $00FF, nil, 0)
else if op^.q in [wordToByte,uwordToByte] then begin
lab1 := GenLabel;
GenNative(m_and_imm, immediate, $00FF, nil, 0);
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end {else if}
else if op^.q in [byteToReal,uByteToReal,wordToReal] then begin
GenCall(11);
toRealType := cgExtended;
end {else if}
else if op^.q = uwordToReal then begin
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenCall(12);
toRealType := cgExtended;
end {else if}
else if op^.q in [longToUbyte,ulongToUbyte] then begin
if gLong.where = A_X then
GenNative(m_and_imm, immediate, $00FF, nil, 0)
else if gLong.where = constant then
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw & $00FF, nil, 0)
else {if gLong.where = onStack then} begin
GenImplied(m_pla);
GenImplied(m_plx);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
end; {else if}
end {else if}
else if op^.q in [longToByte,ulongToByte] then begin
if gLong.where = A_X then
GenNative(m_and_imm, immediate, $00FF, nil, 0)
else if gLong.where = constant then
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw & $00FF, nil, 0)
else {if gLong.where = onStack then} begin
GenImplied(m_pla);
GenImplied(m_plx);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
end; {else if}
lab1 := GenLabel;
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end {else if}
else if op^.q in [longToWord,longToUword,ulongToWord,ulongToUword] then begin
{Note: if the result is in A_X, no further action is needed}
if gLong.where = constant then
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0)
else if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {else if}
end {else if}
else if op^.q in [longToReal,uLongToReal] then begin
if gLong.where = constant then begin
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
end {if}
else if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {else if}
if op^.q = longToReal then
GenCall(12)
else
GenCall(13);
if toRealType <> cgReal then
toRealType := cgExtended;
end {else if}
else if op^.q = realToWord then
GenCall(14)
else if op^.q = realToUbyte then begin
GenCall(14);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
end {else if}
else if op^.q = realToByte then begin
lab1 := GenLabel;
GenCall(14);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end {else if}
else if op^.q = realToUword then
GenCall(15)
else if op^.q in [realToLong,realToUlong] then begin
if op^.q & $00FF = 5 then
GenCall(17)
else
GenCall(16);
if (lLong.preference & A_X) <> 0 then
gLong.where := A_X
else begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
end {else if}
else if op^.q = realToVoid then begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 10, nil, 0);
GenImplied(m_tcs);
end {else if}
else if op^.q in [longToVoid,ulongToVoid] then begin
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
gLong.where := A_X;
end; {if}
end {else if}
else if op^.q in [ubyteToQuad,ubyteToUQuad,uwordToQuad,uwordToUQuad] then begin
GenNative(m_ldy_imm, immediate, 0, nil, 0);
GenImplied(m_phy);
GenImplied(m_phy);
GenImplied(m_phy);
GenImplied(m_pha);
gQuad.where := onStack;
end {else if}
else if op^.q in [byteToQuad,byteToUQuad] then begin
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenImplied(m_dex);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
GenImplied(m_phx);
GenImplied(m_phx);
GenImplied(m_phx);
GenImplied(m_pha);
gQuad.where := onStack;
end {else if}
else if op^.q in [wordToQuad,wordToUQuad] then begin
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenImpliedForFlags(m_tay);
GenNative(m_bpl, relative, lab1, nil, 0);
GenImplied(m_dex);
GenLab(lab1);
GenImplied(m_phx);
GenImplied(m_phx);
GenImplied(m_phx);
GenImplied(m_pha);
gQuad.where := onStack;
end {else if}
else if op^.q in [ulongToQuad,ulongToUQuad] then begin
if gLong.where = A_X then begin
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_phx);
GenImplied(m_pha);
end {if}
else if gLong.where = constant then begin
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
end {else if}
else {if gLong.where = onStack then} begin
GenImplied(m_pla);
GenImplied(m_plx);
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
gQuad.where := onStack;
end {else if}
else if op^.q in [longToQuad,longToUQuad] then begin
if gLong.where = constant then begin
if glong.lval < 0 then begin
GenNative(m_pea, immediate, -1, nil, 0);
GenNative(m_pea, immediate, -1, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
end {if}
else begin
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, 0, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
end; {else}
end {if}
else begin
GenNative(m_ldy_imm, immediate, 0, nil, 0);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end {if}
else {if gLong.where = A_X then}
GenNative(m_cpx_imm, immediate, 0, nil, 0);
lab1 := GenLabel;
GenNative(m_bpl, relative, lab1, nil, 0);
GenImplied(m_dey);
GenLab(lab1);
GenImplied(m_phy);
GenImplied(m_phy);
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
gQuad.where := onStack;
end {else if}
else if op^.q = realToQuad then begin
GenCall(89);
gQuad.where := onStack;
end {else if}
else if op^.q = realToUQuad then begin
GenCall(90);
gQuad.where := onStack;
end {else if}
else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin
GenImplied(m_pla);
GenImplied(m_plx);
GenImplied(m_plx);
GenImplied(m_plx);
end {else if}
else if op^.q in [quadToUByte,uquadToUByte] then begin
GenImplied(m_pla);
GenImplied(m_plx);
GenImplied(m_plx);
GenImplied(m_plx);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
end {else if}
else if op^.q in [quadToByte,uquadToByte] then begin
GenImplied(m_pla);
GenImplied(m_plx);
GenImplied(m_ply);
GenImplied(m_ply);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
lab1 := GenLabel;
GenNative(m_bit_imm, immediate, $0080, nil, 0);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end {else if}
else if op^.q in [quadToLong,uquadToLong,quadToULong,uquadToULong] then begin
GenImplied(m_pla);
GenImplied(m_plx);
GenImplied(m_ply);
GenImplied(m_ply);
if (lLong.preference & A_X) <> 0 then
gLong.where := A_X
else begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
end {else if}
else if op^.q in [quadToVoid,uquadToVoid] then begin
if gQuad.where = onStack then begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end; {if}
end {else if}
else if op^.q = quadToReal then
GenCall(83)
else if op^.q = uquadToReal then
GenCall(84)
else if (op^.q & $000F) = cVoid then
{do nothing}
else if (op^.q & $000F) in [cLong,cULong] then
if (lLong.preference & gLong.where) = 0 then begin
if gLong.where = constant then begin
GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0);
end {if}
else if gLong.where = A_X then begin
GenImplied(m_phx);
GenImplied(m_pha);
end; {else if}
gLong.where := onStack;
end; {if}
if toRealType <> cgVoid then
case toRealType of
cgReal: GenCall(91);
cgDouble: GenCall(92);
cgComp: GenCall(93);
cgExtended: ;
end; {case}
end; {GenCnv}
procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer);
{ generate a pc_equ or pc_neq instruction }
{ }
{ parameters: }
{ op - node to generate the compare for }
{ opcode - Opcode that will use the result of the compare. }
{ If the result is used by a tjp or fjp, this procedure }
{ generates special code and does the branch internally. }
{ lb - For fjp, tjp, this is the label to branch to if }
{ the condition is satisfied. }
var
nd: icptr; {work node}
num: integer; {constant to compare to}
lab1,lab2,lab3: integer; {label numbers}
bne: integer; {instruction for a pc_equ bne branch}
beq: integer; {instruction for a pc_equ beq branch}
lLong: longType; {local long value information}
leftOp,rightOp: pcodes; {opcode codes to left, right}
procedure DoOr (op: icptr);
{ or the two halves of a four byte value }
{ }
{ parameters: }
{ operand to or }
var
disp: integer; {disp of value on stack frame}
begin {DoOr}
with op^ do begin
if opcode = pc_ldo then begin
if smallMemoryModel then begin
GenNative(m_lda_abs, absolute, q, lab, 0);
GenNative(m_ora_abs, absolute, q+2, lab, 0);
end {if}
else begin
GenNative(m_lda_long, longabsolute, q, lab, 0);
GenNative(m_ora_long, longabsolute, q+2, lab, 0);
end; {else}
end {if}
else begin
disp := LabelToDisp(r) + q;
if disp < 254 then begin
GenNative(m_lda_dir, direct, disp, nil, 0);
GenNative(m_ora_dir, direct, disp+2, nil, 0);
end {if}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_lda_dirX, direct, 0, nil, 0);
GenNative(m_ora_dirX, direct, 2, nil, 0);
end; {else}
end; {else}
end; {with}
end; {DoOr}
procedure DoCmp (op: icPtr);
{ compare a long value in A_X to a local or global scalar }
{ }
{ parameters: }
{ op - value to compare to }
var
disp: integer; {disp of value on stack frame}
lab1: integer; {label numbers}
begin {DoCmp}
lab1 := GenLabel;
with op^ do begin
if opcode = pc_ldo then begin
GenNative(m_cmp_abs, absolute, q, lab, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_cpx_abs, absolute, q+2, lab, 0);
end {if}
else begin
disp := LabelToDisp(r) + q;
if disp < 254 then begin
GenNative(m_cmp_dir, direct, disp, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_cpx_dir, direct, disp+2, nil, 0);
end {if}
else begin
GenImplied(m_txy);
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_cmp_dirX, direct, 0, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_tya);
GenNative(m_cmp_dirX, direct, 2, nil, 0);
end; {else}
end; {else}
GenLab(lab1);
end; {with}
end; {DoCmp}
begin {GenEquNeq}
if op^.opcode = pc_equ then begin
bne := m_bne;
beq := m_beq;
end {if}
else begin
bne := m_beq;
beq := m_bne;
end; {else}
if op^.left^.opcode in [pc_lod,pc_ldo] then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
if op^.left^.opcode = pc_ldc then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
leftOp := op^.left^.opcode; {set op codes for fast access}
rightOp := op^.right^.opcode;
if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
(rightOp = pc_ldc) then begin
GenTree(op^.left);
num := op^.right^.q;
lab1 := GenLabel;
if opcode in [pc_fjp,pc_tjp] then begin
if num <> 0 then
GenNative(m_cmp_imm, immediate, num, nil, 0)
else if NeedsCondition(leftOp) then
GenImpliedForFlags(m_tay);
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else begin
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(bne, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
GenImplied(m_txa);
end; {else}
end {if}
else if (op^.optype in [cgLong,cgULong]) and (leftOp in [pc_ldo,pc_lod])
and (rightOp = pc_ldc) and (op^.right^.lval = 0) then begin
if opcode in [pc_fjp,pc_tjp] then begin
DoOr(op^.left);
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else if op^.opcode = pc_equ then begin
lab1 := GenLabel;
lab2 := GenLabel;
DoOr(op^.left);
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenNative(m_bra, relative, lab2, nil, 0);
GenLab(lab1);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenLab(lab2);
end {else if}
else {if op^.opcode = pc_neq then} begin
lab1 := GenLabel;
DoOr(op^.left);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {else if}
end {else if}
else if (op^.optype in [cgLong,cgULong]) and (rightOp in [pc_ldo,pc_lod]) then begin
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
if opcode in [pc_fjp,pc_tjp] then begin
DoCmp(op^.right);
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else begin
lab1 := GenLabel;
lab2 := GenLabel;
DoCmp(op^.right);
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenNative(m_bra, relative, lab2, nil, 0);
GenLab(lab1);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenLab(lab2);
end; {else}
end {else if}
else
case op^.optype of
cgByte,cgUByte,cgWord,cgUWord: begin
if not Complex(op^.left) then
if Complex(op^.right) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
GenTree(op^.left);
if Complex(op^.right) or (not (opcode in [pc_fjp,pc_tjp])) then begin
GenImplied(m_pha);
GenTree(op^.right);
GenImplied(m_sec);
GenNative(m_sbc_s, direct, 1, nil, 0);
GenImplied(m_plx);
GenImplied(m_tax);
if opcode in [pc_fjp,pc_tjp] then begin
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else begin
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
if op^.opcode = pc_equ then
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {else}
end {if}
else begin
OperA(m_cmp_imm, op^.right);
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end; {else}
end; {case optype of cgByte,cgUByte,cgWord,cgUWord}
cgLong,cgULong: begin
gLong.preference := onStack;
GenTree(op^.left);
lLong := gLong;
gLong.preference := A_X;
GenTree(op^.right);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
GenNative(m_ldy_imm, immediate, 1, nil, 0);
GenNative(m_cmp_s, direct, 1, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenImplied(m_dey);
GenLab(lab1);
GenImplied(m_txa);
GenNative(m_cmp_s, direct, 3, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ldy_imm, immediate, 0, nil, 0);
GenLab(lab1);
GenImplied(m_pla);
GenImplied(m_pla);
GenImplied(m_tya);
if opcode in [pc_fjp,pc_tjp] then begin
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(bne, relative, lab1, nil, 0)
else
GenNative(beq, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else if op^.opcode = pc_neq then
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {case optype of cgLong,cgULong}
cgReal,cgDouble,cgComp,cgExtended: begin
GenTree(op^.left);
GenTree(op^.right);
GenCall(36);
if opcode in [pc_fjp,pc_tjp] then begin
lab1 := GenLabel;
if opcode = pc_fjp then
GenNative(bne, relative, lab1, nil, 0)
else
GenNative(beq, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else if op^.opcode = pc_neq then
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {case optype of cgReal..cgExtended}
cgQuad,cgUQuad: begin
if SimpleQuadLoad(op^.left) and (op^.right^.opcode = pc_ldc)
and (op^.right^.qval.hi = 0) and (op^.right^.qval.lo = 0) then begin
lab1 := GenLabel;
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
if not volatile then
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_ora_imm, op^.left, 2);
OpOnWordOfQuad(m_ora_imm, op^.left, 4);
OpOnWordOfQuad(m_ora_imm, op^.left, 6);
GenLab(lab1);
end {if}
else if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right)
and not volatile then begin
lab1 := GenLabel;
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
OpOnWordOfQuad(m_eor_imm, op^.right, 0);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
OpOnWordOfQuad(m_eor_imm, op^.right, 2);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
OpOnWordOfQuad(m_eor_imm, op^.right, 4);
GenNative(m_bne, relative, lab1, nil, 0);
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
OpOnWordOfQuad(m_eor_imm, op^.right, 6);
GenLab(lab1);
end {if}
else begin
gQuad.preference := onStack;
GenTree(op^.left);
gQuad.preference := onStack;
GenTree(op^.right);
lab1 := GenLabel;
lab2 := GenLabel;
GenImplied(m_pla);
GenImplied(m_plx);
GenImplied(m_ply);
GenNative(m_eor_s, direct, 3, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_txa);
GenNative(m_eor_s, direct, 5, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_tya);
GenNative(m_eor_s, direct, 7, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_pla);
GenNative(m_eor_s, direct, 7, nil, 0);
GenNative(m_bra, relative, lab2, nil, 0);
GenLab(lab1);
GenImplied(m_plx);
GenLab(lab2);
GenImplied(m_tax);
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
GenImplied(m_txa);
end; {else}
if opcode in [pc_fjp,pc_tjp] then begin
lab3 := GenLabel;
if opcode = pc_fjp then
GenNative(beq, relative, lab3, nil, 0)
else
GenNative(bne, relative, lab3, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab3);
end {if}
else begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab3);
if op^.opcode = pc_equ then
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {else}
end; {case optype of cgQuad,cgUQuad}
otherwise:
Error(cge1);
end; {case}
end; {GenEquNeq}
procedure GenGilGliGdlGld (op: icptr);
{ Generate code for a pc_gil, pc_gli, pc_gdl or pc_gld }
var
lab1: integer; {branch point}
lab: stringPtr; {op^.lab}
opcode: pcodes; {op^.opcode}
q: integer; {op^.q}
procedure DoGIncDec (opcode: pcodes; lab: stringPtr; p, q: integer);
{ Do a decrement or increment on a global four byte value }
{ }
{ parameters }
{ opcode - operation code }
{ lab - label }
{ q - disp to value }
{ p - number to ind/dec by }
var
lab1: integer; {branch point}
begin {DoGIncDec}
if smallMemoryModel then begin
if opcode in [pc_gil,pc_gli] then begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_inc_abs, absolute, q, lab, 0);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenImplied(m_clc);
GenNative(m_lda_abs, absolute, q, lab, 0);
GenNative(m_adc_imm, immediate, p, nil, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
GenNative(m_inc_abs, absolute, q+2, lab, 0);
GenLab(lab1);
end {if}
else {if opcode in [pc_gdl,pc_gld] then} begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_lda_abs, absolute, q, lab, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_dec_abs, absolute, q+2, lab, 0);
GenLab(lab1);
GenNative(m_dec_abs, absolute, q, lab, 0);
end {if}
else begin
GenImplied(m_sec);
GenNative(m_lda_abs, absolute, q, lab, 0);
GenNative(m_sbc_imm, immediate, p, nil, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_dec_abs, absolute, q+2, lab, 0);
GenLab(lab1);
end; {else}
end {else}
end {of smallMemoryModel}
else begin
if opcode in [pc_gil,pc_gli] then begin
lab1 := GenLabel;
GenImplied(m_clc);
GenNative(m_lda_long, longabsolute, q, lab, 0);
GenNative(m_adc_imm, immediate, p, nil, 0);
GenNative(m_sta_long, longabsolute, q, lab, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
GenNative(m_lda_long, longabsolute, q+2, lab, 0);
GenImplied(m_ina);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
GenLab(lab1);
end {if}
else {if opcode in [pc_gdl,pc_gld] then} begin
lab1 := GenLabel;
GenImplied(m_sec);
GenNative(m_lda_long, longabsolute, q, lab, 0);
GenNative(m_sbc_imm, immediate, p, nil, 0);
GenNative(m_sta_long, longabsolute, q, lab, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_lda_long, longabsolute, q+2, lab, 0);
GenImplied(m_dea);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
GenLab(lab1);
end; {else if}
end; {else}
end; {DoGIncDec}
begin {GenGilGliGdlGld}
opcode := op^.opcode;
q := op^.q;
lab := op^.lab;
case op^.optype of
cgWord, cgUWord: begin
if opcode = pc_gil then
GenNative(m_inc_abs, absolute, q, lab, 0)
else if opcode = pc_gdl then
GenNative(m_dec_abs, absolute, q, lab, 0);
if not skipLoad then
GenNative(m_lda_abs, absolute, q, lab, 0);
if opcode = pc_gli then
GenNative(m_inc_abs, absolute, q, lab, 0)
else if opcode = pc_gld then
GenNative(m_dec_abs, absolute, q, lab, 0);
end;
cgByte, cgUByte: begin
GenNative(m_sep, immediate, 32, nil, 0);
if opcode = pc_gil then
GenNative(m_inc_abs, absolute, q, lab, 0)
else if opcode = pc_gdl then
GenNative(m_dec_abs, absolute, q, lab, 0);
if not skipLoad then
GenNative(m_lda_abs, absolute, q, lab, 0);
if opcode = pc_gli then
GenNative(m_inc_abs, absolute, q, lab, 0)
else if opcode = pc_gld then
GenNative(m_dec_abs, absolute, q, lab, 0);
GenNative(m_rep, immediate, 32, nil, 0);
if not skipLoad then begin
GenNative(m_and_imm, immediate, 255, nil, 0);
if op^.optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
GenNative(m_cmp_imm, immediate, $0000, nil, 0);
end; {if}
end; {if}
end;
cgLong, cgULong: begin
if (A_X & gLong.preference) <> 0 then
gLong.where := A_X
else
gLong.where := onStack;
if opcode in [pc_gil,pc_gdl] then
DoGIncDec(opcode, lab, op^.r, q);
if not skipLoad then
if smallMemoryModel then begin
GenNative(m_ldx_abs, absolute, q+2, lab, 0);
GenNative(m_lda_abs, absolute, q, lab, 0);
if (opcode in [pc_gli,pc_gld]) and (op^.r <> 1) then
gLong.where := onStack;
if gLong.where = onStack then begin
GenImplied(m_phx);
GenImplied(m_pha);
end; {if}
end {if}
else begin
if opcode in [pc_gli,pc_gld] then
gLong.where := onStack;
GenNative(m_lda_long, longabsolute, q+2, lab, 0);
if gLong.where = onStack then
GenImplied(m_pha)
else
GenImplied(m_tax);
GenNative(m_lda_long, longabsolute, q, lab, 0);
if gLong.where = onStack then
GenImplied(m_pha);
end; {else}
if opcode in [pc_gli,pc_gld] then
DoGIncDec(opcode, lab, op^.r, q);
end; {case cgLong,cgULong}
otherwise:
Error(cge1);
end; {case}
end; {GenGilGliGdlGld}
procedure GenIilIliIdlIld (op: icptr);
{ Generate code for a pc_iil, pc_ili, pc_idl or pc_ild }
var
i: integer; {index variable}
lab1: integer; {label}
lSkipLoad: boolean; {copy of skipLoad}
opcode: pcodes; {op^.opcode}
short: boolean; {doing a one byte operand?}
begin {GenIilIliIdlIld}
opcode := op^.opcode;
case op^.optype of
cgByte,cgUByte,cgWord,cgUWord: begin
short := op^.optype in [cgByte,cgUByte];
lSkipLoad := skipLoad;
skipLoad := false;
GetPointer(op^.left);
skipLoad := lSkipLoad;
if gLong.where = inPointer then begin
if short then
GenNative(m_sep, immediate, 32, nil, 0);
if gLong.fixedDisp then
GenNative(m_lda_indl, direct, gLong.disp, nil, 0)
else
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if opcode in [pc_ili,pc_iil] then
GenImplied(m_ina)
else
GenImplied(m_dea);
if gLong.fixedDisp then
GenNative(m_sta_indl, direct, gLong.disp, nil, 0)
else
GenNative(m_sta_indly, direct, gLong.disp, nil, 0);
if not skipLoad then
if opcode = pc_ili then
GenImplied(m_dea)
else if opcode = pc_ild then
GenImplied(m_ina);
if short then
GenNative(m_rep, immediate, 32, nil, 0);
end {if}
else if gLong.where = localAddress then begin
gLong.disp := gLong.disp+op^.q;
if gLong.fixedDisp then begin
if short then
GenNative(m_sep, immediate, 32, nil, 0);
if (gLong.disp < 256) and (gLong.disp >= 0) then begin
if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
if opcode in [pc_ili,pc_iil] then
GenNative(m_inc_dir, direct, gLong.disp, nil, 0)
else
GenNative(m_dec_dir, direct, gLong.disp, nil, 0);
if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
end {if}
else begin
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then
GenNative(m_lda_dirX, direct, 0, nil, 0);
if opcode in [pc_ili,pc_iil] then
GenNative(m_inc_dirX, direct, 0, nil, 0)
else
GenNative(m_dec_dirX, direct, 0, nil, 0);
if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then
GenNative(m_lda_dirX, direct, 0, nil, 0);
end; {else}
if short then
GenNative(m_rep, immediate, 32, nil, 0);
end
else begin
if (gLong.disp > 255) or (gLong.disp < 0) then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
gLong.disp := 0;
end; {if}
if short then
GenNative(m_sep, immediate, 32, nil, 0);
if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then
GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
if opcode in [pc_ili,pc_iil] then
GenNative(m_inc_dirX, direct, gLong.disp, nil, 0)
else
GenNative(m_dec_dirX, direct, gLong.disp, nil, 0);
if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then
GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
if short then
GenNative(m_rep, immediate, 32, nil, 0);
end; {else}
end {else if}
else {if gLong.where = globalLabel then} begin
gLong.disp := gLong.disp+op^.q;
if short then
GenNative(m_sep, immediate, 32, nil, 0);
if gLong.fixedDisp then
if smallMemoryModel then begin
if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then
GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
if opcode in [pc_ili,pc_iil] then
GenNative(m_inc_abs, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_dec_abs, absolute, gLong.disp, gLong.lab, 0);
if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then
GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
end {if}
else begin
GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0);
if opcode in [pc_ili,pc_iil] then
GenImplied(m_ina)
else
GenImplied(m_dea);
GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0);
if not skipLoad then
if opcode = pc_ili then
GenImplied(m_dea)
else if opcode = pc_ild then
GenImplied(m_ina);
end {else}
else
if smallMemoryModel then begin
if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then
GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
if opcode in [pc_ili,pc_iil] then
GenNative(m_inc_absX, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_dec_absX, absolute, gLong.disp, gLong.lab, 0);
if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then
GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
end {if}
else begin
GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0);
if opcode in [pc_ili,pc_iil] then
GenImplied(m_ina)
else
GenImplied(m_dea);
GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
if not skipLoad then
if opcode = pc_ili then
GenImplied(m_dea)
else if opcode = pc_ild then
GenImplied(m_ina);
end; {else}
if short then
GenNative(m_rep, immediate, 32, nil, 0);
end; {else}
if not skipLoad then
if short then begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if op^.optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end; {if}
end; {if}
end; {case cgByte,cgUByte,cgWord,cgUWord}
otherwise:
Error(cge1);
end; {case}
end; {GenIilIliIdlIld}
procedure GenIncDec (op, save: icptr);
{ generate code for pc_inc, pc_dec }
{ }
{ parameters: }
{ op - pc_inc or pc_dec operation }
{ save - save location (pc_str or pc_sro) or nil }
var
disp: integer; {disp in stack frame}
lab1: integer; {branch point}
opcode: pcodes; {temp storage for op code}
size: integer; {number to increment by}
clc,ina,adc: integer; {instructions to generate}
begin {GenIncDec}
{set up local variables}
opcode := op^.opcode;
size := op^.q;
if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin
GenTree(op^.left);
if opcode = pc_inc then begin
clc := m_clc;
ina := m_ina;
adc := m_adc_imm;
end {if}
else begin
clc := m_sec;
ina := m_dea;
adc := m_sbc_imm;
end; {else}
if size = 1 then
GenImplied(ina)
else if size = 2 then begin
GenImplied(ina);
GenImplied(ina);
end {else if}
else if size <> 0 then begin
GenImplied(clc);
GenNative(adc, immediate, size, nil, 0);
end; {else if}
end {if}
else if op^.optype in [cgLong,cgULong] then begin
if SameLoc(op^.left, save) then begin
lab1 := GenLabel;
if size = 1 then begin
if opcode = pc_inc then begin
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0);
GenNative(m_bne, relative, lab1, nil, 0);
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
GenLab(lab1);
end {if}
else {if opcode = pc_dec then} begin
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
GenNative(m_bne, relative, lab1, nil, 0);
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
GenLab(lab1);
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0);
end; {else}
end {if}
else if opcode = pc_inc then begin
GenImplied(m_clc);
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
GenNative(m_adc_imm, immediate, size, nil, 0);
DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2);
GenLab(lab1);
end {else if}
else begin
GenImplied(m_sec);
DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0);
GenNative(m_sbc_imm, immediate, size, nil, 0);
DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2);
GenLab(lab1);
end; {else}
end {if}
else begin
if save <> nil then
gLong.preference := A_X
else
gLong.preference := gLong.preference & (A_X | inpointer);
if opcode = pc_dec then
gLong.preference := gLong.preference & A_X;
GenTree(op^.left);
if opcode = pc_inc then
IncAddr(size)
else begin
lab1 := GenLabel;
if gLong.where = A_X then begin
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, size, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenImplied(m_dex);
end {if}
else begin
GenImplied(m_sec);
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sbc_imm, immediate, size, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_lda_s, direct, 3, nil, 0);
GenImplied(m_dea);
GenNative(m_sta_s, direct, 3, nil, 0);
end; {else}
GenLab(lab1);
end; {else}
if save <> nil then
if save^.opcode = pc_str then begin
disp := LabelToDisp(save^.r) + save^.q;
if disp < 254 then begin
if gLong.where = onStack then
GenImplied(m_pla);
GenNative(m_sta_dir, direct, disp, nil, 0);
if gLong.where = onStack then
GenImplied(m_plx);
GenNative(m_stx_dir, direct, disp+2, nil, 0);
end {else if}
else begin
if gLong.where = A_X then
GenImplied(m_txy);
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if gLong.where = onStack then
GenImplied(m_pla);
GenNative(m_sta_dirX, direct, 0, nil, 0);
if gLong.where = onStack then
GenImplied(m_pla)
else
GenImplied(m_tya);
GenNative(m_sta_dirX, direct, 2, nil, 0);
end; {else}
end {else if}
else {if save^.opcode = pc_sro then} begin
if gLong.where = onStack then
GenImplied(m_pla);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0)
else
GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0);
if smallMemoryModel then begin
if gLong.where = onStack then
GenImplied(m_plx);
GenNative(m_stx_abs, absolute, save^.q+2, save^.lab, 0)
end {if}
else begin
if gLong.where = onStack then
GenImplied(m_pla)
else
GenImplied(m_txa);
GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0);
end; {else}
end; {else}
end; {else}
end {else if}
else
Error(cge1);
end; {GenIncDec}
procedure GenInd (op: icptr);
{ Generate code for a pc_ind }
var
lab1: integer; {label}
lLong: longType; {requested address type}
lQuad: quadType; {requested quad address type}
optype: baseTypeEnum; {op^.optype}
q: integer; {op^.q}
volatileByte: boolean; {is this a volatile byte access?}
begin {GenInd}
optype := op^.optype;
q := op^.q;
case optype of
cgReal,cgDouble,cgComp,cgExtended: begin
gLong.preference := onStack;
GenTree(op^.left);
if q <> 0 then
IncAddr(q);
if optype = cgReal then
GenCall(21)
else if optype = cgDouble then
GenCall(22)
else if optype = cgComp then
GenCall(70)
else if optype = cgExtended then
GenCall(71);
end; {case cgReal,cgDouble,cgComp,cgExtended}
cgLong,cgULong: begin
lLong := gLong;
GetPointer(op^.left);
if gLong.where = inPointer then begin
if q = 0 then begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, 2, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if (A_X & lLong.preference) <> 0 then
GenImplied(m_tax)
else
GenImplied(m_pha);
GenNative(m_lda_indl, direct, gLong.disp, nil, 0);
end {if}
else begin
GenImplied(m_iny);
GenImplied(m_iny);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if (A_X & lLong.preference) <> 0 then
GenImplied(m_tax)
else
GenImplied(m_pha);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
end; {else}
if (A_X & lLong.preference) = 0 then
GenImplied(m_pha);
end {if q = 0}
else begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, q+2, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if (A_X & lLong.preference) <> 0 then
GenImplied(m_tax)
else
GenImplied(m_pha);
GenNative(m_ldy_imm, immediate, q, nil, 0);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, q+2, nil, 0);
GenImplied(m_tay);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if (A_X & lLong.preference) <> 0 then
GenImplied(m_tax)
else
GenImplied(m_pha);
GenImplied(m_dey);
GenImplied(m_dey);
end; {else}
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if (A_X & lLong.preference) = 0 then
GenImplied(m_pha);
end; {else}
end {if glong.where = inPointer}
else if gLong.where = localAddress then begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if (gLong.disp < 254) and (gLong.disp >= 0) then begin
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
end {if}
else begin
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_lda_dirX, direct, 0, nil, 0);
GenNative(m_ldy_dirX, direct, 2, nil, 0);
GenImplied(m_tyx);
end {else}
else begin
if (gLong.disp >= 254) or (gLong.disp < 0) then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
gLong.disp := 0;
end; {if}
GenNative(m_ldy_dirX, direct, gLong.disp+2, nil, 0);
GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
GenImplied(m_tyx);
end; {else}
if (A_X & lLong.preference) = 0 then begin
GenImplied(m_phx);
GenImplied(m_pha);
end; {if}
end {else if gLong.where = localAddress}
else {if gLong.where = globalLabel then} begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if smallMemoryModel then begin
GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
GenNative(m_ldx_abs, absolute, gLong.disp+2, gLong.lab, 0);
end {if}
else begin
GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0);
GenImplied(m_tax);
GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0);
end {else}
else
if smallMemoryModel then begin
GenNative(m_ldy_absX, absolute, gLong.disp+2, gLong.lab, 0);
GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
GenImplied(m_tyx);
end {if}
else begin
GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0);
GenImplied(m_tay);
GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0);
GenImplied(m_tyx);
end; {else}
if (A_X & lLong.preference) = 0 then begin
GenImplied(m_phx);
GenImplied(m_pha);
end; {if}
end; {else}
if (A_X & lLong.preference) <> 0 then
gLong.where := A_X
else
gLong.where := onStack;
end; {cgLong,cgULong}
cgByte,cgUByte,cgWord,cgUWord: begin
GetPointer(op^.left);
if gLong.where = inPointer then begin
volatileByte := (op^.r <> 0) and (optype in [cgByte,cgUByte]);
if q = 0 then begin
if volatileByte then
GenNative(m_sep, immediate, 32, nil, 0);
if gLong.fixedDisp then
GenNative(m_lda_indl, direct, gLong.disp, nil, 0)
else
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if volatileByte then
GenNative(m_rep, immediate, 32, nil, 0);
end {if}
else
if gLong.fixedDisp then begin
if volatileByte then
GenNative(m_sep, immediate, 32, nil, 0);
GenNative(m_ldy_imm, immediate, q, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if volatileByte then
GenNative(m_rep, immediate, 32, nil, 0);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, q, nil, 0);
GenImplied(m_tay);
if volatileByte then
GenNative(m_sep, immediate, 32, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
if volatileByte then
GenNative(m_rep, immediate, 32, nil, 0);
end; {else}
end {if}
else if gLong.where = localAddress then begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if (gLong.disp & $FF00) = 0 then
GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
else begin
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_lda_dirX, direct, 0, nil, 0);
end {else}
else
if (gLong.disp & $FF00) = 0 then
GenNative(m_lda_dirX, direct, gLong.disp, nil, 0)
else begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
GenNative(m_lda_dirX, direct, 0, nil, 0);
end {else}
end {else if}
else {if gLong.where = globalLabel then} begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if smallMemoryModel then
GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0)
else
if smallMemoryModel then
GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0)
end; {else}
if optype in [cgByte,cgUByte] then begin
GenNative(m_and_imm, immediate, 255, nil, 0);
if optype = cgByte then begin
GenNative(m_cmp_imm, immediate, 128, nil, 0);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end; {if}
end; {if}
end; {case cgByte,cgUByte,cgWord,cgUWord}
cgQuad,cgUQuad: begin
lQuad := gQuad;
GetPointer(op^.left);
gQuad := lQuad;
gQuad.where := gQuad.preference; {unless overridden later}
if gLong.where = inPointer then begin
if q = 0 then begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, 6, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenNative(m_lda_indl, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 6, nil, 0);
GenImplied(m_tay);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
end {if q = 0}
else begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, q+6, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, q+6, nil, 0);
GenImplied(m_tay);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
end; {else}
end {if glong.where = inPointer}
else if gLong.where = localAddress then begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if (gLong.disp < 250) and (gLong.disp >= 0) then begin
if gQuad.preference = onStack then begin
GenNative(m_pei_dir, direct, gLong.disp+6, nil, 0);
GenNative(m_pei_dir, direct, gLong.disp+4, nil, 0);
GenNative(m_pei_dir, direct, gLong.disp+2, nil, 0);
GenNative(m_pei_dir, direct, gLong.disp, nil, 0);
end {if}
else begin
GenNative(m_lda_dir, direct, gLong.disp+6, nil, 0);
StoreWordOfQuad(6);
GenNative(m_lda_dir, direct, gLong.disp+4, nil, 0);
StoreWordOfQuad(4);
GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
StoreWordOfQuad(2);
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
end {if}
else begin
gQuad.where := onStack;
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_lda_dirX, direct, 6, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, 4, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, 2, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, 0, nil, 0);
GenImplied(m_pha);
end {else}
else begin
gQuad.where := onStack;
if (gLong.disp >= 250) or (gLong.disp < 0) then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
gLong.disp := 0;
end; {if}
GenNative(m_lda_dirX, direct, gLong.disp+6, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, gLong.disp+4, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, gLong.disp+2, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirX, direct, gLong.disp, nil, 0);
GenImplied(m_pha);
end; {else}
end {else if gLong.where = localAddress}
else {if gLong.where = globalLabel then} begin
gLong.disp := gLong.disp+q;
if gLong.fixedDisp then
if smallMemoryModel then begin
GenNative(m_lda_abs, absolute, gLong.disp+6, gLong.lab, 0);
StoreWordOfQuad(6);
GenNative(m_lda_abs, absolute, gLong.disp+4, gLong.lab, 0);
StoreWordOfQuad(4);
GenNative(m_lda_abs, absolute, gLong.disp+2, gLong.lab, 0);
StoreWordOfQuad(2);
GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0);
StoreWordOfQuad(0);
end {if}
else begin
GenNative(m_lda_long, longAbs, gLong.disp+6, gLong.lab, 0);
StoreWordOfQuad(6);
GenNative(m_lda_long, longAbs, gLong.disp+4, gLong.lab, 0);
StoreWordOfQuad(4);
GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0);
StoreWordOfQuad(2);
GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0);
StoreWordOfQuad(6);
end {else}
else
if smallMemoryModel then begin
gQuad.where := onStack;
GenNative(m_lda_absX, absolute, gLong.disp+6, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_absX, absolute, gLong.disp+4, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_absX, absolute, gLong.disp+2, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0);
GenImplied(m_pha);
end {if}
else begin
gQuad.where := onStack;
GenNative(m_lda_longX, longAbs, gLong.disp+6, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_longX, longAbs, gLong.disp+4, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0);
GenImplied(m_pha);
GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0);
GenImplied(m_pha);
end; {else}
end; {else}
end; {case cgQuad,cgUQuad}
otherwise: Error(cge1);
end; {case}
end; {GenInd}
procedure GenIxa (op: icptr);
{ Generate code for a pc_ixa }
var
lab1: integer; {branch label}
lLong: longType; {type of address}
zero: boolean; {is the index 0?}
procedure Index;
{ Get the index size }
var
lLong: longType; {temp for preserving left node info}
begin {Index}
zero := false;
with op^.right^ do begin
if opcode = pc_ldc then begin
if q = 0 then
zero := true
else
GenNative(m_lda_imm, immediate, q, nil, 0);
end {if}
else begin
lLong := gLong;
GenTree(op^.right);
gLong := lLong;
end; {else}
end; {with}
end; {Index}
function IndexCanBeNegative: boolean;
{ Check if the index value (right argument) of a pc_ixa }
{ can validly be negative. Returns false if this is }
{ precluded by the type of the operation or other available }
{ information, or if any use of a negative index would be }
{ undefined behavior. Otherwise, returns true. }
{ }
{ parameters: }
{ op - pc_ixa operation }
begin {IndexCanBeNegative}
IndexCanBeNegative := true;
if op^.optype in [cgUByte,cgUWord] then
IndexCanBeNegative := false
else if (op^.right^.opcode = pc_ldc) and (op^.right^.q >= 0) then
IndexCanBeNegative := false
else if (op^.left^.opcode in [pc_lao,pc_lda]) and (op^.left^.q = 0) then
{Can't index before start of array, so using a negative index would be UB}
IndexCanBeNegative := false;
end; {IndexCanBeNegative}
begin {GenIxa}
if smallMemoryModel then begin
lLong := gLong;
gLong.preference := inPointer+localAddress+globalLabel;
GenTree(op^.left);
case gLong.where of
onStack: begin
Index;
if not zero then begin
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenNative(m_lda_s, direct, 3, nil, 0);
GenImplied(m_ina);
GenNative(m_sta_s, direct, 3, nil, 0);
GenLab(lab1);
end; {if}
end; {case onStack}
inPointer: begin
if not gLong.fixedDisp then begin
if Complex(op^.right) then begin
GenImplied(m_phy);
Index;
if not zero then begin
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
end; {if}
GenImplied(m_ply);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
OperA(m_adc_imm, op^.right);
GenImplied(m_tay);
end; {else}
end {if}
else begin
Index;
if not zero then begin
GenImplied(m_tay);
gLong.fixedDisp := false;
end; {if}
end; {else}
if (inPointer & lLong.preference) = 0 then begin
if not gLong.fixedDisp then begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
end {if}
else begin
GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
end; {else}
GenImplied(m_phx);
GenImplied(m_pha);
gLong.where := onStack;
end; {if}
end; {case inPointer}
localAddress,globalLabel: begin
if not gLong.fixedDisp then begin
if Complex(op^.right) then begin
GenImplied(m_phx);
Index;
if not zero then begin
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
end; {if}
GenImplied(m_plx);
end {if}
else begin
GenImplied(m_txa);
GenImplied(m_clc);
OperA(m_adc_imm, op^.right);
GenImplied(m_tax);
end; {else}
end {if}
else if Complex(op^.right) then begin
Index;
if not zero then begin
GenImplied(m_tax);
gLong.fixedDisp := false;
end; {if}
end {else if}
else begin
LoadX(op^.right);
gLong.fixedDisp := false;
end; {else}
if gLong.where = globalLabel then
if IndexCanBeNegative then begin
if (gLong.disp >= 0) and (gLong.disp <= 2) then begin
while gLong.disp > 0 do begin
GenImplied(m_inx);
gLong.disp := gLong.disp - 1;
end; {while}
end {if}
else begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
gLong.disp := 0;
end; {else}
end; {if}
if (lLong.preference & gLong.where) = 0 then begin
if (lLong.preference & inPointer) <> 0 then begin
if gLong.where = localAddress then begin
if not gLong.fixedDisp then begin
GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
GenImplied(m_phx);
GenImplied(m_tdc);
GenImplied(m_clc);
if gLong.disp <> 0 then
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenNative(m_adc_s, direct, 1, nil, 0);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenImplied(m_plx);
end {if}
else begin
GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
end; {else}
end {if}
else begin
if not gLong.fixedDisp then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
end {if}
else begin
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
end; {else}
end; {else}
gLong.where := inPointer;
gLong.fixedDisp := true;
gLong.disp := dworkLoc;
end {if}
else begin
if gLong.where = localAddress then begin
if not gLong.fixedDisp then begin
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_phx);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
if gLong.disp <> 0 then
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
end {if}
else begin
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_pha);
end; {else}
end {if}
else begin
if not gLong.fixedDisp then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
GenImplied(m_phx);
GenImplied(m_pha);
end {if}
else begin
GenNative(m_pea, immediate, gLong.disp, gLong.lab, shift16);
GenNative(m_pea, immediate, gLong.disp, gLong.lab, 0);
end; {else}
end; {else}
gLong.where := onStack;
end; {else}
end; {if}
end; {case localAddress,globalLabel}
otherwise:
Error(cge1);
end; {case}
end {if smallMemoryModel}
else begin
gLong.preference := onStack;
GenTree(op^.left);
GenTree(op^.right);
if IndexCanBeNegative then begin
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, $0000, nil, 0);
GenImplied(m_tay);
GenNative(m_bpl, relative, lab1, nil, 0);
GenImplied(m_dex);
GenLab(lab1);
GenImplied(m_phx);
GenImplied(m_pha);
end {else if}
else begin
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_pha);
end; {else}
GenImplied(m_clc);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenImplied(m_pla);
GenNative(m_adc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
gLong.where := onStack;
end; {else}
end; {GenIxa}
procedure GenLilLliLdlLld (op: icptr);
{ Generate code for a pc_lil, pc_lli, pc_ldl or pc_lld }
var
disp: integer; {load location}
lab1: integer; {branch point}
opcode: pcodes; {op^.opcode}
procedure DoXIncDec (op: pcodes; p: integer);
{ Do a decrement or increment on a local four byte value X }
{ bytes into the stack frame }
{ }
{ parameters }
{ op - operation code }
{ p - number to ind/dec by }
var
lab1: integer; {branch point}
begin {DoXIncDec}
if op in [pc_lil,pc_lli] then begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_inc_dirx, direct, 0, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenImplied(m_clc);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenNative(m_adc_imm, immediate, p, nil, 0);
GenNative(m_sta_dirx, direct, 0, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
GenNative(m_inc_dirx, direct, 2, nil, 0);
GenLab(lab1);
end {if}
else {if op in [pc_gdl,pc_gld] then} begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_dec_dirx, direct, 2, nil, 0);
GenLab(lab1);
GenNative(m_dec_dirx, direct, 0, nil, 0);
end {if}
else begin
GenImplied(m_sec);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenNative(m_sbc_imm, immediate, p, nil, 0);
GenNative(m_sta_dirx, direct, 0, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_dec_dirx, direct, 2, nil, 0);
GenLab(lab1);
end; {else}
end; {else}
end; {DoXIncDec}
procedure DoLIncDec (op: pcodes; disp, p: integer);
{ Do a decrement or increment on a local four byte value }
{ }
{ parameters }
{ op - operation code }
{ disp - disp in stack frame to value }
{ p - number to ind/dec by }
var
lab1: integer; {branch point}
begin {DoLIncDec}
if op in [pc_lil,pc_lli] then begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_inc_dir, direct, disp, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenImplied(m_clc);
GenNative(m_lda_dir, direct, disp, nil, 0);
GenNative(m_adc_imm, immediate, p, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
GenNative(m_inc_dir, direct, disp+2, nil, 0);
GenLab(lab1);
end {if}
else {if op in [pc_ldl,pc_lld] then} begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_lda_dir, direct, disp, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_dec_dir, direct, disp+2, nil, 0);
GenLab(lab1);
GenNative(m_dec_dir, direct, disp, nil, 0);
end {if}
else begin
GenImplied(m_sec);
GenNative(m_lda_dir, direct, disp, nil, 0);
GenNative(m_sbc_imm, immediate, p, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_dec_dir, direct, disp+2, nil, 0);
GenLab(lab1);
end; {else}
end; {else}
end; {DoLIncDec}
begin {GenLilLliLdlLld}
disp := LabelToDisp(op^.r);
opcode := op^.opcode;
case op^.optype of
cgLong, cgULong: begin
gLong.where := onStack;
if disp >= 254 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if opcode in [pc_lil,pc_ldl] then
DoXIncDec(opcode, op^.q);
if not skipLoad then begin
GenNative(m_lda_dirx, direct, 2, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenImplied(m_pha);
end {if}
else
gLong.where := A_X;
if opcode in [pc_lli,pc_lld] then
DoXIncDec(opcode, op^.q);
end {if}
else begin
if opcode in [pc_lil,pc_ldl] then
DoLIncDec(opcode, disp, op^.q);
if not skipLoad then begin
GenNative(m_pei_dir, direct, disp+2, nil, 0);
GenNative(m_pei_dir, direct, disp, nil, 0);
end {if}
else
gLong.where := A_X;
if opcode in [pc_lli,pc_lld] then
DoLIncDec(opcode, disp, op^.q);
end; {else}
end;
cgByte, cgUByte, cgWord, cgUWord: begin
if op^.optype in [cgByte,cgUByte] then
GenNative(m_sep, immediate, 32, nil, 0);
if disp >= 256 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if opcode = pc_lil then
GenNative(m_inc_dirx, direct, 0, nil, 0)
else if opcode = pc_ldl then
GenNative(m_dec_dirx, direct, 0, nil, 0);
if not skipLoad then
GenNative(m_lda_dirx, direct, 0, nil, 0);
if opcode = pc_lli then
GenNative(m_inc_dirx, direct, 0, nil, 0)
else if opcode = pc_lld then
GenNative(m_dec_dirx, direct, 0, nil, 0);
end
else begin
if opcode = pc_lil then
GenNative(m_inc_dir, direct, disp, nil, 0)
else if opcode = pc_ldl then
GenNative(m_dec_dir, direct, disp, nil, 0);
if not skipLoad then
GenNative(m_lda_dir, direct, disp, nil, 0);
if opcode = pc_lli then
GenNative(m_inc_dir, direct, disp, nil, 0)
else if opcode = pc_lld then
GenNative(m_dec_dir, direct, disp, nil, 0);
end; {else}
if op^.optype in [cgByte,cgUByte] then begin
GenNative(m_rep, immediate, 32, nil, 0);
if not skipLoad then begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if op^.optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
GenNative(m_cmp_imm, immediate, $0000, nil, 0);
end; {if}
end; {if}
end; {if}
end;
otherwise:
Error(cge1);
end; {case}
end; {GenLilLliLdlLld}
procedure GenLogic (op: icptr);
{ generate a pc_and, pc_ior, pc_bnd, pc_bor or pc_bxr }
var
lab1,lab2,lab3: integer; {label}
nd: icptr; {temp node pointer}
opcode: pcodes; {operation code}
begin {GenLogic}
opcode := op^.opcode;
if opcode in [pc_and,pc_ior] then begin
lab1 := GenLabel;
GenTree(op^.left);
GenImpliedForFlags(m_tax);
lab2 := GenLabel;
if opcode = pc_and then begin
GenNative(m_bne, relative, lab2, nil, 0);
GenNative(m_brl, longrelative, lab1, nil, 0);
end {if}
else begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_brl, longrelative, lab3, nil, 0);
end; {else}
GenLab(lab2);
GenTree(op^.right);
GenImpliedForFlags(m_tax);
GenNative(m_beq, relative, lab1, nil, 0);
if opcode = pc_ior then
GenLab(lab3);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end {if}
else begin
if not Complex(op^.left) then
if Complex(op^.right) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
GenTree(op^.left);
if Complex(op^.right) then begin
GenImplied(m_pha);
GenTree(op^.right);
case opcode of
pc_bnd: GenNative(m_and_s, direct, 1, nil, 0);
pc_bor: GenNative(m_ora_s, direct, 1, nil, 0);
pc_bxr: GenNative(m_eor_s, direct, 1, nil, 0);
otherwise:
Error(cge1);
end; {case}
GenImplied(m_plx);
GenImplied(m_tax);
end {if}
else
case opcode of
pc_bnd: OperA(m_and_imm, op^.right);
pc_bor: OperA(m_ora_imm, op^.right);
pc_bxr: OperA(m_eor_imm, op^.right);
otherwise:
Error(cge1);
end; {case}
end; {else}
end; {GenLogic}
procedure GenSroCpo (op: icptr);
{ Generate code for a pc_sro or pc_cpo }
var
lab: stringPtr; {op^.lab}
lab1: integer; {branch point}
lval: longint; {op^.left^.lval}
opcode: pcodes; {op^.opcode}
optype: baseTypeEnum; {op^.optype}
q: integer; {op^.q}
special: boolean; {special save?}
begin {GenSroCpo}
opcode := op^.opcode;
optype := op^.optype;
q := op^.q;
lab := op^.lab;
case optype of
cgByte, cgUByte: begin
if smallMemoryModel and (op^.left^.opcode = pc_ldc)
and (op^.left^.q = 0) and (opcode = pc_sro) then begin
GenNative(m_sep, immediate, 32, nil, 0);
GenNative(m_stz_abs, absolute, q, lab, 0);
end {if}
else begin
if op^.opcode = pc_sro then
if op^.left^.opcode = pc_cnv then
if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
op^.left := op^.left^.left;
if op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod] then begin
GenNative(m_sep, immediate, 32, nil, 0);
GenTree(op^.left);
end {if}
else begin
GenTree(op^.left);
GenNative(m_sep, immediate, 32, nil, 0);
end; {else}
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
end; {else}
GenNative(m_rep, immediate, 32, nil, 0);
end;
cgWord, cgUWord:
if smallMemoryModel and (op^.left^.opcode = pc_ldc)
and (op^.left^.q = 0) and (opcode = pc_sro) then
GenNative(m_stz_abs, absolute, q, lab, 0)
else begin
GenTree(op^.left);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
end; {else}
cgReal, cgDouble, cgComp, cgExtended: begin
GenTree(op^.left);
GenNative(m_pea, immediate, q, lab, shift16);
GenNative(m_pea, immediate, q, lab, 0);
if opcode = pc_sro then begin
if optype = cgReal then
GenCall(9)
else if optype = cgDouble then
GenCall(10)
else if optype = cgComp then
GenCall(66)
else {if optype = cgExtended then}
GenCall(67);
end {if}
else {if opcode = pc_cpo then} begin
if optype = cgReal then begin
GenCall(9);
GenNative(m_pea, immediate, q, lab, shift16);
GenNative(m_pea, immediate, q, lab, 0);
GenCall(21);
end {if}
else if optype = cgDouble then begin
GenCall(10);
GenNative(m_pea, immediate, q, lab, shift16);
GenNative(m_pea, immediate, q, lab, 0);
GenCall(22);
end {else if}
else if optype = cgComp then begin
GenCall(66);
GenNative(m_pea, immediate, q, lab, shift16);
GenNative(m_pea, immediate, q, lab, 0);
GenCall(70);
end {else if}
else {if optype = cgExtended then}
GenCall(69);
end; {else}
end;
cgLong, cgULong: begin
if (opcode = pc_sro) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
GenAdlSbl(op^.left, op)
else if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then
GenIncDec(op^.left, op)
else if smallMemoryModel and (op^.left^.opcode = pc_ldc) then begin
lval := op^.left^.lval;
if long(lval).lsw = 0 then
GenNative(m_stz_abs, absolute, q, lab, 0)
else begin
GenNative(m_lda_imm, immediate, long(lval).lsw, nil, 0);
GenNative(m_sta_abs, absolute, q, lab, 0)
end; {else}
if long(lval).msw = 0 then
GenNative(m_stz_abs, absolute, q+2, lab, 0)
else begin
GenNative(m_ldx_imm, immediate, long(lval).msw, nil, 0);
GenNative(m_stx_abs, absolute, q+2, lab, 0)
end; {else}
if op^.opcode = pc_cpo then
GenTree(op^.left);
end {if}
else begin
if op^.opcode = pc_sro then
gLong.preference := A_X | inPointer | localAddress | globalLabel | constant
else
gLong.preference := gLong.preference &
(A_X | inPointer | localAddress | globalLabel | constant);
GenTree(op^.left);
case gLong.where of
A_X: begin
if smallMemoryModel then begin
GenNative(m_stx_abs, absolute, q+2, lab, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
end {if}
else begin
GenNative(m_sta_long, longabsolute, q, lab, 0);
if opcode = pc_cpo then
GenImplied(m_pha);
GenImplied(m_txa);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
if opcode = pc_cpo then
GenImplied(m_pla);
end; {else}
end;
onStack: begin
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 1, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 3, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q+2, lab, 0)
else
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
end;
inPointer: begin
GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
if gLong.fixedDisp then
GenNative(m_lda_dir, direct, gLong.disp, nil, 0)
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
if not smallMemoryModel then begin
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
end; {if}
end; {else}
if smallMemoryModel then begin
GenNative(m_stx_abs, absolute, q+2, lab, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
end {if}
else begin
GenNative(m_sta_long, longabsolute, q, lab, 0);
if opcode = pc_cpo then
GenImplied(m_pha);
GenImplied(m_txa);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
if opcode = pc_cpo then
GenImplied(m_pla);
end; {else}
gLong.where := A_X;
end;
localAddress: begin
if smallMemoryModel then
GenNative(m_stz_abs, absolute, q+2, lab, 0)
else begin
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
end; {else}
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
if not gLong.fixedDisp then begin
GenImplied(m_phx);
GenNative(m_adc_s, direct, 1, nil, 0);
GenImplied(m_plx);
end; {if}
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
end;
globalLabel:
if gLong.fixedDisp then begin
if smallMemoryModel then begin
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16);
GenNative(m_stx_abs, absolute, q+2, lab, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
end {if}
else begin
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
if opcode = pc_cpo then
GenImplied(m_tax);
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0);
GenNative(m_sta_long, longabsolute, q, lab, 0);
end; {else}
gLong.where := A_X;
end {if}
else begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
GenNative(m_adc_imm, immediate, 0, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q+2, lab, 0)
else
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
end; {else}
constant: begin
if gLong.lval = 0 then begin
if smallMemoryModel then begin
GenNative(m_stz_abs, absolute, q+2, lab, 0);
GenNative(m_stz_abs, absolute, q, lab, 0);
end {if}
else begin
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
GenNative(m_sta_long, longabsolute, q, lab, 0);
end; {else}
end {if}
else if not smallMemoryModel then begin
GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
GenNative(m_sta_long, longabsolute, q, lab, 0);
end {else if}
else begin
if long(gLong.lval).msw = 0 then
GenNative(m_stz_abs, absolute, q+2, lab, 0)
else begin
GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_stx_abs, absolute, q+2, lab, 0);
end; {else}
if long(gLong.lval).lsw = 0 then
GenNative(m_stz_abs, absolute, q, lab, 0)
else begin
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
GenNative(m_sta_abs, absolute, q, lab, 0);
end; {else}
if (long(gLong.lval).lsw <> 0) and (long(gLong.lval).msw <> 0) then
gLong.where := A_X;
end; {else}
end; {case constant}
otherwise:
Error(cge1);
end; {case}
end; {else}
end; {case CGLong, cgULong}
cgQuad, cgUQuad: begin
if opcode = pc_sro then begin
gQuad.preference := globalLabel;
gQuad.lab := lab;
gQuad.disp := q;
end {if}
else {if opcode = pc_cpo then}
gQuad.preference := onStack;
GenTree(op^.left);
if gQuad.where = onStack then begin
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 1, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q, lab, 0)
else
GenNative(m_sta_long, longabsolute, q, lab, 0);
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 3, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q+2, lab, 0)
else
GenNative(m_sta_long, longabsolute, q+2, lab, 0);
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 5, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q+4, lab, 0)
else
GenNative(m_sta_long, longabsolute, q+4, lab, 0);
if opcode = pc_sro then
GenImplied(m_pla)
else {if opcode = pc_cpo then}
GenNative(m_lda_s, direct, 7, nil, 0);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, q+6, lab, 0)
else
GenNative(m_sta_long, longabsolute, q+6, lab, 0);
end; {if}
end; {case cgQuad, cgUQuad}
end; {case}
end; {GenSroCpo}
procedure GenStoCpi (op: icptr);
{ Generate code for a pc_sto or pc_cpi }
var
disp: integer; {disp in stack frame}
opcode: pcodes; {temp storage for op code}
optype: baseTypeEnum; {operand type}
short: boolean; {use short registers?}
simple: boolean; {is the load a simple load?}
lLong: longType; {address record for left node}
zero: boolean; {is the operand a constant zero?}
lab1: integer; {label}
procedure LoadLSW;
{ load the least significant word of a four byte value }
begin {LoadLSW}
if lLong.where = onStack then
if opcode = pc_sto then
GenImplied(m_pla)
else
GenNative(m_lda_s, direct, 1, nil, 0)
else {if lLong.where = constant then}
GenNative(m_lda_imm, immediate, long(lLong.lval).lsw, nil, 0);
end; {LoadLSW}
procedure LoadMSW;
{ load the most significant word of a four byte value }
{ }
{ Note: LoadLSW MUST be called first! }
begin {LoadMSW}
if lLong.where = onStack then
if opcode = pc_sto then
GenImplied(m_pla)
else
GenNative(m_lda_s, direct, 3, nil, 0)
else {if lLong.where = constant then}
GenNative(m_lda_imm, immediate, long(lLong.lval).msw, nil, 0);
end; {LoadMSW}
procedure LoadWord;
{ Get the operand for a cgByte, cgUByte, cgWord or cgUWord }
{ into the accumulator }
begin {LoadWord}
if simple then begin
with op^.right^ do
if opcode = pc_ldc then
GenNative(m_lda_imm, immediate, q, nil, 0)
else if opcode = pc_lod then
GenNative(m_lda_dir, direct, LabelToDisp(r) + q, nil, 0)
else {if opcode = pc_ldo then}
if smallMemoryModel then
GenNative(m_lda_abs, absolute, q, lab, 0)
else
GenNative(m_lda_long, longabsolute, q, lab, 0);
if not short then
if op^.right^.optype in [cgByte,cgUByte] then
if op^.right^.opcode <> pc_ldc then begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end; {if}
end; {if}
end {if}
else begin
GenImplied(m_pla);
if short then
GenNative(m_sep, immediate, 32, nil, 0);
end {else}
end; {LoadWord}
begin {GenStoCpi}
opcode := op^.opcode;
optype := op^.optype;
case optype of
cgReal,cgDouble,cgComp,cgExtended: begin
if opcode = pc_sto then begin
GenTree(op^.right);
gLong.preference := onStack;
GenTree(op^.left);
if optype = cgReal then
GenCall(9)
else if optype = cgDouble then
GenCall(10)
else if optype = cgComp then
GenCall(66)
else {if optype = cgExtended then}
GenCall(67);
end {if}
else {if opcode = pc_cpi then} begin
if optype = cgExtended then begin
GenTree(op^.right);
gLong.preference := onStack;
GenTree(op^.left);
GenCall(69);
end {if}
else begin
gLong.preference := onStack;
GenTree(op^.left);
GenTree(op^.right);
GenNative(m_lda_s, direct, 13, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_s, direct, 13, nil, 0);
GenImplied(m_pha);
if optype = cgReal then begin
GenCall(9);
GenCall(21);
end {if}
else if optype = cgDouble then begin
GenCall(10);
GenCall(22);
end {else if}
else {if optype = cgComp then} begin
GenCall(66);
GenCall(70);
end; {else}
end; {else}
end; {else}
end; {case cgReal,cgDouble,cgComp,cgExtended}
cgQuad,cgUQuad: begin
gQuad.preference := onStack;
if opcode = pc_sto then
if op^.left^.opcode = pc_lod then begin
disp := LabelToDisp(op^.left^.r) + op^.left^.q;
if disp <= 255 then begin
gQuad.preference := inPointer;
gQuad.disp := disp;
end; {if}
end; {if}
GenTree(op^.right);
if gQuad.where = onStack then begin
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
if opcode = pc_sto then
GenImplied(m_pla)
else {if op^.opcode = pc_cpi then}
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
GenNative(m_ldy_imm, immediate, 2, nil, 0);
if opcode = pc_sto then
GenImplied(m_pla)
else {if op^.opcode = pc_cpi then}
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
GenImplied(m_iny);
GenImplied(m_iny);
if opcode = pc_sto then
GenImplied(m_pla)
else {if op^.opcode = pc_cpi then}
GenNative(m_lda_s, direct, 5, nil, 0);
GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
GenImplied(m_iny);
GenImplied(m_iny);
if opcode = pc_sto then
GenImplied(m_pla)
else {if op^.opcode = pc_cpi then}
GenNative(m_lda_s, direct, 7, nil, 0);
GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
if op^.opcode = pc_cpi then
gQuad.where := onStack;
end; {if}
end; {case cgQuad,cgUQuad}
cgLong,cgULong: begin
if opcode = pc_sto then
gLong.preference := onStack+constant
else
gLong.preference := (onStack+constant) & gLong.preference;
GenTree(op^.right);
lLong := gLong;
gLong.preference := localAddress+inPointer+globalLabel+A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0);
LoadLSW;
GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
GenNative(m_ldy_imm, immediate, 2, nil, 0);
LoadMSW;
GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
end {if}
else if gLong.where = A_X then begin
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0);
LoadLSW;
GenNative(m_sta_indl, direct, dworkLoc, nil, 0);
GenNative(m_ldy_imm, immediate, 2, nil, 0);
LoadMSW;
GenNative(m_sta_indly, direct, dworkLoc, nil, 0);
end {if}
else if gLong.where = localAddress then begin
LoadLSW;
if gLong.fixedDisp then
if (gLong.disp & $FF00) = 0 then
GenNative(m_sta_dir, direct, gLong.disp, nil, 0)
else begin
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
end {else}
else begin
if (gLong.disp >= 254) or (gLong.disp < 0) then begin
GenImplied(m_tay);
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
GenImplied(m_tya);
gLong.disp := 0;
end; {if}
GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
end; {else}
LoadMSW;
if gLong.fixedDisp then
if ((gLong.disp+2) & $FF00) = 0 then
GenNative(m_sta_dir, direct, gLong.disp+2, nil, 0)
else begin
GenNative(m_ldx_imm, immediate, gLong.disp+2, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
end {else}
else begin
if (gLong.disp >= 254) or (gLong.disp < 0) then begin
GenImplied(m_tay);
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
GenImplied(m_tax);
GenImplied(m_tya);
gLong.disp := 0;
end; {if}
GenNative(m_sta_dirX, direct, gLong.disp+2, nil, 0);
end; {else}
end {else if}
else if gLong.where = globalLabel then begin
LoadLSW;
if gLong.fixedDisp then
if smallMemoryModel then
GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
else
if smallMemoryModel then
GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
LoadMSW;
if gLong.fixedDisp then
if smallMemoryModel then
GenNative(m_sta_abs, absolute, gLong.disp+2, gLong.lab, 0)
else
GenNative(m_sta_long, longAbs, gLong.disp+2, gLong.lab, 0)
else
if smallMemoryModel then
GenNative(m_sta_absX, absolute, gLong.disp+2, gLong.lab, 0)
else
GenNative(m_sta_longX, longAbs, gLong.disp+2, gLong.lab, 0);
end {else if}
else begin
LoadLSW;
if gLong.fixedDisp = true then begin
GenNative(m_sta_indl, direct, gLong.disp, nil, 0);
GenNative(m_ldy_imm, immediate, 2, nil, 0);
end {if}
else begin
GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
GenImplied(m_iny);
GenImplied(m_iny);
end; {else}
LoadMSW;
GenNative(m_sta_indly, direct, gLong.Disp, nil, 0);
end; {else}
gLong := lLong;
end; {case cgLong,cgULong}
cgByte,cgUByte,cgWord,cgUWord: begin
short := optype in [cgByte,cgUByte];
simple := false;
zero := false;
if op^.opcode = pc_sto then begin
if short then
if op^.right^.opcode = pc_cnv then
if (op^.right^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
op^.right := op^.right^.left;
with op^.right^ do begin
if opcode = pc_ldo then
simple := true
else if opcode = pc_lod then
simple := LabelToDisp(r) + q < 256
else if opcode = pc_ldc then begin
simple := true;
zero := q = 0;
end; {else if}
end; {with}
end; {if}
if not (zero or simple) then begin
GenTree(op^.right);
GenImplied(m_pha);
end; {if}
GetPointer(op^.left);
if gLong.where = inPointer then begin
if short and simple then
GenNative(m_sep, immediate, 32, nil, 0);
if zero then
GenNative(m_lda_imm, immediate, 0, nil, 0)
else
LoadWord;
if gLong.fixedDisp then
GenNative(m_sta_indl, direct, gLong.disp, nil, 0)
else
GenNative(m_sta_indlY, direct, gLong.disp, nil, 0);
end {if}
else if gLong.where = localAddress then begin
if gLong.fixedDisp then begin
if short and simple then
GenNative(m_sep, immediate, 32, nil, 0);
if (gLong.disp & $FF00) = 0 then
if zero then
GenNative(m_stz_dir, direct, gLong.disp, nil, 0)
else begin
LoadWord;
GenNative(m_sta_dir, direct, gLong.disp, nil, 0);
end {else}
else begin
if zero then begin
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_stz_dirX, direct, 0, nil, 0);
end {if}
else begin
LoadWord;
GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
end; {else}
end {else}
end {if}
else begin
if (gLong.disp & $FF00) <> 0 then begin
GenImplied(m_txa);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, glong.disp, nil, 0);
GenImplied(m_tax);
gLong.disp := 0;
end; {if}
if short and simple then
GenNative(m_sep, immediate, 32, nil, 0);
if zero then
GenNative(m_stz_dirX, direct, gLong.disp, nil, 0)
else begin
LoadWord;
GenNative(m_sta_dirX, direct, gLong.disp, nil, 0);
end; {else}
end; {else}
end {else if}
else {if gLong.where = globalLabel then} begin
if short and simple then
GenNative(m_sep, immediate, 32, nil, 0);
if zero then begin
if not smallMemoryModel then
GenNative(m_lda_imm, immediate, 0, nil, 0);
end {if}
else
LoadWord;
if gLong.fixedDisp then
if smallMemoryModel then
if zero then
GenNative(m_stz_abs, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0)
else
if smallMemoryModel then
if zero then
GenNative(m_stz_absX, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0)
else
GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0);
end; {else}
if short then begin
GenNative(m_rep, immediate, 32, nil, 0);
if opcode = pc_cpi then begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end; {if}
end; {if}
end; {if}
end; {case cgByte,cgUByte,cgWord,cgUWord}
otherwise:
Error(cge1);
end; {case}
end; {GenStoCpi}
procedure GenStrCop (op: icptr);
{ Generate code for a pc_str or pc_cop }
var
disp: integer; {store location}
optype: baseTypeEnum; {op^.optype}
special: boolean; {use special processing?}
zero: boolean; {is the operand a constant zero?}
begin {GenStrCop}
disp := LabelToDisp(op^.r) + op^.q;
optype := op^.optype;
case optype of
cgByte, cgUByte, cgWord, cgUWord: begin
zero := false;
if op^.left^.opcode = pc_ldc then
if op^.opcode = pc_str then
if op^.left^.q = 0 then
zero := true;
if not zero then begin
if optype in [cgByte,cgUByte] then begin
if op^.opcode = pc_str then
if op^.left^.opcode = pc_cnv then
if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then
op^.left := op^.left^.left;
if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod])
and (op^.opcode = pc_str) then begin
GenNative(m_sep, immediate, 32, nil, 0);
GenTree(op^.left);
end {if}
else begin
GenTree(op^.left);
GenNative(m_sep, immediate, 32, nil, 0);
end; {else}
end {if}
else
GenTree(op^.left);
end {if}
else
if optype in [cgByte,cgUByte] then
GenNative(m_sep, immediate, 32, nil, 0);
if disp > 255 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if zero then
GenNative(m_stz_dirx, direct, 0, nil, 0)
else
GenNative(m_sta_dirx, direct, 0, nil, 0);
end {if}
else
if zero then
GenNative(m_stz_dir, direct, disp, nil, 0)
else
GenNative(m_sta_dir, direct, disp, nil, 0);
if optype in [cgByte,cgUByte] then
GenNative(m_rep, immediate, 32, nil, 0);
end;
cgReal, cgDouble, cgComp, cgExtended: begin
GenTree(op^.left);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, disp, nil, 0);
GenImplied(m_pha);
if op^.opcode = pc_str then begin
if optype = cgReal then
GenCall(9)
else if optype = cgDouble then
GenCall(10)
else if optype = cgComp then
GenCall(66)
else {if optype = cgExtended then}
GenCall(67);
end {if}
else begin
if optype = cgReal then begin
GenCall(9);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, disp, nil, 0);
GenImplied(m_pha);
GenCall(21);
end {if}
else if optype = cgDouble then begin
GenCall(10);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, disp, nil, 0);
GenImplied(m_pha);
GenCall(22);
end {else if}
else if optype = cgComp then begin
GenCall(66);
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, disp, nil, 0);
GenImplied(m_pha);
GenCall(70);
end {else if}
else {if optype = cgExtended then}
GenCall(69);
end; {else}
end;
cgLong, cgULong: begin
if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_adl,pc_sbl]) then
GenAdlSbl(op^.left, op)
else if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then
GenIncDec(op^.left, op)
else begin
if op^.opcode = pc_str then
gLong.preference :=
A_X+onStack+inPointer+localAddress+globalLabel+constant
else
gLong.preference := onStack;
GenTree(op^.left);
case gLong.where of
A_X:
if disp < 254 then begin
GenNative(m_stx_dir, direct, disp+2, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
end {else if}
else begin
GenImplied(m_txy);
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenNative(m_sty_dirX, direct, 2, nil, 0);
if op^.opcode = pc_cop then
GenImplied(m_tyx);
end; {else}
onStack:
if disp < 254 then begin
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_sta_dir, direct, disp+2, nil, 0);
end {else if}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_sta_dirX, direct, 2, nil, 0);
end; {else}
inPointer: begin
if (disp < 254) and (gLong.disp < 254) and gLong.fixedDisp
and (disp >= 0) and (gLong.disp >= 0) then begin
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenNative(m_stx_dir, direct, disp+2, nil, 0);
end {if}
else if (disp < 254) and (gLong.disp < 254)
and (disp >= 0) and (gLong.disp >= 0)
and (op^.opcode = pc_str) then begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
GenNative(m_adc_imm, immediate, 0, nil, 0);
GenNative(m_sta_dir, direct, disp+2, nil, 0);
end {else if}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if not gLong.fixedDisp then begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_dir, direct, gLong.disp, nil, 0);
end {if}
else
GenNative(m_lda_dir, direct, gLong.disp, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0);
if not gLong.fixedDisp then
GenNative(m_adc_imm, immediate, 0, nil, 0);
GenNative(m_sta_dirX, direct, 2, nil, 0);
end; {else}
end;
localAddress:
if disp < 254 then begin
GenNative(m_stz_dir, direct, disp+2, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
if not gLong.fixedDisp then begin
GenImplied(m_phx);
GenNative(m_adc_s, direct, 1, nil, 0);
GenImplied(m_plx);
end; {if}
GenNative(m_sta_dir, direct, disp, nil, 0);
end {else if disp < 254}
else begin
if not gLong.fixedDisp then
GenImplied(m_phx);
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, nil, 0);
if not gLong.fixedDisp then
GenNative(m_adc_s, direct, 1, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenNative(m_stz_dirX, direct, 2, nil, 0);
if not gLong.fixedDisp then
GenImplied(m_plx);
end; {else}
globalLabel: begin
if not gLong.fixedDisp then
GenImplied(m_txa);
if disp > 253 then begin
if op^.opcode = pc_cop then
if not gLong.fixedDisp then
GenImplied(m_tay)
else
GenImplied(m_txy);
GenNative(m_ldx_imm, immediate, disp, nil, 0);
end; {if}
if gLong.fixedDisp then
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0)
else begin
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0);
end; {else}
if disp < 254 then
GenNative(m_sta_dir, direct, disp, nil, 0)
else
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16);
if not gLong.fixedDisp then
GenNative(m_adc_imm, immediate, 0, nil, 0);
if disp < 254 then
GenNative(m_sta_dir, direct, disp+2, nil, 0)
else begin
GenNative(m_sta_dirX, direct, 2, nil, 0);
if op^.opcode = pc_cop then
GenImplied(m_tyx);
end; {else}
end;
constant:
if disp < 254 then begin
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_sta_dir, direct, disp+2, nil, 0);
end {else}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_sta_dirX, direct, 2, nil, 0);
end; {else}
otherwise:
Error(cge1);
end; {case}
end; {else}
end;
cgQuad, cgUQuad: begin
if op^.opcode = pc_str then begin
gQuad.preference := localAddress;
gQuad.disp := disp;
end {if}
else {if op^.opcode = pc_cop then}
gQuad.preference := onStack;
GenTree(op^.left);
if gQuad.where = onStack then begin
if disp < 250 then begin
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sta_dir, direct, disp, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_sta_dir, direct, disp+2, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 5, nil, 0);
GenNative(m_sta_dir, direct, disp+4, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 7, nil, 0);
GenNative(m_sta_dir, direct, disp+6, nil, 0);
end {else if}
else begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_sta_dirX, direct, 0, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_sta_dirX, direct, 2, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 5, nil, 0);
GenNative(m_sta_dirX, direct, 4, nil, 0);
if op^.opcode = pc_str then
GenImplied(m_pla)
else {if op^.opcode = pc_cop then}
GenNative(m_lda_s, direct, 7, nil, 0);
GenNative(m_sta_dirX, direct, 6, nil, 0);
end; {else}
end; {if}
end;
otherwise: Error(cge1);
end; {case}
end; {GenStrCop}
procedure GenUnaryLong (op: icptr);
{ generate a pc_bnl or pc_ngl }
begin {GenUnaryLong}
gLong.preference := onStack; {get the operand}
GenTree(op^.left);
case op^.opcode of {do the operation}
pc_bnl: begin
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
end; {case pc_bnl}
pc_ngl: begin
GenImplied(m_sec);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenNative(m_sbc_s, direct, 1, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenNative(m_sbc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
end; {case pc_ngl}
end; {case}
gLong.where := onStack; {the result is on the stack}
end; {GenUnaryLong}
procedure GenUnaryQuad (op: icptr);
{ generate a pc_bnq or pc_ngq }
begin {GenUnaryQuad}
case op^.opcode of {do the operation}
pc_bnq: begin
if SimpleQuadLoad(op^.left) then begin
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
StoreWordOfQuad(6);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
StoreWordOfQuad(4);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
StoreWordOfQuad(2);
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
StoreWordOfQuad(0);
gQuad.where := gQuad.preference;
end {if}
else begin
gQuad.preference := onStack;
GenTree(op^.left);
GenNative(m_lda_s, direct, 1, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenNative(m_lda_s, direct, 5, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 5, nil, 0);
GenNative(m_lda_s, direct, 7, nil, 0);
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
gQuad.where := onStack;
end; {else}
end; {case pc_bnq}
pc_ngq: begin
if SimpleQuadLoad(op^.left) then begin
gQuad.where := gQuad.preference;
if gQuad.preference = onStack then begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
gQuad.preference := inStackLoc;
gQuad.disp := 1;
end; {if}
GenImplied(m_sec);
GenNative(m_lda_imm, immediate, 0, nil, 0);
OpOnWordOfQuad(m_sbc_imm, op^.left, 0);
StoreWordOfQuad(0);
GenNative(m_lda_imm, immediate, 0, nil, 0);
OpOnWordOfQuad(m_sbc_imm, op^.left, 2);
StoreWordOfQuad(2);
GenNative(m_lda_imm, immediate, 0, nil, 0);
OpOnWordOfQuad(m_sbc_imm, op^.left, 4);
StoreWordOfQuad(4);
GenNative(m_lda_imm, immediate, 0, nil, 0);
OpOnWordOfQuad(m_sbc_imm, op^.left, 6);
StoreWordOfQuad(6);
end {if}
else begin
gQuad.preference := onStack;
GenTree(op^.left);
GenImplied(m_sec);
GenNative(m_ldy_imm, immediate, 0, nil, 0);
GenImplied(m_tya);
GenNative(m_sbc_s, direct, 1, nil, 0);
GenNative(m_sta_s, direct, 1, nil, 0);
GenImplied(m_tya);
GenNative(m_sbc_s, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenImplied(m_tya);
GenNative(m_sbc_s, direct, 5, nil, 0);
GenNative(m_sta_s, direct, 5, nil, 0);
GenImplied(m_tya);
GenNative(m_sbc_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
gQuad.where := onStack;
end; {else}
end; {case pc_ngq}
end; {case}
end; {GenUnaryQuad}
{$segment 'gen2'}
procedure GenDebugSourceFile (debugFile: gsosOutStringPtr);
{ generate debug code indicating the specified source file name }
var
i: integer; {loop/index variable}
len: integer; {length of the file name}
begin {GenDebugSourceFile}
GenNative(m_cop, immediate, 6, nil, 0);
GenNative(d_add, genaddress, stringSize, nil, stringReference);
GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
len := debugFile^.theString.size;
if len > 255 then
len := 255;
if maxString-stringSize >= len+1 then begin
stringSpace^[stringSize+1] := chr(len);
for i := 1 to len do
stringSpace^[i+stringSize+1] :=
debugFile^.theString.theString[i];
stringSize := stringSize + len + 1;
end {if}
else
Error(cge3);
end; {GenDebugSourceFile}
procedure GenTree {op: icptr};
{ generate code for op and its children }
{ }
{ parameters: }
{ op - opcode for which to generate code }
procedure GenAdi (op: icptr);
{ generate a pc_adi }
var
nd: icptr;
begin {GenAdi}
if not Complex(op^.left) then
if Complex(op^.right) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
GenTree(op^.left);
if Complex(op^.right) then begin
GenImplied(m_pha);
GenTree(op^.right);
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
GenImplied(m_plx);
end {if}
else begin
GenImplied(m_clc);
OperA(m_adc_imm, op^.right);
end; {else}
end; {GenAdi}
procedure GenBinLong (op: icptr);
{ generate one of: pc_blr, pc_blx, pc_bal, pc_dvl, pc_mdl, }
{ pc_mpl, pc_sll, pc_slr, pc_udl, pc_ulm, pc_uml, pc_vsr }
var
nd: icptr; {for swapping left/right children}
lab1,lab2: integer; {label numbers}
procedure GenOp (ops, opi: integer);
{ generate a binary operation }
{ }
{ parameters: }
{ ops - stack version of operation }
{ opi - immediate version of operation }
begin {GenOp}
if gLong.where = A_X then
GenImplied(m_phx)
else
GenImplied(m_pla);
if gLong.where = constant then begin
GenNative(opi, immediate, long(gLong.lval).lsw, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_s, direct, 3, nil, 0);
GenNative(opi, immediate, long(gLong.lval).msw, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
end {if}
else begin
GenNative(ops, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenImplied(m_pla);
GenNative(ops, direct, 3, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
end; {else}
end; {GenOp}
begin {GenBinLong}
if (op^.left^.opcode = pc_ldc) and
(op^.opcode in [pc_blr,pc_blx,pc_bal]) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
if op^.opcode = pc_mdl then
GenImplied(m_phd); {reserve stack space}
gLong.preference := onStack;
GenTree(op^.left);
if op^.opcode in [pc_blr,pc_blx,pc_bal] then begin
gLong.preference := constant;
GenTree(op^.right);
end {if}
else if op^.opcode in [pc_uml,pc_udl,pc_ulm] then begin
gLong.preference := A_X;
GenTree(op^.right);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
end {else if}
else begin
gLong.preference := onStack;
GenTree(op^.right);
end; {else}
case op^.opcode of
pc_blr: GenOp(m_ora_s, m_ora_imm);
pc_blx: GenOp(m_eor_s, m_eor_imm);
pc_bal: GenOp(m_and_s, m_and_imm);
pc_dvl: GenCall(43);
pc_mdl: begin
lab1 := GenLabel;
lab2 := GenLabel;
{stash high word of dividend (for sign)}
GenNative(m_lda_s, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 9, nil, 0);
GenCall(78); {call ~DIV4}
GenImplied(m_ply); {ignore quotient}
GenImplied(m_ply);
GenImplied(m_pla); {get remainder (always positive or 0)}
GenImplied(m_plx);
GenImplied(m_ply); {if dividend was negative...}
GenNative(m_bpl, relative, lab1, nil, 0);
GenImplied(m_clc); { negate remainder}
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenNative(m_adc_imm, immediate, 1, nil, 0);
GenImplied(m_tay);
GenImplied(m_txa);
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenNative(m_adc_imm, immediate, 0, nil, 0);
GenImplied(m_pha);
GenImplied(m_phy);
GenNative(m_bra, relative, lab2, nil, 0);
GenLab(lab1);
GenImplied(m_phx);
GenImplied(m_pha);
GenLab(lab2);
end;
pc_mpl: GenCall(42);
pc_sll: GenCall(45);
pc_slr: GenCall(47);
pc_udl: GenCall(49);
pc_ulm: GenCall(50);
pc_uml: GenCall(48);
pc_vsr: GenCall(46);
otherwise: Error(cge1);
end; {case}
gLong.where := onStack;
end; {GenBinLong}
procedure GenBinQuad (op: icptr);
{ generate one of: pc_bqr, pc_bqx, pc_baq, pc_mpq, pc_umq, }
{ pc_dvq, pc_udq, pc_mdq, pc_uqm }
procedure GenBitwiseOp;
{ generate a 64-bit binary bitwise operation }
{ }
{ parameters: }
{ ops - stack version of operation }
var
mop: integer; {machine opcode}
begin {GenBitwiseOp}
if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin
case op^.opcode of
pc_bqr: mop := m_ora_imm;
pc_bqx: mop := m_eor_imm;
pc_baq: mop := m_and_imm;
end; {case}
OpOnWordOfQuad(m_lda_imm, op^.left, 6);
OpOnWordOfQuad(mop, op^.right, 6);
StoreWordOfQuad(6);
OpOnWordOfQuad(m_lda_imm, op^.left, 4);
OpOnWordOfQuad(mop, op^.right, 4);
StoreWordOfQuad(4);
OpOnWordOfQuad(m_lda_imm, op^.left, 2);
OpOnWordOfQuad(mop, op^.right, 2);
StoreWordOfQuad(2);
OpOnWordOfQuad(m_lda_imm, op^.left, 0);
OpOnWordOfQuad(mop, op^.right, 0);
StoreWordOfQuad(0);
gQuad.where := gQuad.preference;
end {if}
else begin
case op^.opcode of
pc_bqr: mop := m_ora_s;
pc_bqx: mop := m_eor_s;
pc_baq: mop := m_and_s;
end; {case}
gQuad.preference := onStack;
GenTree(op^.left);
gQuad.preference := onStack;
GenTree(op^.right);
GenImplied(m_pla);
GenNative(mop, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(mop, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(mop, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(mop, direct, 7, nil, 0);
GenNative(m_sta_s, direct, 7, nil, 0);
gQuad.where := onStack;
end; {else}
end; {GenBitwiseOp}
begin {GenBinQuad}
if op^.opcode in [pc_bqr,pc_bqx,pc_baq] then
GenBitwiseOp
else begin
gQuad.preference := onStack;
GenTree(op^.left);
gQuad.preference := onStack;
GenTree(op^.right);
case op^.opcode of
pc_mpq: GenCall(79);
pc_umq: GenCall(80);
pc_dvq: begin
GenCall(81); {do division}
GenImplied(m_pla); {get quotient, discarding remainder}
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
end;
pc_udq: begin
GenCall(82); {do division}
GenImplied(m_pla); {get quotient, discarding remainder}
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
GenImplied(m_pla);
GenNative(m_sta_s, direct, 7, nil, 0);
end;
pc_mdq: begin
GenCall(81); {do division}
GenImplied(m_tsc); {discard quotient, leaving remainder}
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end;
pc_uqm: begin
GenCall(82); {do division}
GenImplied(m_tsc); {discard quotient, leaving remainder}
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end;
pc_slq: GenCall(85);
pc_sqr: GenCall(86);
pc_wsr: GenCall(87);
otherwise: Error(cge1);
end; {case}
gQuad.where := onStack;
end; {else}
end; {GenBinQuad}
procedure GenBno (op: icptr);
{ Generate code for a pc_bno }
var
lLong: longType; {requested address type}
lQuad: quadType;
begin {GenBno}
lLong := gLong;
lQuad := gQuad;
GenTree(op^.left);
gLong := lLong;
gQuad := lQuad;
GenTree(op^.right);
end; {GenBno}
procedure GenBntNgiNot (op: icptr);
{ Generate code for a pc_bnt, pc_ngi or pc_not }
var
lab1: integer;
operandIsBoolean: boolean;
begin {GenntNgiNot}
if op^.opcode = pc_not then
operandIsBoolean := op^.left^.opcode in
[pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt,pc_not];
GenTree(op^.left);
case op^.opcode of
pc_bnt:
GenNative(m_eor_imm, immediate, -1, nil, 0);
pc_ngi: begin
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenImplied(m_ina);
end; {case pc_ngi}
pc_not: begin
if not operandIsBoolean then begin
lab1 := GenLabel;
GenImpliedForFlags(m_tax);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {if}
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {if}
end; {case}
end; {GenBntNgiNot}
procedure GenCui (op: icptr);
{ Generate code for a pc_cui }
var
lab1: integer; {return point}
lLong: longType; {used to reserve gLong}
lQuad: quadType; {saved copy of gQuad}
lArgsSize: integer; {saved copy of argsSize}
extraStackSize: integer; {size of extra stuff pushed on stack}
begin {GenCui}
lArgsSize := argsSize;
argsSize := 0;
extraStackSize := 0;
{For functions returning cg(U)Quad, make space for result}
if op^.optype in [cgQuad,cgUQuad] then
if gQuad.preference <> localAddress then begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end; {if}
{save the stack register}
if ((saveStack or checkStack) and (op^.q >= 0)) or (op^.q > 0) then begin
if stackSaveDepth <> 0 then begin
GenNative(m_pei_dir, direct, stackLoc, nil, 0);
extraStackSize := 2;
end; {if}
GenImplied(m_tsx);
GenNative(m_stx_dir, direct, stackLoc, nil, 0);
stackSaveDepth := stackSaveDepth + 1;
end; {if}
{generate parameters}
{place the operands on the stack}
lQuad := gQuad;
lLong := gLong;
GenTree(op^.left);
{get the address to call}
gLong.preference := onStack;
GenTree(op^.right);
gLong := lLong;
gQuad := lQuad;
{For functions returning cg(U)Quad, x = address to store result in}
if op^.optype in [cgQuad,cgUQuad] then
if gQuad.preference = localAddress then begin
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0);
GenImplied(m_tax);
end {if}
else begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, argsSize+extraStackSize+4+1, nil, 0);
GenImplied(m_tax);
end; {else}
{create a return label}
lab1 := GenLabel;
{place the call/return addrs on stack}
GenNative(m_lda_s, direct, 1, nil, 0);
GenImplied(m_dea);
GenImplied(m_pha);
GenNative(m_sep, immediate, 32, nil, 0);
GenNative(m_lda_s, direct, 5, nil, 0);
GenNative(m_sta_s, direct, 3, nil, 0);
GenNative(m_lda_imm, genAddress, lab1, nil, shift16);
GenNative(m_sta_s, direct, 6, nil, 0);
GenNative(m_rep, immediate, 32, nil, 0);
GenNative(m_lda_imm, genAddress, lab1, nil, subtract1);
GenNative(m_sta_s, direct, 4, nil, 0);
{indirect call}
GenImplied(m_rtl);
GenLab(lab1);
if checkStack and (op^.q >= 0) then begin
{check the stack for errors}
stackSaveDepth := stackSaveDepth - 1;
GenNative(m_ldy_dir, direct, stackLoc, nil, 0);
GenCall(76);
if stackSaveDepth <> 0 then begin
GenImplied(m_ply);
GenNative(m_sty_dir, direct, stackLoc, nil, 0);
end; {if}
end {if}
else if (saveStack and (op^.q >= 0)) or (op^.q > 0) then begin
stackSaveDepth := stackSaveDepth - 1;
if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad])
then
GenImplied(m_txy);
GenNative(m_ldx_dir, direct, stackLoc, nil, 0);
GenImplied(m_txs);
if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad])
then
GenImplied(m_tyx);
if stackSaveDepth <> 0 then begin
GenImplied(m_ply);
GenNative(m_sty_dir, direct, stackLoc, nil, 0);
end; {if}
end; {else}
{save the returned value}
gLong.where := A_X;
if gQuad.preference = localAddress then
gQuad.where := localAddress
else
gQuad.where := onStack;
SaveRetValue(op^.optype);
argsSize := lArgsSize;
end; {GenCui}
procedure GenCup (op: icptr);
{ Generate code for a pc_cup }
var
lLong: longType; {used to reserve gLong}
lQuad: quadType; {saved copy of gQuad}
lArgsSize: integer; {saved copy of argsSize}
extraStackSize: integer; {size of extra stuff pushed on stack}
begin {GenCup}
lArgsSize := argsSize;
argsSize := 0;
extraStackSize := 0;
{For functions returning cg(U)Quad, make space for result}
if op^.optype in [cgQuad,cgUQuad] then
if gQuad.preference <> localAddress then begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end; {if}
{save the stack register}
if ((saveStack or checkStack) and (op^.q >= 0)) or (op^.q > 0) then begin
if stackSaveDepth <> 0 then begin
GenNative(m_pei_dir, direct, stackLoc, nil, 0);
extraStackSize := 2;
end; {if}
GenImplied(m_tsx);
GenNative(m_stx_dir, direct, stackLoc, nil, 0);
stackSaveDepth := stackSaveDepth + 1;
end; {if}
{generate parameters}
lQuad := gQuad;
lLong := gLong;
GenTree(op^.left);
gLong := lLong;
gQuad := lQuad;
{For functions returning cg(U)Quad, x = address to store result in}
if op^.optype in [cgQuad,cgUQuad] then
if gQuad.preference = localAddress then begin
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0);
GenImplied(m_tax);
end {if}
else if argsSize + extraStackSize in [0,1,2] then begin
GenImplied(m_tsx);
GenImplied(m_inx);
if argsSize + extraStackSize in [1,2] then begin
GenImplied(m_inx);
if argsSize + extraStackSize = 2 then
GenImplied(m_inx);
end; {if}
end {if}
else begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, argsSize+extraStackSize+1, nil, 0);
GenImplied(m_tax);
end; {else}
{generate the jsl}
GenNative(m_jsl, longAbs, 0, op^.lab, 0);
{check the stack for errors}
if checkStack and (op^.q >= 0) then begin
stackSaveDepth := stackSaveDepth - 1;
GenNative(m_ldy_dir, direct, stackLoc, nil, 0);
GenCall(76);
if stackSaveDepth <> 0 then begin
GenImplied(m_ply);
GenNative(m_sty_dir, direct, stackLoc, nil, 0);
end; {if}
GenImplied(m_tay);
end {if}
else if (saveStack and (op^.q >= 0)) or (op^.q > 0) then begin
stackSaveDepth := stackSaveDepth - 1;
if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad])
then
GenImplied(m_txy);
GenNative(m_ldx_dir, direct, stackLoc, nil, 0);
GenImplied(m_txs);
if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad])
then
GenImplied(m_tyx);
if stackSaveDepth <> 0 then begin
GenImplied(m_ply);
GenNative(m_sty_dir, direct, stackLoc, nil, 0);
end; {if}
end; {else}
{save the returned value}
gLong.where := A_X;
if gQuad.preference = localAddress then
gQuad.where := localAddress
else
gQuad.where := onStack;
SaveRetValue(op^.optype);
argsSize := lArgsSize;
end; {GenCup}
procedure GenDviMod (op: icptr);
{ Generate code for a pc_dvi, pc_mod, pc_udi or pc_uim }
var
opcode: pcodes; {temp storage}
lab1,lab2,lab3: integer; {label numbers}
val: integer;
power: integer;
begin {GenDviMod}
opcode := op^.opcode;
if (op^.right^.opcode = pc_ldc) and not rangeCheck then begin
val := op^.right^.q;
if opcode = pc_udi then begin
case val of
1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384: begin
GenTree(op^.left);
if val >= 256 then begin
GenNative(m_and_imm, immediate, $FF00, nil, 0);
GenImplied(m_xba);
val := val >> 8;
end; {if}
while not odd(val) do begin
GenImplied(m_lsr_a);
val := val >> 1;
end; {while}
opcode := pc_nop;
end;
otherwise:
if (val >= 1000) or (val < 0) then begin {1000..65535}
GenTree(op^.left);
lab1 := GenLabel;
GenNative(m_ldy_imm, immediate, -1, nil, 0);
GenImplied(m_sec);
GenLab(lab1);
GenImplied(m_iny);
GenNative(m_sbc_imm, immediate, val, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenImplied(m_tya);
opcode := pc_nop;
end; {if}
end; {case}
end {if}
else if opcode = pc_uim then begin
case val of
1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384: begin
GenTree(op^.left);
GenNative(m_and_imm, immediate, val-1, nil, 0);
opcode := pc_nop;
end;
otherwise:
if (val >= 750) or (val < 0) then begin {750..65535}
GenTree(op^.left);
lab1 := GenLabel;
GenImplied(m_sec);
GenLab(lab1);
GenNative(m_sbc_imm, immediate, val, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
GenNative(m_adc_imm, immediate, val, nil, 0);
opcode := pc_nop;
end; {if}
end; {case}
end {else if}
else if opcode = pc_dvi then begin
case val of
-1: begin
GenTree(op^.left);
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenImplied(m_ina);
opcode := pc_nop;
end;
1: begin
GenTree(op^.left);
opcode := pc_nop;
end;
2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384: begin
GenTree(op^.left);
power := 0;
while not odd(val) do begin
power := power + 1;
val := val >> 1;
end; {while}
if power <> 1 then begin
GenNative(m_ldy_imm, immediate, power, nil, 0);
lab1 := GenLabel;
GenLab(lab1);
end; {if}
lab2 := GenLabel;
lab3 := GenLabel;
GenImpliedForFlags(m_tax);
GenImplied(m_clc);
GenNative(m_bpl, relative, lab2, nil, 0);
GenImplied(m_ina);
GenNative(m_beq, relative, lab3, nil, 0);
GenImplied(m_sec);
GenLab(lab2);
GenImplied(m_ror_a);
if power <> 1 then begin
GenImplied(m_dey);
GenNative(m_bne, relative, lab1, nil, 0);
end; {if}
GenLab(lab3);
opcode := pc_nop;
end;
otherwise: ;
end; {case}
end {else if}
else {if opcode = pc_mod then} begin
case val of
-1,1: begin
GenTree(op^.left);
GenNative(m_lda_imm, immediate, 0, nil, 0);
opcode := pc_nop;
end;
2: begin
GenTree(op^.left);
lab1 := GenLabel;
lab2 := GenLabel;
GenImplied(m_asl_a);
GenNative(m_and_imm, immediate, 2, nil, 0);
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
GenImplied(m_dea);
GenImplied(m_dea);
GenLab(lab1);
GenImplied(m_dea);
GenLab(lab2);
opcode := pc_nop;
end;
otherwise: ;
end; {case}
end; {else}
end; {if}
if opcode = pc_nop then
{nothing to do - optimized above}
else if Complex(op^.right) then begin
GenTree(op^.right);
if Complex(op^.left) then begin
GenImplied(m_pha);
GenTree(op^.left);
GenImplied(m_plx);
end {if}
else begin
GenImplied(m_tax);
GenTree(op^.left);
end; {else}
end {else if}
else begin
GenTree(op^.left);
LoadX(op^.right);
end; {else}
if opcode = pc_mod then begin
lab1 := GenLabel;
GenImplied(m_pha); {stash away dividend (for sign)}
GenCall(26); {call ~DIV2}
GenImplied(m_txa); {get remainder (always positive or 0)}
GenImplied(m_ply); {if dividend was negative...}
GenNative(m_bpl, relative, lab1, nil, 0);
GenNative(m_eor_imm, immediate, -1, nil, 0); {...negate remainder}
GenImplied(m_ina);
GenLab(lab1);
end {if}
else if opcode = pc_dvi then
GenCall(26)
else if opcode in [pc_udi,pc_uim] then begin
GenCall(40);
if opcode = pc_uim then
GenImplied(m_txa);
end; {else}
if rangeCheck then
GenCall(25);
end; {GenDviMod}
procedure GenEnt(op: icptr);
{ Generate code for a pc_ent }
var
i: integer;
len: integer;
begin {GenEnt}
if debugStrFlag then begin {gsbug/niftylist debug string}
len := length(op^.lab^);
CnOut(m_brl);
CnOut2(len + 3);
CnOut2($7771);
CnOut(len);
for i := 1 to len do
CnOut(ord(op^.lab^[i]));
end;
if rangeCheck then begin {if range checking is on, check for a stack overflow}
GenNative(m_pea, immediate, localSize - returnSize - 1, nil, 0);
GenCall(1);
end; {if}
if localSize = 0 then begin {create the stack frame}
if parameterSize <> 0 then begin
GenImplied(m_tsc);
GenImplied(m_phd);
GenImplied(m_tcd);
end; {if}
end {if}
else if localSize = 2 then begin
GenImplied(m_pha);
GenImplied(m_tsc);
GenImplied(m_phd);
GenImplied(m_tcd);
end {else if}
else begin
GenImplied(m_tsc);
GenImplied(m_sec);
GenNative(m_sbc_imm, immediate, localSize, nil, 0);
GenImplied(m_tcs);
GenImplied(m_phd);
GenImplied(m_tcd);
end; {if}
if isQuadFunction then begin {save return location for cg(U)Quad}
GenNative(m_stx_dir, direct, funloc, nil, 0);
GenNative(m_stz_dir, direct, funloc+2, nil, 0);
end; {if}
if dataBank then begin {preserve and set data bank}
GenImplied(m_phb);
GenImplied(m_phb);
GenImplied(m_pla);
GenNative(m_sta_dir, direct, bankLoc, nil, 0);
GenNative(m_pea, immediate, 0, @'~GLOBALS', shift8);
GenImplied(m_plb);
GenImplied(m_plb);
end; {if}
{no pc_nam (yet)}
namePushed := false;
end; {GenEnt}
procedure GenFix (op: icptr);
{ Generate code for a pc_fix }
begin {GenFix}
GenNative(m_pea, immediate, localLabel[op^.q], nil, 0);
if op^.optype = cgReal then
GenCall(95)
else if op^.optype = cgDouble then
GenCall(96)
else if op^.optype = cgComp then
GenCall(97);
end; {GenFix}
procedure GenFjpTjp (op: icptr);
{ Generate code for a pc_fjp or pc_tjp }
var
lab1: integer; {branch point}
opcode: pcodes; {op^.left^.opcode}
begin {GenFjpTjp}
if op^.left^.opcode in [pc_equ,pc_geq,pc_grt,pc_les,pc_leq,pc_neq] then
if op^.left^.opcode in [pc_equ,pc_neq] then
GenEquNeq(op^.left, op^.opcode, op^.q)
else
GenCmp(op^.left, op^.opcode, op^.q)
else begin
lab1 := GenLabel;
GenTree(op^.left);
opcode := op^.left^.opcode;
if NeedsCondition(opcode) then
GenImpliedForFlags(m_tax)
else if opcode = pc_ind then
if op^.left^.optype in [cgByte,cgUByte] then
GenImpliedForFlags(m_tax);
if op^.opcode = pc_fjp then
GenNative(m_bne, relative, lab1, nil, 0)
else {if op^.opcode = pc_tjp then}
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, op^.q, nil, 0);
GenLab(lab1);
end; {else}
end; {GenFjpTjp}
procedure GenLaoLad (op: icptr);
{ Generate code for a pc_lao, pc_lad }
var
q: integer; {displacement}
begin {GenLaoLad}
if op^.opcode = pc_lad then
q := 0
else
q := op^.q;
if (globalLabel & gLong.preference) <> 0 then begin
gLong.fixedDisp := true;
gLong.where := globalLabel;
gLong.disp := q;
gLong.lab := op^.lab;
end {if}
else if (A_X & gLong.preference) <> 0 then begin
gLong.where := A_X;
GenNative(m_ldx_imm, immediate, q, op^.lab, shift16);
GenNative(m_lda_imm, immediate, q, op^.lab, 0);
end {else if}
else begin
gLong.where := onStack;
GenNative(m_pea, immediate, q, op^.lab, shift16);
GenNative(m_pea, immediate, q, op^.lab, 0);
end; {else}
end; {GenLaoLad}
procedure GenLbfLbu (op: icptr);
{ Generate code for a pc_lbf or pc_lbu }
var
lLong: longType; {requested address type}
begin {GenLbfLbu}
lLong := gLong;
gLong.preference := onStack;
GenTree(op^.left);
GenNative(m_pea, immediate, op^.r, nil, 0);
GenNative(m_pea, immediate, op^.q, nil, 0);
if op^.opcode = pc_lbf then
GenCall(73)
else
GenCall(72);
if op^.optype in [cgLong,cgULong] then begin
if (A_X & lLong.preference) <> 0 then
gLong.where := A_X
else begin
gLong.where := onStack;
GenImplied(m_phx);
GenImplied(m_pha);
end; {else}
end; {if}
end; {GenLbfLbu}
procedure GenLca (op: icptr);
{ Generate code for a pc_lca }
var
i: integer; {loop/index variable}
begin {GenLca}
gLong.where := onStack;
GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
GenNative(m_pea, immediate, stringSize, nil, stringReference);
if maxString-stringSize >= op^.q then begin
for i := 1 to op^.q do
stringSpace^[i+stringSize] := op^.str^.str[i];
stringSize := stringSize+op^.q;
end
else
Error(cge3);
op^.optype := cgULong;
end; {GenLca}
procedure GenLda (op: icptr);
{ Generate code for a pc_lda }
begin {GenLda}
if (localAddress & gLong.preference) <> 0 then begin
gLong.fixedDisp := true;
gLong.where := localAddress;
gLong.disp := LabelToDisp(op^.r) + op^.q;
end {if}
else if (A_X & gLong.preference) <> 0 then begin
gLong.where := A_X;
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, LabelToDisp(op^.r) + op^.q, nil, 0);
GenNative(m_ldx_imm, immediate, 0, nil, 0);
end {else if}
else begin
gLong.where := onStack;
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, LabelToDisp(op^.r) + op^.q, nil, 0);
GenImplied(m_pha);
end; {else}
end; {GenLda}
procedure GenLdc (op: icptr);
{ Generate code for a pc_ldc }
type
kind = (vint, vbyte); {kinds of equivalenced data}
var
i: integer; {loop/index variable}
rec: realrec; {conversion record}
switch: packed record {used for type conversion}
case rkind: kind of
vint: (i: integer);
vbyte: (b1, b2, b3, b4, b5, b6, b7, b8: byte);
end;
begin {GenLdc}
case op^.optype of
cgByte: begin
if op^.q > 127 then
op^.q := op^.q | $FF00;
GenNative(m_lda_imm, immediate, op^.q, nil, 0);
end;
cgUByte, cgWord, cgUWord:
GenNative(m_lda_imm, immediate, op^.q, nil, 0);
cgReal, cgDouble, cgComp, cgExtended: begin
rec.itsReal := op^.rval;
CnvSX(rec);
i := 9;
while i >= 0 do begin
switch.b1 := rec.inSANE[i];
switch.b2 := rec.inSANE[i+1];
GenNative(m_pea, immediate, switch.i, nil, 0);
i := i-2;
end; {while}
end;
cgLong, cgULong:
if (constant & gLong.preference) <> 0 then begin
gLong.where := constant;
gLong.lval := op^.lval;
end
else if (A_X & gLong.preference) <> 0 then begin
gLong.where := A_X;
GenNative(m_lda_imm, immediate, long(op^.lval).lsw, nil, 0);
GenNative(m_ldx_imm, immediate, long(op^.lval).msw, nil, 0);
end
else begin
gLong.where := onStack;
GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0);
GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0);
end;
cgQuad,cgUQuad: begin
if gQuad.preference = onStack then begin
GenNative(m_pea, immediate, long(op^.qval.hi).msw, nil, 0);
GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0);
GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0);
GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0);
end {if}
else begin
GenNative(m_lda_imm, immediate, long(op^.qval.hi).msw, nil, 0);
StoreWordOfQuad(6);
GenNative(m_lda_imm, immediate, long(op^.qval.hi).lsw, nil, 0);
StoreWordOfQuad(4);
GenNative(m_lda_imm, immediate, long(op^.qval.lo).msw, nil, 0);
StoreWordOfQuad(2);
GenNative(m_lda_imm, immediate, long(op^.qval.lo).lsw, nil, 0);
StoreWordOfQuad(0);
end; {else}
gQuad.where := gQuad.preference;
end;
otherwise:
Error(cge1);
end; {case}
end; {GenLdc}
procedure GenLdo (op: icptr);
{ Generate code for a pc_ldo }
var
lab1: integer; {branch point}
begin {GenLdo}
case op^.optype of
cgWord, cgUWord:
if smallMemoryModel then
GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
else
GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);
cgByte, cgUByte: begin
if smallMemoryModel then
GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0)
else
GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0);
GenNative(m_and_imm, immediate, 255, nil, 0);
if op^.optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
GenNative(m_cmp_imm, immediate, $0000, nil, 0);
end; {if}
end;
cgReal, cgDouble, cgComp, cgExtended: begin
GenNative(m_pea, immediate, op^.q, op^.lab, shift16);
GenNative(m_pea, immediate, op^.q, op^.lab, 0);
if op^.optype = cgReal then
GenCall(21)
else if op^.optype = cgDouble then
GenCall(22)
else if op^.optype = cgComp then
GenCall(70)
else {if op^.optype = cgExtended then}
GenCall(71);
end;
cgLong, cgULong: begin
if (A_X & gLong.preference) <> 0 then
gLong.where := A_X
else
gLong.where := onStack;
if smallMemoryModel then begin
GenNative(m_ldx_abs, absolute, op^.q+2, op^.lab, 0);
GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0);
if gLong.where = onStack then begin
GenImplied(m_phx);
GenImplied(m_pha);
end; {if}
end {if}
else begin
GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0);
if gLong.where = onStack then
GenImplied(m_pha)
else
GenImplied(m_tax);
GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0);
if gLong.where = onStack then
GenImplied(m_pha);
end; {else}
end; {case cgLong,cgULong}
cgQuad, cgUQuad: begin
if smallMemoryModel then begin
GenNative(m_lda_abs, absolute, op^.q+6, op^.lab, 0);
StoreWordOfQuad(6);
GenNative(m_lda_abs, absolute, op^.q+4, op^.lab, 0);
StoreWordOfQuad(4);
GenNative(m_lda_abs, absolute, op^.q+2, op^.lab, 0);
StoreWordOfQuad(2);
GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0);
StoreWordOfQuad(0);
end {if}
else begin
GenNative(m_lda_long, longabsolute, op^.q+6, op^.lab, 0);
StoreWordOfQuad(6);
GenNative(m_lda_long, longabsolute, op^.q+4, op^.lab, 0);
StoreWordOfQuad(4);
GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0);
StoreWordOfQuad(2);
GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0);
StoreWordOfQuad(0);
end; {else}
gQuad.where := gQuad.preference;
end; {case cgQuad,cgUQuad}
otherwise:
Error(cge1);
end; {case}
end; {GenLdo}
procedure GenLnm (op: icptr);
{ Generate code for a pc_lnm }
begin {GenLnm}
if op^.left <> nil then
GenTree(op^.left);
if traceBack then begin
GenNative(m_pea, immediate, op^.r, nil, 0);
GenCall(6);
end; {if}
if debugFlag then begin
if op^.lab <> nil then
GenDebugSourceFile(op^.lab);
GenNative(m_cop, immediate, op^.q, nil, 0);
GenNative(d_wrd, special, op^.r, nil, 0);
end; {if}
end; {GenLnm}
procedure GenLod (op: icptr);
{ Generate code for a pc_lod }
var
disp: integer; {load location}
lab1: integer; {branch point}
optype: baseTypeEnum; {op^.optype}
begin {GenLod}
disp := LabelToDisp(op^.r) + op^.q;
optype := op^.optype;
case optype of
cgReal, cgDouble, cgComp, cgExtended: begin
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, disp, nil, 0);
GenImplied(m_pha);
if optype = cgReal then
GenCall(21)
else if optype = cgDouble then
GenCall(22)
else if optype = cgComp then
GenCall(70)
else {if optype = cgExtended then}
GenCall(71);
end;
cgQuad, cgUQuad: begin
if disp >= 250 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_lda_dirx, direct, 6, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirx, direct, 4, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirx, direct, 2, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenImplied(m_pha);
gQuad.where := onStack;
end {if}
else begin
if gQuad.preference = onStack then begin
GenNative(m_pei_dir, direct, disp+6, nil, 0);
GenNative(m_pei_dir, direct, disp+4, nil, 0);
GenNative(m_pei_dir, direct, disp+2, nil, 0);
GenNative(m_pei_dir, direct, disp, nil, 0);
end {if}
else begin
GenNative(m_lda_dir, direct, disp+6, nil, 0);
StoreWordOfQuad(6);
GenNative(m_lda_dir, direct, disp+4, nil, 0);
StoreWordOfQuad(4);
GenNative(m_lda_dir, direct, disp+2, nil, 0);
StoreWordOfQuad(2);
GenNative(m_lda_dir, direct, disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
gQuad.where := gQuad.preference;
end; {else}
end;
cgLong, cgULong: begin
if ((inPointer & gLong.preference) <> 0) and (disp < 254) then
begin
gLong.where := inPointer;
gLong.fixedDisp := true;
gLong.disp := disp;
end {if}
else if ((A_X & gLong.preference) <> 0) and (disp < 254) then begin
gLong.where := A_X;
GenNative(m_ldx_dir, direct, disp+2, nil, 0);
GenNative(m_lda_dir, direct, disp, nil, 0);
end {else if}
else begin
gLong.where := onStack;
if disp >= 254 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_lda_dirx, direct, 2, nil, 0);
GenImplied(m_pha);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenImplied(m_pha);
end {if}
else begin
GenNative(m_pei_dir, direct, disp+2, nil, 0);
GenNative(m_pei_dir, direct, disp, nil, 0);
end; {else}
end; {else}
end;
cgByte, cgUByte, cgWord, cgUWord: begin
if disp >= 256 then begin
GenNative(m_ldx_imm, immediate, disp, nil, 0);
GenNative(m_lda_dirx, direct, 0, nil, 0);
end
else
GenNative(m_lda_dir, direct, disp, nil, 0);
if optype in [cgByte,cgUByte] then begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
GenNative(m_cmp_imm, immediate, $0000, nil, 0);
end; {if}
end;
end;
otherwise:
Error(cge1);
end; {case}
end; {GenLod}
procedure GenLorLnd (op: icptr);
{ Generate code for a pc_lor or pc_lnd }
var
lab1,lab2: integer; {label}
nd: icptr; {temp node pointer}
opc: pcodes; {operation code}
procedure DoOra;
{ do some common oring operations to reduce space }
begin {DoOra}
if gLong.where = onStack then begin
GenImplied(m_pla);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenImplied(m_pla);
end {if}
else
GenNative(m_stx_dir, direct, dworkLoc, nil, 0);
GenNative(m_ora_dir, direct, dworkLoc, nil, 0);
end; {DoOra}
begin {GenLorLnd}
opc := op^.opcode;
lab1 := GenLabel;
gLong.preference := A_X;
GenTree(op^.left);
DoOra;
lab2 := GenLabel;
if opc = pc_lnd then
GenNative(m_bne, relative, lab2, nil, 0)
else begin
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
end; {else}
GenNative(m_brl, longrelative, lab1, nil, 0);
GenLab(lab2);
gLong.preference := A_X;
GenTree(op^.right);
DoOra;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {GenLorLnd}
procedure GenMov (op: icptr; duplicate: boolean);
{ Generate code for a pc_mov }
{ }
{ parameters: }
{ op - pc_mov instruction }
{ duplicate - should the dest address be left on the }
{ stack? }
var
banks: integer; {number of banks to move}
procedure Load (opcode: integer; op: icptr);
{ generate a load immediate based on instruction type }
{ }
{ parameters: }
{ opcode - native code load operation }
{ op - node to load }
var
i: integer;
begin {Load}
if op^.opcode = pc_lao then
GenNative(opcode, immediate, op^.q, op^.lab, 0)
else begin
GenNative(opcode, immediate, stringsize, nil, StringReference);
if maxstring-stringsize >= op^.q then begin
for i := 1 to op^.q do
stringspace^[i+stringsize] := op^.str^.str[i];
stringsize := stringsize + op^.q;
end {if}
else
Error(cge3);
end; {else}
end; {Load}
begin {GenMov}
{determine if the destination address must be left on the stack}
if smallMemoryModel
and (not duplicate)
and (op^.left^.opcode in [pc_lao,pc_lca])
and (op^.right^.opcode in [pc_lao,pc_lca]) then begin
{take advantage of any available short cuts}
Load(m_ldy_imm, op^.left);
Load(m_ldx_imm, op^.right);
GenNative(m_lda_imm, immediate, op^.q-1, nil, 0);
GenImplied(m_phb);
GenImplied(m_mvn);
with op^.left^ do
if opcode = pc_lao then
GenNative(d_bmov, immediate, q, lab, shift16)
else
GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
with op^.right^ do
if opcode = pc_lao then
GenNative(d_bmov, immediate, q, lab, shift16)
else
GenNative(d_bmov, immediate, 0, nil, stringReference+shift16);
GenImplied(m_plb);
end {if}
else begin
{no short cuts are available - do it the hard way}
gLong.preference := onStack;
GenTree(op^.left);
gLong.preference := onStack;
GenTree(op^.right);
banks := op^.r;
if banks <> 0 then
GenNative(m_pea, immediate, banks, nil, 0);
GenNative(m_pea, immediate, op^.q, nil, 0);
if banks = 0 then begin
if duplicate then
GenCall(55)
else
GenCall(54);
end {if}
else
if duplicate then
GenCall(63)
else
GenCall(62);
end; {else}
end; {GenMov}
procedure GenMpi (op: icptr);
{ Generate code for a pc_mpi or pc_umi }
var
nd: icptr;
val: integer;
begin {GenMpi}
if ((op^.left^.opcode = pc_ldc) or (op^.right^.opcode = pc_ldc))
and ((op^.opcode = pc_umi) or (not rangeCheck)) then begin
if op^.left^.opcode = pc_ldc then begin
val := op^.left^.q;
nd := op^.right;
end {if}
else begin
val := op^.right^.q;
nd := op^.left;
end; {else}
if nd^.opcode = pc_ldc then
GenNative(m_lda_imm, immediate, ord(ord4(val) * ord4(nd^.q)), nil, 0)
else begin
GenTree(nd);
case val of
0: GenNative(m_lda_imm, immediate, 0, nil, 0);
1,2,4,8,16,32,64,128:
while not odd(val) do begin
GenImplied(m_asl_a);
val := val >> 1;
end; {while}
256,512,1024,2048,4096,8192,16384: begin
GenNative(m_and_imm, immediate, $00FF, nil, 0);
GenImplied(m_xba);
val := val >> 8;
while not odd(val) do begin
GenImplied(m_asl_a);
val := val >> 1;
end; {while}
end;
3,5,6,9,10,12,17,18,20,24,33,34,36,40,48,65,66,68,72,80,96: begin
if odd(val) then {prevent lda+pha -> pei optimization}
GenLab(GenLabel);
while not odd(val) do begin
GenImplied(m_asl_a);
val := val >> 1;
end; {while}
GenImplied(m_pha);
val := val - 1;
while not odd(val) do begin
GenImplied(m_asl_a);
val := val >> 1;
end; {while}
GenImplied(m_clc);
GenNative(m_adc_s, direct, 1, nil, 0);
GenImplied(m_plx);
end;
-1,-2,-4,-8,-16,-32,-64,-128: begin
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenImplied(m_ina);
val := -val;
while not odd(val) do begin
GenImplied(m_asl_a);
val := val >> 1;
end; {while}
end;
-256: begin
GenNative(m_eor_imm, immediate, -1, nil, 0);
GenImplied(m_ina);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
GenImplied(m_xba);
end;
otherwise: begin
if val = $8000 then begin
GenImplied(m_lsr_a);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenImplied(m_ror_a);
end {if}
else begin
GenNative(m_ldx_imm, immediate, val, nil, 0);
if op^.opcode = pc_mpi then
GenCall(28)
else {pc_umi}
GenCall(94);
end; {else}
end;
end; {case}
end; {else}
end {if}
else begin
if not Complex(op^.left) then
if Complex(op^.right) then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
GenTree(op^.left);
if Complex(op^.right) then begin
GenImplied(m_pha);
GenTree(op^.right);
GenImplied(m_plx);
end {if}
else
LoadX(op^.right);
if op^.opcode = pc_mpi then begin
GenCall(28);
if rangeCheck then
GenCall(25);
end {if}
else {pc_umi}
GenCall(94);
end; {else}
end; {GenMpi}
procedure GenNam (op: icptr);
{ Generate code for a pc_nam }
var
i: integer; {loop/index variable}
begin {GenNam}
{generate a call to install the name in the traceback facility}
if traceBack then begin
GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16);
GenNative(m_pea, immediate, stringSize, nil, stringReference);
GenCall(5);
namePushed := true;
end; {if}
{send the name to the profiler}
if profileFlag then begin
GenNative(m_cop, immediate, 3, nil, 0);
GenNative(d_add, genaddress, stringSize, nil, stringReference);
GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16);
end; {if}
{place the name in the string buffer}
if maxString-stringSize >= op^.q+1 then begin
stringSpace^[stringSize+1] := chr(op^.q);
for i := 1 to op^.q do
stringSpace^[i+stringSize+1] := op^.str^.str[i];
stringSize := stringSize + op^.q + 1;
end {if}
else
Error(cge3);
{send the file name to the debugger}
if debugFlag then
GenDebugSourceFile(@debugSourceFileGS);
end; {GenNam}
procedure GenNat (op: icptr);
{ Generate code for a pc_nat }
var
flags: integer; {work var for flags}
mode: addressingmode; {work var for addressing mode}
pval: longint; {temp pointer}
val: longint; {constant operand}
begin {GenNat}
val := op^.opnd;
flags := op^.q;
pval := op^.llab;
mode := addressingMode(op^.r);
if op^.slab <> 0 then
val := val+LabelToDisp(op^.slab);
if mode in [relative,longrelative] then
GenNative(op^.s, mode, op^.llab, op^.lab, op^.q)
else if (mode = longabsolute) and (op^.llab <> 0) then
GenNative(op^.s, mode, long(val).lsw, pointer(pval),
flags | localLab)
else if (mode = longabsolute) and (op^.llab = 0)
and (op^.lab = nil) then
GenNative(op^.s, mode, 0, pointer(val), flags | constantOpnd)
else begin
if (mode = absolute) and (op^.llab = 0) then
flags := flags | constantOpnd;
if op^.llab <> 0 then
GenNative(op^.s, mode, long(val).lsw, pointer(pval),
flags | localLab)
else
GenNative(op^.s, mode, long(val).lsw, op^.lab, flags);
end; {else}
end; {GenNat}
procedure GenNgr (op: icptr);
{ Generate code for a pc_ngr }
begin {GenNgr}
GenTree(op^.left);
GenNative(m_lda_s, direct, 9, nil, 0);
GenNative(m_eor_imm, immediate, -32767-1, nil, 0);
GenNative(m_sta_s, direct, 9, nil, 0);
end; {GenNgr}
procedure GenPop (op: icptr);
{ Generate code for a pc_pop }
var
isIncLoad: boolean; {is the operand one of the inc/dec & load commands?}
begin {GenPop}
glong.preference := A_X; {generate the operand}
gQuad.preference := nowhere;
isIncLoad := op^.left^.opcode in
[pc_lil,pc_lli,pc_ldl,pc_lld,pc_gil,pc_gli,pc_gdl,pc_gld,
pc_iil,pc_ili,pc_idl,pc_ild];
if isIncLoad then
skipLoad := true;
if op^.left^.opcode = pc_mov then
GenMov(op^.left, false)
else if op^.left^.opcode in [pc_cop,pc_cpo,pc_cpi,pc_cbf] then begin
if op^.left^.opcode = pc_cop then
op^.left^.opcode := pc_str
else if op^.left^.opcode = pc_cpo then
op^.left^.opcode := pc_sro
else if op^.left^.opcode = pc_cpi then
op^.left^.opcode := pc_sto
else {if op^.left^.opcode = pc_cbf then}
op^.left^.opcode := pc_sbf;
GenTree(op^.left);
end {else if}
else begin
GenTree(op^.left);
if isIncLoad then
skipLoad := false;
case op^.optype of {do the pop}
otherwise: Error(cge1);
cgByte, cgUByte, cgWord, cgUWord, cgVoid: ;
cgLong, cgULong:
if not isIncLoad then
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_pla);
end; {if}
{else do nothing}
cgQuad, cgUQuad: begin
if gQuad.where = onStack then begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 8, nil, 0);
GenImplied(m_tcs);
end; {if}
end;
cgReal, cgDouble, cgComp, cgExtended: begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 10, nil, 0);
GenImplied(m_tcs);
end;
end; {case}
end; {else}
end; {GenPop}
procedure GenPsh (op: icptr);
{ Generate code for a pc_psh }
begin {GenPsh}
gLong.preference := onStack;
GenTree(op^.left);
GenTree(op^.right);
GenImplied(m_pha);
GenCall(77);
end; {GenPsh}
procedure GenRbo (op: icptr);
{ Generate code for a pc_rbo }
begin {GenRbo}
GenTree(op^.left);
GenImplied(m_xba);
end; {GenRbo}
procedure GenRealBinOp (op: icptr);
{ Generate code for a pc_adr, pc_dvr, pc_mpr or pc_sbr }
var
nd: icptr; {temp pointer}
snum: integer; {library subroutine numbers}
ss,sd,sc,se: integer; {sane call numbers}
begin {GenRealBinOp}
case op^.opcode of
pc_adr: begin
snum := 56;
ss := $0200;
sd := $0100;
sc := $0500;
se := $0000;
end;
pc_dvr: begin
snum := 57;
ss := $0206;
sd := $0106;
sc := $0506;
se := $0006;
end;
pc_mpr: begin
snum := 58;
ss := $0204;
sd := $0104;
sc := $0504;
se := $0004;
end;
pc_sbr: begin
snum := 59;
ss := $0202;
sd := $0102;
sc := $0502;
se := $0002;
end;
end; {case}
if op^.opcode in [pc_mpr,pc_adr] then
if op^.left^.opcode in [pc_lod,pc_ldo] then begin
nd := op^.left;
op^.left := op^.right;
op^.right := nd;
end; {if}
GenTree(op^.left);
if (op^.right^.opcode in [pc_lod,pc_ldo]) and (floatCard = 0) then
with op^.right^ do begin
if opcode = pc_lod then begin
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tdc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, LabelToDisp(r) + q, nil, 0);
GenImplied(m_pha);
end {if}
else begin
GenNative(m_pea, immediate, q, lab, shift16);
GenNative(m_pea, immediate, q, lab, 0);
end; {else}
GenNative(m_pea, immediate, 0, nil, 0);
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 7, nil, 0);
GenImplied(m_pha);
if optype = cgReal then
sd := ss
else if optype = cgExtended then
sd := se
else if optype = cgComp then
sd := sc;
GenNative(m_pea, immediate, sd, nil, 0);
GenNative(m_ldx_imm, immediate, $090A, nil, 0);
GenNative(m_jsl, longAbs, 0, nil, toolCall);
end {with}
else begin
GenTree(op^.right);
GenCall(snum);
end; {else}
end; {GenRealBinOp}
procedure GenRet (op: icptr);
{ Generate code for a pc_ret }
var
size: integer; {localSize + parameterSize}
lab1: integer; {label}
begin {GenRet}
{pop the name record}
if namePushed then
GenCall(2);
{generate an exit code for the debugger/profiler's benefit}
if debugFlag or profileFlag then
GenNative(m_cop, immediate, 4, nil, 0);
{if anything needs to be removed from the stack, move the return val}
size := localSize + parameterSize;
if parameterSize <> 0 then begin
if localSize > 253 then begin
GenNative(m_ldx_imm, immediate, localSize+1, nil, 0);
GenNative(m_lda_dirx, direct, 0, nil, 0);
GenNative(m_ldy_dirx, direct, 1, nil, 0);
GenNative(m_ldx_imm, immediate,
localSize+parameterSize+1, nil, 0);
GenNative(m_sta_dirx, direct, 0, nil, 0);
GenNative(m_sty_dirx, direct, 1, nil, 0);
end {if}
else begin
GenNative(m_lda_dir, direct, localSize+2, nil, 0);
if localSize+parameterSize > 253 then begin
GenNative(m_ldx_imm, immediate,
localSize+parameterSize+1, nil, 0);
GenNative(m_sta_dirx, direct, 1, nil, 0);
GenNative(m_lda_dir, direct, localSize+1, nil, 0);
GenNative(m_sta_dirx, direct, 0, nil, 0);
end {if}
else begin
GenNative(m_sta_dir, direct,
localSize+parameterSize+2, nil, 0);
GenNative(m_lda_dir, direct, localSize+1, nil, 0);
GenNative(m_sta_dir, direct,
localSize+parameterSize+1, nil, 0);
end; {else}
end; {else}
end; {if}
{load the value to return}
case op^.optype of
cgVoid: ;
cgByte,cgUByte: begin
GenNative(m_lda_dir, direct, funLoc, nil, 0);
GenNative(m_and_imm, immediate, $00FF, nil, 0);
if op^.optype = cgByte then begin
GenNative(m_bit_imm, immediate, $0080, nil, 0);
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_ora_imm, immediate, $FF00, nil, 0);
GenLab(lab1);
end; {if}
if size <> 2 then
GenImplied(m_tay);
end;
cgWord,cgUWord:
if size = 2 then
GenNative(m_lda_dir, direct, funLoc, nil, 0)
else
GenNative(m_ldy_dir, direct, funLoc, nil, 0);
cgReal:
GenCall(3);
cgDouble:
GenCall(4);
cgComp:
GenCall(64);
cgExtended:
GenCall(65);
cgLong,cgULong: begin
GenNative(m_ldx_dir, direct, funLoc+2, nil, 0);
GenNative(m_ldy_dir, direct, funLoc, nil, 0);
end;
cgQuad,cgUQuad: ; {return value was already written}
otherwise:
Error(cge1);
end; {case}
{restore data bank reg}
if dataBank then begin
GenNative(m_pei_dir, direct, bankLoc, nil, 0);
GenImplied(m_plb);
GenImplied(m_plb);
end; {if}
{get rid of the stack frame space}
if size <> 0 then
GenImplied(m_pld);
if size = 2 then
GenImplied(m_ply)
else if size <> 0 then begin
GenImplied(m_tsc);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, size, nil, 0);
GenImplied(m_tcs);
end; {if}
{put return value in correct place}
case op^.optype of
cgByte,cgUByte,cgWord,cgUWord: begin
if size <> 2 then
GenImplied(m_tya);
if toolParms then {save value on stack for tools}
GenNative(m_sta_s, direct, returnSize+1, nil, 0);
end;
cgLong,cgULong,cgReal,cgDouble,cgComp,cgExtended: begin
GenImplied(m_tya);
if toolParms then begin {save value on stack for tools}
GenNative(m_sta_s, direct, returnSize+1, nil, 0);
GenImplied(m_txa);
GenNative(m_sta_s, direct, returnSize+3, nil, 0);
end; {if}
end;
cgVoid,cgQuad,cgUQuad: ;
otherwise:
Error(cge1);
end; {case}
{return to the caller}
GenImplied(m_rtl);
end; {GenRet}
procedure GenSbfCbf (op: icptr);
{ Generate code for a pc_sbf or pc_cbf }
begin {GenSbfCbf}
gLong.preference := onStack;
GenTree(op^.left);
GenNative(m_pea, immediate, op^.r, nil, 0);
GenNative(m_pea, immediate, op^.q, nil, 0);
if op^.optype in [cgLong,cgULong] then begin
gLong.preference := onStack;
GenTree(op^.right);
end {if}
else begin
GenNative(m_pea, immediate, 0, nil, 0);
GenTree(op^.right);
GenImplied(m_pha);
end; {else}
if op^.opcode = pc_sbf then
GenCall(74)
else begin
GenCall(75);
if not (op^.optype in [cgLong,cgULong]) then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
end; {else}
end; {GenSbfCbf}
procedure GenSbi (op: icptr);
{ Generate code for a pc_sbi }
begin {GenSbi}
if Complex(op^.right) then begin
GenTree(op^.right);
if Complex(op^.left) then begin
GenImplied(m_pha);
GenTree(op^.left);
GenImplied(m_sec);
GenNative(m_sbc_s, direct, 1, nil, 0);
GenImplied(m_plx);
end {if}
else begin
GenNative(m_eor_imm, immediate, $FFFF, nil, 0);
GenImplied(m_sec);
OperA(m_adc_imm, op^.left);
end; {else}
end {if}
else begin
GenTree(op^.left);
GenImplied(m_sec);
OperA(m_sbc_imm, op^.right);
end; {else}
end; {GenSbi}
procedure GenStk (op: icptr);
{ Generate code for a pc_stk }
var
lab1: integer; {branch point}
begin {GenStk}
if op^.left^.opcode = pc_psh then begin
if (op^.left^.right^.opcode = pc_ldc) and
(op^.left^.right^.optype in [cgWord,cgUWord]) then
argsSize := argsSize + op^.left^.right^.q
else
Error(cge1);
end {if}
else
case op^.optype of
cgByte,cgUByte,cgWord,cgUWord:
argsSize := argsSize + cgWordSize;
cgReal,cgDouble,cgComp,cgExtended:
argsSize := argsSize + cgExtendedSize;
cgLong,cgULong:
argsSize := argsSize + cgLongSize;
cgQuad,cgUQuad:
argsSize := argsSize + cgQuadSize;
otherwise: Error(cge1);
end; {case}
glong.preference := onStack; {generate the operand}
gQuad.preference := onStack;
GenTree(op^.left);
if op^.optype in {do the stk}
[cgByte, cgUByte, cgWord, cgUWord] then
GenImplied(m_pha);
end; {GenStk}
procedure GenShlShrUsr (op: icptr);
{ Generate code for a pc_shl, pc_shr or pc_usr }
var
i,op1,op2,num: integer; {temp variables}
begin {GenShlShrUsr}
{get the standard native operations}
if op^.opcode = pc_shl then begin
op1 := m_asl_a;
op2 := m_lsr_a;
end {if}
else begin
op1 := m_lsr_a;
op2 := m_asl_a;
end; {else}
{take short cuts if they are legal}
if (op^.right^.opcode = pc_ldc) and (op^.opcode <> pc_shr) then begin
num := op^.right^.q;
if (num > 16) or (num < -16) then
GenNative(m_lda_imm, immediate, 0, nil, 0)
else if num > 0 then begin
GenTree(op^.left);
if num >= 8 then begin
GenImplied(m_xba);
if op1 = m_lsr_a then
i := $00FF
else
i := $FF00;
GenNative(m_and_imm, immediate, i, nil, 0);
num := num-8;
end; {if}
for i := 1 to num do
GenImplied(op1);
end {else if}
else if num < 0 then begin
GenTree(op^.left);
if num <= -8 then begin
GenImplied(m_xba);
if op2 = m_lsr_a then
i := $00FF
else
i := $FF00;
GenNative(m_and_imm, immediate, i, nil, 0);
num := num+8;
end; {if}
for i := 1 to -num do
GenImplied(op2);
end {else if}
else
GenTree(op^.left);
end {if}
else begin
GenTree(op^.left);
if Complex(op^.right) then begin
GenImplied(m_pha);
GenTree(op^.right);
GenImplied(m_tax);
GenImplied(m_pla);
end {if}
else
LoadX(op^.right);
if op^.opcode = pc_shl then
GenCall(23)
else if op^.opcode = pc_shr then
GenCall(24)
else {if op^.opcode = pc_usr then}
GenCall(41);
end; {else}
end; {GenShlShrUsr}
procedure GenTl1 (op: icptr);
{ Generate code for a pc_tl1 }
var
lLong: longType; {used to reserve gLong}
tp: baseTypeEnum; {operand type}
begin {GenTl1}
if op^.r in [2,4] then begin
GenImplied(m_pha);
if op^.r = 4 then
GenImplied(m_pha);
end; {if}
lLong := gLong;
GenTree(op^.left);
gLong := lLong;
GenNative(m_ldx_imm, immediate, op^.q, nil, 0);
GenNative(m_jsl, longAbs, 0, pointer(op^.lval), toolCall);
if smallMemoryModel then
GenNative(m_sta_abs, absolute, 0, @'~TOOLERROR', 0)
else
GenNative(m_sta_long, longAbs, 0, @'~TOOLERROR', 0);
if op^.r in [2,4] then begin
if op^.r = 2 then begin
GenImplied(m_pla);
tp := cgWord;
end {if}
else begin
gLong.where := onStack;
tp := cgLong;
end; {else}
end; {if}
end; {GenTl1}
procedure GenTri (op: icptr);
{ Generate code for a pc_tri }
var
lab1,lab2,lab3: integer; {label for branches}
begin {GenTri}
lab1 := GenLabel;
lab2 := GenLabel;
lab3 := GenLabel;
GenTree(op^.left);
if NeedsCondition(op^.left^.opcode) then
GenImpliedForFlags(m_tax);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lab2, nil, 0);
GenLab(lab1);
gLong.preference := onStack;
GenTree(op^.right^.right);
GenNative(m_brl, longrelative, lab3, nil, 0);
GenLab(lab2);
gLong.preference := onStack;
GenTree(op^.right^.left);
GenLab(lab3);
gLong.where := onStack;
end; {GenTri}
procedure GenXjp (op: icptr);
{ Generate code for a pc_xjp }
var
lab1,lab2: integer;
q: integer;
begin {GenXjp}
q := op^.q;
GenTree(op^.left);
GenNative(m_cmp_imm, immediate, q, nil, 0);
lab1 := GenLabel;
GenNative(m_bcc, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, q, nil, 0);
GenLab(lab1);
GenImplied(m_asl_a);
GenImplied(m_tax);
lab1 := GenLabel;
GenNative(m_jmp_indX, absolute, lab1, nil, 0);
GenLab(lab1);
end; {GenXjp}
procedure DirEnp;
{ Generate code for a dc_enp }
begin {DirEnp}
GenImplied(d_end);
EndSeg;
InitLabels;
end; {DirEnp}
procedure DirStr (op: icptr);
{ Generate code for a dc_str }
begin {DirStr}
skipLoad := false;
InitNative;
Header(op^.lab, op^.r, op^.q);
end; {DirStr}
procedure DirSym (op: icptr);
{ Generate code for a dc_sym }
begin {DirSym}
if debugFlag then
GenNative(d_sym, special, op^.q, pointer(op^.lab), 0);
end; {DirSym}
begin {GenTree}
{write('GEN: '); WriteCode(op); {debug}
Spin;
case op^.opcode of
dc_cns: GenNative(d_cns, gnrConstant, op^.q, pointer(op), 0);
dc_dst: GenNative(d_lab, gnrSpace, op^.q, nil, 0);
dc_enp: DirEnp;
dc_lab: GenLab(op^.q);
dc_loc,dc_prm: ;
dc_glb: GenNative(d_lab, gnrLabel, op^.r, op^.lab, isPrivate*op^.q);
dc_pin: GenNative(d_pin, special, 0, nil, 0);
dc_str: DirStr(op);
dc_sym: DirSym(op);
pc_add: GenNative(d_add, genaddress, op^.q, nil, 0);
pc_adi: GenAdi(op);
pc_adl,pc_sbl: GenAdlSbl(op, nil);
pc_adq,pc_sbq: GenAdqSbq(op);
pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op);
pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op);
pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm,
pc_uml,pc_vsr: GenBinLong(op);
pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm,pc_slq,
pc_sqr,pc_wsr: GenBinQuad(op);
pc_bnl,pc_ngl: GenUnaryLong(op);
pc_bnq,pc_ngq: GenUnaryQuad(op);
pc_bno: GenBno(op);
pc_bnt,pc_ngi,pc_not: GenBntNgiNot(op);
pc_cnv: GenCnv(op);
pc_cui: GenCui(op);
pc_cup: GenCup(op);
pc_dec,pc_inc: GenIncDec(op, nil);
pc_dvi,pc_mod,pc_udi,pc_uim: GenDviMod(op);
pc_ent: GenEnt(op);
pc_equ,pc_neq: GenEquNeq(op, op^.opcode, 0);
pc_fix: GenFix(op);
pc_fjp,pc_tjp: GenFjpTjp(op);
pc_geq,pc_grt,pc_leq,pc_les: GenCmp(op, op^.opcode, 0);
pc_gil,pc_gli,pc_gdl,pc_gld: GenGilGliGdlGld(op);
pc_iil,pc_ili,pc_idl,pc_ild: GenIilIliIdlIld(op);
pc_ind: GenInd(op);
pc_ixa: GenIxa(op);
pc_lao,pc_lad: GenLaoLad(op);
pc_lbf,pc_lbu: GenLbfLbu(op);
pc_lca: GenLca(op);
pc_lda: GenLda(op);
pc_ldc: GenLdc(op);
pc_ldo: GenLdo(op);
pc_lil,pc_lli,pc_ldl,pc_lld: GenLilLliLdlLld(op);
pc_lnm: GenLnm(op);
pc_lod: GenLod(op);
pc_lor,pc_lnd: GenLorLnd(op);
pc_mov: GenMov(op, true);
pc_mpi,pc_umi: GenMpi(op);
pc_nam: GenNam(op);
pc_nat: GenNat(op);
pc_ngr: GenNgr(op);
pc_nop: ;
pc_pop: GenPop(op);
pc_psh: GenPsh(op);
pc_rbo: GenRbo(op);
pc_ret: GenRet(op);
pc_sbf,pc_cbf: GenSbfCbf(op);
pc_sbi: GenSbi(op);
pc_shl,pc_shr,pc_usr: GenShlShrUsr(op);
pc_stk: GenStk(op);
pc_sro,pc_cpo: GenSroCpo(op);
pc_sto,pc_cpi: GenStoCpi(op);
pc_str,pc_cop: GenStrCop(op);
pc_tl1: GenTl1(op);
pc_tri: GenTri(op);
pc_ujp: GenNative(m_brl, longrelative, op^.q, nil, 0);
pc_xjp: GenXjp(op);
otherwise: Error(cge1);
end; {case}
end; {GenTree}
{---------------------------------------------------------------}
procedure Gen {blk: blockPtr};
{ Generates native code for a list of blocks }
{ }
{ parameters: }
{ blk - first of the list of blocks }
const
locSize = 4; {variables <= this size allocated first}
var
bk: blockPtr; {used to trace block lists}
minSize: integer; {location for the next local label}
op: icptr; {used to trace code lists}
procedure DirLoc1 (op: icptr);
{ allocates stack frame locations for small dc_loc }
begin {DirLoc1}
if op^.q <= locSize then begin
if op^.r < maxLocalLabel then begin
localLabel[op^.r] := minSize;
minSize := minSize + op^.q;
end {if}
else
Error(cge2);
end; {if}
end; {DirLoc1}
procedure DirLoc2 (op: icptr);
{ allocates stack frame locations for large dc_loc }
begin {DirLoc2}
if op^.q > locSize then begin
if op^.r < maxLocalLabel then begin
localLabel[op^.r] := minSize;
minSize := minSize + op^.q;
end {if}
else
Error(cge2);
end; {if}
end; {DirLoc2}
procedure DirPrm (op: icptr);
{ allocates stack frame locations for parameters }
begin {DirPrm}
if op^.s < maxLocalLabel then
localLabel[op^.s] := localSize + returnSize + 1 + op^.r
else
Error(cge2);
end; {DirPrm}
procedure Scan (op: icptr);
{ scans the code stream for instructions that effect the }
{ size of the stack frame }
{ }
{ parameters: }
{ op - scan this opcode and its children }
var
opcode: pcodes; {op^.opcode}
size: integer; {function return value size}
begin {Scan}
if op^.left <> nil then
Scan(op^.left);
if op^.right <> nil then
Scan(op^.right);
opcode := op^.opcode;
if opcode = dc_loc then
localSize := localSize + op^.q
else if opcode = dc_prm then
parameterSize := parameterSize + op^.q
else if opcode = pc_ret then begin
case op^.optype of
otherwise: size := 0;
cgByte,cgUByte,cgWord,cgUWord: size := cgWordSize;
cgReal: size := cgRealSize;
cgDouble: size := cgDoubleSize;
cgComp: size := cgCompSize;
cgExtended: size := cgExtendedSize;
cgLong,cgULong: size := cgLongSize;
cgQuad,cgUQuad: begin
size := cgLongSize; {pointer}
isQuadFunction := true;
end;
end; {case}
funLoc := 1;
if dworkLoc <> 0 then
dworkLoc := dworkLoc + size;
minSize := minSize + size;
localSize := localSize + size;
end {else if}
else if opcode in
[pc_les,pc_leq,pc_grt,pc_geq,pc_sto,pc_cpi,pc_ind,pc_lor,pc_lnd,
pc_ili,pc_iil,pc_idl,pc_ild,pc_ixa]
then begin
if dworkLoc = 0 then begin
dworkLoc := minSize;
minSize := minSize + 4;
localSize := localSize + 4;
end; {if}
end; {else if}
end; {Scan}
begin {Gen}
bk := blk; {determine the size of the stack frame}
localSize := 0;
parameterSize := 0;
funLoc := 0;
dworkLoc := 0;
minSize := 1;
stackSaveDepth := 0;
isQuadFunction := false;
while bk <> nil do begin
op := bk^.code;
while op <> nil do begin
Scan(op);
op := op^.next;
end; {while}
bk := bk^.next;
end; {while}
if saveStack or checkStack or (strictVararg and hasVarargsCall) then begin
stackLoc := minSize;
minSize := minSize + 2;
localSize := localSize + 2;
end; {if}
if dataBank then begin
bankLoc := minSize;
minSize := minSize + 2;
localSize := localSize + 2;
end; {if}
bk := blk; {allocate locations for the values}
while bk <> nil do begin
op := bk^.code;
while op <> nil do begin
if op^.opcode = dc_loc then
DirLoc1(op)
else if op^.opcode = dc_prm then
DirPrm(op);
op := op^.next;
end; {while}
bk := bk^.next;
end; {while}
bk := blk;
while bk <> nil do begin
op := bk^.code;
while op <> nil do begin
if op^.opcode = dc_loc then
DirLoc2(op);
op := op^.next;
end; {while}
bk := bk^.next;
end; {while}
while blk <> nil do begin {generate code for the block}
op := blk^.code;
while op <> nil do begin
GenTree(op);
op := op^.next;
end; {while}
blk := blk^.next;
end; {while}
end; {Gen}
function LabelToDisp {lab: integer): integer};
{ convert a local label number to a stack frame displacement }
{ }
{ parameters: }
{ lab - label number }
begin {LabelToDisp}
if lab = 0 then
LabelToDisp := funLoc
else
LabelToDisp := localLabel[lab];
end; {LabelToDisp}
end.