{$inline on}
{$define DEBUG}
 
program emulador8080;
 
{$ifdef DEBUG}
uses
  crt    //Necesaria para el procedimiento clrscr
  ;
{$endif}
 
const
  MAXMEM = $FFFF;
  MAXPUERTOS= $FF;
  VECTOR_RESET = $0000;
 
type
  TDirMem = 0..MAXMEM;
  TDirPuertos = 0..MAXPUERTOS;
 
  TMemoria = array[TDirMem] of byte;
  TPuertos = array[TDirPuertos] of byte;
 
  TPSW = record
    S,    
    Z,
    H, {Half Carry} 
    P, {Parity/Overflow}
    N, {Add/Substract}
    C {Carry} : boolean;
  end;
 
var
  Mem : TMemoria;
  Puertos : TPuertos;
  PSW : TPSW;
  {General Purpose Register}
  {Main Register Set}
  A,
  B,C,
  D,E,
  H,L,    
  {Alternate Register Set}
  A1,
  B1,C1,
  D1,E1,
  H1,L1    : byte;
  {Special Purpose Register}
  IX,IY,SP,PC: word;
  {I= Interruptor, R= Refresh}
  I,R    : byte;
 
  INTE  : boolean;
  Halt  : boolean;  
 
{=============================================================================
 Interfaz de control del Emulador =============================================================================}
 
{$IFDEF DEBUG}
 
function Desensamblado(I: byte): string;
  function NombreRegistro(r : byte): string; inline;
  var
    op  : string;
  begin
    case r of
    0: op := 'B';
    1: op := 'C';
    2: op := 'D';
    3: op := 'E';
    4: op := 'H';
    5: op := 'L';
    6: op := '[HL]';
    7: op := 'A';
    end;
    NombreRegistro := op;
  end;
 
begin
    case I of        {Decodify}
    $00:  Desensamblado := 'NOP';        {Execute}
  end;
end;
 
procedure Interfaz_CargarContenidoMemoria;
var
  F : file of byte;
  Nombre : string;
  i     : word;
  b     : byte;
begin
  write('Nombre del archivo: '); readln(Nombre);
  assign(F, Nombre);
  system.reset(F);
  i := 0;
  while not eof(F) do
  begin
    read(F,b);
    Mem[i] := b;
    i := i + 1;
  end;
  close(F);
end;
 
procedure Interfaz_GuardarContenidoMemoria;
var
  F : file of byte;
  Nombre : string;
  i     : word;
begin
  write('Nombre del archivo: '); readln(Nombre);
  assign(F, Nombre);
  system.rewrite(F);
  for i := 0 to MAXMEM do
    write(F,Mem[i]);
  close(F);
end;
 
procedure Interfaz_Desplegar;
  procedure DesplegarPSW;
  begin
    with PSW do
    begin
      if S then write('S(X)') else write('S( )');
      if Z  then write(' Z(X)') else write(' Z( )');
      if H  then write(' H(X)') else write(' H( )');
      if P  then write(' P(X)') else write(' P( )');
      if N  then write(' N(X)') else write(' N( )');
      if C  then writeln(' C(X)') else writeln(' C( )');
    end;
  end;
var
  S,s2 : char;
  valor : byte;
  valor16 : word;
