program Emulator;

{$MODE OBJFPC}

uses SysUtils, Crt;

{$ifdef tape}
type
    //Tape file path and reset state
    Tape = record
        Path: shortstring;
        Reset: boolean;
        Pos: integer;
    end;
{$endif}

const
    IO = $ffff;

var
    Hlt, ASCII: boolean; //Halt and ASCII flags
    Op: 0 .. $f; //Opcode
    X, Y: 0 .. 3; //Register arguments
    Addr, IP, RP: word; //Address argument and instruction and return pointers
    R: array [0 .. 3] of byte; //General-purpose registers
    Mem: array [0 .. $ffef] of byte; //Memory
    Prog{$ifdef printer}, Prn{$endif}{$ifdef tape}, TapeIn, TapeOut{$endif}: file of byte; //Program file, line printer, and tape reader and punch tapes
    {$ifdef tape}
    Reader, Punch: Tape; //States of the tape reader and punch
    State: file of Tape; //File storing the states of the tape reader and punch
    {$endif}
    Ch, Scan: ansichar; //Character for input and output and scancode for non-ASCII keys

//Terminal output
procedure Output;
begin
    //Do not output most of the control codes
    if Ch <= ansichar ($1f) then begin
        if Ch = ansichar (7) then write (Ch) //Bell
        else if Ch = ansichar (8) then write (Ch) //Backspace
        else if Ch = ansichar ($a) then write (Ch) //Line feed
        else if Ch = ansichar ($d) then write (Ch) //Carriage return
        else write (''); //Others
    end
    else if Ch = ansichar ($7f) then write ('') //Delete
    //Output all regular characters
    else write (Ch);
end;

