source: tags/1.0.0/UTarget.pas

unit UTarget;

{$mode Delphi}{$H+}

interface

uses
  Classes, SysUtils, StrUtils, Registry, URegistry, SpecializedList, Dialogs,
  FileUtil, Process, Menus, LazFileUtils;

type
  TCompilerOptimization = (coNone, coNormal);

  TTargetCapability = (tcRun, tcPause, tcStop, tcStepOut, tcStepOver, tcStepInto,
    tcRunToCursor, tcCompile, tcBreakpoint);
  TTargetCapabilities = set of TTargetCapability;

  TRunState = (rsStopped, rsPaused, rsRunning);

  TStepOperation = (soNormal, soStepIn, soStepOut);

  TDebugStep = class
    SourcePosition: Integer;
    TargetPosition: Integer;
    Operation: TStepOperation;
  end;

  { TDebugStepList }

  TDebugStepList = class(TListObject)
    function SearchBySourcePos(Pos: Integer): TDebugStep;
    function SearchByTargetPos(Pos: Integer): TDebugStep;
    procedure AddStep(SourcePos, TargetPos: Integer; Operation: TStepOperation);
    procedure UpdateTargetPos(Old, New: Integer);
  end;

  TBreakPoint = class
    TargetAddress: Integer;
    System: Boolean;
  end;

  { TBreakPointList }

  TBreakPointList = class(TListObject)
    procedure AddItem(TargetAddress: Integer);
    procedure SetSystem(TargetAddress: Integer);
    procedure AddSystem(TargetAddress: Integer);
    procedure ClearSystem;
    function SearchByTargetPos(Pos: Integer): TBreakPoint;
  end;

  TMessage = class
    Text: string;
    Position: TPoint;
  end;

  { TMessageList }

  TMessageList = class(TListObject)
  private
    FOnChange: TNotifyEvent;
    procedure DoChange;
  public
    procedure AddMessage(Text: string);
    procedure AppendMessage(Text: string);
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TLogEvent = procedure (Lines: TStrings) of object;

  { TTarget }

  TTarget = class
  private
    FOnLog: TLogEvent;
  protected
    FCompiled: Boolean;
    function SourceReadNext: Char;
  protected
    FSourceCode: string;
    FTargetCode: string;
    FTargetIndex: Integer;
    Indent: Integer;
    FState: TRunState;
    FOnChangeState: TNotifyEvent;
    procedure LoadProgram; virtual;
    procedure SetSourceCode(AValue: string); virtual;
    function GetTargetCode: string; virtual;
    procedure AddLine(Text: string = '');
    function LongFileName(FileName: string): string;
    function GetExecutionPosition: Integer; virtual;
    procedure SetState(AValue: TRunState); virtual;
  public
    Name: string;
    ProgramName: string;
    ImageIndex: Integer;
    OptimizationLevel: TCompilerOptimization;
    CompilerPath: string;
    ExecutorPath: string;
    SourceExtension: string;
    RunExtension: string;
    CompiledExtension: string;
    ProjectFileName: string;
    Capabilities: TTargetCapabilities;
    BreakPoints: TBreakPointList;
    DebugSteps: TDebugStepList;
    Messages: TMessageList;
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Reset; virtual;
    procedure OptimizeSource; virtual;
    procedure Compile; virtual;
    procedure CompileToFile; virtual;
    procedure RunFromFile; virtual;
    procedure Run; virtual;
    procedure Pause; virtual;
    procedure Stop; virtual;
    procedure StepOver; virtual;
    procedure StepInto; virtual;
    procedure StepOut; virtual;
    procedure RunToCursor(Pos: Integer); virtual;
    procedure LoadFromRegistry(Context: TRegistryContext); virtual;
    procedure SaveToRegistry(Context: TRegistryContext); virtual;
    property State: TRunState read FState write SetState;
    property SourceCode: string write SetSourceCode;
    property TargetCode: string read GetTargetCode;
    property Compiled: Boolean read FCompiled write FCompiled;
    property ExecutionPosition: Integer read GetExecutionPosition;
    property OnChangeState: TNotifyEvent read FOnChangeState write FOnChangeState;
    property OnLog: TLogEvent read FOnLog write FOnLog;
  end;

  { TTargetList }

  TTargetList = class(TListObject)
    procedure LoadFromRegistry(Context: TRegistryContext);
    procedure SaveToRegistry(Context: TRegistryContext);
    function FindByName(Name: string): TTarget;
    procedure LoadToMenuItem(MenuItem: TMenuItem; Action: TNotifyEvent;
      CurrentTarget: TTarget);
  end;


resourcestring
  SCompilerNotFound = 'Compiler "%s" not found';
  SExecutorNotFound = 'Executor "%s" not found';
  SCompiledFileNotFound = 'Program compiled file "%s" not found';


implementation

{ TMessageList }

procedure TMessageList.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TMessageList.AddMessage(Text: string);
var
  NewItem: TMessage;
