source: branches/ByteArray/Assembler.pas

unit Assembler;

interface

uses
  Classes, SysUtils, Instructions, Cpu, Generics.Collections, BigInt,
  Memory, Message, Parser;

type
  { TLabelRef }

  TLabelRef = record
    LabelName: string;
    RefPos: Integer;
    TextPos: TPoint;
    class function Create(LabelName: string; RefPos: Integer; TextPos: TPoint): TLabelRef; static;
  end;

  { TAssembler }

  TAssembler = class
  private
    FOnError: TErrorEvent;
    Parser: TParser;
    InstDataWidth: TBigIntSize;
    InstAddressWidth: TBigIntSize;
    function ParseVar: Boolean;
    function ParseDb: Boolean;
    function ParseOrg: Boolean;
    function ParseInstruction: Boolean;
    function ParseInstructionParameter(ParamType: TParamType; Memory: TMemory): Boolean;
    function ParseLabel: Boolean;
    procedure UpdateLabelRefs;
    function ParseNumParam(out Number: TBigInt): Boolean;
    function ParseReg(out RegIndex: TRegIndex): Boolean;
    function ParseDataWidth(out Size: TBigIntSize): Boolean;
    function ParseAddressWidth(out Size: TBigIntSize): Boolean;
  public
    InstructionSet: TInstructionInfos;
    Memory: TMemory;
    Labels: TDictionary<string, TBigInt>;
    LabelRefs: TList<TLabelRef>;
    Variables: TDictionary<string, TBigInt>;
    Messages: TMessages;
    DataWidth: TBigIntSize;
    AddressWidth: TBigIntSize;
    procedure Error(Text: string; Pos: TPoint);
    procedure Compile(Source: string);
    procedure LoadFromFile(FileName: string);
    function ParseStr(var Text: string; Separator: string): string;
    constructor Create;
    destructor Destroy; override;
    property OnError: TErrorEvent read FOnError write FOnError;
  end;


implementation

resourcestring
  SCompilationFinished = 'Compilation finished.';
  SExpectedNumber = 'Expected number.';
  SExpectedRegisterName = 'Expected register name.';
  SExpectedNumericIndex = 'Expected numeric register index.';
  SExpectedVariableName = 'Expected variable name.';
  SExpectedVariableValue = 'Expected variable value.';
  SUnsupportedParameterType = 'Unsupported parameter type';
  SDuplicateLabel = 'Duplicate label %s.';
  SLabelReferencedButNotDefined = 'Label %s referenced but not defined.';
  SDuplicateVariableName = 'Duplicate variable name %s';
  SExpectedParameter = 'Expected parameter';
  SExpectedParameterType = 'Expected parameter type [%s]';
  SExpectedNumberButFound = 'Expected number but %s found.';

{ TLabelRef }

class function TLabelRef.Create(LabelName: string; RefPos: Integer; TextPos: TPoint): TLabelRef;
begin
  Result.LabelName := LabelName;
  Result.RefPos := RefPos;
  Result.TextPos := TextPos;
end;

{ TAssembler }

procedure TAssembler.UpdateLabelRefs;
var
  I: Integer;
  Addr: TBigInt;
begin
  for I := 0 to LabelRefs.Count - 1 do begin
    if Labels.TryGetValue(LabelRefs[I].LabelName, Addr) then
      Memory.Write(LabelRefs[I].RefPos, 1, Addr)
      else Error(Format(SLabelReferencedButNotDefined, [LabelRefs[I].LabelName]),
        LabelRefs[I].TextPos);
  end;
end;

function TAssembler.ParseNumParam(out Number: TBigInt): Boolean;
var
  Token: TToken;
  LastPos: TParserPos;
begin
  LastPos := Parser.Pos;
  Result := False;
  Token := Parser.ReadNext;
  if Token.Kind = tkNumber then begin
    if TryStrToBigInt(Token.Value, Number) then begin
      Result := True;
    end;
  end else
  if Token.Kind = tkIdentifier then begin;
    if Variables.TryGetValue(Token.Value, Number) then begin
      Result := True;
    end else
    if Labels.TryGetValue(Token.Value, Number) then begin
      Result := True;
    end else begin
      LabelRefs.Add(TLabelRef.Create(Token.Value, Memory.Position + 1, Parser.Pos.Pos));
      Number := 0;
      Result := True;
    end;
  end;
  if not Result then Parser.Pos := LastPos;
