458 lines
17 KiB
Plaintext
458 lines
17 KiB
Plaintext
program Assembler;
|
|
|
|
{$MODE OBJFPC}
|
|
|
|
uses Sysutils, Strutils;
|
|
|
|
type
|
|
//Label or reference table entry
|
|
LblRec = record
|
|
Addr: word;
|
|
Lbl: ansistring;
|
|
Line: integer;
|
|
Offset: integer;
|
|
Resolved: boolean;
|
|
end;
|
|
|
|
var
|
|
LP, Count, Offset: integer; //Line pointer, generic counter, and relative offset
|
|
Line, DatOrg: ansistring; //Line of assembly and data or org element
|
|
Elem: array [0 .. 4] of ansistring; //Parsed elements
|
|
Lbl, Ref: array [0 .. $ffff] of LblRec; //Label and reference tables
|
|
AllRefsResolved: boolean; //Whether there are any references to nonexistent labels
|
|
Addr, BP, SP, EP: word; //Address argument and byte, start, and end pointers
|
|
Bin: array [0 .. $ffef] of byte; //Assembled binary
|
|
Prog: file of byte; //Program file
|
|
|
|
//Check if a string is numeric
|
|
function IsNumeric (S: string): boolean;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 1 to length (S) do
|
|
if not (S [I] in ['a' .. 'f', 'A' .. 'F', '0' .. '9']) then exit (false);
|
|
exit (true);
|
|
end;
|
|
|
|
//Check if a string is alphanumeric
|
|
function IsAlphaNum (S: string): boolean;
|
|
var
|
|
I: integer;
|
|
begin
|
|
for I := 1 to length (S) do
|
|
if not (S [I] in ['a' .. 'z', 'A' .. 'Z', '0' .. '9']) then exit (false);
|
|
exit (true);
|
|
end;
|
|
|
|
//Print a label error and abort
|
|
procedure LblError;
|
|
begin
|
|
writeln ('Error (line ', LP, '): illegal label');
|
|
halt (1);
|
|
end;
|
|
|
|
//Print a reference error and abort
|
|
procedure RefError;
|
|
begin
|
|
writeln ('Error (line ', LP, '): illegal reference(s) relative to this line');
|
|
halt (1);
|
|
end;
|
|
|
|
//Print an argument error and abort
|
|
procedure ArgError;
|
|
begin
|
|
writeln ('Error (line ', LP, '): illegal argument(s)');
|
|
halt (1);
|
|
end;
|
|
|
|
//Print a memory error and abort if the assembler is about to write beyond available memory
|
|
procedure MemError;
|
|
begin
|
|
writeln ('Error (line ', LP, '): memory overflow');
|
|
halt (1);
|
|
end;
|
|
|
|
//Assemble a single register argument
|
|
procedure OneArgReg (I: integer);
|
|
begin
|
|
if CompareText (Elem [I], 'R0') = 0 then Bin [BP] := Bin [BP] + 0
|
|
else if CompareText (Elem [I], 'R1') = 0 then Bin [BP] := Bin [BP] + 4
|
|
else if CompareText (Elem [I], 'R2') = 0 then Bin [BP] := Bin [BP] + 8
|
|
else if CompareText (Elem [I], 'R3') = 0 then Bin [BP] := Bin [BP] + $c
|
|
else ArgError;
|
|
end;
|
|
|
|
//Assemble two register arguments
|
|
procedure TwoArgRegs;
|
|
begin
|
|
//First argument
|
|
OneArgReg (2);
|
|
//Second argument
|
|
if CompareText (Elem [3], 'R0') = 0 then Bin [BP] := Bin [BP] + 0
|
|
else if CompareText (Elem [3], 'R1') = 0 then Bin [BP] := Bin [BP] + 1
|
|
else if CompareText (Elem [3], 'R2') = 0 then Bin [BP] := Bin [BP] + 2
|
|
else if CompareText (Elem [3], 'R3') = 0 then Bin [BP] := Bin [BP] + 3
|
|
else ArgError;
|
|
end;
|
|
|
|
//Assemble an address argument
|
|
procedure AddrArg (I, A: integer);
|
|
begin
|
|
Offset := 0;
|
|
try
|
|
//Address
|
|
if Hex2Dec (Elem [I]) <= $ffff then Addr := Hex2Dec (Elem [I])
|
|
else ArgError;
|
|
except
|
|
//Label reference
|
|
//Check if the reference is relative
|
|
if Trim (ExtractDelimited (2, Elem [I], ['+', '-'])) <> '' then begin
|
|
//Check for more than one offset
|
|
if Trim (ExtractDelimited (3, Elem [I], ['+', '-'])) <> '' then ArgError;
|
|
//Extract the offset
|
|
try
|
|
if Hex2Dec (Trim (ExtractDelimited (2, Elem [I], ['+', '-']))) <= $ffff
|
|
then Offset := Hex2Dec (Trim (ExtractDelimited (2, Elem [I], ['+', '-'])))
|
|
else ArgError;
|
|
except
|
|
ArgError;
|
|
end;
|
|
if Trim (ExtractDelimited (2, Elem [I], ['-'])) <> '' then Offset := -Offset;
|
|
Elem [I] := Trim (ExtractDelimited (1, Elem [I], ['+', '-']));
|
|
end;
|
|
//Check if the reference is numeric
|
|
if IsNumeric (Elem [I]) = true then ArgError;
|
|
//Check if the reference is alphanumeric
|
|
if IsAlphaNum (Elem [I]) = false then ArgError;
|
|
//Backwards
|
|
Count := 0;
|
|
while CompareText (Elem [I], Lbl [Count] .Lbl) <> 0 do begin
|
|
if Lbl [Count] .Lbl = '' then break;
|
|
Count := Count + 1;
|
|
end;
|
|
if Lbl [Count] .Lbl <> '' then Addr := Lbl [Count] .Addr
|
|
//Forwards
|
|
else begin
|
|
//Find the first empty slot in the reference table
|
|
Count := 0;
|
|
while Ref [Count] .Lbl <> '' do Count := Count + 1;
|
|
//Store the reference in the table
|
|
Ref [Count] .Addr := BP + A;
|
|
Ref [Count] .Lbl := Elem [I];
|
|
Ref [Count] .Line := LP;
|
|
Ref [Count] .Offset := Offset;
|
|
Ref [Count] .Resolved := false;
|
|
//Placeholder
|
|
Addr := 0;
|
|
Offset := 0;
|
|
end;
|
|
end;
|
|
if (BP + 1 + A) >= $fff0 then MemError;
|
|
//Add the offset
|
|
if Addr + Offset >= 0 then begin
|
|
if Addr + Offset <= $ffff then Addr := Addr + Offset
|
|
else ArgError;
|
|
end
|
|
else ArgError;
|
|
Bin [BP + A] := Addr shr 8;
|
|
Bin [BP + 1 + A] := Addr and $00ff;
|
|
end;
|
|
|
|
begin
|
|
|
|
//Check for and set up a program file
|
|
if ParamCount <> 1 then begin
|
|
writeln ('Usage: assembler program (< input)');
|
|
halt (1);
|
|
end;
|
|
|
|
//Initialise the byte and start pointers
|
|
LP := 1;
|
|
BP := 0;
|
|
SP := 0;
|
|
EP := 0;
|
|
|
|
//Begin the main loop
|
|
repeat
|
|
|
|
//Read a line
|
|
readln (Line);
|
|
|
|
//A hack for fixing an unexplained extra readln after the loop that does nothing
|
|
if BP = $fff0 then MemError;
|
|
|
|
//Convert tabs to spaces
|
|
Line := Tab2Space (Line, 1);
|
|
|
|
//Remove the comment if any
|
|
Line := Trim (ExtractDelimited (1, Line, [';']));
|
|
|
|
//Check for an empty line
|
|
if Line <> '' then begin
|
|
|
|
//(Re-)initialise the elements
|
|
Elem [0] := '';
|
|
Elem [1] := '';
|
|
Elem [2] := '';
|
|
Elem [3] := '';
|
|
Elem [4] := '';
|
|
|
|
//Check if the first element is a label
|
|
if RightStr (ExtractWord (1, Line, [' ']), 1) = ':' then begin
|
|
//Extract the label
|
|
Elem [0] := Trim (ExtractDelimited (1, Line, [':']));
|
|
Line := Trim (ExtractDelimited (2, Line, [':']));
|
|
//Check if the label is hexadecimal
|
|
try
|
|
Count := Hex2Dec (Elem [0]);
|
|
LblError;
|
|
except
|
|
//Check if the label is alphanumeric
|
|
if IsAlphaNum (Elem [0]) = false then LblError;
|
|
//Find the first empty slot in the label table
|
|
Count := 0;
|
|
while Lbl [Count] .Lbl <> '' do Count := Count + 1;
|
|
//Store the label in the table
|
|
Lbl [Count] .Addr := BP;
|
|
Lbl [Count] .Lbl := Elem [0];
|
|
//Check for forward references
|
|
Count := 0;
|
|
repeat
|
|
while CompareText (Elem [0], Ref [Count] .Lbl) <> 0 do begin
|
|
if Ref [Count] .Lbl = '' then break;
|
|
Count := Count + 1;
|
|
end;
|
|
if Ref [Count] .Lbl <> '' then begin
|
|
//Add the offset and store the address
|
|
if BP + Ref [Count] .Offset >= 0 then begin
|
|
if BP + Ref [Count] .Offset <= $ffff then begin
|
|
Bin [Ref [Count] .Addr] := (BP + Ref [Count] .Offset) shr 8;
|
|
Bin [Ref [Count] .Addr + 1] := (BP + Ref [Count] .Offset) and $00ff;
|
|
Ref [Count] .Resolved := true;
|
|
end
|
|
else RefError;
|
|
end
|
|
else RefError;
|
|
Count := Count + 1;
|
|
end;
|
|
until Ref [Count] .Lbl = '';
|
|
end;
|
|
end;
|
|
|
|
//Check for the org pseudo-instruction
|
|
if CompareText (ExtractWord (1, Line, [' ']), 'ORG') = 0 then begin
|
|
if BP = 0 then begin
|
|
if Elem [0] = '' then begin
|
|
//Set the starting point
|
|
if ExtractWord (3, Line, [' ']) <> '' then ArgError;
|
|
DatOrg := ExtractWord (2, Line, [' ']);
|
|
try
|
|
if Hex2Dec (DatOrg) <=$ffff then begin
|
|
BP := Hex2Dec (DatOrg);
|
|
SP := BP;
|
|
end
|
|
else ArgError;
|
|
except
|
|
ArgError;
|
|
end;
|
|
end
|
|
else LblError;
|
|
end
|
|
else begin
|
|
if Elem [0] = '' then begin
|
|
//Set the starting point
|
|
if ExtractWord (3, Line, [' ']) <> '' then ArgError;
|
|
DatOrg := ExtractWord (2, Line, [' ']);
|
|
try
|
|
if Hex2Dec (DatOrg) <=$ffff then begin
|
|
if BP > EP then EP := BP;
|
|
BP := Hex2Dec (DatOrg);
|
|
if BP < SP then SP := BP;
|
|
end
|
|
else ArgError;
|
|
except
|
|
ArgError;
|
|
end;
|
|
end
|
|
else LblError;
|
|
end;
|
|
end
|
|
|
|
//Check for the data pseudo-instruction
|
|
else if CompareText (ExtractWord (1, Line, [' ']), 'DATA') = 0 then begin
|
|
//Extract and store the data
|
|
if ExtractWord (3, Line, [' ']) <> '' then ArgError;
|
|
DatOrg := ExtractWord (2, Line, [' ']);
|
|
try
|
|
if Hex2Dec (DatOrg) <=$ff then Bin [BP] := Hex2Dec (DatOrg)
|
|
else ArgError;
|
|
except
|
|
ArgError;
|
|
end;
|
|
//Increment the byte pointer
|
|
BP := BP + 1;
|
|
end
|
|
|
|
//Check for the addr pseudo-instruction
|
|
else if CompareText (ExtractWord (1, Line, [' ']), 'ADDR') = 0 then begin
|
|
//Extract the reference
|
|
Elem [1] := Copy2SpaceDel (Line);
|
|
Elem [2] := Trim (Line);
|
|
//Check if the reference is numeric
|
|
if IsNumeric (Elem [2]) = true then ArgError;
|
|
//Extract and store the address
|
|
AddrArg (2, 0);
|
|
//Increment the byte pointer
|
|
BP := BP + 2;
|
|
end
|
|
|
|
//Check for an instruction
|
|
else if Line <> '' then begin
|
|
|
|
//Parse the instruction
|
|
//Extract the opcode
|
|
Elem [1] := Copy2SpaceDel (Line);
|
|
//Extract the arguments
|
|
Elem [2] := Trim (ExtractDelimited (1, Line, [',']));
|
|
Elem [3] := Trim (ExtractDelimited (2, Line, [',']));
|
|
Elem [4] := Trim (ExtractDelimited (3, Line, [',']));
|
|
|
|
//Assemble the opcode
|
|
if CompareText (Elem [1], 'HALT') = 0 then Bin [BP] := 0
|
|
else if CompareText (Elem [1], 'RET') = 0 then Bin [BP] := $10
|
|
else if CompareText (Elem [1], 'SHL') = 0 then Bin [BP] := $20
|
|
else if CompareText (Elem [1], 'SHR') = 0 then Bin [BP] := $30
|
|
else if CompareText (Elem [1], 'ROL') = 0 then Bin [BP] := $40
|
|
else if CompareText (Elem [1], 'ROR') = 0 then Bin [BP] := $50
|
|
else if CompareText (Elem [1], 'NAND') = 0 then Bin [BP] := $60
|
|
else if CompareText (Elem [1], 'AND') = 0 then Bin [BP] := $70
|
|
else if CompareText (Elem [1], 'OR') = 0 then Bin [BP] := $80
|
|
else if CompareText (Elem [1], 'XOR') = 0 then Bin [BP] := $90
|
|
else if CompareText (Elem [1], 'LOAD') = 0 then Bin [BP] := $a0
|
|
else if CompareText (Elem [1], 'STORE') = 0 then Bin [BP] := $b0
|
|
else if CompareText (Elem [1], 'BREQ') = 0 then Bin [BP] := $c0
|
|
else if CompareText (Elem [1], 'BRNEQ') = 0 then Bin [BP] := $d0
|
|
else if CompareText (Elem [1], 'CLEQ') = 0 then Bin [BP] := $e0
|
|
else if CompareText (Elem [1], 'CLNEQ') = 0 then Bin [BP] := $f0
|
|
else begin
|
|
writeln ('Error (line ', LP, '): no such instruction');
|
|
halt (1);
|
|
end;
|
|
|
|
//Check for incorrect number of arguments
|
|
if Trim (ExtractDelimited (4, Line, [','])) <> '' then ArgError
|
|
else if Bin [BP] <= $10 then begin
|
|
if Elem [2] <> '' then ArgError
|
|
else if Elem [3] <> '' then ArgError
|
|
else if Elem [4] <> '' then ArgError;
|
|
end
|
|
else if Bin [BP] <= $b0 then begin
|
|
if Elem [4] <> '' then ArgError;
|
|
end;
|
|
|
|
//Assemble the arguments
|
|
//Shifts
|
|
if Bin [BP] >= $20 then if Bin [BP] <= $50 then begin
|
|
//First argument
|
|
OneArgReg (2);
|
|
//Second argument
|
|
if CompareText (Elem [3], '1') = 0 then Bin [BP] := Bin [BP] + 1
|
|
else if CompareText (Elem [3], '2') = 0 then Bin [BP] := Bin [BP] + 2
|
|
else if CompareText (Elem [3], '3') = 0 then Bin [BP] := Bin [BP] + 3
|
|
else if CompareText (Elem [3], '4') = 0 then Bin [BP] := Bin [BP] + 0
|
|
else ArgError;
|
|
end;
|
|
//Logical operations
|
|
if Bin [BP] >= $60 then if Bin [BP] <= $90 then TwoArgRegs;
|
|
//Load
|
|
if Bin [BP] = $a0 then begin
|
|
//First argument
|
|
OneArgReg (2);
|
|
//Second argument
|
|
//Immediate
|
|
if LeftStr (Elem [3], 1) = '#' then begin
|
|
Elem [3] := TrimLeftSet (Elem [3], ['#']);
|
|
if (BP + 1) >= $fff0 then MemError;
|
|
try
|
|
if Hex2Dec (Elem [3]) <= $ff then begin
|
|
Bin [BP] := Bin [BP] + 3;
|
|
Bin [BP + 1] := Hex2Dec (Elem [3]);
|
|
end
|
|
else ArgError;
|
|
except
|
|
ArgError;
|
|
end;
|
|
end
|
|
//Address
|
|
else AddrArg (3, 1);
|
|
end;
|
|
//Store
|
|
if Bin [BP] = $b0 then begin
|
|
//First argument
|
|
AddrArg (2, 1);
|
|
//Second argument
|
|
if CompareText (Elem [3], 'R0') = 0 then Bin [BP] := Bin [BP] + 0
|
|
else if CompareText (Elem [3], 'R1') = 0 then Bin [BP] := Bin [BP] + 1
|
|
else if CompareText (Elem [3], 'R2') = 0 then Bin [BP] := Bin [BP] + 2
|
|
else if CompareText (Elem [3], 'R3') = 0 then Bin [BP] := Bin [BP] + 3
|
|
else ArgError;
|
|
end;
|
|
//Branches and calls
|
|
if Bin [BP] >= $c0 then begin
|
|
//First and second arguments
|
|
TwoArgRegs;
|
|
//Third argument
|
|
AddrArg (4, 1);
|
|
end;
|
|
|
|
//Increment the byte pointer
|
|
if Bin [BP] >= $a0 then begin
|
|
if Bin [BP] <= $af then begin
|
|
if (Bin [BP] and 3) <> 0 then BP := BP + 2
|
|
else BP := BP + 3;
|
|
end
|
|
else BP := BP + 3;
|
|
end
|
|
else BP := BP + 1;
|
|
|
|
end;
|
|
|
|
end;
|
|
|
|
//Increment the line pointer
|
|
LP := LP + 1;
|
|
|
|
until eof ();
|
|
|
|
//Check that all references to labels were properly resolved
|
|
AllRefsResolved := true;
|
|
Count := 0;
|
|
while Ref [Count] .Lbl <> '' do begin
|
|
if Ref [Count] .Resolved = false then begin
|
|
writeln ('Error (line ', Ref [Count] .Line, '): label not found: ', Ref [Count] .Lbl);
|
|
AllRefsResolved := false;
|
|
end;
|
|
Count := Count + 1;
|
|
end;
|
|
if AllRefsResolved = false then halt (1);
|
|
|
|
//Set the end pointer and reset the byte pointer to the start of the program
|
|
if BP > EP then EP := BP;
|
|
BP := SP;
|
|
|
|
//Write the program file
|
|
{$i-}
|
|
assign (Prog, ParamStr (1));
|
|
rewrite (Prog);
|
|
{$i+}
|
|
if IOResult <> 0 then begin
|
|
writeln ('Error: program file cannot be written to');
|
|
halt (1);
|
|
end;
|
|
repeat
|
|
write (Prog, Bin [BP]);
|
|
BP := BP + 1;
|
|
until BP = EP;
|
|
|
|
end.
|