unit Disassembler;

interface

uses
  Classes, SysUtils, Z80Instructions, Z80InstructionInfo, StrUtils, MemoryTypes,
  Generics.Collections;

type

  { TDecodedInstruction }

  TDecodedInstruction = class
    Address: Word;
    Opcodes: array of Byte;
    Name: string;
    Parameters: string;
    Comment: string;
    constructor Create;
    procedure AddOpcode(Data: Byte);
    function GetOpcodesText: string;
  end;

  { TDecodedInstructions }

  TDecodedInstructions = class(TObjectList<TDecodedInstruction>)
    function SearchAddress(Address: Word): TDecodedInstruction;
    function SearchAddressIndex(Address: Word): Integer;
  end;

  { TDisassembler }

  TDisassembler = class
    InstructionSet: TInstructionSet;
    Memory: TMemory;
    DecodedInstructions: TDecodedInstructions;
    procedure Disassemble;
    procedure SaveToFile(FileName: string);
    procedure ToLines(Lines: TStrings);
    constructor Create;
    destructor Destroy; override;
  end;

  TComment = record
    Address: Word;
    Text: string;
  end;


implementation

const
  Comments: array[0..35] of TComment = (
    (Address: $3; Text: 'GETL (Reads one line of data from the keyboard and stores it in the memory area starting at the address in the DE register.)'),
    (Address: $6; Text: 'LETNL (Moves the cursor to the beginning of the next line.)'),
    (Address: $9; Text: 'Line feed'),
    (Address: $c; Text: 'PRNTS (Display a space at the cursor position.)'),
    (Address: $f; Text: 'Move cursor to next tab position'),
    (Address: $12; Text: 'PRNTS (Display a character.)'),
    (Address: $15; Text: 'MSG (Displays a message.)'),
    (Address: $18; Text: 'IOSVC'),
    (Address: $1b; Text: 'GETKEY (Reads a character code (ASCII) from the keyboard.)'),
    (Address: $1e; Text: 'BRKEY (Checks whether the I SHIFT I and I BREAK I keys are both being pressed.)'),
    (Address: $30; Text: 'MELDY'),
    (Address: $33; Text: 'TIMST (Sets and starts the built-in clock.)'),
    (Address: $3b; Text: 'TIMRD (Reads the built-in clock and returns the time.'),
    (Address: $3e; Text: 'BELL'),
    (Address: $41; Text: 'XTEMP (Sets the music tempo.)'),
    (Address: $44; Text: 'MSTA (Generates a continuous sound of the specified frequency.)'),
    (Address: $47; Text: 'MSTP (Stops the sound generated with the CALL MSTA subroutine.)'),
    (Address: $308; Text: 'Init 8253 counters.'),
    (Address: $3da; Text: 'ASC (Loads the ASCII character.)'),
    (Address: $3f9; Text: 'HEX (Converts the 8 data bits stored in the ACC into a hexadecimal number.)'),
    (Address: $410; Text: 'HLHEX (Converts a string of 4 ASCII characters into a hexadecimal number and loads it in the HL register.)'),
    (Address: $41f; Text: '2HEX (Converts a string of 2 ASCII characters into a hexadecimal number and loads it into the ACC.)'),
    (Address: $73e; Text: 'Init 8255 PIO.'),
    (Address: $9b3; Text: '??KEY (Blinks the cursor to prompt for key input.)'),
    (Address: $a32; Text: 'Something with 8255 PIO.'),
    (Address: $bb9; Text: '?ADCN (Converts ASCII codes into display codes.)'),
    (Address: $bce; Text: '?DACN (Converts display codes into ASCII codes.)'),
    (Address: $da6; Text: '?BLNK (Detects the vertical blanking period.)'),
    (Address: $ddc; Text: '?DPCT (Controls display.)'),
    (Address: $fb1; Text: '?POINT (Loads the current cursor location into the HL register.)'),
    (Address: $fd8; Text: 'Write FF to (HL) B times.'),
    (Address: $1171; Text: 'Cursor pos.'),
    (Address: $1172; Text: 'Cursor pos.'),
    (Address: $e414; Text: 'Delay'),
    (Address: $e800; Text: 'Cold start'),
    (Address: $e813; Text: 'Base init.')
  );

