source: branches/virtcpu varint/UOpcode.pas

unit UOpcode;

{$mode delphi}

interface

uses
  Classes, SysUtils, fgl, UCpu;

type
  TOpcodeParam = (prNone, prReg, prData, prAddr, prAddrRel);
  TOpcodeDef = class
    Opcode: TOpcode;
    Name: string;
    Param1: TOpcodeParam;
    Param2: TOpcodeParam;
    Param3: TOpcodeParam;
    Param4: TOpcodeParam;
  end;

  { TOpcodeDefs }

  TOpcodeDefs = class(TFPGObjectList<TOpcodeDef>)
    procedure CheckMissingOpcodes;
    function SearchByOpcode(Opcode: TOpcode): TOpcodeDef;
    function SearchByName(Name: string): TOpcodeDef;
    function AddNew(Opcode: TOpcode; Name: string;
      Param1: TOpcodeParam = prNone;
      Param2: TOpcodeParam = prNone;
      Param3: TOpcodeParam = prNone;
      Param4: TOpcodeParam = prNone): TOpcodeDef;
    constructor Create(FreeObjects: Boolean = True);
  end;

  function IntToHexEx(Value: Int64; Digits: ShortInt = -1; Prefix: string = ''): string; overload;
  function IntToHexEx(Value: QWord; Digits: ShortInt = -1; Prefix: string = ''): string; overload;


implementation

const
  HexChars: array[0..15] of Char = '0123456789ABCDEF';

function IntToHexEx(Value: Int64; Digits: ShortInt = -1; Prefix: string = ''): string;
var
  I: Integer;
  Negative: Boolean;
begin
  Negative := Value < 0;
  if Negative then Value := -Value;
  Result := '';
  if Digits >= 0 then begin
    for I := 0 to Digits - 1 do begin
      Result := HexChars[Value and $f] + Result;
      Value := Value shr 4;
    end;
  end else begin
    if Value <> 0 then begin
      while QWord(Value) > 0 do begin
        Result := HexChars[Value and $f] + Result;
        Value := Value shr 4;
      end;
    end else Result := '0';
  end;
  Result := Prefix + Result;
  if Negative then Result := '-' + Result;
end;

function IntToHexEx(Value: QWord; Digits: ShortInt = -1; Prefix: string = ''): string;
var
  I: Integer;
begin
  Result := '';
  if Digits >= 0 then begin
    for I := 0 to Digits - 1 do begin
      Result := HexChars[Value and $f] + Result;
      Value := Value shr 4;
    end;
  end else begin
    if Value <> 0 then begin
      while Value > 0 do begin
        Result := HexChars[Value and $f] + Result;
        Value := Value shr 4;
      end;
    end else Result := '0';
  end;
  Result := Prefix + Result;
end;

{ TOpcodeDefs }

procedure TOpcodeDefs.CheckMissingOpcodes;
var
  Opcode: TOpcode;
  OpcodeDef: TOpcodeDef;
begin
  for Opcode := Low(TOpcode) to High(TOpcode) do begin
    OpcodeDef := SearchByOpcode(Opcode);
    if not Assigned(OpcodeDef) then
      raise Exception.Create('Opcode ' + IntToStr(Integer(Opcode)) + ' is not defined.');
  end;
end;

function TOpcodeDefs.SearchByOpcode(Opcode: TOpcode): TOpcodeDef;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Opcode <> Opcode) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TOpcodeDefs.SearchByName(Name: string): TOpcodeDef;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TOpcodeDefs.AddNew(Opcode: TOpcode; Name: string;
  Param1: TOpcodeParam = prNone;
  Param2: TOpcodeParam = prNone;
  Param3: TOpcodeParam = prNone;
  Param4: TOpcodeParam = prNone): TOpcodeDef;
begin
  Result := TOpcodeDef.Create;
  Result.Opcode := Opcode;
  Result.Name := Name;
  Result.Param1 := Param1;
  Result.Param2 := Param2;
  Result.Param3 := Param3;
  Result.Param4 := Param4;
  Add(Result);
end;

constructor TOpcodeDefs.Create(FreeObjects: Boolean = True);
begin
  inherited;
{  TOpcode = (opNop, opLoad, opLoadConst, opNeg,
    opJump, opJumpRel,
    opInc, opDec,
    opLoadMem, opStoreMem,
    opAdd, opSub,
    opInput, opOutput,
    opCall, opCallRel, opRet,
    opExchg,
    opAnd, opOr, opXor,
    opShl, opShr,
    opRor, opRol,
    opPush, opPop,
    opJumpRelCond,
    opLdir, opLddr,
    opJumpCond, opTestEqual, opTestNotEqual, opTestLess,
    opTestLessEqual, opTestGreater, opTestGreaterEqual,
    opMul, opDiv, opHalt
  );
 }
  AddNew(opNop, 'NOP');
  AddNew(opHalt, 'HALT');
  AddNew(opLoad, 'LD', prReg, prReg);
  AddNew(opLoadConst, 'LDI', prReg, prData);
  AddNew(opJump, 'JP', prAddr);
  AddNew(opJumpCond, 'JPC', prAddr);
  AddNew(opJumpRel, 'JR', prAddrRel);
  AddNew(opJumpRelCond, 'JRC', prAddrRel);
  AddNew(opTestEqual, 'TE', prReg, prReg);
  AddNew(opTestNotEqual, 'TNE', prReg, prReg);
  AddNew(opTestGreater, 'TG', prReg, prReg);
  AddNew(opTestGreaterEqual, 'TGE', prReg, prReg);
  AddNew(opTestLess, 'TL', prReg, prReg);
  AddNew(opTestLessEqual, 'TLE', prReg, prReg);
  AddNew(opTestZero, 'TZ', prReg);
  AddNew(opTestNotZero, 'TNZ', prReg);
  AddNew(opNeg, 'NEG', prReg);
  AddNew(opClear, 'CLR', prReg);
  AddNew(opLoadMem, 'LDM', prReg, prReg);
  AddNew(opStoreMem, 'STM', prReg, prReg);
  AddNew(opExchg, 'EX', prReg, prReg);
  AddNew(opPush, 'PUSH', prReg);
  AddNew(opPop, 'POP', prReg);
  AddNew(opCall, 'CALL', prAddr);
  AddNew(opCallRel, 'CALR', prAddr);
  AddNew(opRet, 'RET');
  AddNew(opAdd, 'ADD', prReg, prReg);
  AddNew(opSub, 'SUB', prReg, prReg);
  AddNew(opInc, 'INC', prReg);
  AddNew(opDec, 'DEC', prReg);
  AddNew(opInput, 'IN', prReg, prReg);
  AddNew(opOutput, 'OUT', prReg, prReg);
  AddNew(opShl, 'SHL', prReg, prReg);
  AddNew(opShr, 'SHR', prReg, prReg);
  AddNew(opRol, 'ROL', prReg, prReg);
  AddNew(opRor, 'ROR', prReg, prReg);
  AddNew(opTestEqual, 'TESTEQ', prReg, prReg);
  AddNew(opAnd, 'AND', prReg, prReg);
  AddNew(opOr, 'OR', prReg, prReg);
  AddNew(opXor, 'XOR', prReg, prReg);
  AddNew(opLdir, 'LDIR', prReg, prReg, prReg, prReg);
  AddNew(opLddr, 'LDDR', prReg, prReg, prReg, prReg);
  AddNew(opMul, 'MUL', prReg, prReg);
  AddNew(opDiv, 'DIV', prReg, prReg);
  AddNew(opMod, 'MOD', prReg, prReg);
  CheckMissingOpcodes;
end;

end.