mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-12-10 19:51:47 +00:00
99a10590b1
The branch range calculation treated dcl directives as taking 2 bytes rather than 4, which could result in out-of-range branches. These could result in linker errors (for forward branches) or silently generating wrong code (for backward branches).
This patch now treats dcb, dcw, and dcl as separate directives in the native-code layer, so the appropriate length can be calculated for each.
Here is an example of code affected by this:
int main(int argc, char **argv) {
top:
if (!argc) { /* this caused a linker error */
asm {
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
dcl 0
}
goto top; /* this generated bad code with no error */
}
}
680 lines
21 KiB
ObjectPascal
680 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);
|
|
if opc = o_dcb then begin
|
|
code^.s := d_dcb;
|
|
code^.r := ord(direct);
|
|
end {if}
|
|
else if opc = o_dcw then begin
|
|
code^.s := d_dcw;
|
|
code^.r := ord(absolute);
|
|
end {else if}
|
|
else begin
|
|
code^.s := d_dcl;
|
|
code^.r := ord(longabsolute);
|
|
end; {else}
|
|
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.
|