source: branches/virtcpu varint/UAssembler.pas

unit UAssembler;

{$mode delphi}

interface

uses
  Classes, SysUtils, fgl, UCpu, UOpcode, UInstructionWriter;

type
  TErrorEvent = procedure (Text: string) of object;

  { TParser }

  TParser = class
  private
    FOnError: TErrorEvent;
    procedure Error(Text: string);
  public
    Text: string;
    procedure Expect(Text: string);
    function IsOperator(C: Char): Boolean;
    function IsWhiteSpace(C: Char): Boolean;
    function ReadNext: string;
    function EndOfText: Boolean;
    property OnError: TErrorEvent read FOnError write FOnError;
  end;

  TLabelRef = class
    Address: QWord;
    Relative: Boolean;
  end;

  { TLabel }

  TLabel = class
    Name: string;
    Address: QWord;
    Refs: TFPGList<TLabelRef>;
    constructor Create;
    destructor Destroy; override;
  end;

  { TLabels }

  TLabels = class(TFPGObjecTList<TLabel>)
    function SearchByName(Name: string): TLabel;
  end;

  { TAssembler }

  TAssembler = class
  private
    FOnError: TErrorEvent;
    OpcodeDefs: TOpcodeDefs;
    InstructionIP: QWord;
    procedure Error(Text: string);
    procedure ParseParam(Param: TOpcodeParam);
    procedure WriteRefAddr(Name: string; Relative: Boolean = False);
    procedure WriteRefData(Name: string);
    procedure UpdateLabelRef;
    procedure ParseInstruction;
  public
    Parser: TParser;
    Labels: TLabels;
    Source: TStringList;
    InstructionWriter: TInstructionWriter;
    procedure Compile;
    constructor Create;
    destructor Destroy; override;
    property OnError: TErrorEvent read FOnError write FOnError;
  end;


implementation

{ TLabels }

function TLabels.SearchByName(Name: string): TLabel;
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;

{ TLabel }

constructor TLabel.Create;
begin
  Refs := TFPGList<TLabelRef>.Create;
end;

destructor TLabel.Destroy;
begin
  Refs.Free;
  inherited Destroy;
end;

{ TParser }

procedure TParser.Error(Text: string);
begin
  if Assigned(FOnError) then FOnError(Text);
end;

procedure TParser.Expect(Text: string);
var
  Next: string;
begin
  Next := ReadNext;
  if Next <> Text then
    Error('Expected ' + Text + ' but ' + Next + ' found');
end;

function TParser.IsOperator(C: Char): Boolean;
begin
  Result := (C = ',') or (C = ';');
end;