function SearchComment(Address: Word): string;
var
  I: Integer;
begin
  I := 0;
  while (I <= High(Comments)) and (Comments[I].Address <> Address) do Inc(I);
  if I <= High(Comments) then Result := Comments[I].Text
    else Result := '';
end;

{ TDecodedInstructions }

function TDecodedInstructions.SearchAddress(Address: Word): TDecodedInstruction;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Address <> Address) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TDecodedInstructions.SearchAddressIndex(Address: Word): Integer;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Address <> Address) do Inc(I);
  if I < Count then Result := I
    else Result := -1;
end;

{ TDecodedInstruction }

constructor TDecodedInstruction.Create;
begin
  Parameters := '';
end;

procedure TDecodedInstruction.AddOpcode(Data: Byte);
begin
  SetLength(Opcodes, Length(Opcodes) + 1);
  Opcodes[Length(Opcodes) - 1] := Data;
end;

function TDecodedInstruction.GetOpcodesText: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to Length(Opcodes) - 1 do
    Result := Result + IntToHex(Opcodes[I], 2) + ' ';
  Result := Trim(Result);
end;

procedure TDisassembler.Disassemble;
var
  J: Integer;
  Value: Integer;
  Instruction: TInstruction;
  InstructionInfo: TInstructionInfo;
  DecodedInstruction: TDecodedInstruction;
  DestAddress: Longint;