begin
  clrscr;
  DesplegarPSW;
  writeln('A= ', A);
  write('B= ', B);    writeln(' C= ', C);
  write('D= ', D);    writeln(' E= ', E);
  write('H= ', H);    writeln(' L= ', L);
  writeln('IX= ', IX);
  writeln('IY= ', IY);
  writeln('SP= ', SP);
  writeln('PC= ', PC);
  write('I= ', I); writeln(' : ', Desensamblado(i));
  write('Q=salir, [ABCDEHL]=regs, F=PSW, M=mem, X=IX, Y=IY, P=PC, S=SP, R=leer, W=escribir, ENTER=continuar: ');
  readln(S);
  S := upcase(S);
  case S of
  'Q': Halt := true;
  'A': begin
          write('A= '); readln(valor);
          A := valor;
       end;
  'B': begin
          write('B= '); readln(valor);
          B := valor;
       end;
  'C': begin
          write('C= '); readln(valor);
          C := valor;
       end;
  'D': begin
          write('D= '); readln(valor);
          D := valor;
       end;
  'E': begin
          write('E= '); readln(valor);
          E := valor;
       end;
  'F': begin
          write('Bandera [SZHPNC]'); readln(S2);
          S2 := upcase(S2);
          case S2 of
          'S':    PSW.S  := not PSW.S;
          'Z':    PSW.Z  := not PSW.Z;
          'H':    PSW.H  := not PSW.H;
          'P':    PSW.P  := not PSW.P;
          'N':    PSW.N  := not PSW.N;
          'C':  PSW.C  := not PSW.C;
          end;
       end;
  'H': begin
          write('H= '); readln(valor);
          H := valor;
       end;
  'L': begin
          write('L= '); readln(valor);
          L := valor;
       end;
  'P': begin
          write('PC= '); readln(valor16);
          PC := valor16;
       end;
  'S': begin
          write('SP= '); readln(valor16);
          SP := valor16;
       end;
  'M': begin
          write('Dir= '); readln(valor16);
          write('valor= '); readln(valor);
          Mem[valor16] := valor;
       end;
  'R': Interfaz_CargarContenidoMemoria;
  'X': begin
          write('IX= '); readln(valor16);
          IX := valor16;
       end;
  'Y': begin
          write('IY= '); readln(valor16);
          IY := valor16;
       end;
  'W': Interfaz_GuardarContenidoMemoria;
  end;
end;
 
{$ENDIF}
 
{=============================================================================
 Funciones relativas al PSW  =============================================================================}
 
function PSW_ParidadPar: boolean; inline;
var
  conta : byte;    //Número de 1's presentes en A
  i     : byte;
begin
  conta := 0;
  for i := 0 to 7 do
    conta := conta + (A shr i) and $01;
  PSW_ParidadPar := (conta mod 2) = 0;
end;
 
procedure PSW_ActualizarLogico(temp  : byte); inline;
begin
  with PSW do
  begin
    S  := (temp and $80) = $80;    
    Z  := temp = $00;    
    H := false;
    P  := PSW_ParidadPar;    
    C  := false;
  end;
end;
 
procedure PSW_ActualizarAritmetico(r1, r2 : byte; temp : word); inline;
begin
  with PSW do
  begin
    S  := (temp and $80) = $80;
    Z  := temp = $00;
    PSW.H := ((temp xor r1 xor r2) and $10) = $10;
    P  := PSW_ParidadPar;
    PSW.C  := temp > 255;
  end;
end;
 
{=============================================================================
 Funciones relativas a la ALU  =============================================================================}
 
function ALU_add(r1, r2, Cin : byte): byte; inline; {ADD}
var
  temp : word;
begin
  temp   := r1 + r2 + Cin;
  PSW_ActualizarAritmetico(r1, r2, temp);
  ALU_add := temp;
end;
 
function ALU_sub(r1, r2, Bin : byte): byte; inline; {Subtract}
var
  temp : word;
begin
  temp   := r1 - r2 - Bin;
  PSW_ActualizarAritmetico(r1, r2, temp);
  ALU_sub := temp;
end;
 
 
function ALU_and(r1, r2 : byte): byte; inline;  {Logical AND}
var
  temp : byte;
begin
  temp := r1 and r2;
  PSW_ActualizarLogico(temp);
  ALU_and := temp;
end;
 
function ALU_or(r1, r2 : byte): byte; inline; {Logical OR}
var
  temp : byte;
begin
  temp := r1 or r2;
  PSW_ActualizarLogico(temp);
  ALU_or := temp;
end;
 
function ALU_xor(r1, r2 : byte): byte; inline; {Logical Exclusive OR}
var
  temp : byte;
begin
  temp := r1 xor r2;
  PSW_ActualizarLogico(temp);
  ALU_xor := temp;
end;
 
function ALU_bcd(r : byte): byte; inline;
var
temp:byte;
begin
  temp:=(r and $0f);
  ALU_bcd:=((r shr 4)*16)+temp;
end;
 
{=============================================================================
 Funciones relativas a la Unidad de Control =============================================================================}
 
procedure CPU_VerificarInterrupciones;
begin
end;
 
procedure CPU_Reset;
begin
  A := $00;
  B := $00;    C := $00;
  D := $00;    E := $00;
  H := $00;    L := $00;
  with PSW do
  begin
    S := false;    
    Z := true;
    H := false;    
    P  := false;    //NOTA : Checar      
    C := false;
  end;
  SP := MAXMEM;
  PC := VECTOR_RESET;
  Halt := false;
  INTE := true; {NOTA: Los estudiante deben verificar esto.}