function TParser.IsWhiteSpace(C: Char): Boolean;
begin
  Result := (C = ' ') or (C = #8);
end;

function TParser.ReadNext: string;
var
  P: Integer;
begin
  Text := Trim(Text);
  P := 1;
  if (Length(Text) > 0) and IsOperator(Text[P]) then begin
    Result := Text[P];
    Delete(Text, 1, 1);
  end else begin
    while (P <= Length(Text)) and not IsWhiteSpace(Text[P]) and not IsOperator(Text[P]) do Inc(P);
    Result := Copy(Text, 1, P - 1);
    Delete(Text, 1, P - 1);
  end;
end;

function TParser.EndOfText: Boolean;
begin
  Result := Text = '';
end;

{ TAssembler }

procedure TAssembler.Error(Text: string);
begin
  if Assigned(FOnError) then FOnError(Text);
end;

procedure TAssembler.ParseParam(Param: TOpcodeParam);
var
  Reg: T;
  Addr: Int64;
  Next: string;
begin
  if Param = prReg then begin
    Next := Parser.ReadNext;
    if (Length(Next) > 1) and (Next[1] = 'R') then
      Reg := StrToInt(Copy(Next, 2, Length(Next)))
    else Error('Expected register name but found ' + Next);
    InstructionWriter.Write(Reg);
  end else
  if Param = prData then begin
    Next := Parser.ReadNext;
    if TryStrToInt64(Next, Addr) then
      InstructionWriter.Write(Addr)
      else WriteRefData(Next);
  end else
  if Param = prAddr then begin
    Next := Parser.ReadNext;
    if TryStrToInt64(Next, Addr) then
      InstructionWriter.Write(Addr)
      else WriteRefAddr(Next);
  end else
  if Param = prAddrRel then begin
    Next := Parser.ReadNext;
    if TryStrToInt64(Next, Addr) then
      InstructionWriter.Write(InstructionWriter.IP + Addr)
      else WriteRefAddr(Next, True);
  end;
end;

procedure TAssembler.WriteRefAddr(Name: string; Relative: Boolean = False);
var
  L: TLabel;
  NewRef: TLabelRef;
begin
  L := Labels.SearchByName(Name);
  if Assigned(L) then begin
    if Relative then
      InstructionWriter.WriteSigned(InstructionWriter.GetRelativeAddr(
        InstructionIP, L.Address))
      else InstructionWriter.Write(L.Address);
  end else begin
    L := TLabel.Create;
    L.Name := Name;
    NewRef := TLabelRef.Create;
    NewRef.Address := InstructionWriter.IP;
    if Relative then NewRef.Relative := True;
    L.Refs.Add(NewRef);
    Labels.Add(L);
    InstructionWriter.Write(0);
  end;
end;

procedure TAssembler.WriteRefData(Name: string);
var
  L: TLabel;
  NewRef: TLabelRef;
begin
  L := Labels.SearchByName(Name);
  if Assigned(L) then begin
    InstructionWriter.Write(L.Address);
  end else begin
    L := TLabel.Create;
    L.Name := Name;
    NewRef := TLabelRef.Create;
    NewRef.Address := InstructionWriter.IP;
    L.Refs.Add(NewRef);
    Labels.Add(L);
    InstructionWriter.Write(0);
  end;
end;

procedure TAssembler.UpdateLabelRef;
var
  I: Integer;
  R: Integer;
begin
  for I := 0 to Labels.Count - 1 do
  with TLabel(Labels[I]) do begin
    for R := 0 to Refs.Count - 1 do
    begin
      InstructionWriter.IP := Refs[R].Address;
      if Refs[R].Relative then InstructionWriter.WriteSigned(InstructionWriter.GetRelativeAddr(
        InstructionWriter.IP - 1, Address))
        else InstructionWriter.Write(Address);
    end;
  end;
end;

procedure TAssembler.ParseInstruction;
var
  Next: string;
  LabelName: string;
  NewLabel: TLabel;
  OpcodeDef: TOpcodeDef;
begin
  Next := Parser.ReadNext;
  if Next = '' then Exit;
  if Next.StartsWith('//') then Exit;
  if (Length(Next) > 0) and (Next[Length(Next)] = ':') then begin
    LabelName := Copy(Next, 1, Length(Next) - 1);
    NewLabel := Labels.SearchByName(LabelName);
    if not Assigned(NewLabel) then begin
      NewLabel := TLabel.Create;
      NewLabel.Name := LabelName;
      Labels.Add(NewLabel);
    end;
    NewLabel.Address := InstructionWriter.IP;
    Next := Parser.ReadNext;
  end;
  if Next = '' then Exit;
  OpcodeDef := OpcodeDefs.SearchByName(Next);
  if Assigned(OpcodeDef) then begin
    InstructionIP := InstructionWriter.IP;
    InstructionWriter.Write(Byte(OpcodeDef.Opcode));
    ParseParam(OpcodeDef.Param1);
    if OpcodeDef.Param2 <> prNone then begin
      Parser.Expect(',');
      ParseParam(OpcodeDef.Param2);
      if OpcodeDef.Param3 <> prNone then begin
        Parser.Expect(',');
        ParseParam(OpcodeDef.Param3);
      end;
    end;
  end else
  if Next = 'STRING' then begin
    Next := Parser.ReadNext;
    if (Length(Next) >= 2) and (Next[1] = '''') and (Next[Length(Next)] = '''') then
      InstructionWriter.WriteString(Copy(Next, 2, Length(Next) - 2));
  end else
  Error('Unknown instruction ' + Next);
end;

procedure TAssembler.Compile;
var
  I: Integer;
  Next: string;
begin
  InstructionWriter.Init;
  Labels.Clear;
  for I := 0 to Source.Count - 1 do begin
    Parser.Text := Source[I];
    ParseInstruction;
    repeat
      Next := Parser.ReadNext;
      if (Next = '') or (Next <> ';') then Break;
      ParseInstruction;
    until False;
  end;
  UpdateLabelRef;
end;

constructor TAssembler.Create;
begin
  OpcodeDefs := TOpcodeDefs.Create;
  Source := TStringList.Create;
  Labels := TLabels.Create;
  Parser := TParser.Create;
  Parser.OnError := Error;
  InstructionWriter := TInstructionWriter.Create;
end;

destructor TAssembler.Destroy;
begin
  FreeAndNil(InstructionWriter);
  FreeAndNil(Parser);
  FreeAndNil(Labels);
  FreeAndNil(Source);
  FreeAndNil(OpcodeDefs);
  inherited Destroy;
end;



end.