ORCA-C/Asm.pas
Stephen Heumann 7e822819b7 Allow the WDM instruction to be used in the mini-assembler.
This can be useful under emulators that may implement special functionality using WDM.

It is implemented as taking a one-byte numeric operand.
2020-01-11 21:58:21 -06:00

675 lines
21 KiB
ObjectPascal

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Asm }
{ }
{ This unit implements the built-in assembler and }
{ disassembler. }
{ }
{ External Subroutines: }
{ }
{ AsmFunction - assemble an assembly language function }
{ AsmStatement - assemble some in-line code }
{ InitAsm - initialize the assembler }
{ }
{---------------------------------------------------------------}
unit Asm;
interface
{$LibPrefix '0/obj/'}
uses CCommon, Table, CGI, Scanner, Symbol, MM, Expression;
{$segment 'CC'}
procedure AsmFunction (variable: identPtr);
{ Assemble an assembly language function }
{ }
{ parameters: }
{ variable - pointer to the function variable }
procedure AsmStatement;
{ Assemble some in-line code }
procedure InitAsm;
{ Initialize the assembler }
{---------------------------------------------------------------}
implementation
{---------------------------------------------------------------}
var
doingAsmFunction: boolean; {was AsmStatement called from AsmFunction?}
{- Imported from the parser: -----------------------------------}
procedure Match (kind: tokenEnum; err: integer); extern;
{ insure that the next token is of the specified type }
{ }
{ parameters: }
{ kind - expected token kind }
{ err - error number if the expected token is not found }
{- Private routines --------------------------------------------}
function FindLabel (name: stringPtr; definition: boolean): integer;
{ Find a label in the label list. If none exists, create one. }
{ }
{ parameters: }
{ name - name of the label }
{ definition - is this the defining point? }
label 1;
var
lb: gotoPtr; {work pointer}
lnum: integer; {label number}
begin {FindLabel}
lb := gotoList; {try to find an existing label}
while lb <> nil do begin
if lb^.name^ = name^ then begin
lnum := lb^.lab;
goto 1;
end;
lb := lb^.next;
end; {while}
lb := pointer(Malloc(sizeof(gotoRecord))); {no label record exists: create one}
lb^.next := gotoList;
gotoList := lb;
lb^.name := name;
lnum := GenLabel;
lb^.lab := lnum;
lb^.defined := false;
1:
if definition then begin
if lb^.defined then
Error(77)
else begin
lb^.defined := true;
Gen1(dc_lab, lb^.lab);
end; {else}
end; {if}
FindLabel := lnum;
end; {FindLabel}
{- Global routines ---------------------------------------------}
procedure AsmFunction {variable: identPtr};
{ Assemble an assembly language function }
{ }
{ parameters: }
{ variable - pointer to the function variable }
var
tl: tempPtr; {work pointer}
begin {AsmFunction}
{process the statements}
doingAsmFunction := true;
AsmStatement;
doingAsmFunction := false;
{finish the subroutine}
Gen0 (dc_enp); {finish the segment}
CheckGotoList; {make sure all labels are declared}
while tempList <> nil do begin {dump the local labels}
tl := tempList;
tempList := tl^.next;
dispose(tl);
end; {while}
LInit; {dispose of the local memory pool}
nameFound := false; {no pc_nam for the next function (yet)}
doingFunction := false; {no longer doing a function}
end; {AsmFunction}
procedure AsmStatement;
{ Assemble some in-line code }
label 1,2,3,99;
var
i: integer; {loop variable}
lnum: integer; {label number}
name: packed array[0..3] of char; {op code name}
opc: opcode; {operation code enumeration}
opname: tokenType; {operation code token}
optype: operands; {operand type}
{set by Exp}
{----------}
isConstant: boolean; {constant? (or identifier expression}
operand: tokenType; {operand (if not isConstant)}
operation: (plus,minus,none); {kind of operation}
size: (directPage,absoluteaddress,longAddress); {size of the operand}
value: longint; {expression value}
procedure Skip;
{ An error was found: skip to the end & quit }
begin {Skip}
charKinds[ord('#')] := ch_pound;
while not (token.kind in [rbracech,eofsy]) do
NextToken;
charKinds[ord('#')] := illegal;
goto 99;
end; {Skip}
procedure Exp (stop: tokenSet; EOLallowed: boolean);
{ Parse an expression in an operand }
{ }
{ Parameters: }
{ stop - stop symbols }
{ EOLallowed - can the expression end with EOL? }
{ }
{ Outputs: }
{ isConstant - constant? (or identifier expression) }
{ operand - operand (if not isConstant) }
{ operation - kind of operation }
{ size - size of the operand }
{ value - expression value }
var
forced: boolean; {is the expression type forced?}
i: 0..maxint; {loop/index variable}
id: identPtr; {identifier}
tcode: intermediate_code; {temp storage for code}
begin {Exp}
if token.kind in [ltch,barch,gtch] {allow for operand size forcing}
then begin
forced := true;
if token.kind = ltch then
size := directPage
else if token.kind = barch then
size := absoluteaddress
else {if token.kind = gtch then}
size := longAddress;
NextToken;
end {if}
else
forced := false;
if EOLallowed then begin {handle expressions that can end at eol}
reportEOL := true;
stop := stop+[eolsy];
end; {if}
if token.kind = ident then begin {handle expressions with an identifier}
if not forced then
size := absoluteaddress;
isConstant := false;
operand := token;
id := FindSymbol(token, variableSpace, false, true);
if id = nil then begin
code^.llab := FindLabel(token.name, false);
if (not forced) and (not smallMemoryModel) then
size := longAddress;
end {if}
else begin
operand.symbolPtr := id;
if id^.storage in [stackFrame,parameter] then begin
code^.slab := id^.lln;
if not forced then
size := directPage;
end {if}
else begin
code^.lab := id^.name;
if id^.itype^.kind = functionType then begin
if id^.itype^.isPascal then begin
code^.lab := pointer(Malloc(length(id^.name^)+1));
CopyString(pointer(code^.lab), pointer(id^.name));
for i := 1 to length(code^.lab^) do
if code^.lab^[i] in ['a'..'z'] then
code^.lab^[i] := chr(ord(code^.lab^[i]) & $5F);
end; {if}
end; {if}
if (not forced) and (not smallMemoryModel) then
size := longAddress;
end; {else}
end; {else}
NextToken;
if token.kind in [plusch,minusch] then begin
if token.kind = plusch then
operation := plus
else
operation := minus;
NextToken;
tcode := code^;
Expression(arrayExpression, stop);
code^ := tcode;
value := expressionValue;
if expressionType^.kind = scalarType then
if expressionType^.baseType <= cgUWord then
value := value & $0000FFFF;
end {if}
else begin
operation := none;
value := 0;
end; {else}
end {if token = ident}
else begin {constant expression}
operation := none;
isConstant := true;
tcode := code^;
Expression(arrayExpression, stop);
code^ := tcode;
value := expressionValue;
if expressionType^.kind = scalarType then
if expressionType^.baseType <= cgUWord then
value := value & $0000FFFF;
if not forced then
if long(value).msw = 0 then begin
if long(value).lsw & $FF00 = 0 then
size := directPage
else
size := absoluteaddress;
end {if}
else
size := longAddress;
end; {else}
reportEOL := false;
if token.kind = eolsy then
NextToken;
end; {Exp}
function RegCompare (str: stringPtr; reg: char): boolean;
{ Compare a string to a register constant }
{ }
{ parameters: }
{ str - string pointer }
{ reg - register character }
begin {RegCompare}
RegCompare := false;
if length(str^) = 1 then
RegCompare := chr(ord(str^[1]) | $20) = reg;
end; {RegCompare}
procedure CheckForComment;
{ Handle an assembly language comment (ignore chars from ; to EOL) }
begin {CheckForComment}
while token.kind = semicolonch do begin
while not (charKinds[ord(ch)] in [ch_eol,ch_eof]) do
NextCh;
NextCh;
NextToken;
end; {if}
end; {CheckForComment}
begin {AsmStatement}
Match(lbracech,27);
while not (token.kind in [rbracech,eofsy]) do begin
{find the label and op-code}
CheckForComment;
charKinds[ord('#')] := ch_pound; {allow # as a token}
if token.kind <> ident then begin {error if not an identifier}
Error(9);
Skip;
end; {if}
opname := token;
NextToken;
while token.kind = colonch do begin {define a label}
lnum := FindLabel(opname.name, true);
NextToken;
CheckForComment;
if token.kind <> ident then
Skip;
opname := token;
NextToken;
end; {while}
charKinds[ord('#')] := illegal; {don't allow # as a token}
{identify the op-code}
if length(opname.name^) = 3 then begin
name := opname.name^;
for i := 1 to 3 do
if name[i] in ['A'..'Z'] then
name[i] := chr(ord(name[i]) | $20);
for opc := o_adc to o_xce do
if names[opc] = name then
goto 1;
end; {if}
Error(95);
Skip;
1: code^.q := 0; {default to no flags}
{handle general operand instructions}
if opc <= o_tsb then begin
optype := op;
if token.kind = lparench then begin
NextToken;
Exp([commach,rparench], false);
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if RegCompare(token.name, 'x') then begin
NextToken;
Match(rparench,12);
if size = directPage then
optype := i_dp_x
else if size = absoluteaddress then
optype := i_op_x
else
Error(96);
end {if}
else if RegCompare(token.name, 's') then begin
NextToken;
Match(rparench,12);
Match(commach,86);
if token.kind = ident then begin
if RegCompare(token.name, 'y') then
NextToken
else
Error(97);
end {if}
else
Error(97);
if size = directPage then
optype := i_dp_s_y
else Error(96);
end {else if}
else
Error(97);
end {if token.kind = ident}
else Error(97);
end {if token.kind = commach}
else if token.kind = rparench then begin
NextToken;
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if RegCompare(token.name, 'y') then
NextToken
else
Error(97);
end {if}
else Error(97);
if size = directPage then
optype := i_dp_y
else Error(96);
end {if}
else begin
if size = directPage then
optype := i_dp
else if size = absoluteaddress then
optype := i_op
else
Error(96);
end; {else}
end {else if token.kind = rparench}
else Error(12);
end {if}
else if token.kind = lbrackch then begin
NextToken;
Exp([commach,rbrackch], false);
Match(rbrackch,24);
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if RegCompare(token.name, 'y') then
NextToken
else
Error(97);
end {if}
else Error(97);
if size = directPage then
optype := li_dp_y
else Error(96);
end {if}
else begin
if size = directPage then
optype := li_dp
else if size = absoluteaddress then
optype := i_la
else
Error(96);
end; {else}
end {else if}
else if token.kind = poundch then begin
optype := imm;
NextToken;
if token.kind = ltch then begin
NextToken;
Exp([semicolonch], true);
end {if}
else if token.kind = gtch then begin
NextToken;
Exp([semicolonch], true);
if isConstant then
value := value >> 8
else
code^.q := shift8;
end {else if}
else if token.kind = carotch then begin
NextToken;
Exp([semicolonch], true);
if isConstant then
value := value >> 16
else
code^.q := shift16;
end {else if}
else
Exp([semicolonch], true);
end {else if}
else begin
if token.kind = ident then
if RegCompare(token.name, 'a') then begin
optype := acc;
NextToken;
goto 2;
end; {if}
Exp([commach,semicolonch], true);
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if RegCompare(token.name, 'x') then begin
NextToken;
if size = directPage then
optype := dp_x
else if size = absoluteaddress then
optype := op_x
else
optype := long_x;
end {if}
else if RegCompare(token.name, 'y') then begin
NextToken;
if size = directPage then
optype := dp_y
else if size = absoluteaddress then
optype := op_y
else
Error(96);
end {else if}
else if RegCompare(token.name, 's') then begin
NextToken;
if size = directPage then
optype := dp_s
else Error(96);
end {else if}
else Error(97);
end {if token.kind = ident}
else Error(97);
end {if}
else begin
if size = directPage then
optype := dp
else if size = absoluteaddress then
optype := op
else
optype := la;
end; {else}
end; {else}
2: {make sure the operand is valid}
if nopcodes[opc,optype] = 0 then begin
if optype = i_dp_x then
optype := i_op_x
else if optype = i_dp then
optype := i_op
else if optype = dp then
optype := op
else if optype = dp_x then
optype := op_x
else if optype = dp_y then
optype := op_y;
if nopcodes[opc,optype] = 0 then
if optype = op then
optype := la;
if nopcodes[opc,optype] = 0 then
Error(98);
end; {if}
code^.s := nopcodes[opc,optype];
if optype = acc then
code^.r := ord(implied)
else if optype = imm then
code^.r := ord(imm)
else if optype in [la,long_x] then
code^.r := ord(longabsolute)
else if optype in [op,op_x,op_y,i_op,i_op_x,i_la] then
code^.r := ord(absolute)
else
code^.r := ord(direct);
end {if opc <= o_tsb}
{handle data declarations}
else if opc <= o_dcl then begin
Exp([semicolonch], true);
code^.s := d_add;
if opc = o_dcb then
code^.r := ord(direct)
else if opc = o_dcw then
code^.r := ord(absolute)
else
code^.r := ord(longabsolute);
end {if opc <= o_dcl}
{handle the brk instruction}
else if opc = o_brk then begin
Exp([semicolonch], true);
code^.r := ord(direct);
code^.s := 0;
end {if opc = o_brk}
{handle the wdm instruction (treated as having a one-byte operand)}
else if opc = o_wdm then begin
Exp([semicolonch], true);
code^.r := ord(direct);
code^.s := $42;
end {if opc = o_wdm}
{handle moves}
else if opc in [o_mvn,o_mvp] then begin
if opc = o_mvn then
code^.s := $54
else
code^.s := $44;
Gen0(pc_nat);
code^.s := d_bmov;
code^.r := ord(immediate);
Exp([commach,semicolonch], false);
if isConstant then begin
code^.opnd := long(value).msw;
code^.q := 0;
end {if}
else begin
code^.opnd := value;
code^.q := shift16;
end; {else}
Gen0(pc_nat);
Match(commach,86);
code^.s := d_bmov;
code^.r := ord(immediate);
Exp([semicolonch], true);
if isConstant then begin
code^.opnd := long(value).msw;
code^.q := 0;
end {if}
else begin
code^.opnd := value;
code^.q := shift16;
end; {else}
goto 3;
end {if opc in [o_mvn,o_mvp]}
{handle relative branches}
else if opc <= o_bvs then begin
code^.s := ropcodes[opc];
if token.kind = ident then begin
code^.llab := FindLabel(token.name, false);
NextToken;
code^.lab := nil;
if opc in [o_brl,o_per] then
code^.r := ord(longrelative)
else
code^.r := ord(relative);
goto 3;
end {if}
else Error(97);
end {else if opc <= o_bvs}
{handle implied operand instructions}
else begin
code^.s := iopcodes[opc];
code^.r := ord(implied);
end;
{generate the code}
if operation = minus then
code^.opnd := -value
else
code^.opnd := value;
3: Gen0(pc_nat);
CheckForComment;
end; {while}
99:
if doingAsmFunction then
useGlobalPool := true;
Match(rbracech,23);
end; {AsmStatement}
procedure InitAsm;
{ Initialize the assembler }
begin {AsmInit}
doingAsmFunction := false;
end; {AsmInit}
end.