end;

function TAssembler.ParseReg(out RegIndex: TRegIndex): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
  Index: Integer;
begin
  Result := False;
  LastPos := Parser.Pos;
  Token := Parser.ReadNext;
  if (Length(Token.Value) >= 2) and (Token.Value[1] = 'R') then begin
    if TryStrToInt(Copy(Token.Value, 2, MaxInt), Index) then begin
      RegIndex := Index;
      Result := True;
    end;
  end;
  if not Result then Parser.Pos := LastPos;
end;

function TAssembler.ParseDataWidth(out Size: TBigIntSize): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
  Index: Integer;
begin
  Result := False;
  LastPos := Parser.Pos;
  Token := Parser.ReadNext;
  if (Length(Token.Value) >= 2) and (Token.Value[1] = 'D') then begin
    if TryStrToInt(Copy(Token.Value, 2, MaxInt), Index) then begin
      Size := Index;
      Result := True;
    end;
  end;
  if not Result then Parser.Pos := LastPos;
end;

function TAssembler.ParseAddressWidth(out Size: TBigIntSize): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
  Index: Integer;
begin
  Result := False;
  LastPos := Parser.Pos;
  Token := Parser.ReadNext;
  if (Length(Token.Value) >= 2) and (Token.Value[1] = 'A') then begin
    if TryStrToInt(Copy(Token.Value, 2, MaxInt), Index) then begin
      Size := Index;
      Result := True;
    end;
  end;
  if not Result then Parser.Pos := LastPos;
end;

procedure TAssembler.Error(Text: string; Pos: TPoint);
begin
  Messages.AddMessage(Text, Pos);
  if Assigned(FOnError) then
    FOnError(Text, Pos);
end;

procedure TAssembler.Compile(Source: string);
begin
  Messages.Clear;
  Memory.Size := 1000;
  Memory.Position := 0;
  Labels.Clear;
  LabelRefs.Clear;
  Variables.Clear;
  Parser.Reset;
  Parser.Source := Source;
  while not Parser.CheckNextKind(tkEof) do begin
    ParseLabel;
    if ParseVar then begin
    end else
    if ParseDb then begin
    end else
    if ParseOrg then begin
    end else
    if ParseInstruction then begin
    end;
    if Parser.CheckNextKind(tkEof) then begin
    end else Parser.Expect(tkEol);
  end;
  Parser.Expect(tkEof);
  UpdateLabelRefs;
  Error(SCompilationFinished, Point(0, 0));
  Memory.Size := Memory.Position;
end;

function TAssembler.ParseVar: Boolean;
var
  TokenName: TToken;
  TokenValue: TToken;
  Number: TBigInt;
begin
  Result := False;
  if Parser.CheckNextAndRead(tkIdentifier, 'VAR') then begin
    Result := True;
    while True do begin
      TokenName := Parser.ReadNext;
      if TokenName.Kind = tkIdentifier then begin
        TokenValue := Parser.ReadNext;
        if TokenValue.Kind = tkNumber then begin
          if not Labels.ContainsKey(TokenName.Value) and not Variables.ContainsKey(TokenName.Value) then begin
            if TryStrToBigInt(TokenValue.Value, Number) then
              Variables.Add(TokenName.Value, Number)
            else Error(SExpectedNumber, TokenValue.Pos);
          end else Error(Format(SDuplicateVariableName, [TokenName.Value]), TokenName.Pos);
        end else Error(SExpectedVariableValue, TokenValue.Pos);
      end else Error(SExpectedVariableName, TokenName.Pos);
      if Parser.CheckNextAndRead(tkSpecialSymbol, ',') then begin
        Continue;
      end;
      Break;
    end;
  end;
end;

function TAssembler.ParseDb: Boolean;
var
  Token: TToken;
  Number: TBigInt;
begin
  Result := False;
  if Parser.CheckNextAndRead(tkIdentifier, 'DB') then begin
    Result := True;
    while True do begin
      if ParseNumParam(Number) then begin
        Memory.WritePos(1, Number);
      end else begin
        Token := Parser.ReadNext;
        if Token.Kind = tkString then begin
          Memory.WriteStringPos(Token.Value);
        end else
        if Token.Kind = tkEof then
        else if Token.Kind = tkEol then
        else raise Exception.Create(SExpectedParameter);
      end;
      if Parser.CheckNextAndRead(tkSpecialSymbol, ',') then begin
        Continue;
      end;
      Break;
    end;
  end;