begin
  Memory.Position := 0;
  while Memory.Position < Memory.Size do begin
    DecodedInstruction := TDecodedInstruction.Create;
    DecodedInstruction.Address := Memory.Position;
    Value := Memory.ReadByte;
    DecodedInstruction.AddOpcode(Value);
    if Value = $CB then begin
      Value := Memory.ReadByte;
      DecodedInstruction.AddOpcode(Value);
      Value := $100 or Value;
    end else
    if Value = $DD then begin
      Value := Memory.ReadByte;
      DecodedInstruction.AddOpcode(Value);
      if Value = $CB then begin
        Value := Memory.ReadByte;
        DecodedInstruction.AddOpcode(Value);
        Value := $500 or Value;
      end else Value := $200 or Value;
    end else
    if Value = $ED then begin
      Value := Memory.ReadByte;
      DecodedInstruction.AddOpcode(Value);
      Value := $300 or Value;
    end else
    if Value = $FD then begin
      Value := Memory.ReadByte;
      DecodedInstruction.AddOpcode(Value);
      if Value = $CB then begin
        Value := Memory.ReadByte;
        DecodedInstruction.AddOpcode(Value);
        Value := $600 or Value;
      end else Value := $400 or Value;
    end;
    if (Value >= 0) and (Value <= Integer(High(TInstruction))) then begin
      Instruction := TInstruction(Value);
      InstructionInfo := InstructionSet.SearchInstruction(Instruction);
      if Assigned(InstructionInfo) then begin
        DecodedInstruction.Name := InstructionInfo.Name;
        for J := 0 to Length(InstructionInfo.Params) - 1 do begin
          if J > 0 then
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + ', ';
          if InstructionInfo.Params[J] = ptNumberByte then begin
            Value := Memory.ReadByte;
            DecodedInstruction.AddOpcode(Value);
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + IntToHex(Value, 2);
          end else
          if InstructionInfo.Params[J] = ptNumberWord then begin
            Value := Memory.ReadWord;
            DecodedInstruction.AddOpcode(Value shr 8);
            DecodedInstruction.AddOpcode(Value and $ff);
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + IntToHex(Value, 4);
          end else
          if InstructionInfo.Params[J] = ptNumberByteIndir then begin
            Value := Memory.ReadByte;
            DecodedInstruction.AddOpcode(Value);
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + '(' + IntToHex(Value, 2) + ')';
          end else
          if InstructionInfo.Params[J] = ptNumberWordIndir then begin
            Value := Memory.ReadWord;
            DecodedInstruction.AddOpcode(Value shr 8);
            DecodedInstruction.AddOpcode(Value and $ff);
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + '(' + IntToHex(Value, 4) + ')';
          end else
          if InstructionInfo.Params[J] = ptDisplacement then begin
            Value := Memory.ReadByte;
            DecodedInstruction.AddOpcode(Value);
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + IntToStr(ShortInt(Value));
          end else
          if InstructionInfo.Params[J] in [ptRegA, ptRegB, ptRegC, ptRegD,
            ptRegE, ptRegH, ptRegL, ptRegR, ptRegI,
            ptRegAF, ptRegBC, ptRegDE, ptRegHL, ptRegSP, ptRegIX, ptRegIY,
            ptRegAFPair, ptRegBCPair, ptRegDEPair, ptRegHLPair,
            ptFlagZ, ptFlagNZ, ptFlagC, ptFlagNC, ptFlagP, ptFlagPO, ptFlagPE, ptFlagM,
            ptRegBCIndir, ptRegDEIndir, ptRegHLIndir, ptRegSPIndir, ptRegCIndir,
            pt00, pt08, pt10, pt18, pt20, pt28, pt30, pt38,
            pt0, pt1, pt2, pt3, pt4, pt5, pt6, pt7] then begin
            DecodedInstruction.Parameters := DecodedInstruction.Parameters + ParamTypeText[InstructionInfo.Params[J]];
          end else
            raise Exception.Create('Unsupported instruction parameter type');
        end;
      end;
    end;

    DecodedInstruction.Comment := SearchComment(DecodedInstruction.Address);
    if DecodedInstruction.Comment = '' then begin
      if DecodedInstruction.Name = 'JP' then
        if TryStrToInt('$' + DecodedInstruction.Parameters, DestAddress) then begin
          DecodedInstruction.Comment := SearchComment(DestAddress);
          if DecodedInstruction.Comment <> '' then DecodedInstruction.Comment := 'Jump to ' + DecodedInstruction.Comment;
        end;
      if DecodedInstruction.Name = 'CALL' then
        if TryStrToInt('$' + DecodedInstruction.Parameters, DestAddress) then begin
          DecodedInstruction.Comment := SearchComment(DestAddress);
          if DecodedInstruction.Comment <> '' then DecodedInstruction.Comment := 'Call to ' + DecodedInstruction.Comment;
        end;
    end;
    DecodedInstructions.Add(DecodedInstruction);
  end;
end;

procedure TDisassembler.SaveToFile(FileName: string);
var
  Lines: TStringList;
begin
  Lines := TStringList.Create;
  Disassemble;
  ToLines(Lines);
  Lines.SaveToFile(FileName);
  FreeAndNil(Lines);
end;

procedure TDisassembler.ToLines(Lines: TStrings);
var
  I: Integer;
  OpcodesText: string;
begin
  Lines.Clear;
  for I := 0 to DecodedInstructions.Count - 1 do
  with TDecodedInstruction(DecodedInstructions[I]) do begin
    OpcodesText := GetOpcodesText;
    OpcodesText := OpcodesText + DupeString(' ', 13 - Length(OpcodesText));
    Lines.Add(IntToHex(Address, 4) + ' ' + OpcodesText + ' ' + Name + ' ' + Parameters);
  end;
end;

constructor TDisassembler.Create;
begin
  InstructionSet := TInstructionSet.Create;
  DecodedInstructions := TDecodedInstructions.Create;
end;

destructor TDisassembler.Destroy;
begin
  FreeAndNil(DecodedInstructions);
  FreeAndNil(InstructionSet);
  inherited;
end;

end.