begin
  NewItem := TMessage.Create;
  NewItem.Text := Text;
  Add(NewItem);
  DoChange;
end;

procedure TMessageList.AppendMessage(Text: string);
begin
  if Count > 0 then begin
    TMessage(Last).Text := TMessage(Last).Text + Text;
    DoChange;
  end else AddMessage(Text);
end;

{ TBreakPointList }

procedure TBreakPointList.AddItem(TargetAddress: Integer);
var
  NewItem: TBreakPoint;
begin
  NewItem := TBreakPoint.Create;
  NewItem.TargetAddress := TargetAddress;
  Add(NewItem);
end;

procedure TBreakPointList.SetSystem(TargetAddress: Integer);
begin
  ClearSystem;
  AddSystem(TargetAddress);
end;

procedure TBreakPointList.AddSystem(TargetAddress: Integer);
var
  NewItem: TBreakPoint;
begin
  NewItem := TBreakPoint.Create;
  NewItem.TargetAddress := TargetAddress;
  NewItem.System := True;
  Add(NewItem);
end;

procedure TBreakPointList.ClearSystem;
var
  I: Integer;
begin
  for I := Count - 1 downto 0 do
    if TBreakPoint(Items[I]).System then Delete(I);
end;

function TBreakPointList.SearchByTargetPos(Pos: Integer): TBreakPoint;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TBreakPoint(Items[I]).TargetAddress < Pos) do Inc(I);
  if I < Count then Result := TBreakPoint(Items[I])
    else Result := nil;
end;

{ TDebugStepList }

function TDebugStepList.SearchBySourcePos(Pos: Integer
  ): TDebugStep;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TDebugStep(Items[I]).SourcePosition < Pos) do Inc(I);
  if I < Count then Result := TDebugStep(Items[I])
    else Result := nil;
end;

function TDebugStepList.SearchByTargetPos(Pos: Integer
  ): TDebugStep;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TDebugStep(Items[I]).TargetPosition < Pos) do Inc(I);
  if I < Count then Result := TDebugStep(Items[I])
    else Result := nil;
end;

procedure TDebugStepList.AddStep(SourcePos, TargetPos: Integer;
  Operation: TStepOperation);
var
  NewItem: TDebugStep;
begin
  NewItem := TDebugStep.Create;
  NewItem.SourcePosition := SourcePos;
  NewItem.TargetPosition := TargetPos;
  NewItem.Operation := Operation;
  Add(NewItem);
end;

procedure TDebugStepList.UpdateTargetPos(Old, New: Integer);
var
  I: Integer;
begin
  I := 0;
  while (I < Count) do begin
    if TDebugStep(Items[I]).TargetPosition = Old then
      TDebugStep(Items[I]).TargetPosition := New;
    Inc(I);
  end;
end;


{ TTargetList }

