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;

    //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
                    writeln ('Error (line ', LP, '): ORG must be the first instruction');
                    halt (1);
                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
    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.