mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-11-05 02:07:22 +00:00
2317 lines
77 KiB
ObjectPascal
2317 lines
77 KiB
ObjectPascal
{$optimize 7}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ ORCA Native Code Generation }
|
|
{ }
|
|
{ This module of the code generator is called to generate }
|
|
{ native code instructions. The native code is optimized }
|
|
{ and written to the object segment. }
|
|
{ }
|
|
{ Externally available procedures: }
|
|
{ }
|
|
{ EndSeg - close out the current segment }
|
|
{ GenNative - write a native code instruction to the output }
|
|
{ file }
|
|
{ GenImplied - short form of GenNative - reduces code size }
|
|
{ GenCall - short form of jsl to library subroutine - reduces }
|
|
{ code size }
|
|
{ GenLab - generate a label }
|
|
{ InitFile - Set up the object file }
|
|
{ InitNative - set up for a new segment }
|
|
{ RefName - handle a reference to a named label }
|
|
{ }
|
|
{---------------------------------------------------------------}
|
|
|
|
unit Native;
|
|
|
|
interface
|
|
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses CCommon, CGI, CGC, ObjOut;
|
|
|
|
{$segment 'CodeGen'}
|
|
|
|
type
|
|
labelptr = ^labelentry; {pointer to a forward ref node}
|
|
labelentry = record {forward ref node}
|
|
addr: integer;
|
|
next: labelptr;
|
|
end;
|
|
|
|
labelrec = record {label record}
|
|
defined: boolean; {Note: form used in objout.asm}
|
|
chain: labelptr;
|
|
case boolean of
|
|
true : (val: longint);
|
|
false: (ival,hval: integer);
|
|
end;
|
|
|
|
var
|
|
{current instruction info}
|
|
{------------------------}
|
|
pc: longint; {program counter}
|
|
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
didOne: boolean; {has an optimization been done?}
|
|
labeltab: array[0..maxlabel] of labelrec; {label table}
|
|
localLabel: array[0..maxLocalLabel] of integer; {local variable label table}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure EndSeg;
|
|
|
|
{ close out the current segment }
|
|
|
|
|
|
procedure GenNative (p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
|
|
procedure GenImplied (p_opcode: integer);
|
|
|
|
{ short form of GenNative - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_code - operation code }
|
|
|
|
|
|
procedure GenCall (callNum: integer);
|
|
|
|
{ short form of jsl to library subroutine - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ callNum - subroutine # to generate a call for }
|
|
|
|
|
|
procedure GenLab (lnum: integer);
|
|
|
|
{ generate a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lnum - label number }
|
|
|
|
|
|
procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
|
|
|
|
{ Set up the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
|
|
procedure InitNative;
|
|
|
|
{ set up for a new segment }
|
|
|
|
|
|
procedure LabelSearch (lab: integer; len, shift, disp: integer);
|
|
|
|
{ resolve a label reference }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ len - # bytes for the generated code }
|
|
{ shift - shift factor }
|
|
{ disp - disp past the label }
|
|
{ }
|
|
{ Note 1: maxlabel is reserved for use as the start of the }
|
|
{ string space }
|
|
{ Note 2: negative length indicates relative branch }
|
|
{ Note 3: zero length indicates 2 byte addr -1 }
|
|
|
|
|
|
procedure RefName (lab: stringPtr; disp, len, shift: integer);
|
|
|
|
{ handle a reference to a named label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label name }
|
|
{ disp - displacement past the label }
|
|
{ len - number of bytes in the reference }
|
|
{ shift - shift factor }
|
|
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
npeepSize = 128; {native peephole optimizer window size}
|
|
nMaxPeep = 4; {max # instructions needed to opt.}
|
|
|
|
type
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
npeepRange = 1..npeepsize; {subrange for native code peephole opt.}
|
|
|
|
nativeType = record {native code instruction}
|
|
opcode: integer; {op code}
|
|
mode: addressingMode; {addressing mode}
|
|
operand: integer; {operand value}
|
|
name: stringPtr; {operand label}
|
|
flags: integer; {modifier flags}
|
|
end;
|
|
|
|
registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal);
|
|
registerType = record {used to track register contents}
|
|
condition: registerConditions;
|
|
value: integer;
|
|
lab: stringPtr;
|
|
flags: integer;
|
|
end;
|
|
|
|
var
|
|
{native peephole optimization}
|
|
{----------------------------}
|
|
aRegister, {current register contents}
|
|
xRegister,
|
|
yRegister: registerType;
|
|
nleadOpcodes: set of 0..max_opcode; {instructions that can start an opt.}
|
|
nstopOpcodes: set of 0..max_opcode; {instructions not involved in opt.}
|
|
nnextspot: npeepRange; {next empty spot in npeep}
|
|
npeep: array[npeepRange] of nativeType; {native peephole array}
|
|
|
|
{I/O files}
|
|
{---------}
|
|
fname1, fname2: gsosOutString; {file names}
|
|
nextSuffix: char; {next suffix character to use}
|
|
|
|
|
|
procedure GenSymbols (sym: ptr; doGlobals: integer); extern;
|
|
|
|
{ generate the symbol table }
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
procedure LabelSearch {lab: integer; len, shift, disp: integer};
|
|
|
|
{ resolve a label reference }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ len - # bytes for the generated code }
|
|
{ shift - shift factor }
|
|
{ disp - disp past the label }
|
|
{ }
|
|
{ Note 1: maxlabel is reserved for use as the start of the }
|
|
{ string space }
|
|
{ Note 2: negative length indicates relative branch }
|
|
{ Note 3: zero length indicates 2 byte addr -1 }
|
|
|
|
var
|
|
next: labelptr; {work pointer}
|
|
|
|
begin {LabelSearch}
|
|
if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin
|
|
|
|
{handle a relative branch to a known disp}
|
|
if len = -1 then
|
|
CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len)
|
|
else
|
|
CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len);
|
|
end {if}
|
|
else begin
|
|
if lab <> maxlabel then begin
|
|
|
|
{handle a normal label reference}
|
|
Purge; {empty the constant buffer}
|
|
if len < 0 then begin
|
|
len := -len; {generate a RELEXPR}
|
|
Out(238);
|
|
Out(len);
|
|
Out2(len); Out2(0);
|
|
end {if}
|
|
else begin
|
|
if isJSL then {generate a standard EXPR}
|
|
Out(243)
|
|
else
|
|
Out(235);
|
|
if len = 0 then
|
|
Out(2)
|
|
else
|
|
Out(len);
|
|
end; {else}
|
|
end; {if}
|
|
Out(135); {generate a relative offset from the seg. start}
|
|
if not labeltab[lab].defined then begin
|
|
next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference}
|
|
next^.next := labeltab[lab].chain;
|
|
labeltab[lab].chain := next;
|
|
next^.addr := blkcnt;
|
|
Out2(0);
|
|
Out2(0);
|
|
end {if}
|
|
else {labeltab[lab].defined} begin
|
|
Out2(labeltab[lab].ival); {value known: write it}
|
|
Out2(labeltab[lab].hval);
|
|
end; {else}
|
|
if len = 0 then begin
|
|
Out(129); {subtract 1 from addr}
|
|
Out2(1); Out2(0);
|
|
Out(2);
|
|
len := 2;
|
|
end; {if}
|
|
if disp <> 0 then begin
|
|
Out(129); {add in the displacement}
|
|
Out2(disp);
|
|
if disp < 0 then
|
|
Out2(-1)
|
|
else
|
|
Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if shift <> 0 then begin
|
|
Out(129); {shift the address}
|
|
Out2(-shift); Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
if lab <> maxlabel then {if not a string, end the expression}
|
|
Out(0);
|
|
pc := pc+len; {update the pc}
|
|
end; {else}
|
|
end; {LabelSearch}
|
|
|
|
|
|
procedure UpDate (lab: integer; labelValue: longint);
|
|
|
|
{ define a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label number }
|
|
{ labelValue - displacement in seg where label is located }
|
|
|
|
var
|
|
next,temp: labelptr; {work pointers}
|
|
|
|
begin {UpDate}
|
|
if labeltab[lab].defined then
|
|
Error(cge1)
|
|
else begin
|
|
|
|
{define the label for future references}
|
|
with labeltab[lab] do begin
|
|
defined := true;
|
|
val := labelValue;
|
|
next := chain;
|
|
end; {with}
|
|
|
|
{resolve any forward references}
|
|
if next <> nil then begin
|
|
Purge;
|
|
while next <> nil do begin
|
|
segdisp := next^.addr;
|
|
Out2(long(labelvalue).lsw);
|
|
Out2(long(labelvalue).msw);
|
|
blkcnt := blkcnt-4;
|
|
temp := next;
|
|
next := next^.next;
|
|
end; {while}
|
|
segdisp := blkcnt;
|
|
end; {if}
|
|
end; {else}
|
|
end; {UpDate}
|
|
|
|
|
|
procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer;
|
|
name: stringPtr; flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ opcode - native op code }
|
|
{ mode - addressing mode }
|
|
{ operand - integer operand }
|
|
{ name - named operand }
|
|
{ flags - operand modifier flags }
|
|
|
|
label 1;
|
|
|
|
type
|
|
rkind = (k1,k2,k3); {cnv record types}
|
|
|
|
var
|
|
ch: char; {temp storage for string constants}
|
|
cns: realRec; {for converting reals to bytes}
|
|
cnv: record {for converting double, real to bytes}
|
|
case rkind of
|
|
k1: (rval: real;);
|
|
k2: (dval: double;);
|
|
k3: (ival1,ival2,ival3,ival4: integer;);
|
|
end;
|
|
count: integer; {number of constants to repeat}
|
|
i,j,k: integer; {loop variables}
|
|
lsegDisp: integer; {for backtracking while writting the }
|
|
{ debugger's symbol table }
|
|
lval: longint; {temp storage for long constant}
|
|
nptr: stringPtr; {pointer to a name}
|
|
sptr: longstringPtr; {pointer to a string constant}
|
|
|
|
|
|
procedure GenImmediate1;
|
|
|
|
{ generate a one byte immediate operand }
|
|
|
|
begin {GenImmediate1}
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235); Out(1); {one byte expression}
|
|
Out(128); {current location ctr}
|
|
Out(129); Out2(-16); Out2(-1); {-16}
|
|
Out(7); {bit shift}
|
|
Out(0); {end of expr}
|
|
pc := pc+1;
|
|
end {if}
|
|
else if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand)
|
|
else if (flags & shift16) <> 0 then
|
|
RefName(name, operand, 1, -16)
|
|
else
|
|
CnOut(operand);
|
|
end; {GenImmediate1}
|
|
|
|
|
|
procedure GenImmediate2;
|
|
|
|
{ generate a two byte immediate operand }
|
|
|
|
begin {GenImmediate2}
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235); Out(2);
|
|
LabelSearch(maxLabel, 2, 0, 0);
|
|
if operand <> 0 then begin
|
|
Out(129);
|
|
Out2(operand); Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if (flags & shift16) <> 0 then begin
|
|
Out(129);
|
|
Out2(-16); Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else if (flags & shift8) <> 0 then
|
|
RefName(name, operand, 2, -8)
|
|
else if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand)
|
|
else if (flags & shift16) <> 0 then
|
|
RefName(name, operand, 2, -16)
|
|
else if name = nil then
|
|
CnOut2(operand)
|
|
else
|
|
RefName(name, operand, 2, 0);
|
|
end; {GenImmediate2}
|
|
|
|
|
|
procedure DefGlobal (private: integer);
|
|
|
|
{ define a global label }
|
|
{ }
|
|
{ parameters: }
|
|
{ private - private flag }
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
|
|
begin {DefGlobal}
|
|
Purge;
|
|
Out(230); {global label definition}
|
|
Out(ord(name^[0])); {write label name}
|
|
for i := 1 to ord(name^[0]) do
|
|
Out(ord(name^[i]));
|
|
Out2(0); {length attribute}
|
|
Out(ord('N')); {type attribute: other directive}
|
|
Out(private); {private or global?}
|
|
end; {DefGlobal}
|
|
|
|
|
|
begin {WriteNative}
|
|
{ writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1,
|
|
' operand=', operand:1); {debug}
|
|
case mode of
|
|
|
|
implied:
|
|
CnOut(opcode);
|
|
|
|
immediate: begin
|
|
if opcode = d_bmov then
|
|
GenImmediate1
|
|
else begin
|
|
if opcode = m_and_imm then
|
|
if not longA then
|
|
if operand = 255 then
|
|
goto 1;
|
|
CnOut(opcode);
|
|
if opcode = m_pea then
|
|
GenImmediate2
|
|
else if opcode in
|
|
[m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm,
|
|
m_sbc_imm,m_bit_imm] then
|
|
if longA then
|
|
GenImmediate2
|
|
else
|
|
GenImmediate1
|
|
else if opcode in [m_rep,m_sep,m_cop] then begin
|
|
GenImmediate1;
|
|
if opcode = m_rep then begin
|
|
if odd(operand div 32) then longA := true;
|
|
if odd(operand div 16) then longI := true;
|
|
end {if}
|
|
else if opcode = m_sep then begin
|
|
if odd(operand div 32) then longA := false;
|
|
if odd(operand div 16) then longI := false;
|
|
end; {else}
|
|
end {else}
|
|
else
|
|
if longI then
|
|
GenImmediate2
|
|
else
|
|
GenImmediate1;
|
|
end; {else}
|
|
end;
|
|
|
|
longabs: begin
|
|
CnOut(opcode);
|
|
isJSL := opcode = m_jsl; {allow for dynamic segs}
|
|
if name = nil then
|
|
if odd(flags div toolcall) then begin
|
|
CnOut2(0);
|
|
CnOut(225);
|
|
end {if}
|
|
else
|
|
LabelSearch(operand, 3, 0, 0)
|
|
else
|
|
if odd(flags div toolcall) then begin
|
|
CnOut2(long(name).lsw);
|
|
CnOut(long(name).msw);
|
|
end {if}
|
|
else
|
|
RefName(name, operand, 3, 0);
|
|
isJSL := false;
|
|
end;
|
|
|
|
longabsolute: begin
|
|
if opcode <> d_add then begin
|
|
CnOut(opcode);
|
|
i := 3;
|
|
end {if}
|
|
else
|
|
i := 4;
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, i, 0, operand)
|
|
else if (flags & constantOpnd) <> 0 then begin
|
|
lval := ord4(name);
|
|
CnOut2(long(lval).lsw);
|
|
if opcode = d_add then
|
|
CnOut2(long(lval).msw)
|
|
else
|
|
CnOut(long(lval).msw);
|
|
end {else if}
|
|
else if name <> nil then
|
|
RefName(name, operand, i, 0)
|
|
else begin
|
|
CnOut2(operand);
|
|
CnOut(0);
|
|
if opcode = d_add then
|
|
CnOut(0);
|
|
end; {else}
|
|
end;
|
|
|
|
absolute: begin
|
|
if opcode <> d_add then
|
|
CnOut(opcode);
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 2, 0, operand)
|
|
else if name <> nil then
|
|
RefName(name, operand, 2, 0)
|
|
else if (flags & constantOpnd) <> 0 then
|
|
CnOut2(operand)
|
|
else
|
|
LabelSearch(operand, 2, 0, 0);
|
|
end;
|
|
|
|
direct: begin
|
|
if opcode <> d_add then
|
|
CnOut(opcode);
|
|
if (flags & localLab) <> 0 then
|
|
LabelSearch(long(name).lsw, 1, 0, operand)
|
|
else if name <> nil then
|
|
RefName(name, operand, 1, 0)
|
|
else
|
|
CnOut(operand);
|
|
end;
|
|
|
|
longrelative: begin
|
|
CnOut(opcode);
|
|
LabelSearch(operand, -2, 0, 0);
|
|
end;
|
|
|
|
relative: begin
|
|
CnOut(opcode);
|
|
LabelSearch(operand, -1, 0, 0);
|
|
end;
|
|
|
|
gnrLabel:
|
|
if name = nil then
|
|
UpDate(operand, pc+cbufflen)
|
|
else begin
|
|
DefGlobal((flags >> 5) & 1);
|
|
if operand <> 0 then begin
|
|
Out(241);
|
|
Out2(operand);
|
|
Out2(0);
|
|
pc := pc+operand;
|
|
end; {if}
|
|
end; {else}
|
|
|
|
gnrSpace:
|
|
if operand <> 0 then begin
|
|
Out(241);
|
|
Out2(operand);
|
|
Out2(0);
|
|
pc := pc+operand;
|
|
end; {if}
|
|
|
|
gnrConstant: begin
|
|
if icptr(name)^.optype = cgString then
|
|
count := 1
|
|
else
|
|
count := icptr(name)^.q;
|
|
for i := 1 to count do
|
|
case icptr(name)^.optype of
|
|
cgByte,cgUByte : CnOut(icptr(name)^.r);
|
|
cgWord,cgUWord : CnOut2(icptr(name)^.r);
|
|
cgLong,cgULong : begin
|
|
lval := icptr(name)^.lval;
|
|
CnOut2(long(lval).lsw);
|
|
CnOut2(long(lval).msw);
|
|
end;
|
|
cgReal : begin
|
|
cnv.rval := icptr(name)^.rval;
|
|
CnOut2(cnv.ival1);
|
|
CnOut2(cnv.ival2);
|
|
end;
|
|
cgDouble : begin
|
|
cnv.dval := icptr(name)^.rval;
|
|
CnOut2(cnv.ival1);
|
|
CnOut2(cnv.ival2);
|
|
CnOut2(cnv.ival3);
|
|
CnOut2(cnv.ival4);
|
|
end;
|
|
cgComp : begin
|
|
cns.itsReal := icptr(name)^.rval;
|
|
CnvSC(cns);
|
|
for j := 1 to 8 do
|
|
CnOut(cns.inCOMP[j]);
|
|
end;
|
|
cgExtended : begin
|
|
cns.itsReal := icptr(name)^.rval;
|
|
CnvSX(cns);
|
|
for j := 1 to 10 do
|
|
CnOut(cns.inSANE[j]);
|
|
end;
|
|
cgString : begin
|
|
sptr := icptr(name)^.str;
|
|
for j := 1 to sptr^.length do
|
|
CnOut(ord(sPtr^.str[j]));
|
|
end;
|
|
ccPointer : begin
|
|
if icptr(name)^.lab <> nil then begin
|
|
Purge;
|
|
Out(235);
|
|
Out(4);
|
|
Out(131);
|
|
pc := pc+4;
|
|
nptr := icptr(name)^.lab;
|
|
for j := 0 to ord(nptr^[0]) do
|
|
Out(ord(nptr^[j]));
|
|
lval := icptr(name)^.pVal;
|
|
if lval <> 0 then begin
|
|
Out(129);
|
|
Out2(long(lval).lsw);
|
|
Out2(long(lval).msw);
|
|
Out(2-icptr(name)^.r);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else begin
|
|
lval := icptr(name)^.pVal;
|
|
if icptr(name)^.r = 1 then
|
|
operand := stringSize+long(lval).lsw
|
|
else
|
|
operand := stringSize-long(lval).lsw;
|
|
flags := stringReference;
|
|
GenImmediate2;
|
|
flags := stringReference+shift16;
|
|
GenImmediate2;
|
|
sptr := icptr(name)^.pStr;
|
|
j := sptr^.length;
|
|
if maxString-stringSize >= j+1 then begin
|
|
for k := 1 to j do
|
|
stringSpace[k+stringSize] :=
|
|
sptr^.str[k];
|
|
stringSpace[stringSize+j+1] := chr(0);
|
|
stringSize := stringSize+j+1;
|
|
end {if}
|
|
else
|
|
Error(cge3);
|
|
end; {else}
|
|
end;
|
|
otherwise : Error(cge1);
|
|
end; {case}
|
|
end;
|
|
|
|
genAddress: begin
|
|
if opcode < 256 then
|
|
CnOut(opcode);
|
|
if (flags & stringReference) <> 0 then begin
|
|
Purge;
|
|
Out(235);
|
|
Out(2);
|
|
LabelSearch(maxLabel,2,0,0);
|
|
if operand <> 0 then begin
|
|
Out(129);
|
|
Out2(operand);
|
|
Out2(0);
|
|
Out(1);
|
|
end; {if}
|
|
if (flags & shift16) <> 0 then begin
|
|
Out(129);
|
|
Out2(-16);
|
|
Out2(-1);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0);
|
|
end {if}
|
|
else if operand = 0 then begin
|
|
CnOut(0);
|
|
CnOut(0);
|
|
end {else if}
|
|
else if (flags & shift16) <> 0 then
|
|
if longA then
|
|
LabelSearch(operand, 2, 16, 0)
|
|
else
|
|
LabelSearch(operand, 1, 16, 0)
|
|
else
|
|
LabelSearch(operand, 0, 0, 0);
|
|
end;
|
|
|
|
special:
|
|
if opcode = d_pin then begin
|
|
segDisp := 36;
|
|
out2(long(pc).lsw+cBuffLen);
|
|
blkCnt := blkCnt-2;
|
|
segDisp := blkCnt;
|
|
end {if}
|
|
else if opcode = d_sym then begin
|
|
CnOut(m_cop);
|
|
CnOut(5);
|
|
Purge;
|
|
lsegDisp := segDisp+1;
|
|
CnOut2(0);
|
|
symLength := 0;
|
|
GenSymbols(pointer(name), operand);
|
|
segDisp := lSegDisp;
|
|
out2(symLength);
|
|
blkCnt := blkCnt-2;
|
|
segDisp := blkCnt;
|
|
end {else if}
|
|
else {d_wrd}
|
|
CnOut2(operand);
|
|
|
|
otherwise: Error(cge1);
|
|
|
|
end; {case}
|
|
1:
|
|
end; {WriteNative}
|
|
|
|
|
|
procedure CheckRegisters(p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer);
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
label 1,2;
|
|
|
|
begin {CheckRegisters}
|
|
case p_opcode of
|
|
m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,m_and_imm,
|
|
m_and_s,m_asl_a,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_lda_absx,
|
|
m_lda_dirx,m_lda_indl,m_lda_indly,m_lda_longx,m_lda_s,m_lsr_a,m_ora_abs,
|
|
m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,m_pla,m_sbc_abs,
|
|
m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc,m_tsb_dir,m_tsb_abs:
|
|
aRegister.condition := regUnknown;
|
|
|
|
m_ldy_absX,m_ldy_dirX,m_ply:
|
|
yRegister.condition := regUnknown;
|
|
|
|
m_plx:
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_clc,m_cmp_abs,
|
|
m_cmp_dir,m_cmp_imm,m_cmp_s,m_cpx_imm,m_jml,m_pha,m_phb,m_phd,
|
|
m_phx,m_phy,m_plb,m_pld,m_rtl,m_rts,m_sec,m_sta_absX,
|
|
m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_longX,
|
|
m_sta_s,m_stx_dir,m_sty_dir,m_sty_dirX,m_stz_abs,m_stz_absX,
|
|
m_stz_dir,m_stz_dirX,m_tcs,m_tcd,d_add,d_pin,m_pei_dir,m_cpx_abs,
|
|
m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd: ;
|
|
|
|
m_pea: begin
|
|
if aRegister.condition = regImmediate then
|
|
if aRegister.value = p_operand then
|
|
if aRegister.lab = p_name then
|
|
if aRegister.flags = p_flags then
|
|
if longA then begin
|
|
p_opcode := m_pha;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
if longI then begin
|
|
if xRegister.condition = regImmediate then
|
|
if xRegister.value = p_operand then
|
|
if xRegister.lab = p_name then
|
|
if xRegister.flags = p_flags then begin
|
|
p_opcode := m_phx;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
if yRegister.condition = regImmediate then
|
|
if yRegister.value = p_operand then
|
|
if yRegister.lab = p_name then
|
|
if yRegister.flags = p_flags then begin
|
|
p_opcode := m_phy;
|
|
p_mode := implied;
|
|
goto 2;
|
|
end; {if}
|
|
end; {if}
|
|
end;
|
|
|
|
m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long: begin
|
|
if aRegister.condition = regAbsolute then
|
|
if aRegister.lab = p_name then
|
|
if aRegister.value = p_operand then
|
|
if not (p_opcode in [m_sta_abs,m_sta_long]) then
|
|
aRegister.condition := regUnknown;
|
|
if xRegister.condition = regAbsolute then
|
|
if xRegister.lab = p_name then
|
|
if xRegister.value = p_operand then
|
|
if p_opcode <> m_stx_abs then
|
|
xRegister.condition := regUnknown;
|
|
if yRegister.condition = regAbsolute then
|
|
if yRegister.lab = p_name then
|
|
if yRegister.value = p_operand then
|
|
if p_opcode <> m_sty_abs then
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_dec_dir,m_dec_dirX,m_inc_dir,m_inc_dirX: begin
|
|
if aRegister.condition = regLocal then
|
|
if aRegister.value = p_operand then
|
|
aRegister.condition := regUnknown;
|
|
if xRegister.condition = regLocal then
|
|
if xRegister.value = p_operand then
|
|
xRegister.condition := regUnknown;
|
|
if yRegister.condition = regLocal then
|
|
if yRegister.value = p_operand then
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_dex:
|
|
if xRegister.condition = regImmediate then
|
|
xRegister.value := xRegister.value-1
|
|
else
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_dey:
|
|
if yRegister.condition = regImmediate then
|
|
yRegister.value := yRegister.value-1
|
|
else
|
|
yRegister.condition := regUnknown;
|
|
|
|
m_ina:
|
|
if aRegister.condition = regImmediate then
|
|
aRegister.value := aRegister.value+1
|
|
else
|
|
aRegister.condition := regUnknown;
|
|
|
|
m_inx:
|
|
if xRegister.condition = regImmediate then
|
|
xRegister.value := xRegister.value+1
|
|
else
|
|
xRegister.condition := regUnknown;
|
|
|
|
m_iny:
|
|
if yRegister.condition = regImmediate then
|
|
yRegister.value := yRegister.value+1
|
|
else
|
|
yRegister.condition := regUnknown;
|
|
|
|
otherwise,
|
|
m_jsl,m_mvn,m_rep,m_sep,d_lab,d_end,d_bmov,d_cns: begin
|
|
aRegister.condition := regUnknown;
|
|
xRegister.condition := regUnknown;
|
|
yRegister.condition := regUnknown;
|
|
end;
|
|
|
|
m_lda_abs,m_lda_long: begin
|
|
if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end;
|
|
aRegister.condition := regAbsolute;
|
|
aRegister.value := p_operand;
|
|
aRegister.lab := p_name;
|
|
aRegister.flags := p_flags;
|
|
end;
|
|
|
|
m_lda_dir: begin
|
|
if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end; {else if}
|
|
aRegister.condition := regLocal;
|
|
aRegister.value := p_operand;
|
|
aRegister.flags := p_flags;
|
|
end;
|
|
|
|
m_lda_imm: begin
|
|
if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then
|
|
goto 1
|
|
else if longA = longI then begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then begin
|
|
p_opcode := m_txa;
|
|
p_mode := implied;
|
|
aRegister := xRegister;
|
|
goto 2;
|
|
end {if}
|
|
else if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then begin
|
|
p_opcode := m_tya;
|
|
p_mode := implied;
|
|
aRegister := yRegister;
|
|
goto 2;
|
|
end; {else if}
|
|
end; {else if}
|
|
if (aRegister.condition = regImmediate) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then
|
|
if aRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dea;
|
|
p_mode := implied;
|
|
aRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if aRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_ina;
|
|
p_mode := implied;
|
|
aRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
aRegister.condition := regImmediate;
|
|
aRegister.value := p_operand;
|
|
aRegister.flags := p_flags;
|
|
aRegister.lab := p_name;
|
|
end;
|
|
|
|
m_ldx_abs: begin
|
|
if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then
|
|
goto 1
|
|
else if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else if}
|
|
else if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
xRegister.condition := regAbsolute;
|
|
xRegister.value := p_operand;
|
|
xRegister.lab := p_name;
|
|
xRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldx_dir: begin
|
|
if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then
|
|
goto 1
|
|
else if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else if}
|
|
else if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
xRegister.condition := regLocal;
|
|
xRegister.value := p_operand;
|
|
xRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldx_imm: begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then
|
|
goto 1
|
|
else if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) and
|
|
(aRegister.lab = p_name) and
|
|
(aRegister.flags = p_flags) then begin
|
|
p_opcode := m_tax;
|
|
p_mode := implied;
|
|
xRegister := aRegister;
|
|
end {else}
|
|
else if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then begin
|
|
p_opcode := m_tyx;
|
|
p_mode := implied;
|
|
xRegister := yRegister;
|
|
end {else if}
|
|
else begin
|
|
if (xRegister.condition = regImmediate) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then
|
|
if xRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dex;
|
|
p_mode := implied;
|
|
xRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if xRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_inx;
|
|
p_mode := implied;
|
|
xRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
xRegister.condition := regImmediate;
|
|
xRegister.value := p_operand;
|
|
xRegister.flags := p_flags;
|
|
xRegister.lab := p_name;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_abs: begin
|
|
if (yRegister.condition = regAbsolute) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) then
|
|
goto 1
|
|
else if (aRegister.condition = regAbsolute) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regAbsolute) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
yRegister.condition := regAbsolute;
|
|
yRegister.value := p_operand;
|
|
yRegister.lab := p_name;
|
|
yRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_dir: begin
|
|
if (yRegister.condition = regLocal) and
|
|
(yRegister.value = p_operand) then
|
|
goto 1
|
|
else if (aRegister.condition = regLocal) and
|
|
(aRegister.value = p_operand) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regLocal) and
|
|
(xRegister.value = p_operand) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
yRegister.condition := regLocal;
|
|
yRegister.value := p_operand;
|
|
yRegister.flags := p_flags;
|
|
end; {else}
|
|
end;
|
|
|
|
m_ldy_imm: begin
|
|
if (yRegister.condition = regImmediate) and
|
|
(yRegister.value = p_operand) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then
|
|
goto 1
|
|
else if (aRegister.condition = regImmediate) and
|
|
(aRegister.value = p_operand) and
|
|
(aRegister.flags = p_flags) and
|
|
(aRegister.lab = p_name) and
|
|
(longA = longI) then begin
|
|
p_opcode := m_tay;
|
|
p_mode := implied;
|
|
yRegister := aRegister;
|
|
end {else if}
|
|
else if (xRegister.condition = regImmediate) and
|
|
(xRegister.value = p_operand) and
|
|
(xRegister.lab = p_name) and
|
|
(xRegister.flags = p_flags) then begin
|
|
p_opcode := m_txy;
|
|
p_mode := implied;
|
|
yRegister := xRegister;
|
|
end {else if}
|
|
else begin
|
|
if (yRegister.condition = regImmediate) and
|
|
(yRegister.lab = p_name) and
|
|
(yRegister.flags = p_flags) then
|
|
if yRegister.value = (p_operand + 1) then begin
|
|
p_opcode := m_dey;
|
|
p_mode := implied;
|
|
yRegister.value := p_operand;
|
|
goto 2;
|
|
end {if}
|
|
else if yRegister.value = (p_operand - 1) then begin
|
|
p_opcode := m_iny;
|
|
p_mode := implied;
|
|
yRegister.value := p_operand;
|
|
goto 2;
|
|
end; {else if}
|
|
yRegister.condition := regImmediate;
|
|
yRegister.value := p_operand;
|
|
yRegister.flags := p_flags;
|
|
yRegister.lab := p_name;
|
|
end; {else}
|
|
end;
|
|
|
|
m_tax: begin
|
|
if aRegister.condition <> regUnknown then
|
|
if aRegister.condition = xRegister.condition then
|
|
if aRegister.value = xRegister.value then
|
|
if aRegister.flags = xRegister.flags then
|
|
if aRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if aRegister.lab = xRegister.lab then
|
|
goto 1;
|
|
xRegister := aRegister;
|
|
end;
|
|
|
|
m_tay: begin
|
|
if aRegister.condition <> regUnknown then
|
|
if aRegister.condition = yRegister.condition then
|
|
if aRegister.value = yRegister.value then
|
|
if aRegister.flags = yRegister.flags then
|
|
if aRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if aRegister.lab = yRegister.lab then
|
|
goto 1;
|
|
yRegister := aRegister;
|
|
end;
|
|
|
|
m_txa: begin
|
|
if xRegister.condition <> regUnknown then
|
|
if xRegister.condition = aRegister.condition then
|
|
if xRegister.value = aRegister.value then
|
|
if xRegister.flags = aRegister.flags then
|
|
if xRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if xRegister.lab = aRegister.lab then
|
|
goto 1;
|
|
aRegister := xRegister;
|
|
end;
|
|
|
|
m_txy: begin
|
|
if xRegister.condition <> regUnknown then
|
|
if xRegister.condition = yRegister.condition then
|
|
if xRegister.value = yRegister.value then
|
|
if xRegister.flags = yRegister.flags then
|
|
if xRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if xRegister.lab = yRegister.lab then
|
|
goto 1;
|
|
yRegister := xRegister;
|
|
end;
|
|
|
|
m_tya: begin
|
|
if yRegister.condition <> regUnknown then
|
|
if yRegister.condition = aRegister.condition then
|
|
if yRegister.value = aRegister.value then
|
|
if yRegister.flags = aRegister.flags then
|
|
if yRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if yRegister.lab = aRegister.lab then
|
|
goto 1;
|
|
aRegister := yRegister;
|
|
end;
|
|
|
|
m_tyx: begin
|
|
if yRegister.condition <> regUnknown then
|
|
if yRegister.condition = xRegister.condition then
|
|
if yRegister.value = xRegister.value then
|
|
if yRegister.flags = xRegister.flags then
|
|
if yRegister.condition <> regAbsolute then
|
|
goto 1
|
|
else if yRegister.lab = xRegister.lab then
|
|
goto 1;
|
|
xRegister := yRegister;
|
|
end;
|
|
end; {case}
|
|
2:
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
1:
|
|
end; {CheckRegisters}
|
|
|
|
|
|
procedure Remove (ns: integer); extern;
|
|
|
|
{ Remove the instruction ns from the peephole array }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - index of the instruction to remove }
|
|
|
|
|
|
function Short (n, lab: integer): boolean; extern;
|
|
|
|
{ see if a label is within range of a one-byte relative branch }
|
|
{ }
|
|
{ parameters: }
|
|
{ n - index to branch instruction }
|
|
{ lab - label number }
|
|
|
|
{--------------------------------------------------------------------------}
|
|
|
|
procedure EndSeg;
|
|
|
|
{ close out the current segment }
|
|
|
|
var
|
|
i: integer;
|
|
|
|
begin {EndSeg}
|
|
Purge; {dump constant buffer}
|
|
if stringsize <> 0 then begin {define string space}
|
|
UpDate(maxLabel, pc); {define the local label for the string space}
|
|
for i := 1 to stringsize do
|
|
CnOut(ord(stringspace[i]));
|
|
Purge;
|
|
end; {if}
|
|
Out(0); {end the segment}
|
|
segDisp := 8; {update header}
|
|
Out2(long(pc).lsw);
|
|
Out2(long(pc).msw);
|
|
blkcnt := blkcnt-4; {purge the segment to disk}
|
|
segDisp := blkcnt;
|
|
CloseSeg;
|
|
end; {EndSeg}
|
|
|
|
|
|
procedure GenNative {p_opcode: integer; p_mode: addressingMode;
|
|
p_operand: integer; p_name: stringPtr; p_flags: integer};
|
|
|
|
{ write a native code instruction to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_opcode - native op code }
|
|
{ p_mode - addressing mode }
|
|
{ p_operand - integer operand }
|
|
{ p_name - named operand }
|
|
{ p_flags - operand modifier flags }
|
|
|
|
var
|
|
done: boolean; {loop termination}
|
|
llongA: boolean; {for tracking A size during opt.}
|
|
i: integer; {index}
|
|
op: integer; {temp storage for opcode}
|
|
|
|
|
|
procedure Purge;
|
|
|
|
{ Empty the peephole array }
|
|
|
|
begin {Purge}
|
|
while nnextSpot > 1 do begin
|
|
if registers then
|
|
CheckRegisters(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
|
|
npeep[1].name, npeep[1].flags)
|
|
else
|
|
WriteNative(npeep[1].opcode, npeep[1].mode, npeep[1].operand,
|
|
npeep[1].name, npeep[1].flags);
|
|
Remove(1);
|
|
end; {while}
|
|
end; {Purge}
|
|
|
|
|
|
procedure Optimize(ns: integer; longA: boolean);
|
|
|
|
{ Optimize the instruction starting at ns }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - index of instruction to check for optimization }
|
|
{ longA - is the accumulator long? }
|
|
|
|
label 1;
|
|
|
|
var
|
|
tn: nativeType; {temp operation}
|
|
|
|
|
|
function ASafe (ns: integer): boolean;
|
|
|
|
{ See if it is safe to skip loading the A register }
|
|
{ }
|
|
{ parameters: }
|
|
{ ns - starting index }
|
|
|
|
label 1;
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
opcode: integer; {copy of current op code}
|
|
|
|
begin {ASafe}
|
|
ASafe := false;
|
|
for i := ns to nnextSpot-1 do begin
|
|
opcode := npeep[i].opcode;
|
|
if opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_jml,m_jsl,
|
|
m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,m_lda_indl,
|
|
m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_mvn,m_pla,m_rtl,
|
|
m_rts,m_tdc,m_txa,m_tya,m_tsc,d_end,d_bmov,d_add,d_pin,d_wrd,
|
|
d_sym,d_cns] then begin
|
|
ASafe := true;
|
|
goto 1;
|
|
end {if}
|
|
else if opcode in
|
|
[m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,
|
|
m_and_imm,m_and_s,m_asl_a,m_cmp_abs,m_cmp_dir,m_cmp_dirX,m_cmp_imm,
|
|
m_cmp_long,m_cmp_s,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,
|
|
m_ina,m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,
|
|
m_lda_indl,m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_lsr_a,
|
|
m_ora_abs,m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,
|
|
m_pha,m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_sta_abs,m_sta_absX,
|
|
m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_long,m_sta_longX,
|
|
m_sta_s,m_tax,m_tay,m_tcd,m_tcs,m_xba,m_tsb_dir,m_tsb_abs] then
|
|
goto 1;
|
|
end; {for}
|
|
1:
|
|
end; {ASafe}
|
|
|
|
|
|
function SignExtension (ns: integer): boolean;
|
|
|
|
{ See if the pattern is a sugn extension }
|
|
{ }
|
|
{ Parameters: }
|
|
{ ns - start of suspected pattern }
|
|
{ }
|
|
{ Returns: true for a sign extension, else false }
|
|
|
|
begin {SignExtension}
|
|
SignExtension := false;
|
|
if npeep[ns].opcode = m_ldx_imm then
|
|
if npeep[ns].operand = 0 then
|
|
if npeep[ns+1].opcode = m_tay then
|
|
if npeep[ns+2].opcode = m_bpl then
|
|
if npeep[ns+3].opcode = m_dex then
|
|
SignExtension := true;
|
|
end; {SignExtension}
|
|
|
|
|
|
begin {Optimize}
|
|
with npeep[ns] do
|
|
case opcode of
|
|
|
|
m_and_imm:
|
|
if npeep[ns+1].opcode = m_and_imm then begin
|
|
operand := operand & npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_asl_a:
|
|
if npeep[ns+1].opcode = m_tay then
|
|
if npeep[ns+2].opcode = m_iny then
|
|
if npeep[ns+3].opcode = m_iny then begin
|
|
opcode := m_ina;
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
npeep[ns+2].opcode := m_tay;
|
|
Remove(ns+3);
|
|
end; {if}
|
|
|
|
m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc:
|
|
if npeep[ns+2].opcode = d_lab then
|
|
if npeep[ns+2].operand = operand then
|
|
if npeep[ns+1].opcode = m_brl then begin
|
|
if Short(ns,npeep[ns+1].operand) then begin
|
|
operand := npeep[ns+1].operand;
|
|
Remove(ns+1);
|
|
if opcode = m_bcs then
|
|
opcode := m_bcc
|
|
else if opcode = m_beq then
|
|
opcode := m_bne
|
|
else if opcode = m_bne then
|
|
opcode := m_beq
|
|
else if opcode = m_bmi then
|
|
opcode := m_bpl
|
|
else if opcode = m_bcc then
|
|
opcode := m_bcs
|
|
else
|
|
opcode := m_bmi;
|
|
end; {if}
|
|
end {if m_brl}
|
|
else if npeep[ns+1].opcode = m_bra then begin
|
|
operand := npeep[ns+1].operand;
|
|
Remove(ns+1); Remove(ns+1);
|
|
if opcode = m_bcs then
|
|
opcode := m_bcc
|
|
else if opcode = m_beq then
|
|
opcode := m_bne
|
|
else if opcode = m_bne then
|
|
opcode := m_beq
|
|
else if opcode = m_bmi then
|
|
opcode := m_bpl
|
|
else if opcode = m_bcc then
|
|
opcode := m_bcs
|
|
else
|
|
opcode := m_bmi;
|
|
end; {else if m_bra}
|
|
|
|
m_brl:
|
|
if Short(ns,operand) then begin
|
|
opcode := m_bra;
|
|
mode := relative;
|
|
didOne := true;
|
|
end; {if}
|
|
|
|
m_bvs:
|
|
if npeep[ns+2].opcode = d_lab then
|
|
if npeep[ns+2].operand = operand then
|
|
if npeep[ns+1].opcode = m_bmi then
|
|
if npeep[ns+4].opcode = d_lab then
|
|
if npeep[ns+1].operand = npeep[ns+4].operand then
|
|
if npeep[ns+3].opcode = m_brl then
|
|
if Short(ns,npeep[ns+3].operand) then
|
|
if Short(ns+1,npeep[ns+3].operand) then begin
|
|
operand := npeep[ns+3].operand;
|
|
npeep[ns+1].operand := npeep[ns+3].operand;
|
|
npeep[ns+1].opcode := m_bpl;
|
|
Remove(ns+3);
|
|
end; {if}
|
|
|
|
m_dec_abs:
|
|
if npeep[ns+1].opcode = m_lda_abs then
|
|
if name^ = npeep[ns+1].name^ then
|
|
if npeep[ns+2].opcode = m_beq then
|
|
Remove(ns+1);
|
|
|
|
m_lda_abs:
|
|
if npeep[ns+1].opcode = m_clc then begin
|
|
if npeep[ns+2].opcode = m_adc_abs then
|
|
if operand = npeep[ns+2].operand then
|
|
if name = npeep[ns+2].name then
|
|
if not rangeCheck then begin
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_dea then begin
|
|
if npeep[ns+2].opcode = m_tax then begin
|
|
opcode := m_ldx_abs;
|
|
npeep[ns+1].opcode := m_dex;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+2].opcode = m_sta_abs then begin
|
|
if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
|
|
m_ora_imm,m_ora_longX,m_ora_s] then
|
|
if operand = npeep[ns+2].operand then
|
|
if name = npeep[ns+2].name then begin
|
|
npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
|
|
npeep[ns+2].opcode := m_tsb_abs;
|
|
Remove(ns);
|
|
end; {if}
|
|
end {else if}
|
|
else if SignExtension(ns+1) then begin
|
|
npeep[ns+2] := npeep[ns];
|
|
Remove(ns);
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_xba then
|
|
if npeep[ns+2].opcode = m_and_imm then
|
|
if npeep[ns+2].operand = $00FF then begin
|
|
operand := operand+1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_lda_dir:
|
|
if npeep[ns+1].opcode = m_clc then begin
|
|
if npeep[ns+2].opcode = m_adc_dir then
|
|
if operand = npeep[ns+2].operand then
|
|
if not rangeCheck then begin
|
|
npeep[ns+1].opcode := m_asl_a;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end
|
|
else if npeep[ns+1].opcode = m_dea then begin
|
|
if npeep[ns+2].opcode = m_tax then begin
|
|
opcode := m_ldx_dir;
|
|
npeep[ns+1].opcode := m_dex;
|
|
Remove(ns+2);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_pha then begin
|
|
if longA then begin
|
|
opcode := m_pei_dir;
|
|
Remove(ns+1);
|
|
end {if}
|
|
end {else if}
|
|
else if npeep[ns+2].opcode = m_sta_dir then begin
|
|
if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX,
|
|
m_ora_imm,m_ora_longX,m_ora_s] then
|
|
if operand = npeep[ns+2].operand then begin
|
|
npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0;
|
|
npeep[ns+2].opcode := m_tsb_dir;
|
|
Remove(ns);
|
|
end {if}
|
|
end {else if}
|
|
else if SignExtension(ns+1) then begin
|
|
npeep[ns+2] := npeep[ns];
|
|
Remove(ns);
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_xba then
|
|
if npeep[ns+2].opcode = m_and_imm then
|
|
if npeep[ns+2].operand = $00FF then begin
|
|
operand := operand+1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_pei_dir:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
opcode := m_lda_dir;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_lda_imm:
|
|
if npeep[ns+1].opcode = m_pha then
|
|
if ASafe(ns+2) then
|
|
if longA then begin
|
|
opcode := m_pea;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_ldx_imm:
|
|
if npeep[ns+1].opcode = m_lda_imm then
|
|
if npeep[ns+2].opcode = m_phx then
|
|
if npeep[ns+3].opcode = m_pha then begin
|
|
opcode := m_pea;
|
|
npeep[ns+1].opcode := m_pea;
|
|
Remove(ns+2);
|
|
Remove(ns+2);
|
|
end; {if}
|
|
|
|
m_ldy_imm:
|
|
if npeep[ns+1].opcode = m_sep then
|
|
if npeep[ns+1].operand = 32 then begin
|
|
didOne := true;
|
|
tn := npeep[ns];
|
|
npeep[ns] := npeep[ns+1];
|
|
npeep[ns+1] := tn;
|
|
end; {if}
|
|
|
|
m_ora_abs:
|
|
if npeep[ns+1].opcode = m_sta_abs then
|
|
if operand = npeep[ns+1].operand then
|
|
if name = npeep[ns+1].name then begin
|
|
opcode := m_tsb_abs;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_ora_dir:
|
|
if npeep[ns+1].opcode = m_sta_dir then
|
|
if operand = npeep[ns+1].operand then begin
|
|
opcode := m_tsb_dir;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_pea:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
opcode := m_lda_imm;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_sta_abs:
|
|
if npeep[ns+1].opcode = m_lda_abs then
|
|
if operand = npeep[ns+1].operand then
|
|
if name = npeep[ns+1].name then
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
|
|
Remove(ns+1);
|
|
|
|
m_sta_dir:
|
|
if npeep[ns+1].opcode = m_lda_dir then
|
|
if operand = npeep[ns+1].operand then
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then
|
|
Remove(ns+1);
|
|
|
|
m_plb:
|
|
if npeep[ns+1].opcode = m_phb then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_plx:
|
|
if npeep[ns+1].opcode = m_pha then begin
|
|
opcode := m_sta_s;
|
|
mode := direct;
|
|
operand := 1;
|
|
Remove(ns+1);
|
|
end; {if}
|
|
|
|
m_tax:
|
|
if npeep[ns+1].opcode = m_phx then begin
|
|
Remove(ns+1);
|
|
opcode := m_pha;
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_txa then begin
|
|
if not (npeep[ns+2].opcode in
|
|
[m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
end {else if}
|
|
else if npeep[ns+1].opcode = m_dey then
|
|
if npeep[ns+2].opcode = m_dey then
|
|
if npeep[ns+3].opcode = m_lda_indly then
|
|
if npeep[ns+4].opcode = m_stx_dir then begin
|
|
npeep[ns] := npeep[ns+4];
|
|
opcode := m_sta_dir;
|
|
Remove(ns+4);
|
|
end; {if}
|
|
|
|
m_tya:
|
|
if npeep[ns+1].opcode = m_sta_dir then begin
|
|
npeep[ns+1].opcode := m_sty_dir;
|
|
Remove(ns);
|
|
end {if}
|
|
else if npeep[ns+1].opcode = m_sta_abs then begin
|
|
npeep[ns+1].opcode := m_sty_abs;
|
|
Remove(ns);
|
|
end; {else if}
|
|
|
|
m_tyx:
|
|
if npeep[ns+1].opcode = m_phx then begin
|
|
Remove(ns+1);
|
|
opcode := m_phy;
|
|
end; {if}
|
|
|
|
m_pha:
|
|
if npeep[ns+1].opcode = m_pla then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end {if}
|
|
else if npeep[ns+1].opcode in [m_ldx_abs,m_ldx_dir] then
|
|
if npeep[ns+2].opcode = m_pla then begin
|
|
Remove(ns+2);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_phy:
|
|
if npeep[ns+1].opcode = m_ply then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
m_rep:
|
|
if npeep[ns+1].opcode = m_sep then
|
|
if npeep[ns].operand = npeep[ns+1].operand then begin
|
|
Remove(ns);
|
|
Remove(ns);
|
|
end; {if}
|
|
|
|
otherwise: ;
|
|
|
|
end; {case}
|
|
1:
|
|
end; {Optimize}
|
|
|
|
begin {GenNative}
|
|
{ writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1,
|
|
' operand=', p_operand:1); {debug}
|
|
if npeephole then begin
|
|
if (nnextspot = 1) and not (p_opcode in nleadOpcodes) then begin
|
|
if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end {if}
|
|
else if p_opcode in nstopOpcodes then begin
|
|
repeat
|
|
didOne := false;
|
|
i := 1;
|
|
llongA := longA;
|
|
while i < nnextSpot-nMaxPeep do begin
|
|
op := npeep[i].opcode;
|
|
if op = m_sep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := false;
|
|
end {if}
|
|
else if op = m_rep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := true;
|
|
end; {else}
|
|
Optimize(i,llongA);
|
|
i := i+1;
|
|
end; {while}
|
|
until not didone;
|
|
Purge;
|
|
if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end {else if}
|
|
else if nnextSpot = npeepSize then begin
|
|
repeat
|
|
didOne := false;
|
|
i := 1;
|
|
llongA := longA;
|
|
while i < nnextSpot-nMaxPeep do begin
|
|
op := npeep[i].opcode;
|
|
if op = m_sep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := false;
|
|
end {if}
|
|
else if op = m_rep then begin
|
|
if npeep[i].operand & $20 <> 0 then
|
|
llongA := true;
|
|
end; {else}
|
|
Optimize(i,llongA);
|
|
i := i+1;
|
|
end; {while}
|
|
until not didone;
|
|
done := false;
|
|
repeat
|
|
if nnextSpot = 1 then
|
|
done := true
|
|
else begin
|
|
if npeep[1].opcode in nleadOpcodes then
|
|
done := true
|
|
else begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode,
|
|
nPeep[1].operand, nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name,nPeep[1].flags);
|
|
Remove(1);
|
|
end; {else}
|
|
end; {else}
|
|
until done;
|
|
if nnextSpot = nPeepSize then begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags);
|
|
Remove(1);
|
|
end; {if}
|
|
with npeep[nnextSpot] do begin
|
|
opcode := p_opcode;
|
|
mode := p_mode;
|
|
operand := p_operand;
|
|
name := p_name;
|
|
flags := p_flags;
|
|
end; {with}
|
|
nnextSpot := nnextSpot+1;
|
|
if not (npeep[1].opcode in nleadOpcodes) then begin
|
|
if registers then
|
|
CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags)
|
|
else
|
|
WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand,
|
|
nPeep[1].name, nPeep[1].flags);
|
|
Remove(1);
|
|
end; {if}
|
|
end {else if}
|
|
else begin
|
|
with npeep[nnextSpot] do begin
|
|
opcode := p_opcode;
|
|
mode := p_mode;
|
|
operand := p_operand;
|
|
name := p_name;
|
|
flags := p_flags;
|
|
end; {with}
|
|
nnextSpot := nnextSpot+1;
|
|
end; {else}
|
|
end {if}
|
|
else if p_opcode <> d_end then
|
|
if registers then
|
|
CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags)
|
|
else
|
|
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
|
|
end; {GenNative}
|
|
|
|
|
|
procedure GenImplied {p_opcode: integer};
|
|
|
|
{ short form of GenNative - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ p_code - operation code }
|
|
|
|
begin {GenImplied}
|
|
GenNative(p_opcode, implied, 0, nil, 0);
|
|
end; {GenImplied}
|
|
|
|
|
|
procedure GenCall {callNum: integer};
|
|
|
|
{ short form of jsl to library subroutine - reduces code size }
|
|
{ }
|
|
{ parameters: }
|
|
{ callNum - subroutine # to generate a call for }
|
|
|
|
var
|
|
sp: stringPtr; {work string}
|
|
|
|
begin {GenCall}
|
|
case callNum of
|
|
1: sp := @'~CHECKSTACK';
|
|
2: sp := @'~RESETNAME';
|
|
3: sp := @'~CREALRET';
|
|
4: sp := @'~CDOUBLERET';
|
|
5: sp := @'~SETNAME';
|
|
6: sp := @'~SETLINENUMBER';
|
|
7: sp := @'~REALFN';
|
|
8: sp := @'~DOUBLEFN';
|
|
9: sp := @'~SAVEREAL';
|
|
10: sp := @'~SAVEDOUBLE';
|
|
11: sp := @'~CNVINTREAL';
|
|
12: sp := @'~CNVLONGREAL';
|
|
13: sp := @'~CNVULONGREAL';
|
|
14: sp := @'~CNVREALINT';
|
|
15: sp := @'~CNVREALUINT';
|
|
16: sp := @'~CNVREALLONG';
|
|
17: sp := @'~CNVREALULONG';
|
|
18: sp := @'~CNVL2'; {PASCAL}
|
|
19: sp := @'~SAVESET';
|
|
20: sp := @'~LOADSET'; {PASCAL}
|
|
21: sp := @'~LOADREAL';
|
|
22: sp := @'~LOADDOUBLE';
|
|
23: sp := @'~SHIFTLEFT';
|
|
24: sp := @'~SSHIFTRIGHT';
|
|
25: sp := @'~INTCHKC';
|
|
26: sp := @'~DIV2';
|
|
27: sp := @'~MOD2';
|
|
28: sp := @'~MUL2';
|
|
29: sp := @'~GRTL';
|
|
30: sp := @'~GEQL';
|
|
31: sp := @'~GRTE';
|
|
32: sp := @'~GEQE';
|
|
33: sp := @'~SETINCLUSION';
|
|
34: sp := @'~GRTSTRING';
|
|
35: sp := @'~GEQSTRING';
|
|
36: sp := @'~EQUE';
|
|
37: sp := @'~SETEQU';
|
|
38: sp := @'~EQUSTRING';
|
|
39: sp := @'~UMUL2';
|
|
40: sp := @'~UDIV2';
|
|
41: sp := @'~USHIFTRIGHT';
|
|
42: sp := @'~MUL4';
|
|
43: sp := @'~PDIV4';
|
|
44: sp := @'~MOD4';
|
|
45: sp := @'~SHL4';
|
|
46: sp := @'~LSHR4';
|
|
47: sp := @'~ASHR4'; {CC}
|
|
48: sp := @'~UMUL4'; {CC}
|
|
49: sp := @'~UDIV4'; {CC}
|
|
50: sp := @'~UMOD4'; {CC}
|
|
51: sp := @'~COPYREAL';
|
|
52: sp := @'~COPYDOUBLE';
|
|
53: sp := @'~XJPERROR';
|
|
54: sp := @'~MOVE';
|
|
55: sp := @'~MOVE2';
|
|
56: sp := @'~ADDE';
|
|
57: sp := @'~DIVE';
|
|
58: sp := @'~MULE';
|
|
59: sp := @'~SUBE';
|
|
60: sp := @'~POWER';
|
|
61: sp := @'~ARCTAN2E';
|
|
62: sp := @'~LONGMOVE';
|
|
63: sp := @'~LONGMOVE2';
|
|
64: sp := @'~CCOMPRET';
|
|
65: sp := @'~CEXTENDEDRET';
|
|
66: sp := @'~SAVECOMP';
|
|
67: sp := @'~SAVEEXTENDED';
|
|
68: sp := @'~COPYCOMP';
|
|
69: sp := @'~COPYEXTENDED';
|
|
70: sp := @'~LOADCOMP';
|
|
71: sp := @'~LOADEXTENDED';
|
|
72: sp := @'~LOADUBF';
|
|
73: sp := @'~LOADBF';
|
|
74: sp := @'~SAVEBF';
|
|
75: sp := @'~COPYBF';
|
|
76: sp := @'~STACKERR'; {CC}
|
|
77: sp := @'~LOADSTRUCT'; {CC}
|
|
otherwise:
|
|
Error(cge1);
|
|
end; {case}
|
|
GenNative(m_jsl, longabs, 0, sp, 0);
|
|
end; {GenCall}
|
|
|
|
|
|
procedure GenLab {lnum: integer};
|
|
|
|
{ generate a label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lnum - label number }
|
|
|
|
begin {GenLab}
|
|
GenNative(d_lab, gnrlabel, lnum, nil, 0);
|
|
end; {GenLab}
|
|
|
|
|
|
procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean};
|
|
|
|
{ Set up the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
|
|
procedure RootFile;
|
|
|
|
{ Create and write the initial entry segment }
|
|
|
|
const
|
|
dispToOpen = 21; {disps to glue routines for NDAs}
|
|
dispToClose = 38;
|
|
dispToAction = 50;
|
|
dispToInit = 65;
|
|
dispToCDAOpen = 9; {disps to glue routines for CDAs}
|
|
dispToCDAClose = 36;
|
|
|
|
var
|
|
i: integer; {loop index}
|
|
lab: stringPtr; {for holdling names var pointers}
|
|
menuLen: integer; {length of the menu name string}
|
|
|
|
|
|
procedure SetDataBank;
|
|
|
|
{ set up the data bank register }
|
|
|
|
begin {SetDataBank}
|
|
CnOut(m_pea);
|
|
RefName(@'~GLOBALS', 0, 2, -8);
|
|
CnOut(m_plb);
|
|
CnOut(m_plb);
|
|
end; {SetDataBank}
|
|
|
|
|
|
begin {RootFile}
|
|
{open the initial object module}
|
|
fname2.theString.theString := concat(fname1.theString.theString, '.root');
|
|
fname2.theString.size := length(fname2.theString.theString);
|
|
OpenObj(fname2);
|
|
|
|
{write the header}
|
|
Header(@'~_ROOT', $4000, 0);
|
|
|
|
{new desk accessory initialization}
|
|
if isNewDeskAcc then begin
|
|
|
|
{set up the initial jump table}
|
|
lab := @'~_ROOT';
|
|
menuLen := length(menuLine);
|
|
RefName(lab, menuLen + dispToOpen, 4, 0);
|
|
RefName(lab, menuLen + dispToClose, 4, 0);
|
|
RefName(lab, menuLen + dispToAction, 4, 0);
|
|
RefName(lab, menuLen + dispToInit, 4, 0);
|
|
CnOut2(refreshPeriod);
|
|
CnOut2(eventMask);
|
|
for i := 1 to menuLen do
|
|
CnOut(ord(menuLine[i]));
|
|
CnOut(0);
|
|
|
|
{glue code for calling open routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(openName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_sta_s); CnOut(4);
|
|
CnOut(m_txa);
|
|
CnOut(m_sta_s); CnOut(6);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling close routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(closeName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling action routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pha);
|
|
CnOut(m_phy);
|
|
CnOut(m_phx);
|
|
CnOut(m_jsl);
|
|
RefName(actionName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling init routine}
|
|
CnOut(m_pha);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pha);
|
|
CnOut(m_jsl);
|
|
RefName(initName, 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{classic desk accessory initialization}
|
|
else if isClassicDeskAcc then begin
|
|
|
|
{write the name}
|
|
menuLen := length(menuLine);
|
|
CnOut(menuLen);
|
|
for i := 1 to menuLen do
|
|
CnOut(ord(menuLine[i]));
|
|
|
|
{set up the initial jump table}
|
|
lab := @'~_ROOT';
|
|
RefName(lab, menuLen + dispToCDAOpen, 4, 0);
|
|
RefName(lab, menuLen + dispToCDAClose, 4, 0);
|
|
|
|
{glue code for calling open routine}
|
|
CnOut(m_pea);
|
|
CnOut2(1);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(@'~CDASTART', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~CDASHUTDOWN', 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
|
|
{glue code for calling close routine}
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_jsl);
|
|
RefName(closeName, 0, 3, 0);
|
|
CnOut(m_pea);
|
|
CnOut2(0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{control panel device initialization}
|
|
else if isCDev then begin
|
|
CnOut(m_pea);
|
|
CnOut2(1);
|
|
CnOut(m_jsl);
|
|
RefName(@'~DAID', 0, 3, 0);
|
|
CnOut(m_phb);
|
|
SetDataBank;
|
|
CnOut(m_pla);
|
|
CnOut(m_sta_s); CnOut(13);
|
|
CnOut(m_pla);
|
|
CnOut(m_sta_s); CnOut(13);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_tay);
|
|
CnOut(m_lda_s); CnOut(3);
|
|
CnOut(m_pha);
|
|
CnOut(m_lda_s); CnOut(3);
|
|
CnOut(m_pha);
|
|
CnOut(m_txa);
|
|
CnOut(m_sta_s); CnOut(7);
|
|
CnOut(m_tya);
|
|
CnOut(m_sta_s); CnOut(5);
|
|
CnOut(m_plb);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{NBA initialization}
|
|
else if isNBA then begin
|
|
CnOut(m_jsl);
|
|
RefName(@'~NBASTARTUP', 0, 3, 0);
|
|
CnOut(m_phx);
|
|
CnOut(m_phy);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~NBASHUTDOWN', 0, 3, 0);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{XCMD initialization}
|
|
else if isXCMD then begin
|
|
CnOut(m_jsl);
|
|
RefName(@'~XCMDSTARTUP', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(openName,0,3,0);
|
|
CnOut(m_jsl);
|
|
RefName(@'~XCMDSHUTDOWN', 0, 3, 0);
|
|
CnOut(m_rtl);
|
|
end
|
|
|
|
{normal program initialization}
|
|
else begin
|
|
|
|
{write the initial JSL}
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~_BWSTARTUP4', 0, 3, 0)
|
|
else
|
|
RefName(@'~_BWSTARTUP3', 0, 3, 0);
|
|
|
|
{set the data bank register}
|
|
SetDataBank;
|
|
|
|
{write JSL to main entry point}
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~C_STARTUP2', 0, 3, 0)
|
|
else
|
|
RefName(@'~C_STARTUP', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
RefName(@'main', 0, 3, 0);
|
|
CnOut(m_jsl);
|
|
if rtl then
|
|
RefName(@'~C_SHUTDOWN2', 0, 3, 0)
|
|
else
|
|
RefName(@'~C_SHUTDOWN', 0, 3, 0);
|
|
end;
|
|
|
|
{finish the current segment}
|
|
EndSeg;
|
|
end; {RootFile}
|
|
|
|
|
|
procedure SetStack;
|
|
|
|
{ Set up a stack frame }
|
|
|
|
begin {SetStack}
|
|
if stackSize <> 0 then begin
|
|
currentSegment := '~_STACK '; {write the header}
|
|
Header(@'~_STACK', $4012, 0);
|
|
currentSegment := defaultSegment;
|
|
Out($F1); {write the DS record to reserve space}
|
|
Out2(stackSize);
|
|
Out2(0);
|
|
EndSeg; {finish the current segment}
|
|
end; {if}
|
|
end; {SetStack}
|
|
|
|
|
|
begin {InitFile}
|
|
fname1 := keepname^;
|
|
if partial or (keepFlag = 3) then
|
|
FindSuffix(fname1, nextSuffix)
|
|
else begin
|
|
if (keepFlag = 1) and (not noroot) then begin
|
|
RootFile;
|
|
SetStack;
|
|
CloseObj;
|
|
end; {if}
|
|
DestroySuffixes(fname1);
|
|
nextSuffix := 'a';
|
|
end; {else}
|
|
fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix);
|
|
fname2.theString.size := length(fname2.theString.theString);
|
|
OpenObj(fname2);
|
|
end; {InitFile}
|
|
|
|
|
|
procedure InitNative;
|
|
|
|
{ set up for a new segment }
|
|
|
|
begin {InitNative}
|
|
aRegister.condition := regUnknown; {set up the peephole optimizer}
|
|
xRegister.condition := regUnknown;
|
|
yRegister.condition := regUnknown;
|
|
nnextspot := 1;
|
|
nleadOpcodes := [m_asl_a,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,m_bvs,m_bcc,
|
|
m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
|
|
m_pha,m_plb,m_plx,m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep,
|
|
m_ora_dir,m_ora_abs,m_and_imm,m_pea];
|
|
nstopOpcodes := [d_end,d_pin];
|
|
|
|
stringSize := 0; {initialize scalars for a new segment}
|
|
pc := 0;
|
|
cbufflen := 0;
|
|
longA := true;
|
|
longI := true;
|
|
end; {InitNative}
|
|
|
|
|
|
procedure RefName {lab: stringPtr; disp, len, shift: integer};
|
|
|
|
{ handle a reference to a named label }
|
|
{ }
|
|
{ parameters: }
|
|
{ lab - label name }
|
|
{ disp - displacement past the label }
|
|
{ len - number of bytes in the reference }
|
|
{ shift - shift factor }
|
|
|
|
var
|
|
i: integer; {loop var}
|
|
slen: integer; {length of string}
|
|
|
|
begin {RefName}
|
|
Purge; {clear any constant bytes}
|
|
if isJSL then {expression header}
|
|
Out(243)
|
|
else
|
|
Out(235);
|
|
Out(len);
|
|
Out(131);
|
|
pc := pc+len;
|
|
slen := length(lab^);
|
|
Out(slen);
|
|
for i := 1 to slen do
|
|
Out(ord(lab^[i]));
|
|
if disp <> 0 then begin {if there is a disp, add it in}
|
|
Out(129);
|
|
Out2(disp);
|
|
Out2(0);
|
|
Out(1);
|
|
end; {end}
|
|
if shift <> 0 then begin {if there is a shift, add it in}
|
|
Out(129);
|
|
Out2(shift);
|
|
if shift < 0 then
|
|
Out2(-1)
|
|
else
|
|
Out2(0);
|
|
Out(7);
|
|
end; {if}
|
|
Out(0); {end of expression}
|
|
end; {RefName}
|
|
|
|
end.
|
|
|
|
{$append 'native.asm'}
|