source: branches/UltimatOS/UAssembler.pas

unit UAssembler;

interface

uses
  Classes, SysUtils, Generics.Collections, UMemory, UCpu;

type
  TInstructionParam = (ipNone, ipRegIndex, ipAddress, ipData, ipIndex,
    ipRegIndexRel, ipAddressRel);

  TInstructionDef = class
    Code: TInstruction;
    Name: string;
    Param1: TInstructionParam;
    Param2: TInstructionParam;
  end;

  { TInstructionDefs }

  TInstructionDefs = class(TObjectList<TInstructionDef>)
    function AddNew(Code: TInstruction; Name: string; Param1: TInstructionParam = ipNone;
      Param2: TInstructionParam = ipNone): TInstructionDef;
    function SearchByName(Name: string): TInstructionDef;
  end;

  { TLabel }

  TLabel = class
    Name: string;
    Address: TAddress;
    ForwardRefs: array of TAddress;
    procedure AddForwardRef(Address: TAddress);
  end;

  { TLabels }

  TLabels = class(TObjectList<TLabel>)
    function AddNew(Name: string; Address: TAddress): TLabel;
    function SearchByName(Name: string): TLabel;
  end;

  TConstant = class
    Name: string;
    Value: Integer;
  end;

  { TConstants }

  TConstants = class(TObjectList<TConstant>)
    function AddNew(Name: string; Value: Integer): TConstant;
    function SearchByName(Name: string): TConstant;
  end;

  { TAssembler }

  TAssembler = class
  private
    InstructionDefs: TInstructionDefs;
    Labels: TLabels;
    Constants: TConstants;
    LineNumber: Integer;
    function ParseText(var Text: string; Separator: Char): string;
    function ParseConst(Text: string; out Value: Integer): Boolean;
    function ParseLabel(Text: string; out Value: Integer): Boolean;
    function ParseNumber(Text: string; out Value: Integer): Boolean;
    procedure WriteParam(Param: TInstructionParam; var Text: string);
    procedure Error(Text: string);
  public
    Memory: TMemory;
    IP: Integer;
    procedure Parse(Lines: TStrings);
    procedure ParseLine(Text: string);
    procedure WriteInstruction(Instruction: TInstruction);
    procedure WriteAddress(Address: TAddress);
    procedure WriteData(Data: TData);
    procedure WriteIndex(Index: Byte);
    procedure WriteReg(Index: Byte);
    procedure WriteByte(Value: Byte);
    procedure WriteWord(Value: Word);
    procedure WriteCardinal(Value: Cardinal);
    constructor Create;
    destructor Destroy; override;
  end;

implementation

{ TLabel }

procedure TLabel.AddForwardRef(Address: TAddress);
begin
  SetLength(ForwardRefs, Length(ForwardRefs) + 1);
  ForwardRefs[Length(ForwardRefs) - 1] := Address;
end;

{ TConstants }

function TConstants.AddNew(Name: string; Value: Integer): TConstant;
begin
  Result := TConstant.Create;
  Result.Name := Name;
  Result.Value := Value;
  Add(Result);
end;

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

{ TLabels }

function TLabels.AddNew(Name: string; Address: TAddress): TLabel;
begin
  Result := TLabel.Create;
  Result.Name := Name;
  Result.Address := Address;
  Add(Result);
end;

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;

{ TInstructionDefs }

function TInstructionDefs.AddNew(Code: TInstruction; Name: string;
  Param1: TInstructionParam; Param2: TInstructionParam): TInstructionDef;
begin
  Result := TInstructionDef.Create;
  Result.Code := Code;
  Result.Name := Name;
  Result.Param1 := Param1;
  Result.Param2 := Param2;
  Add(Result);
end;

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


{ TAssembler }

function TAssembler.ParseText(var Text: string; Separator: Char
  ): string;
var
  I: Integer;
begin
  I := Pos(Separator, Text);
  if I > 0 then begin
    Result := Copy(Text, 1, I - 1);
    Delete(Text, 1, I);
  end else begin
    Result := Text;
    Text := '';
  end;
end;

function TAssembler.ParseConst(Text: string; out Value: Integer): Boolean;
var
  FoundConstant: TConstant;