end;

function TAssembler.ParseOrg: Boolean;
var
  Token: TToken;
begin
  Result := False;
  if Parser.CheckNextAndRead(tkIdentifier, 'ORG') then begin
    Result := True;
    Token := Parser.ReadNext;
    if Token.Kind = tkNumber then begin
      Memory.Position := StrToInt(Token.Value);
    end else Error(Format(SExpectedNumberButFound, [Token.Value]), Token.Pos);
  end;
end;

function TAssembler.ParseInstruction: Boolean;
var
  InstructionInfos: TInstructionInfos;
  I: Integer;
  Token: TToken;
  LastPos: TParserPos;
  J: Integer;
  AllowedParams: set of TParamType;
  ParamType: TParamType;
  ParamOk: Boolean;
  LastMessagesCount: Integer;
  Text: string;
  EmptyParam: Boolean;
  InstructionMemory: TMemory;
  ParamMemory: TMemory;
begin
  Result := False;
  LastPos := Parser.Pos;
  Token := Parser.ReadNext;
  InstructionInfos := InstructionSet.SearchByNameMultiple(Token.Value);
  InstDataWidth := DataWidth;
  InstAddressWidth := AddressWidth;
  InstructionMemory := TMemory.Create;
  InstructionMemory.Grow := True;
  ParamMemory := TMemory.Create;
  ParamMemory.Grow := True;
  J := 0;
  if InstructionInfos.Count > 0 then
  repeat
    EmptyParam := False;

    if J > 0 then
      Parser.Expect(tkSpecialSymbol, ',');

    // Get allowed parameters
    AllowedParams := [];
    for I := 0 to InstructionInfos.Count - 1 do begin
      if Length(InstructionInfos[I].Params) > J then
        AllowedParams := AllowedParams + [InstructionInfos[I].Params[J]]
        else EmptyParam := True;
    end;

    if AllowedParams <> [] then begin
      ParamOk := False;
      for ParamType := Low(TParamType) to High(TParamType) do begin
        if ParamType in AllowedParams then begin
          LastMessagesCount := Messages.Count;
          ParamMemory.Clear;
          if ParseInstructionParameter(ParamType, ParamMemory) and
            (LastMessagesCount = Messages.Count) then begin
            ParamOk := True;
            InstructionMemory.WriteMemoryPos(ParamMemory);
            Break;
          end else Messages.Count := LastMessagesCount;
        end;
      end;
      if not ParamOk then begin
        if EmptyParam then begin
          ParamType := ptNone;
        end else begin
          Text := '';
          for ParamType := Low(TParamType) to High(TParamType) do begin
            if ParamType in AllowedParams then begin
              if Text <> '' then Text := Text + ' or ';
              Text := Text + ParamTypeString[ParamType]
            end;
          end;

          Error(Format(SExpectedParameterType, [Text]), Parser.Pos.Pos);
          Break;
        end;
      end;
    end;

    // Remove not matching instruction infos
    for I := InstructionInfos.Count - 1 downto 0 do
      if (Length(InstructionInfos[I].Params) > J) and
        (InstructionInfos[I].Params[J] <> ParamType) then InstructionInfos.Delete(I);

    if (InstructionInfos.Count = 1) and (J >= (Length(InstructionInfos[0].Params) - 1)) then begin
      Memory.WritePos(1, Byte(InstructionInfos[0].Instruction));
      Memory.WriteMemoryPos(InstructionMemory);
      Result := True;
      Break;
    end;

    Inc(J);
  until False;

  if not Result then Parser.Pos := LastPos;
  FreeAndNil(ParamMemory);
  FreeAndNil(InstructionMemory);
end;

function TAssembler.ParseInstructionParameter(ParamType: TParamType; Memory: TMemory): Boolean;
var
  LastPos: TParserPos;
  I: Integer;
  RegIndex: TRegIndex;
  Number: TBigInt;
  Token: TToken;
