program Assembler;

{$MODE OBJFPC}

uses Sysutils, Strutils;

type
    //Label or reference table entry
    LblRec = record
        Addr: word;
        Lbl: string;
    end;

var
    LP, Count: integer; //Line pointer and generic counter
    Line, DatOrg: string; //Line of assembly and data or org element
    Elem: array [0 .. 4] of string; //Parsed elements
    Lbl, Ref: array [0 .. $ffff] of LblRec; //Label and reference tables
    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

//Print an argument error and abort
procedure ArgError;
begin
    writeln ('Error (line ', LP, '): incorrect argument(s)');
    halt;
end;

//Print a memory error and abort if the assembler is about to write beyond available memory
procedure MemError;
begin
    if (BP + 2) >= $fff0 then begin
        writeln ('Error (line ', LP, '): out of memory');
        halt;
    end;
end;

//Assemble a first or only argument that is a register
procedure FirstArgReg;
begin
    if CompareText (Elem [2], 'R0') = 0 then Bin [BP] := Bin [BP] + 0
    else if CompareText (Elem [2], 'R1') = 0 then Bin [BP] := Bin [BP] + 4
    else if CompareText (Elem [2], 'R2') = 0 then Bin [BP] := Bin [BP] + 8
    else if CompareText (Elem [2], 'R3') = 0 then Bin [BP] := Bin [BP] + $c
    else ArgError;
end;

//Assemble two register arguments
procedure TwoArgRegs;
begin
    //First argument
    FirstArgReg;
    //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;

begin

    //Check for an set up a program file
    if ParamCount <> 1 then begin
        writeln ('Usage: assembler program (< input)');
        halt;
    end;

    //Initialise the byte and start pointers
    LP := 1;
    BP := 0;
    SP := 0;

    //Begin the main loop
    repeat

        //Read a line
        readln (Line);

        //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 (Trim (ExtractWord (1, Line, [' ', '	'])), 1) = ':' then begin
                //Find the first empty slot in the label table
                Count := 0;
                while Lbl [Count] .Lbl <> '' do Count := Count + 1;
                //Extract the label
                Lbl [Count] .Addr := BP;
                Elem [0] := Trim (ExtractDelimited (1, Line, [':']));
                Lbl [Count] .Lbl := Elem [0];
                Line := Trim (ExtractDelimited (2, Line, [':']));
                //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
                        Bin [Ref [Count] .Addr] := BP shr 8;
                        Bin [Ref [Count] .Addr + 1] := BP and $00ff;
                        Count := Count + 1;
                    end;
                until Ref [Count] .Lbl = '';
            end;

            //Check for the org pseudo-instruction
            if CompareText (Trim (ExtractWord (1, Line, [' ', '	'])), 'ORG') = 0 then begin
                if BP = 0 then begin
                    if Elem [0] = '' then begin
                        //Set the starting point
                        if Trim (ExtractWord (3, Line, [' ', '	'])) <> '' then ArgError;
                        DatOrg := Trim (ExtractWord (2, Line, [' ', '	']));
                        try
                            if Hex2Dec (DatOrg) <=$ffff then begin
                                BP := Hex2Dec (DatOrg);
                                SP := BP;
                            end
                            else ArgError;
                        except
                            ArgError;
                        end;
                    end
                    else begin
                        writeln ('Error (line ', LP, '): ORG cannot have a label');
                        halt;
                    end;
                end
                else begin
                    writeln ('Error (line ', LP, '): ORG must be the first instruction');
                    halt;
                end;
            end

            //Check for the data pseudo-instruction
            else if CompareText (Trim (ExtractWord (1, Line, [' ', '	'])), 'DATA') = 0 then begin
                //Extract and store the data
                if Trim (ExtractWord (3, Line, [' ', '	'])) <> '' then ArgError;
                DatOrg := Trim (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 an instruction
            else if Line <> '' then begin

                //Parse the instruction
                //Extract the opcode
                Elem [1] := Trim (ExtractWord (1, Line, [' ', '	']));
                //Extract the arguments
                Elem [2] := Trim (ExtractWord (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;
                end;

                //Check for incorrect number of arguments
                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] <= $50 then begin
                    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 FirstArgReg;
                //Logical operations
                if Bin [BP] >= $60 then if Bin [BP] <= $90 then TwoArgRegs;
                //Load
                if Bin [BP] = $a0 then begin
                    //First argument
                    FirstArgReg;
                    //Second argument
                    try
                        //Address
                        if Hex2Dec (Elem [3]) <= $ffff then Addr := Hex2Dec (Elem [3])
                        else ArgError;
                    except
                        //Label reference
                        //Backwards
                        Count := 0;
                        while CompareText (Elem [3], 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;
                            //Extract the reference
                            Ref [Count] .Addr := BP + 1;
                            Ref [Count] .Lbl := Elem [3];
                            //Placeholder
                            Addr := 0;
                        end;
                    end;
                    MemError;
                    Bin [BP + 1] := Addr shr 8;
                    Bin [BP + 2] := Addr and $00ff;
                end;
                //Store
                if Bin [BP] = $b0 then begin
                    //First argument
                    try
                        //Address
                        if Hex2Dec (Elem [2]) <= $ffff then Addr := Hex2Dec (Elem [2])
                        else ArgError;
                    except
                        //Label reference
                        //Backwards
                        Count := 0;
                        while CompareText (Elem [2], 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;
                            //Extract the reference
                            Ref [Count] .Addr := BP + 1;
                            Ref [Count] .Lbl := Elem [2];
                            //Placeholder
                            Addr := 0;
                        end;
                    end;
                    MemError;
                    Bin [BP + 1] := Addr shr 8;
                    Bin [BP + 2] := Addr and $00ff;
                    //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] + 4
                    else if CompareText (Elem [3], 'R2') = 0 then Bin [BP] := Bin [BP] + 8
                    else if CompareText (Elem [3], 'R3') = 0 then Bin [BP] := Bin [BP] + $c
                    else ArgError;
                end;
                //Branches and calls
                if Bin [BP] >= $c0 then begin
                    //First and second arguments
                    TwoArgRegs;
                    //Third argument
                    try
                        //Address
                        if Hex2Dec (Elem [4]) <= $ffff then Addr := Hex2Dec (Elem [4])
                        else ArgError;
                    except
                        //Label reference
                        //Backwards
                        Count := 0;
                        while CompareText (Elem [4], 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;
                            //Extract the reference
                            Ref [Count] .Addr := BP + 1;
                            Ref [Count] .Lbl := Elem [4];
                            //Placeholder
                            Addr := 0;
                        end;
                    end;
                    MemError;
                    Bin [BP + 1] := Addr shr 8;
                    Bin [BP + 2] := Addr and $00ff;
                end;

                //Increment the byte pointer
                if Bin [BP] >= $a0 then BP := BP + 3
                else BP := BP + 1;

            end;

        end;

        //Increment the line pointer
        LP := LP + 1;

        //A hack for fixing an unexplained extra readln after the loop that does nothing
        if BP = $fff0 then break;

    until eof ();

    //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;
    end;
    repeat
        write (Prog, Bin [BP]);
        BP := BP + 1;
    until BP = EP;

end.