source: tags/1.3.0/Target.pas

unit Target;

interface

uses
  Classes, SysUtils, StrUtils, Registry, RegistryEx, fgl, 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, rsCompiling);

  TStepOperation = (soNormal, soStepIn, soStepOut);

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

  { TDebugSteps }

  TDebugSteps = class(TFPGObjectList<TDebugStep>)
    function SearchBySourcePos(Pos: Integer): TDebugStep;
    function SearchByProgramPos(Pos: Integer): TDebugStep;
    function SearchByTargetPos(Pos: Integer): TDebugStep;
    function SearchIndexByProgramPos(Pos: Integer): Integer;
    procedure AddStep(SourcePos, TargetPos: Integer; Operation: TStepOperation);
    procedure UpdateTargetPos(OldProgramFrom, OldProgramTo, NewProgramFrom,
        NewProgramTo: Integer; NewTarget: Integer = 0);
  end;

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

  { TBreakPoints }

  TBreakPoints = class(TFPGObjectList<TBreakPoint>)
    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;

  { TMessages }

  TMessages = class(TFPGObjectList<TMessage>)
  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;
  TMessageEvent = procedure (Text: string) of object;

  { TTarget }

  TTarget = class
  private
    FOnLog: TLogEvent;
    FOnMessage: TMessageEvent;
  protected
    FCompiledExtension: string;
    FSourceExtension: string;
    FName: string;
    FImageIndex: Integer;
    FCapabilities: TTargetCapabilities;
    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
    ProgramName: string;
    OptimizationLevel: TCompilerOptimization;
    CompilerPath: string;
    ExecutorPath: string;
    ProjectFileName: string;
    BreakPoints: TBreakPoints;
    DebugSteps: TDebugSteps;
    DebugEnabled: Boolean;
    Selected: Boolean;
    procedure SendMessage(Text: string);
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Reset; virtual;
    procedure OptimizeSource; virtual;
    procedure Compile; virtual;
    procedure CompileToFile; virtual;
    function GetSourceFileName: string; virtual;
    function GetCompileParams: TStringArray; virtual;
    function GetCompileFileName: string; virtual;
    procedure RunFromFile; virtual;
    function GetRunParams: TStringArray; 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 SourceExtension: string read FSourceExtension;
    property CompiledExtension: string read FCompiledExtension;
    property Name: string read FName;
    property ImageIndex: Integer read FImageIndex;
    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 Capabilities: TTargetCapabilities read FCapabilities;
    property OnChangeState: TNotifyEvent read FOnChangeState write FOnChangeState;
    property OnLog: TLogEvent read FOnLog write FOnLog;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  end;

  { TTargets }

  TTargets = class(TFPGObjectList<TTarget>)
    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';
  SStopped = 'Stopped';
  SPaused = 'Paused';
  SRunning = 'Running';
  SCompiling = 'Compiling';
  SNone = 'None';
  SNormal = 'Normal';
  SProgramIndexError = 'Old program index higher than new (old: %d, new: %d)';
  SFirstIndexHigherThanLastIndex = 'First index higher than last index';
  SFirstIndexOutOfRange = 'First index out of range';
  SLastIndexOutOfRange = 'Last index out of range';

const
  CompiledDir = 'compiled';

var
  RunStateText: array[TRunState] of string = (SStopped, SPaused, SRunning,
    SCompiling);
  CompilerOptimizationText: array[TCompilerOptimization] of string = (SNone, SNormal);

procedure UpdateTranslation;


implementation

uses
  FormConsole, Common;

procedure UpdateTranslation;
begin
  RunStateText[rsStopped] := SStopped;
  RunStateText[rsPaused] := SPaused;
  RunStateText[rsRunning] := SRunning;
  RunStateText[rsCompiling] := SCompiling;
  CompilerOptimizationText[coNone] := SNone;
  CompilerOptimizationText[coNormal] := SNormal;
end;

{ TMessages }

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

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

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

{ TBreakPoints }

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

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

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

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

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

{ TDebugSteps }

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

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

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

function TDebugSteps.SearchIndexByProgramPos(Pos: Integer): Integer;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].ProgramPosition < Pos) do Inc(I);
  if I < Count then Result := I
    else Result := -1;
end;

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

procedure TDebugSteps.UpdateTargetPos(OldProgramFrom, OldProgramTo, NewProgramFrom,
  NewProgramTo: Integer; NewTarget: Integer = 0);
var
  I: Integer;
  First: Integer;
  Last: Integer;
begin
  First := SearchIndexByProgramPos(OldProgramFrom);
  Last := SearchIndexByProgramPos(OldProgramTo);
  if (First <> -1) and (Last <> -1) then begin
    if First > Last then
      raise Exception.Create(SFirstIndexHigherThanLastIndex);
    if (First < 0) or (First >= Count) then
      raise Exception.Create(SFirstIndexOutOfRange);
    if (Last < 0) or (Last >= Count) then
      raise Exception.Create(SLastIndexOutOfRange);
    for I := Last downto First + 1 do Delete(I);

    if NewProgramTo - NewProgramFrom = 0 then begin
      Delete(First);
    end else
    if NewProgramTo > NewProgramFrom then begin
      Items[First].ProgramPosition := NewProgramFrom;
      Items[First].TargetPosition := NewTarget;
    end else
      raise Exception.Create(Format(SProgramIndexError, [SProgramIndexError, NewProgramTo]));
  end;
