source: branches/Machine/UCompiler.pas

unit UCompiler;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, Contnrs;

type
  TCodeLabel = class
    Name: string;
    Address: Integer;
  end;

  { TCodeLabels }

  TCodeLabels = class(TObjectList)
    function SearchByName(Name: string): TCodeLabel;
  end;

  TCodeDefine = class
    Name: string;
    Value: string;
  end;

  { TCodeDefines }

  TCodeDefines = class(TObjectList)
    function SearchByName(Name: string): TCodeDefine;
  end;

  { TCompiler }

  TCompiler = class
  private
    Addr: Integer;
    procedure Emit(Value: Integer);
    procedure CompileParamPart(var Indir: Integer; Param: string);
    procedure CompileParam(Num: Integer; Param: string);
    procedure CompileParamDefine(var Indir: Integer; Param: string);
  public
    Code: array of Integer;
    CodeLabels: TCodeLabels;
    CodeDefines: TCodeDefines;
    procedure Compile(Source: TStrings);
    constructor Create;
    destructor Destroy; override;
  end;


implementation

uses
  UMachine;

{ TCodeDefines }

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

{ TCodeLabels }

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

procedure TCompiler.Emit(Value: Integer);
begin
  Code[Addr] := Value;
  Inc(Addr);
end;

procedure TCompiler.CompileParamPart(var Indir: Integer; Param: string);
var
  Value: Integer;
begin
  if Indir = 0 then Emit(Integer(opParamSet))
    else Emit(Integer(opParamIndirect));
  if Indir = 0 then begin
    if TryStrToInt(Param, Value) then Emit(StrToInt(Param))
      else raise Exception.Create('Unsupported parameter value ''' + Param + '''');
  end else begin
    if Param = 'M' then Emit(Integer(atMemory))
    else if Param = 'R' then Emit(Integer(atRegister))
    else if Param = 'P' then Emit(Integer(atIOPort))
    else if Param = 'S' then Emit(Integer(atSysRegister))
    else begin
      if TryStrToInt(Param, Value) then Emit(StrToInt(Param))
        else raise Exception.Create('Unsupported parameter value ''' + Param + '''');
    end;
  end;
  Inc(Indir);
end;

procedure TCompiler.CompileParam(Num: Integer; Param: string);
var
  Part: string;
  I: Integer;
  CodeLabel: TCodeLabel;
  CodeDefine: TCodeDefine;
begin
  Param := Trim(Param);
  if Num = 0 then Emit(Integer(opParamClearAll))
    else Emit(Integer(opParamNext));
  I := 0;
  CodeLabel := CodeLabels.SearchByName(Param);
  if Assigned(CodeLabel) then
    CompileParamPart(I, IntToStr(CodeLabel.Address))
  else begin
    while Pos('^', Param) > 0 do begin
      Part := Copy(Param, 1, Pos('^', Param) - 1);
      Delete(Param, 1, Length(Part) + 1);
      CompileParamDefine(I, Part);
    end;
    CompileParamDefine(I, Param);
  end;
end;

procedure TCompiler.CompileParamDefine(var Indir: Integer; Param: string);
var
  CodeDefine: TCodeDefine;
  Part: string;
begin
  CodeDefine := CodeDefines.SearchByName(Param);
  if Assigned(CodeDefine) then begin
    Param := CodeDefine.Value;
    while Pos('^', Param) > 0 do begin
      Part := Copy(Param, 1, Pos('^', Param) - 1);
      Delete(Param, 1, Length(Part) + 1);
      CompileParamPart(Indir, Part);
    end;
    CompileParamPart(Indir, Param);
  end else
    CompileParamPart(Indir, Param);
end;

procedure TCompiler.Compile(Source: TStrings);
var
  I: Integer;
  Line: string;
  Instruction: string;
  Param1, Param2: string;
  CodeLabel: TCodeLabel;
  CodeDefine: TCodeDefine;
begin
  SetLength(Code, 10000);
  Addr := 0;
  for I := 0 to Source.Count - 1 do begin
    Line := Trim(Source[I]);
    if Pos(' ', Line) > 0 then begin
      Instruction := Copy(Line, 1, Pos(' ', Line) - 1);
      Delete(Line, 1, Length(Instruction) + 1);
    end else Instruction := Line;

    if Instruction = 'CP' then begin
      Param1 := Copy(Line, 1, Pos(',', Line) - 1);
      Delete(Line, 1, Length(Param1) + 1);
      Param2 := Line;
      CompileParam(0, Param1);
      CompileParam(1, Param2);
      Emit(Integer(opCopy));
    end else
    if Instruction = 'ADD' then begin
      if Pos(',', Line) > 0 then begin
        Param1 := Copy(Line, 1, Pos(',', Line) - 1);
        Delete(Line, 1, Length(Param1) + 1);
        Param2 := Line;
        CompileParam(0, Param1);
        CompileParam(1, Param2);
      end else begin
        CompileParam(0, Line);
      end;
      Emit(Integer(opAdd));
    end else
    if Instruction = 'SUB' then begin
      if Pos(',', Line) > 0 then begin
        Param1 := Copy(Line, 1, Pos(',', Line) - 1);
        Delete(Line, 1, Length(Param1) + 1);
        Param2 := Line;
        CompileParam(0, Param1);
        CompileParam(1, Param2);
      end else begin
        CompileParam(0, Line);
      end;
      Emit(Integer(opSub));
    end else
    if Instruction = 'SKIP' then begin
      CompileParam(0, Line);
      Emit(Integer(opSkip));
    end else
    if Instruction = 'HALT' then begin
      Emit(Integer(opHalt));
    end else
    if Instruction = 'LABEL' then begin
      CodeLabel := CodeLabels.SearchByName(Line);
      if Assigned(CodeLabel) then raise Exception.Create('Label ''' + Line + ''' already used')
        else begin
          CodeLabel := TCodeLabel.Create;
          CodeLabel.Name := Line;
          CodeLabel.Address := Addr;
          CodeLabels.Add(CodeLabel);
        end;
    end else
    if Instruction = 'DEF' then begin
      if Pos(' ', Line) > 0 then begin
        Param1 := Copy(Line, 1, Pos(' ', Line) - 1);
        Delete(Line, 1, Length(Param1) + 1);
        Param2 := Line;
      end else begin
        Param1 := Line;
        Param2 := '';
      end;
      CodeDefine := CodeDefines.SearchByName(Line);
      if Assigned(CodeDefine) then raise Exception.Create('Define ''' + Line + ''' already used')
        else begin
          CodeDefine := TCodeDefine.Create;
          CodeDefine.Name := Param1;
          CodeDefine.Value := Param2;
          CodeDefines.Add(CodeDefine);
        end;
    end;
  end;
end;

constructor TCompiler.Create;
begin
  CodeLabels := TCodeLabels.Create;
  CodeDefines := TCodeDefines.Create;
end;

destructor TCompiler.Destroy;
begin
  CodeLabels.Free;
  CodeDefines.Free;
  inherited Destroy;
end;

end.