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
    //The last address of RAM
    {$if defined(RAM4)}
    LastRAM = $fff; //4 KiB
    {$elseif defined(RAM8)}
    LastRAM = $1fff; //8 KiB
    {$elseif defined(RAM16)}
    LastRAM = $3fff; //16 KiB
    {$elseif defined(RAM32)}
    LastRAM = $7fff; //32 KiB
    {$elseif defined(RAM64)}
    LastRAM = $ffef; //64 KiB
    {$else}
    LastRAM = $7ff; //2 KiB (default)
    {$endif}

var
    Hlt, Verbose, Echo: boolean; //Halt, verbose, and echo flags
    Op, Regs: 0 .. $f; //Opcode
    X, Y: 0 .. 3; //Register arguments
    Addr, IP, RP: word; //Immediate or address argument and instruction and return pointers
    R: array [0 .. 3] of byte; //General-purpose registers
    Mem: array [0 .. LastRAM] of byte; //Random access 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
    IC, LFX: integer; //Instruction counter for CPU speed
    Fetched: byte; //Fetched byte

//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 begin //Bodge for line feed
            LFX := WhereX;
            write (Ch);
            GotoXY (LFX, WhereY);
        end
        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;

//Wait to emulate CPU speed of ~500 KIPS
{$ifndef fast}
procedure wait;
begin
    if IC div 500 = 0 then sleep (1)
    else sleep (IC div 500);
    IC := 0;
end;
{$endif}

//Load a byte from memory
function LoadByte (W: word): byte;
var
    B: byte;
begin
    //Terminal input
    if W = $ffff then begin
        {$ifndef fast}
        wait;
        {$endif}
        //Read a keypress
        Ch := ReadKey;
        //Handle non-character keys
        if Ch = ansichar (0) then begin
            if keypressed then begin
                Scan := ReadKey;
                //The delete key inserts the delete character
                if Scan = ansichar ($53) then Ch := ansichar ($7f);
            end;
        end
        //Bodge for the CRT unit not working perfectly in Linux
        else if Ch <= ansichar ($7f) then begin
            if keypressed then begin
                Ch := ansichar (0);
                repeat
                    scan := ReadKey;
                until keypressed = false;
            end;
        end;
        //Process the keypress
        if Echo then Output; //Local echo
        B := byte (Ch);
    end
    //Tape reader
    {$ifdef tape}
    else if W = $fffd then begin
        {$ifndef fast}
        wait;
        {$endif}
        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, B);
            close (TapeIn);
            Reader.Pos := Reader.Pos + 1;
        except
            B := $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}
    //Unused addresses
    else if W > LastRAM then B := 0
    //Regular load
    else B := Mem [W];
    //Result
    LoadByte := B;
end;

procedure StoreByte (W: word; B: byte);
begin
    //Terminal output
    if W = $ffff then begin
        {$ifndef fast}
        wait;
        {$endif}
        Ch := ansichar (B);
        Output;
        if Ch = ansichar ($12) then Echo := true;
        if Ch = ansichar ($14) then Echo := false;
    end
    //Printer
    {$ifdef printer}
    else if W = $fffe then begin
        {$ifndef fast}
        wait;
        {$endif}
        assign (Prn, '/dev/usb/lp0');
        try
            rewrite (Prn);
            write (Prn, B);
            close (Prn);
        except
        end;
    end
    {$endif}
    //Tape punch
    {$ifdef tape}
    else if W = $fffd then begin
        {$ifndef fast}
        wait;
        {$endif}
        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, B);
                    close (TapeOut);
                    Punch.Reset := false;
                except
                end;
            end
            else if Punch.Reset then begin
                try
                    rewrite (TapeOut);
                    write (TapeOut, B);
                    close (TapeOut);
                    Punch.Reset := false;
                except
                end;
            end
            else begin
                try
                    reset (TapeOut);
                    seek (TapeOut, FileSize (TapeOut));
                    write (TapeOut, B);
                    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 if W <= LastRAM then Mem [W] := B;
end;

procedure Call;
begin
    //Low byte of the return address
    RP := RP - 1;
    StoreByte (RP, IP and $ff);
    //High byte of the return address
    RP := RP - 1;
    StoreByte (RP, IP shr 8);
    //Call
    IP := Addr;
end;