begin
  FoundConstant := Constants.SearchByName(UpperCase(Text));
  if Assigned(FoundConstant) then begin
    Result := True;
    Value := FoundConstant.Value;
  end;
  Result := False;
end;

function TAssembler.ParseLabel(Text: string; out Value: Integer): Boolean;
var
  FoundLabel: TLabel;
begin
  Result := True;
  FoundLabel := Labels.SearchByName(UpperCase(Text));
  if Assigned(FoundLabel) then begin
    // Existing label
    if FoundLabel.Address = -1 then begin
      FoundLabel.AddForwardRef(IP);
      Value := 0;
    end else
      Value := FoundLabel.Address;
  end else begin
    // Forward label reference
    with Labels.AddNew(UpperCase(Text), -1) do begin
      AddForwardRef(IP);
    end;
    Value := 0;
  end;
end;

function TAssembler.ParseNumber(Text: string; out Value: Integer): Boolean;
begin
  if TryStrToInt(Text, Value) then begin
    Result := True;
  end else
    Result := False;
end;

procedure TAssembler.WriteParam(Param: TInstructionParam; var Text: string);
var
  Address: string;
  FoundLabel: TLabel;
  FoundConstant: TConstant;
  Value: Integer;
begin
  case Param of
    ipAddress: begin
      Address := Trim(ParseText(Text, ','));
      if TryStrToInt(Address, Value) then begin
        WriteAddress(Value);
      end else begin
        FoundConstant := Constants.SearchByName(UpperCase(Address));
        if Assigned(FoundConstant) then begin
          WriteAddress(FoundConstant.Value);
          Exit;
        end;
        ParseLabel(Address, Value);
        WriteAddress(Value);
      end;
    end;
    ipAddressRel: begin
      Address := Trim(ParseText(Text, ','));
      if Address.StartsWith('(') and Address.EndsWith(')') then begin
        Address := Copy(Address, 2, Length(Address) - 2);
        if TryStrToInt(Address, Value) then begin
          WriteAddress(Value);
        end else begin
          FoundConstant := Constants.SearchByName(UpperCase(Address));
          if Assigned(FoundConstant) then begin
            WriteAddress(FoundConstant.Value);
            Exit;
          end;
          ParseLabel(Address, Value);
          WriteAddress(Value);
        end;
      end else Error('Expected indirect address ' + Address);
    end;
    ipRegIndex: begin
      Address := Trim(ParseText(Text, ','));
      if Address.StartsWith('R') then begin
        WriteReg(StrToInt(Copy(Address, 2, MaxInt)));
      end else Error('Expected register ' + Address);
    end;
    ipRegIndexRel: begin
      Address := Trim(ParseText(Text, ','));
      if Address.StartsWith('(') and Address.EndsWith(')') then begin
        Address := Copy(Address, 2, Length(Address) - 2);
        if Address.StartsWith('R') then begin
          WriteReg(StrToInt(Copy(Address, 2, MaxInt)));
        end else Error('Expected register ' + Address);
      end else Error('Expected indirect address ' + Address);
    end;
    ipData: begin
      Address := Trim(ParseText(Text, ','));
      if TryStrToInt(Address, Value) then begin
        WriteData(Value);
      end else begin
        FoundConstant := Constants.SearchByName(UpperCase(Address));
        if Assigned(FoundConstant) then begin
          WriteData(FoundConstant.Value);
          Exit;
        end;
        ParseLabel(Address, Value);
        WriteData(Value);
      end;
    end;
    ipIndex: begin
      Address := Trim(ParseText(Text, ','));
      if TryStrToInt(Address, Value) then begin
        WriteIndex(Value);
      end else begin
        FoundConstant := Constants.SearchByName(UpperCase(Address));
        if Assigned(FoundConstant) then begin
          WriteIndex(FoundConstant.Value);
        end else Error('Unknown constant ' + Address);
      end;
    end;
  end;
end;

procedure TAssembler.Error(Text: string);
begin
  raise Exception.Create(IntToStr(LineNumber) + ': ' + Text);
end;

procedure TAssembler.Parse(Lines: TStrings);
var
  I: Integer;