begin
  LastPos := Parser.Pos;
  Result := True;
  case ParamType of
    ptData: begin
      if ParseNumParam(Number) then Memory.WritePos(InstDataWidth, Number)
        else begin
          Error(SExpectedNumber, Parser.Pos.Pos);
          Result := False;
        end;
    end;
    ptAddress: begin
      if ParseNumParam(Number) then Memory.WritePos(InstAddressWidth, Number)
        else begin
          Error(SExpectedNumber, Parser.Pos.Pos);
          Result := False;
        end;
    end;
    ptReg: begin
      if ParseReg(RegIndex) then Memory.WritePos(1, Byte(RegIndex))
        else begin
          Error(SExpectedRegisterName, Parser.Pos.Pos);
          Result := False;
        end;
    end;
    ptRegIndirect: begin
      if not Parser.Expect(tkSpecialSymbol, '(') then Result := False;
      if ParseReg(RegIndex) then Memory.WritePos(1, Byte(RegIndex))
        else begin
          Error(SExpectedRegisterName, Parser.Pos.Pos);
          Result := False;
        end;
      if not Parser.Expect(tkSpecialSymbol, ')') then Result := False;;
    end;
    ptRegIndirectIndex: begin
      if not Parser.Expect(tkSpecialSymbol, '(') then Result := False;
      if ParseReg(RegIndex) then begin
        Memory.WritePos(1, Byte(RegIndex));
        if not Parser.Expect(tkSpecialSymbol, '+') then Result := False;
        if ParseNumParam(Number) then Memory.WritePos(InstAddressWidth, Number)
          else begin
            Error(SExpectedNumericIndex, Parser.Pos.Pos);
            Result := False;
          end;
      end else begin
        Error(SExpectedRegisterName, Parser.Pos.Pos);
        Result := False;
      end;
      if not Parser.Expect(tkSpecialSymbol, ')') then Result := False;
    end;
    ptDataWidth: begin
      if ParseDataWidth(InstDataWidth) then begin
        Memory.WritePos(1, InstDataWidth)
      end else begin
        Error(SExpectedRegisterName, Parser.Pos.Pos);
        Result := False;
      end;
    end;
    ptAddressWidth: begin
      if ParseAddressWidth(InstAddressWidth) then begin
        Memory.WritePos(1, InstAddressWidth)
      end else begin
        Error(SExpectedRegisterName, Parser.Pos.Pos);
        Result := False;
      end;
    end;
    else begin
      Result := False;
      Error(SUnsupportedParameterType, Parser.Pos.Pos);
    end;
  end;
  if not Result then Parser.Pos := LastPos;
end;

function TAssembler.ParseLabel: Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
  Addr: TBigInt;
begin
  Result := False;
  LastPos := Parser.Pos;
  Token := Parser.ReadNext;
  if Parser.CheckNextAndRead(tkSpecialSymbol, ':') then begin
    Result := True;
    if not Labels.TryGetValue(Token.Value, Addr) then begin
      Labels.Add(Token.Value, Memory.Position);
    end else Error(Format(SDuplicateLabel, [Token.Value]), Token.Pos);
  end;
  if not Result then Parser.Pos := LastPos;
end;

procedure TAssembler.LoadFromFile(FileName: string);
var
  Lines: TStringList;
begin
  Lines := TStringList.Create;
  try
    Lines.LoadFromFile(FileName);
    Compile(Lines.Text);
  finally
    Lines.Free;
  end;
end;

function TAssembler.ParseStr(var Text: string; Separator: string): string;
var
  P: Integer;
begin
  P := Pos(Separator, Text);
  if P > 0 then begin
    Result := Trim(Copy(Text, 1, P - 1));
    Text := Trim(Copy(Text, P + 1, MaxInt));
  end else begin
    Result := Trim(Text);
    Text := '';
  end;
end;

constructor TAssembler.Create;
begin
  Parser := TParser.Create;
  Parser.OnError := Error;
  Messages := TMessages.Create;
  Memory := TMemory.Create;
  InstructionSet := TInstructionInfos.Create;
  InstructionSet.Init;
  Labels := TDictionary<string, TBigInt>.Create;
  LabelRefs := TList<TLabelRef>.Create;
  Variables := TDictionary<string, TBigInt>.Create;
end;

destructor TAssembler.Destroy;
begin
  FreeAndNil(Variables);
  FreeAndNil(Labels);
  FreeAndNil(LabelRefs);
  FreeAndNil(InstructionSet);
  FreeAndNil(Memory);
  FreeAndNil(Messages);
  FreeAndNil(Parser);
  inherited;
end;

end.