end;
 
{=============================================================================
 Funciones relativas a la Memoria =============================================================================}
 
function Memoria_Leer(d : word): byte; inline;
begin
  Memoria_Leer := Mem[d];
end;
 
procedure Memoria_Escribir(d : word; b : byte); inline;
begin
  Mem[d] := b;
end;
 
function Memoria_DecodificarDirecto: word; inline;
begin
  Memoria_DecodificarDirecto := (Memoria_Leer(PC+2) shl 8) or Memoria_Leer(PC+1);
end;
 
function Memoria_LeerInmediato: byte; inline;
begin
  Memoria_LeerInmediato := Memoria_Leer(PC+1);
end;
 
function Memoria_LeerDirecto: byte; inline;
begin
  Memoria_LeerDirecto := Memoria_Leer( Memoria_DecodificarDirecto );
end;
 
procedure Memoria_EscribirDirecto(v : byte);
begin
  Memoria_Escribir( Memoria_DecodificarDirecto, v );
end;
 
function Memoria_LeerPila: word; inline;
var
  alto, bajo : byte;
begin
  bajo := Memoria_Leer(SP);
  SP := SP + 1;
  alto := Memoria_Leer(SP);
  SP := SP + 1;
  Memoria_LeerPila := (alto shl 8) or bajo;
end;
 
procedure Memoria_EscribirPila(v : word);
begin
  SP := SP - 2;
  Memoria_Escribir(SP, v and $00FF);
  Memoria_Escribir(SP+1, (v shr 8) and $00FF);
end;
 
{=============================================================================
 Funciones relativas a los Registros
 =============================================================================}
 
procedure Registros_Escribir(r : byte; v : byte);
begin
  case r of
  $00: B := v;
  $01: C := v;
  $02: D := v;
  $03: E := v;
  $04: H := v;
  $05: L := v;
  $06: Mem[(H shl 8) or L] := v;
  $07: A := v;
  end;
end;
 
function Registros_Leer(r : byte): byte; inline;
var
  op  : byte;
begin
  case r of
  0: op := B;
  1: op := C;
  2: op := D;
  3: op := E;
  4: op := H;
  5: op := L;
  6: op := Mem[(H shl 8) or L];
  7: op := A;
  end;
  Registros_Leer := op;
end;
 
function Registros_LeerPar(I : byte): word; inline;
var
  r : byte;
  temp : word;
begin
  r := (I and $30) shr 4;
  case r of
  $00: temp := (B shl 8) or C;
  $01: temp := (D shl 8) or E;
  $02: temp := (H shl 8) or L;
  $03: temp := SP;
  end;
  Registros_LeerPar := temp;
end;
 
procedure Registros_EscribirPar(I: byte; v : word);
var
  r : byte;
begin
  r := (I and $30) shr 4;
  case r of
  $00: begin
        B := (v and $FF00) shr 8;
        C := (v and $00FF);
      end;
  $01: begin
        D := (v and $FF00) shr 8;
        E := (v and $00FF);
      end;
 
  $02: begin
        H := (v and $FF00) shr 8;
        L := (v and $00FF);
      end;
 
  $03: SP := v;
  end;
end;
 
procedure IXIY(Registro : boolean);
var 
Reg: word;
begin
      if Registro= true then
      Reg:=IX
      else Reg:=IY;
    PC:=PC+1;
    I:=Mem[PC];
end;
 
{=============================================================================
 Instrucciones del Procesador  Z80 =============================================================================}
 
procedure InstruccionDesconocida( ByteCode : byte);
begin
  writeln(stderr, 'Instrucción desconocida: ', ByteCode);
  PC := PC + 1;
end;
 
procedure NOP;
begin
  PC := PC + 1;
end;
 
{=============================================================================
 R U T I N A   P R I N C I P A L   D E L   E M U L A D O R   
 =============================================================================}
begin
  {Arranque de la máquina (RESET)}
  CPU_Reset;
  {Ciclo de Instrucción}
  repeat
    I := Mem[PC];    {Fetch}
    case I of        {Decodify}
    $00:  NOP;        {Execute}
    else
      InstruccionDesconocida(I);
    end;
    if INTE then
      CPU_VerificarInterrupciones;
{$ifdef DEBUG}
    Interfaz_Desplegar;
{$endif}
  until Halt;
end.