begin
  for I := 0 to Lines.Count - 1 do begin
    LineNumber := I + 1;
    ParseLine(Lines[I]);
  end;
  for I := 0 to Labels.Count - 1 do begin
    if Length(Labels[I].ForwardRefs) > 0 then
      Error('Forward reference not satisfied ' + Labels[I].Name);
  end;
end;

procedure TAssembler.ParseLine(Text: string);
var
  FoundLabel: TLabel;
  FoundConstant: TConstant;
  LabelName: string;
  InstructionName: string;
  InstructionDef: TInstructionDef;
  I: Integer;
  ConstName: string;
  ConstValue: string;
  Lines: TStringList;
  Param: string;
  Num: Integer;
begin
  // Remove comments
  I := Pos(';', Text);
  if I > 0 then begin
    Text := Trim(Copy(Text, 1, I - 1));
  end;

  // Process labels
  if Pos(':', Text) > 0 then begin
    LabelName := Trim(ParseText(Text, ':'));
    FoundLabel := Labels.SearchByName(UpperCase(LabelName));
    if not Assigned(FoundLabel) then begin
      Labels.AddNew(UpperCase(LabelName), IP);
    end else begin
      if Length(FoundLabel.ForwardRefs) > 0 then begin
        FoundLabel.Address := IP;
        // Update forward references
        for I := 0 to Length(FoundLabel.ForwardRefs) - 1 do
          PAddress(@Memory.Data[FoundLabel.ForwardRefs[I]])^ := IP;
        SetLength(FoundLabel.ForwardRefs, 0);
      end else
        Error('Duplicate label ' + LabelName);
    end;
  end;
  Text := Trim(Text);
  InstructionName := Trim(ParseText(Text, ' '));
  if InstructionName.StartsWith('.') then begin
    InstructionName := Copy(InstructionName, 2, MaxInt);
    if InstructionName = 'const' then begin
      ConstName := Trim(ParseText(Text, ' '));
      ConstValue := Trim(Text);
      FoundConstant := Constants.SearchByName(UpperCase(ConstName));
      if Assigned(FoundConstant) then begin
        FoundConstant.Value := StrToInt(ConstValue);
      end else begin
        Constants.AddNew(UpperCase(ConstName), StrToInt(ConstValue));
      end;
    end else
    if InstructionName = 'include' then begin
      if FileExists(Text) then begin
        Lines := TStringList.Create;
        try
          Lines.LoadFromFile(Text);
          Parse(Lines);
        finally
          Lines.Free;
        end;
      end else Error('File ' + Text + ' doesn''t exist');
    end else
    if InstructionName = 'db' then begin
      while Text <> '' do begin
        Param := ParseText(Text, ',');
        if Param.StartsWith('"') and Param.EndsWith('"') then begin
          Param := Copy(Param, 2, Length(Param) - 2);
          for I := 1 to Length(Param) do
            WriteByte(Ord(Param[I]));
        end else WriteByte(StrToInt(Param));
      end;
    end else
    if InstructionName = 'dw' then begin
      while Text <> '' do begin
        Param := ParseText(Text, ',');
        if Param.StartsWith('"') and Param.EndsWith('"') then begin
          Param := Copy(Param, 2, Length(Param) - 2);
          for I := 1 to Length(Param) do
            WriteWord(Ord(Param[I]));
        end else WriteWord(StrToInt(Param));
      end;
    end else
    if InstructionName = 'dd' then begin
      while Text <> '' do begin
        Param := Trim(ParseText(Text, ','));
        if Param.StartsWith('"') and Param.EndsWith('"') then begin
          Param := Copy(Param, 2, Length(Param) - 2);
          for I := 1 to Length(Param) do
            WriteCardinal(Ord(Param[I]));
        end else begin
          if ParseNumber(Param, Num) then
            WriteCardinal(Num)
          else if ParseConst(Param, Num) then
            WriteCardinal(Num)
          else if ParseLabel(Param, Num) then
            WriteCardinal(Num);
        end;
      end;
    end else
    if InstructionName = 'org' then begin
      IP := StrToInt(Text);
    end else Error('Unsupported directive name ' + InstructionName);
  end else begin
    InstructionDef := InstructionDefs.SearchByName(UpperCase(InstructionName));
    if Assigned(InstructionDef) then begin
      WriteInstruction(InstructionDef.Code);
      WriteParam(InstructionDef.Param1, Text);
      WriteParam(InstructionDef.Param2, Text);
    end else begin
      if InstructionName <> '' then
        Error('Unknown instruction ' + InstructionName);
    end;
  end;
