ORCA-C/Native.pas
Stephen Heumann a6ef872513 Add debugging option to detect illegal use of null pointers.
This adds debugging code to detect null pointer dereferences, as well as pointer arithmetic on null pointers (which is also undefined behavior, and can lead to later dereferences of the resulting pointers).

Note that ORCA/Pascal can already detect null pointer dereferences as part of its more general range-checking code. This implementation for ORCA/C will report the same error as ORCA/Pascal ("Subrange exceeded"). However, it does not include any of the other forms of range checking that ORCA/Pascal does, and (unlike in ORCA/Pascal) it is controlled by a separate flag from stack overflow checking.
2023-02-12 18:56:02 -06:00

2671 lines
90 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: longint;
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 GenImpliedForFlags (p_opcode: integer);
{ Generate implied addressing instruction used for flags only. }
{ }
{ parameters: }
{ p_code - operation code (m_tax or m_tay) }
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
{register optimization}
{---------------------}
aRegister, {current register contents}
xRegister,
yRegister: registerType;
lastRegOpcode: integer; {opcode of last reg/flag-setting instr.}
{native peephole optimization}
{----------------------------}
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); if (shift > 0) then Out2(-1) else Out2(0);
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,k4); {cnv record types}
var
bp: ^byte; {byte pointer}
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: (qval: longlong);
k4: (ival1,ival2,ival3,ival4: integer;);
end;
count: integer; {number of constants to repeat}
i,j,k: integer; {loop variables}
lsegDisp: longint; {for backtracking while writing 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); if (operand < 0) then Out2(-1) else 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}
function ShiftSize (flags: integer): integer;
{ Determine the shift size specified by flags. }
{ (Positive means right shift, negative means left shift.) }
{ }
{ parameters: }
{ flags - the flags }
begin {ShiftSize}
if (flags & shift8) <> 0 then
ShiftSize := 8
else if (flags & shift16) <> 0 then
ShiftSize := 16
else if (flags & shiftLeft8) <> 0 then
ShiftSize := -8
else
ShiftSize := 0;
end; {ShiftSize}
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;
opcode := opcode & ~asmFlag;
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 & ~asmFlag) = 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_dcl 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_dcl 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_dcl then
CnOut(0);
end; {else}
end;
absolute: begin
if opcode <> d_dcw 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_dcb 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;
cgQuad,cgUQuad : begin
cnv.qval := icptr(name)^.qval;
CnOut2(cnv.ival1);
CnOut2(cnv.ival2);
CnOut2(cnv.ival3);
CnOut2(cnv.ival4);
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
if not icptr(name)^.isByteSeq then begin
sptr := icptr(name)^.str;
for j := 1 to sptr^.length do
CnOut(ord(sPtr^.str[j]));
end {if}
else begin
lval := 0;
while lval < icptr(name)^.len do begin
bp := pointer(
ord4(icptr(name)^.data) + lval);
CnOut(bp^);
lval := lval + 1;
end;
end; {else}
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 then begin
for k := 1 to j do
stringSpace^[k+stringSize] :=
sptr^.str[k];
stringSize := stringSize+j;
end {if}
else
Error(cge3);
end; {else}
end;
otherwise : Error(cge1);
end; {case}
end;
genAddress: begin
if opcode < 256 then {includes opcodes with asmFlag}
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 if (flags & subtract1) <> 0 then
LabelSearch(operand, 0, ShiftSize(flags), 0)
else
LabelSearch(operand, 2, 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,3;
function NZMatchA: boolean;
{ Are the N and Z flags known to match the value in A? }
{ }
{ Note: Assumes long registers }
begin {NZMatchA}
NZMatchA := lastRegOpcode in
[m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_adc_indl,m_adc_indly,
m_and_abs,m_and_dir,m_and_imm,m_and_s,m_and_indl,m_and_indly,m_asl_a,
m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_eor_indl,m_eor_indly,
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_long,m_ora_longX,m_ora_s,m_ora_indl,
m_ora_indly,m_pla,m_rol_a,m_ror_a,m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,
m_sbc_indl,m_sbc_indly,m_tax,m_tay,m_tcd,m_tdc,m_txa,m_tya];
end; {NZMatchA}
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_long,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_adc_indl,m_adc_indly,
m_and_indl,m_and_indly,m_ora_indl,m_ora_indly,m_sbc_indl,m_sbc_indly,
m_eor_indl,m_eor_indly,m_rol_a,m_ror_a:
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_bvs,
m_pha,m_phb,m_phd,m_php,m_phx,m_phy,m_pei_dir,m_tcs:
goto 3;
m_bra,m_brl,m_clc,m_cmp_abs,m_cmp_dir,m_cmp_imm,m_cmp_s,m_cmp_indl,
m_cmp_indly,m_cpx_imm,m_jml,m_jmp_indX,m_plb,m_rtl,m_rts,m_sec,d_add,d_pin,
m_cpx_abs,m_cpx_dir,m_cmp_dirx,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}
goto 3;
end;
m_sta_s: begin
if aRegister.condition = regLocal then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
yRegister.condition := regUnknown;
goto 3;
end;
m_pld,m_tcd: begin
if aRegister.condition = regLocal then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
yRegister.condition := regUnknown;
end;
m_sta_indl,m_sta_indlY: begin
if aRegister.condition <> regImmediate then
aRegister.condition := regUnknown;
if xRegister.condition <> regImmediate then
xRegister.condition := regUnknown;
if yRegister.condition <> regImmediate then
yRegister.condition := regUnknown;
goto 3;
end;
m_sta_absX,m_stz_absX,m_sta_longX: begin
if aRegister.condition = regAbsolute then
if aRegister.lab = p_name then
aRegister.condition := regUnknown;
if xRegister.condition = regAbsolute then
if xRegister.lab = p_name then
xRegister.condition := regUnknown;
if yRegister.condition = regAbsolute then
if yRegister.lab = p_name then
yRegister.condition := regUnknown;
goto 3;
end;
m_dec_abs,m_inc_abs,m_tsb_abs: begin
if aRegister.condition = regAbsolute then
if aRegister.lab = p_name then
if aRegister.value = p_operand then
aRegister.condition := regUnknown;
if xRegister.condition = regAbsolute then
if xRegister.lab = p_name then
if xRegister.value = p_operand then
xRegister.condition := regUnknown;
if yRegister.condition = regAbsolute then
if yRegister.lab = p_name then
if yRegister.value = p_operand then
yRegister.condition := regUnknown;
end;
m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long,m_stz_abs: 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;
goto 3;
end;
m_dec_dir,m_inc_dir,m_tsb_dir: 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_sta_dir,m_stx_dir,m_sty_dir,m_stz_dir: begin
if aRegister.condition = regLocal then
if aRegister.value = p_operand then
if p_opcode <> m_sta_dir then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
if xRegister.value = p_operand then
if p_opcode <> m_stx_dir then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
if yRegister.value = p_operand then
if p_opcode <> m_sty_dir then
yRegister.condition := regUnknown;
goto 3;
end;
m_dec_dirX,m_inc_dirX: begin
if aRegister.condition = regLocal then
if aRegister.value >= p_operand-1 then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
if xRegister.value >= p_operand-1 then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
if yRegister.value >= p_operand-1 then
yRegister.condition := regUnknown;
end;
m_sta_dirX,m_sty_dirX,m_stz_dirX: begin
if aRegister.condition = regLocal then
if aRegister.value >= p_operand-1 then
aRegister.condition := regUnknown;
if xRegister.condition = regLocal then
if xRegister.value >= p_operand-1 then
xRegister.condition := regUnknown;
if yRegister.condition = regLocal then
if yRegister.value >= p_operand-1 then
yRegister.condition := regUnknown;
goto 3;
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 (p_flags & forFlags) <> 0 then begin
if longA then
if longI then
if NZMatchA then
goto 1;
end {if}
else 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 (p_flags & forFlags) <> 0 then begin
if longA then
if longI then
if NZMatchA then
goto 1;
end {if}
else 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: {emit the instruction normally}
lastRegOpcode := p_opcode;
3: {branch here for instructions that}
{do not modify A/X/Y or flags }
WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags);
1: {branch here to skip the instruction}
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);
if pc > $00010000 then
if currentSegment <> '~ARRAYS ' then
Error(184);
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_jmp_indX,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_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 not (opcode in
[m_clc,m_cop,m_cpx_abs,m_cpx_dir,m_cpx_imm,m_dec_abs,m_dec_absX,
m_dec_dir,m_dec_dirX,m_dex,m_dey,m_inc_abs,m_inc_absX,m_inc_dir,
m_inc_dirX,m_inx,m_iny,m_ldx_abs,m_ldx_dir,m_ldx_imm,m_ldy_abs,
m_ldy_absX,m_ldy_dir,m_ldy_dirX,m_ldy_imm,m_pea,m_pei_dir,m_phb,
m_phd,m_phx,m_phy,m_php,m_plb,m_pld,m_plx,m_ply,m_plp,m_rep,
m_sec,m_sep,m_stx_dir,m_stx_abs,m_sty_abs,m_sty_dir,m_sty_dirX,
m_stz_abs,m_stz_absX,m_stz_dir,m_stz_dirX,m_tsx,m_txs,m_txy,
m_tyx,d_lab]) then
goto 1;
end; {for}
1:
end; {ASafe}
function SignExtension (ns: integer): boolean;
{ See if the pattern is a sign 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_eor_imm:
if npeep[ns+1].opcode = m_eor_imm then begin
operand := operand ! npeep[ns+1].operand;
Remove(ns+1);
end; {if}
m_ora_imm:
if npeep[ns+1].opcode = m_ora_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 begin
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}
end {else if}
else if npeep[ns+1].opcode = m_tay then
if npeep[ns+2].opcode = m_lda_dir then begin
opcode := m_ldy_dir;
Remove(ns+1);
end {if}
else if npeep[ns+2].opcode = m_pld then
if npeep[ns+3].opcode = m_tsc then begin
opcode := m_ldy_dir;
Remove(ns+1);
end; {if}
m_ldx_dir:
if npeep[ns+1].opcode = m_txs then {optimize stack repair code}
if npeep[ns+2].opcode = m_tsx then begin
if npeep[ns+3].opcode = m_stx_dir then
if npeep[ns+3].operand = npeep[ns].operand then begin
Remove(ns+2);
Remove(ns+2);
end; {if}
end {if}
else if npeep[ns+2].opcode in
[m_sta_dir,m_sta_abs,m_sta_long,m_sta_indl,m_tyx] then begin
if (npeep[ns+2].opcode <> m_sta_dir)
or (npeep[ns+2].operand <> npeep[ns].operand) then
if npeep[ns+3].opcode = m_tsx then
if npeep[ns+4].opcode = m_stx_dir then
if npeep[ns+4].operand = npeep[ns].operand then begin
Remove(ns+3);
Remove(ns+3);
if npeep[ns+2].opcode = m_tyx then
Remove(ns+2);
end; {if}
end {else if}
else if npeep[ns+2].opcode = m_tsc then begin
npeep[ns].opcode := m_lda_dir;
npeep[ns+1].opcode := m_tcs;
Remove(ns+2);
end; {else 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}
{disabled - can generate bad code if the x value is used}
{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
if (npeep[ns+4].operand - npeep[ns+3].operand < -1)
or (npeep[ns+4].operand - npeep[ns+3].operand > 2)
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
if ASafe(ns+2) then begin
npeep[ns+1].opcode := m_sty_dir;
Remove(ns);
end; {if}
end {if}
else if npeep[ns+1].opcode = m_sta_abs then begin
if ASafe(ns+2) then begin
npeep[ns+1].opcode := m_sty_abs;
Remove(ns);
end; {if}
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}
{ kws }
{ stz $xx, stz $xx }
m_stz_abs, m_stz_absX:
if npeep[ns].opcode = npeep[ns+1].opcode then
if npeep[ns].operand = npeep[ns+1].operand then
if npeep[ns].name = npeep[ns+1].name then
if not volatile then
Remove(ns+1);
m_stz_dir, m_stz_dirX:
if npeep[ns].opcode = npeep[ns+1].opcode then
if npeep[ns].operand = npeep[ns+1].operand then
if not volatile then
Remove(ns+1);
m_tcd:
if npeep[ns+1].opcode = m_tdc then
Remove(ns+1)
else if npeep[ns+1].opcode in [m_pea,m_stz_dir,m_stz_abs] then
if npeep[ns+2].opcode = m_tdc then
Remove(ns+2);
m_tcs:
if npeep[ns+1].opcode = m_tsx then
if npeep[ns+2].opcode = m_stx_dir then begin
npeep[ns+2].opcode := m_sta_dir;
Remove(ns+1);
end; {if}
m_tsx:
if npeep[ns+1].opcode = m_stx_dir then
if npeep[ns+2].opcode = m_pei_dir then
if npeep[ns+3].opcode = m_tsx then
if npeep[ns+4].opcode = m_stx_dir then
if npeep[ns+1].operand = npeep[ns+2].operand then
if npeep[ns+1].operand = npeep[ns+4].operand then
begin
npeep[ns+1].opcode := m_phx;
npeep[ns+1].mode := implied;
Remove(ns+2);
end; {if}
{extra explicit cases to ensure this case statement uses a jump table}
m_rtl,m_rts,m_jml,m_jsl,m_mvn,m_plp,m_pld,m_txs,
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 GenImpliedForFlags {p_opcode: integer};
{ Generate implied addressing instruction used for flags only. }
{ }
{ parameters: }
{ p_code - operation code (m_tax or m_tay) }
begin {GenImpliedForFlags}
GenNative(p_opcode, implied, 0, nil, forFlags);
end; {GenImpliedForFlags}
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}
78: sp := @'~DIV4'; {CC}
79: sp := @'~MUL8';
80: sp := @'~UMUL8';
81: sp := @'~CDIV8';
82: sp := @'~UDIV8';
83: sp := @'~CNVLONGLONGREAL';
84: sp := @'~CNVULONGLONGREAL';
85: sp := @'~SHL8';
86: sp := @'~ASHR8';
87: sp := @'~LSHR8';
88: sp := @'~SCMP8';
89: sp := @'~CNVREALLONGLONG';
90: sp := @'~CNVREALULONGLONG';
91: sp := @'~SINGLEPRECISION';
92: sp := @'~DOUBLEPRECISION';
93: sp := @'~COMPPRECISION';
94: sp := @'~CUMUL2';
95: sp := @'~REALFIX';
96: sp := @'~DOUBLEFIX';
97: sp := @'~COMPFIX';
98: sp := @'~CHECKPTRC';
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 holding names var pointers}
menuLen: integer; {length of the menu name string}
procedure SetDataBank;
{ set up the data bank register }
var
lisJSL: boolean; {saved copy of isJSL}
begin {SetDataBank}
lisJSL := isJSL;
isJSL := false;
CnOut(m_pea);
RefName(@'~GLOBALS', 0, 2, -8);
CnOut(m_plb);
CnOut(m_plb);
isJSL := lisJSL;
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);
{force this to be a static segment}
if (segmentKind & $8000) <> 0 then begin
currentSegment := ' ';
segmentKind := 0;
end; {if}
{write the header}
InitNative;
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}
isJSL := true;
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);
isJSL := false;
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}
isJSL := true;
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);
isJSL := false;
end
{control panel device initialization}
else if isCDev then begin
CnOut(m_phb); {save data bank}
SetDataBank; {set data bank}
CnOut(m_plx); {get RTL address & original data bank}
CnOut(m_ply);
CnOut(m_lda_s); CnOut(3); {move CDev parameters}
CnOut(m_pha);
CnOut(m_lda_s); CnOut(3);
CnOut(m_pha);
CnOut(m_lda_s); CnOut(9);
CnOut(m_sta_s); CnOut(5);
CnOut(m_lda_s); CnOut(11);
CnOut(m_sta_s); CnOut(7);
CnOut(m_lda_s); CnOut(13);
CnOut(m_sta_s); CnOut(9);
CnOut(m_sta_s); CnOut(15); {store message in result space}
CnOut(m_lda_long); {store original user ID in result space}
RefName(@'~USER_ID',0,3,0);
CnOut(m_sta_s); CnOut(17);
CnOut(m_txa); {save RTL address & original data bank}
CnOut(m_sta_s); CnOut(11);
CnOut(m_tya);
CnOut(m_sta_s); CnOut(13);
CnOut(m_pea); CnOut2(1); {get user ID}
CnOut(m_jsl);
RefName(@'~DAID', 0, 3, 0);
CnOut(m_jsl); {call CDev main routine}
RefName(openName,0,3,0);
CnOut(m_jml); {clean up and return to caller}
RefName(@'~CDEVCLEANUP', 0, 3, 0);
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}
isJSL := true;
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);
isJSL := false;
CnOut(m_jml);
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}
segmentKind := 0;
Header(@'~_STACK', $4012, 0);
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;
lastRegOpcode := 0; {BRK}
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,m_tcd];
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'}