begin

    //Initialise the halt and echo flags, the pointers, and the instruction counter
    Hlt := false;
    Echo := true;
    IP := 0;
    RP := LastRAM + 1;
    IC := 0;

    //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}

    //Check the arguments
    if ParamCount = 0 then begin
        writeln ('Usage: emulator (-v) program (2> verbose_output)');
        halt (1);
    end;
    if ParamStr (1) = '-v' then begin
        Verbose := true;
        if ParamCount <> 2 then begin
            writeln ('Usage: emulator (-v) program (2> verbose_output)');
            halt (1);
        end;
    end
    else begin
        Verbose := false;
        if ParamCount <> 1 then begin
            writeln ('Usage: emulator (-v) program (2> verbose_output)');
            halt (1);
        end;
    end;

    //Read a program file and check for errors
    {$i-}
    if Verbose = true then assign (Prog, ParamStr (2))
    else assign (Prog, ParamStr (1));
    reset (Prog);
    if FileSize (Prog) > LastRAM + 1 then begin
        writeln ('Error: program size cannot exceed ', LastRam + 1, ' bytes');
        halt (1);
    end;
    {$i+}
    if IOResult <> 0 then begin
        writeln ('Error: program file cannot be read from');
        halt (1);
    end;
    repeat
        read (Prog, Mem [IP]);
        IP := IP + 1;
    until (eof (Prog));

    //Reinitialise the instruction pointer
    IP := 0;

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

        //Print the CPU state to StdErr
        if Verbose = true then writeln (StdErr, 'IR: ', IntToHex (Op, 1), IntToHex (Regs, 1), IntToHex (Addr, 4), ';  IP: ', IntToHex (IP, 4), ', RP: ', IntToHex (RP, 4), ';  R0: ', IntToHex (R[0], 2), ', R1: ', IntToHex (R[1], 2), ', R2: ', IntToHex (R[2], 2), ', R3: ', IntToHex (R[3], 2), ansichar ($d));

        //Fetch the instruction and increment the instruction pointer
        //Fetch the opcode and register arguments
        Fetched := LoadByte (IP);
        //Decode the opcode
        Op := Fetched and $f0 shr 4;
        //Decode the register arguments
        Regs := Fetched and $f;
        X := Fetched and $c shr 2;
        Y := Fetched and 3;
        IP := IP + 1;
        //Immediate or address argument
        if Op >= $a then begin
            //Immediate or high byte of address
            Fetched := LoadByte (IP);
            Addr := Fetched;
            Addr := Addr shl 8;
            IP := IP + 1;
            //Low byte of address
            if Op = $a then begin
                if Y = 0 then begin
                    Fetched := LoadByte (IP);
                    Addr := Addr + Fetched;
                    IP := IP + 1;
                end;
            end
            else begin
                Fetched := LoadByte (IP);
                Addr := Addr + Fetched;
                IP := IP + 1;
            end;
        end
        else Addr := 0;

        //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 := LoadByte (RP);
            IP := IP shl 8;
            RP := RP + 1;
            //Low byte of the return address
            IP := IP + LoadByte (RP);
            RP := RP + 1;
        end
        //Shl
        else if Op = 2 then begin
            if Y = 0 then R [X] := R [X] shl 4
            else R [X] := R [X] shl Y;
        end
        //Shr
        else if Op = 3 then begin
            if Y = 0 then R [X] := R [X] shr 4
            else R [X] := R [X] shr Y;
        end
        //Rol
        else if Op = 4 then begin
            if Y = 0 then R [X] := RolByte (R [X], 4)
            else R [X] := RolByte (R [X], Y);
        end
        //Ror
        else if Op = 5 then begin
            if Y = 0 then R [X] := RorByte (R [X], 4)
            else R [X] := RorByte (R [X], Y);
        end
        //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
            //Immediate
            if Y <> 0 then R [X] := Addr shr 8
            //Address
            else R [X] := LoadByte (Addr);
        end
        //Store
        else if Op = $b then StoreByte (Addr, R [Y])
        //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 Call;
        end
        //Clneq
        else if Op = $f then begin
            if R [X] <> R [Y] then Call;
        end;

        //Increment the instruction counter
        IC := IC + 1;

    end;

    {$ifndef fast}
    wait;
    {$endif}

end.