end;

procedure TAssembler.WriteInstruction(Instruction: TInstruction);
begin
  Memory.Data[IP] := Byte(Instruction);
  Inc(IP);
end;

procedure TAssembler.WriteAddress(Address: TAddress);
begin
  PAddress(@Memory.Data[IP])^ := Address;
  Inc(IP, SizeOf(TAddress));
end;

procedure TAssembler.WriteData(Data: TData);
begin
  PData(@Memory.Data[IP])^ := Data;
  Inc(IP, SizeOf(TData));
end;

procedure TAssembler.WriteIndex(Index: Byte);
begin
  Memory.Data[IP] := Index;
  Inc(IP);
end;

procedure TAssembler.WriteReg(Index: Byte);
begin
  Memory.Data[IP] := Index;
  Inc(IP);
end;

procedure TAssembler.WriteByte(Value: Byte);
begin
  Memory.Data[IP] := Value;
  Inc(IP);
end;

procedure TAssembler.WriteWord(Value: Word);
begin
  PWord(@Memory.Data[IP])^ := Value;
  Inc(IP, SizeOf(Word));
end;

procedure TAssembler.WriteCardinal(Value: Cardinal);
begin
  PCardinal(@Memory.Data[IP])^ := Value;
  Inc(IP, SizeOf(Cardinal));
end;

constructor TAssembler.Create;
begin
  Labels := TLabels.Create;
  Constants := TConstants.Create;
  InstructionDefs := TInstructionDefs.Create;
  with InstructionDefs do begin
    AddNew(inNop, 'NOP');
    AddNew(inHalt, 'HALT');
    AddNew(inSet, 'SET', ipRegIndex, ipData);
    AddNew(inInput, 'IN', ipRegIndex, ipAddressRel);
    AddNew(inOutput, 'OUT', ipAddressRel, ipRegIndex);
    AddNew(inInc, 'INC', ipRegIndex);
    AddNew(inDec, 'DEC', ipRegIndex);
    AddNew(inAdd, 'ADD', ipRegIndex, ipRegIndex);
    AddNew(inSub, 'SUB', ipRegIndex, ipRegIndex);
    AddNew(inJp, 'JP', ipAddress);
    AddNew(inJpz, 'JPZ', ipRegIndex, ipAddress);
    AddNew(inJpnz, 'JPNZ', ipRegIndex, ipAddress);
    AddNew(inCall, 'CALL', ipAddress);
    AddNew(inRet, 'RET');
    AddNew(inPush, 'PUSH', ipRegIndex);
    AddNew(inPop, 'POP', ipRegIndex);
    AddNew(inCopy, 'COPY', ipRegIndex, ipRegIndex);
    AddNew(inShl, 'SHL', ipRegIndex, ipIndex);
    AddNew(inShr, 'SHR', ipRegIndex, ipIndex);
    AddNew(inLoad, 'LD', ipRegIndex, ipRegIndexRel);
    AddNew(inLoadi, 'LDI', ipRegIndex, ipAddressRel);
    AddNew(inStore, 'ST', ipRegIndexRel, ipRegIndex);
    AddNew(inMul, 'MUL', ipRegIndex, ipRegIndex);
    AddNew(inAnd, 'AND', ipRegIndex, ipRegIndex);
    AddNew(inAndi, 'ANDI', ipRegIndex, ipData);
    AddNew(inOr, 'OR', ipRegIndex, ipRegIndex);
    AddNew(inXor, 'XOR', ipRegIndex, ipRegIndex);
    AddNew(inInt, 'INT', ipIndex);
    AddNew(inReti, 'RETI');
    AddNew(inEnableInt, 'EI');
    AddNew(inDisableInt, 'DI');
  end;
end;

destructor TAssembler.Destroy;
begin
  FreeAndNil(InstructionDefs);
  FreeAndNil(Constants);
  FreeAndNil(Labels);
  inherited;
end;

end.