end;

{ TTargets }

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

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

function TTargets.FindByName(Name: string): TTarget;
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;

procedure TTargets.LoadToMenuItem(MenuItem: TMenuItem; Action: TNotifyEvent
  ; CurrentTarget: TTarget);
var
  NewMenuItem: TMenuItem;
  I: Integer;
begin
  if Assigned(MenuItem) then begin
    while MenuItem.Count > Count do
      MenuItem.Delete(MenuItem.Count - 1);
    while MenuItem.Count < Count do begin
      NewMenuItem := TMenuItem.Create(MenuItem);
      MenuItem.Add(NewMenuItem);
    end;
    for I := 0 to Count - 1 do begin
      MenuItem.Items[I].Caption := Items[I].Name;
      MenuItem.Items[I].OnClick := Action;
      MenuItem.Items[I].ImageIndex := Items[I].ImageIndex;
      if Items[I] = CurrentTarget then MenuItem.Items[I].Checked := True;
    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.SendMessage(Text: string);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Text);
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 UNIX}
  Result := StringReplace(FileName, ' ', '\ ', [rfReplaceAll]);
  {$ENDIF}
end;

constructor TTarget.Create;
begin
  inherited;
  OptimizationLevel := coNormal;
  BreakPoints := TBreakPoints.Create;
  DebugSteps := TDebugSteps.Create;
end;

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

procedure TTarget.Reset;
begin
end;

procedure TTarget.OptimizeSource;
begin
end;

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

procedure TTarget.CompileToFile;
var
  SourceFile: string;
  Lines: TStringList;
  Output, Error: string;
  Executable: string;
  Parameters: array of string;
begin
  SourceFile := GetSourceFileName;
  ForceDirectories(ExtractFilePath(SourceFile));
  with TStringList.Create do
  try
    Text := FTargetCode;
    SaveToFile(SourceFile);
  finally
    Free;
  end;
  if CompilerPath <> '' then begin;
    if FileExists(CompilerPath) then begin
      Executable := LongFileName(CompilerPath);
      Parameters := GetCompileParams;

      ExecuteProgramOutput(Executable, GetCompileParams, GetEnvironmentVariables,
        Output, Error, ExitCode, ExtractFilePath(SourceFile));

      if Assigned(FOnLog) then begin
        Lines := TStringList.Create;
        Lines.Text := Output;
        Lines.Insert(0, Executable + ' ' + Implode(',', Parameters));
        FOnLog(Lines);
        Lines.Free;
      end;

    end else raise Exception.Create(Format(SCompilerNotFound, [CompilerPath]));
  end;
end;

function TTarget.GetSourceFileName: string;
begin
  Result := ExtractFilePath(ProjectFileName) +
    CompiledDir + DirectorySeparator + Name + DirectorySeparator +
    ExtractFileNameOnly(ProjectFileName) + SourceExtension;
  if not DirectoryIsWritable(ExtractFilePath(Result)) then
    Result := GetAppConfigDir(False) + CompiledDir + DirectorySeparator + Name +
      DirectorySeparator + ExtractFileNameOnly(ProjectFileName) + SourceExtension;;
end;

function TTarget.GetCompileParams: TStringArray;
begin
  Result := [LongFileName(GetSourceFileName)];
end;

function TTarget.GetCompileFileName: string;
begin
  Result := ExtractFilePath(ProjectFileName) +
    CompiledDir + DirectorySeparator + Name + DirectorySeparator +
    ExtractFileNameOnly(ProjectFileName) + CompiledExtension;
  if not DirectoryIsWritable(ExtractFilePath(Result)) then
    Result := GetAppConfigDir(False) + CompiledDir + DirectorySeparator + Name +
      DirectorySeparator + ExtractFileNameOnly(ProjectFileName) + CompiledExtension;
end;

procedure TTarget.RunFromFile;
var
  CompiledFile: string;
  FormConsole: TFormConsole;
  Parameters: TStringArray;
  I: Integer;
begin
  CompiledFile := GetCompileFileName;
  if FileExists(CompiledFile) then
  try
    FormConsole := TFormConsole.Create(nil);
    if ExecutorPath <> '' then begin
      if not FileExists(ExecutorPath) then
        raise Exception.Create(Format(SExecutorNotFound, [ExecutorPath]));
      FormConsole.Executable := LongFileName(ExecutorPath);
      Parameters := GetRunParams;
      for I := 0 to Length(Parameters) - 1 do
        FormConsole.Parameters.Add(Parameters[I]);
    end else
      FormConsole.Executable := LongFileName(CompiledFile);
    FormConsole.ShowModal;
  finally
    FormConsole.Free;
  end
  else raise Exception.Create(Format(SCompiledFileNotFound, [CompiledFile]));
end;

function TTarget.GetRunParams: TStringArray;
begin
  Result := [LongFileName(GetCompileFileName)];
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);
    Selected := ReadBoolWithDefault('Selected', Selected);
  finally
    Free;
  end;
end;

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

procedure TTarget.LoadProgram;
begin
end;

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

end.