procedure TTargetList.LoadFromRegistry(Context: TRegistryContext);
var
  I: Integer;
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    for I := 0 to Count - 1 do
      TTarget(Items[I]).LoadFromRegistry(TRegistryContext.Create(Context.RootKey, Context.Key + '\' + TTarget(Items[I]).Name));
  finally
    Free;
  end;
end;

procedure TTargetList.SaveToRegistry(Context: TRegistryContext);
var
  I: Integer;
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    for I := 0 to Count - 1 do
    with TTarget(Items[I]) do
      TTarget(Items[I]).SaveToRegistry(TRegistryContext.Create(Context.RootKey, Context.Key + '\' + TTarget(Items[I]).Name));
  finally
    Free;
  end;
end;

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

procedure TTargetList.LoadToMenuItem(MenuItem: TMenuItem; Action: TNotifyEvent
  ; CurrentTarget: TTarget);
var
  NewMenuItem: TMenuItem;
  I: Integer;
begin
  if Assigned(MenuItem) then begin
    MenuItem.Clear;
    for I := 0 to Count - 1 do begin
      NewMenuItem := TMenuItem.Create(MenuItem);
      NewMenuItem.Caption := TTarget(Items[I]).Name;
      NewMenuItem.OnClick := Action;
      NewMenuItem.ImageIndex := TTarget(Items[I]).ImageIndex;
      if TTarget(Items[I]) = CurrentTarget then NewMenuItem.Checked := True;
      MenuItem.Add(NewMenuItem);
    end;
  end;
end;

{ TTarget }

function TTarget.GetTargetCode: string;
begin
  Result := FTargetCode;
end;

function TTarget.GetExecutionPosition: Integer;
begin
  Result := 0;
end;

procedure TTarget.SetState(AValue: TRunState);
begin
  if FState = AValue then Exit;
  FState := AValue;
end;

procedure TTarget.SetSourceCode(AValue: string);
begin
  FSourceCode := AValue;
end;

procedure TTarget.AddLine(Text: string = '');
begin
  FTargetCode := FTargetCode + DupeString('  ', Indent) + Text + LineEnding;
end;

function TTarget.LongFileName(FileName: string): string;
begin
  Result := FileName;
  {$IFDEF Windows}
  Result := '"' + FileName + '"';
  {$ENDIF}
  {$IFDEF Linux}
  Result := StringReplace(FileName, ' ', '\ ', [rfReplaceAll]);
  {$ENDIF}
end;

constructor TTarget.Create;
begin
  inherited;
  OptimizationLevel := coNormal;
  BreakPoints := TBreakPointList.Create;
  DebugSteps := TDebugStepList.Create;
  Messages := TMessageList.Create;
end;

destructor TTarget.Destroy;
begin
  FreeAndNil(Messages);
  FreeAndNil(DebugSteps);
  FreeAndNil(BreakPoints);
  inherited Destroy;
end;

procedure TTarget.Reset;
begin
  Messages.Clear;
end;

procedure TTarget.OptimizeSource;
begin
end;

procedure TTarget.Compile;
begin
  LoadProgram;
  if OptimizationLevel = coNormal then OptimizeSource;
  Compiled := True;
end;

procedure TTarget.CompileToFile;
var
  Process: TProcess;
  CompiledFile: string;
  Lines: TStringList;
  I: Integer;
begin
  CompiledFile := ExtractFilePath(ProjectFileName) +
    'compiled' + DirectorySeparator + Name + DirectorySeparator +
    ExtractFileNameOnly(ProjectFileName) + SourceExtension;
  ForceDirectoriesUTF8(ExtractFilePath(CompiledFile));
  with TStringList.Create do
  try
    Text := FTargetCode;
    SaveToFile(CompiledFile);
  finally
    Free;
  end;
  if FileExistsUTF8(CompilerPath) then
    try
      Process := TProcess.Create(nil);
      Process.CurrentDirectory := ExtractFilePath(CompiledFile);
      Process.Executable := LongFileName(CompilerPath);
      Process.Parameters.Add(LongFileName(CompiledFile));
      for I := 0 to GetEnvironmentVariableCount - 1 do
        Process.Environment.Add(GetEnvironmentString(I));
      Process.Options := [poWaitOnExit, poUsePipes];
      Process.Execute;
      if Assigned(FOnLog) then begin
        Lines := TStringList.Create;
        Lines.LoadFromStream(Process.Output);
        Lines.Insert(0, Process.Executable + ' ' + Process.Parameters.Text);
        FOnLog(Lines);
        Lines.Free;
      end;
    finally
      Process.Free;
    end else raise Exception.Create(Format(SCompilerNotFound, [CompilerPath]));
end;

procedure TTarget.RunFromFile;
var
  Process: TProcess;
  CompiledFile: string;
  RunFile: string;
begin
  if ExecutorPath = '' then Exit;

  CompiledFile := ExtractFilePath(ProjectFileName) +
    'compiled' + DirectorySeparator + Name + DirectorySeparator +
    ExtractFileNameOnly(ProjectFileName) + CompiledExtension;
  RunFile := ExtractFilePath(ProjectFileName) +
    'compiled' + DirectorySeparator + Name + DirectorySeparator +
    ExtractFileNameOnly(ProjectFileName) + RunExtension;
  if not FileExistsUTF8(ExecutorPath) then
    raise Exception.Create(Format(SExecutorNotFound, [ExecutorPath]));
  if FileExistsUTF8(CompiledFile) then
  try
    Process := TProcess.Create(nil);
    if ExecutorPath <> '' then begin
      Process.Executable := LongFileName(ExecutorPath);
      Process.Parameters.Add(LongFileName(RunFile));
    end else Process.Executable := LongFileName(RunFile);
    Process.ShowWindow := swoShow;
    Process.Options := [poWaitOnExit, poNewConsole];
    Process.Execute;
  finally
    Process.Free;
  end else raise Exception.Create(Format(SCompiledFileNotFound, [CompiledFile]));
end;

procedure TTarget.Run;
begin
end;

procedure TTarget.Pause;
begin

end;

procedure TTarget.Stop;
begin
end;

procedure TTarget.StepOver;
begin

end;

procedure TTarget.StepInto;
begin

end;

procedure TTarget.StepOut;
begin

end;

procedure TTarget.RunToCursor(Pos: Integer);
begin

end;

procedure TTarget.LoadFromRegistry(Context: TRegistryContext);
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    CompilerPath := ReadStringWithDefault('CompilerPath', CompilerPath);
    ExecutorPath := ReadStringWithDefault('ExecutorPath', ExecutorPath);
  finally
    Free;
  end;
end;

procedure TTarget.SaveToRegistry(Context: TRegistryContext);
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    if CompilerPath <> '' then WriteString('CompilerPath', CompilerPath)
      else DeleteValue('CompilerPath');
    if ExecutorPath <> '' then WriteString('ExecutorPath', ExecutorPath)
      else DeleteValue('ExecutorPath');
  finally
    Free;
  end;
end;

procedure TTarget.LoadProgram;
begin
end;

function TTarget.SourceReadNext: Char;
begin
  Result := ' ';
end;

end.