begin

    //Initialise the halt flag and the pointers
    Hlt := false;
    IP := 0;
    RP := $fff0;

    //Initialise the tape reader and punch
    {$ifdef tape}
    Reader.Path := '';
    Reader.Reset := true;
    Reader.Pos := 0;
    Punch.Path := '';
    Punch.Reset := true;
    Punch.Pos := 0;
    {$endif}

    //Read a program file and check for errors
    if ParamCount <> 1 then begin
        writeln ('Usage: emulator program');
        halt;
    end;
    {$i-}
    assign (Prog, ParamStr (1));
    reset (Prog);
    {$i+}
    if IOResult <> 0 then begin
        writeln ('Error: program file cannot be read from');
        halt;
    end;
    repeat
        read (Prog, Mem [IP]);
        IP := IP + 1;
    until (eof (Prog)) or (IP = $fff0);
    if IP = $fff0 then begin
        writeln ('Error: memory overflow');
        halt;
    end;

    //Reinitialise the instruction pointer
    IP := 0;

    //Begin the main loop
    while Hlt = false do begin

        //Fetch the instruction and increment the instruction pointer
        //Opcode
        Op := Mem [IP] and $f0 shr 4;
        //Register arguments
        X := Mem [IP] and $c shr 2;
        Y := Mem [IP] and 3;
        IP := IP + 1;
        if IP > $ffef then begin
            writeln ('Error: illegal instruction pointer value');
            halt;
        end;
        //Address argument
        if Op >= $a then begin
            //High byte
            Addr := Mem [IP];
            Addr := Addr shl 8;
            IP := IP + 1;
            if IP > $ffef then begin
                writeln ('Error: illegal instruction pointer value');
                halt;
            end;
            //Low byte
            Addr := Addr + Mem [IP];
            IP := IP + 1;
            if IP > $ffef then begin
                writeln ('Error: illegal instruction pointer value');
                halt;
            end;
        end;

        //Decode and execute the instruction
        //Halt
        if Op = 0 then Hlt := true
        //Ret
        else if Op = 1 then begin
            //High byte of the return address
            IP := Mem [RP];
            IP := IP shl 8;
            RP := RP + 1;
            if RP > $fff0 then begin
                writeln ('Error: illegal return pointer value');
                halt;
            end;
            //Low byte of the return address
            IP := IP + Mem [RP];
            RP := RP + 1;
            if RP > $fff0 then begin
                writeln ('Error: illegal return pointer value');
                halt;
            end;
        end
        //Shl
        else if Op = 2 then R [X] := R [X] shl 1
        //Shr
        else if Op = 3 then R [X] := R [X] shr 1
        //Rol
        else if Op = 4 then R [X] := RolByte (R [X])
        //Ror
        else if Op = 5 then R [X] := RorByte (R [X])
        //Nand
        else if Op = 6 then R [X] := not (R [X] and R [Y])
        //And
        else if Op = 7 then R [X] := R [X] and R [Y]
        //Or
        else if Op = 8 then R [X] := R [X] or R [Y]
        //Xor
        else if Op = 9 then R [X] := R [X] xor R [Y]
        //Load
        else if Op = $a then begin
            //Terminal input
            if Addr = IO then begin
                //Read a keypress
                repeat
                Ch := ReadKey;
                    //Check for non-ASCII keys
                    if Ch = ansichar (0) then begin
                        //Non-ASCII
                        if keypressed then begin
                            Scan := ReadKey;
                            //The delete key inserts the delete character
                            if Scan = ansichar ($53) then begin
                                Ch := ansichar ($7f);
                                ASCII := true;
                            end
                            //Unused function keys insert a null
                            else ASCII := true;
                        end
                        //Null
                        else ASCII := true;
                    end
                    //Other ASCII
                    else ASCII := true;
                until ASCII = true;
                //Bodge for the home and end keys
                if Ch = ansichar ($37) then begin
                    if keypressed then begin
                        Scan := ReadKey;
                        Scan := ReadKey;
                        Scan := ReadKey;
                        Ch := ansichar (0);
                    end;
                end
                else if Ch = ansichar ($38) then begin
                    if keypressed then begin
                        Scan := ReadKey;
                        Scan := ReadKey;
                        Scan := ReadKey;
                        Ch := ansichar (0);
                    end;
                end;
                //Process the keypress
                Output; //Local echo
                R [X] := byte (Ch);
            end
            //Tape reader
            {$ifdef tape}
            else if Addr = $fffd then begin
                assign (State, ExpandFileName ('~/.tapes.thingamajig'));
                //Check the reader state
                if FileExists (ExpandFileName ('~/.tapes.thingamajig')) then begin
                    try
                        reset (State);
                        read (State, Reader);
                        read (State, Punch);
                        close (State);
                    except
                    end;
                end;
                //Read
                assign (TapeIn, Reader.Path);
                try
                    reset (TapeIn);
                    seek (TapeIn, Reader.Pos);
                    read (TapeIn, R [X]);
                    close (TapeIn);
                    Reader.Pos := Reader.Pos + 1;
                except
                    R [X] := $ff;
                end;
                //Save the reader state
                if FileExists (ExpandFileName ('~/.tapes.thingamajig')) then begin
                    try
                        rewrite (State);
                        write (State, Reader);
                        write (State, Punch);
                        close (State);
                    except
                    end;
                end;
            end
            {$endif}
            //Regular load
            else R [X] := Mem [Addr];
        end
        //Store
        else if Op = $b then begin
            //Terminal output
            if Addr = IO then begin
                Ch := ansichar (R [X]);
                Output;
            end
            //Printer
            {$ifdef printer}
            else if Addr = $fffe then begin
                assign (Prn, '/dev/usb/lp0');
                try
                    rewrite (Prn);
                    write (Prn, R [X]);
                    close (Prn);
                except
                end;
            end
            {$endif}
            //Tape punch
            {$ifdef tape}
            else if Addr = $fffd then begin
                assign (State, ExpandFileName ('~/.tapes.thingamajig'));
                //Check the punch state
                if FileExists (ExpandFileName ('~/.tapes.thingamajig')) then begin
                    try
                        reset (State);
                        read (State, Reader);
                        read (State, Punch);
                        close (State);
                    except
                    end;
                end;
                //Punch
                if Punch.Path <> '' then begin
                    assign (TapeOut, Punch.Path);
                    if FileExists (Punch.Path) = false then begin
                        try
                            rewrite (TapeOut);
                            write (TapeOut, R [X]);
                            close (TapeOut);
                            Punch.Reset := false;
                        except
                        end;
                    end
                    else if Punch.Reset then begin
                        try
                            rewrite (TapeOut);
                            write (TapeOut, R [X]);
                            close (TapeOut);
                            Punch.Reset := false;
                        except
                        end;
                    end
                    else begin
                        try
                            reset (TapeOut);
                            seek (TapeOut, FileSize (TapeOut));
                            write (TapeOut, R [X]);
                            close (TapeOut);
                        except
                        end;
                    end;
                end;
                //Save the punch state
                if FileExists (ExpandFileName ('~/.tapes.thingamajig')) then begin
                    try
                        rewrite (State);
                        write (State, Reader);
                        write (State, Punch);
                        close (State);
                    except
                    end;
                end;
            end
            {$endif}

            //Regular store
            else Mem [Addr] := R [X];
        end
        //Breq
        else if Op = $c then begin
            if R [X] = R [Y] then IP := Addr;
        end
        //Brneq
        else if Op = $d then begin
            if R [X] <> R [Y] then IP := Addr;
        end
        //Cleq
        else if Op = $e then begin
            if R [X] = R [Y] then begin
                //Low byte of the return address
                RP := RP - 1;
                if RP > $fff0 then begin
                    writeln ('Error: illegal return pointer value');
                    halt;
                end;
                Mem [RP] := IP and $ff;
                //High byte of the return address
                RP := RP - 1;
                if RP > $fff0 then begin
                    writeln ('Error: illegal return pointer value');
                    halt;
                end;
                Mem [RP] := IP shr 8;
                //Call
                IP := Addr;
                if IP > $ffef then begin
                    writeln ('Error: illegal instruction pointer value');
                    halt;
                end;
            end;
        end
        //Clneq
        else if Op = $f then begin
            if R [X] <> R [Y] then begin
                //Low byte of the return address
                RP := RP - 1;
                if RP > $fff0 then begin
                    writeln ('Error: illegal return pointer value');
                    halt;
                end;
                Mem [RP] := IP and $ff;
                //High byte of the return address
                RP := RP - 1;
                if RP > $fff0 then begin
                    writeln ('Error: illegal return pointer value');
                    halt;
                end;
                Mem [RP] := IP shr 8;
                //Call
                IP := Addr;
                if IP > $ffef then begin
                    writeln ('Error: illegal instruction pointer value');
                    halt;
                end;
            end;
        end;

    end;

end.