source: trunk/UTarget.pas @ 114

Last change on this file since 114 was 114, checked in by chronos, 15 months ago
  • Modified: Improved stepping through source and target code. Each step has source, program and target index.
File size: 14.0 KB
Line 
1unit UTarget;
2
3{$mode Delphi}{$H+}
4
5interface
6
7uses
8  Classes, SysUtils, StrUtils, Registry, URegistry, fgl, Dialogs,
9  FileUtil, Process, Menus, LazFileUtils;
10
11type
12  TCompilerOptimization = (coNone, coNormal);
13
14  TTargetCapability = (tcRun, tcPause, tcStop, tcStepOut, tcStepOver, tcStepInto,
15    tcRunToCursor, tcCompile, tcBreakpoint);
16  TTargetCapabilities = set of TTargetCapability;
17
18  TRunState = (rsStopped, rsPaused, rsRunning);
19
20  TStepOperation = (soNormal, soStepIn, soStepOut);
21
22  TDebugStep = class
23    SourcePosition: Integer;
24    ProgramPosition: Integer;
25    TargetPosition: Integer;
26    Operation: TStepOperation;
27  end;
28
29  { TDebugStepList }
30
31  TDebugStepList = class(TFPGObjectList<TDebugStep>)
32    function SearchBySourcePos(Pos: Integer): TDebugStep;
33    function SearchByProgramPos(Pos: Integer): TDebugStep;
34    function SearchByTargetPos(Pos: Integer): TDebugStep;
35    function SearchIndexByProgramPos(Pos: Integer): Integer;
36    procedure AddStep(SourcePos, TargetPos: Integer; Operation: TStepOperation);
37    procedure UpdateTargetPos(OldProgramFrom, OldProgramTo, NewProgram, NewTarget: Integer);
38  end;
39
40  TBreakPoint = class
41    TargetAddress: Integer;
42    System: Boolean;
43  end;
44
45  { TBreakPointList }
46
47  TBreakPointList = class(TFPGObjectList<TBreakPoint>)
48    procedure AddItem(TargetAddress: Integer);
49    procedure SetSystem(TargetAddress: Integer);
50    procedure AddSystem(TargetAddress: Integer);
51    procedure ClearSystem;
52    function SearchByTargetPos(Pos: Integer): TBreakPoint;
53  end;
54
55  TMessage = class
56    Text: string;
57    Position: TPoint;
58  end;
59
60  { TMessageList }
61
62  TMessageList = class(TFPGObjectList<TMessage>)
63  private
64    FOnChange: TNotifyEvent;
65    procedure DoChange;
66  public
67    procedure AddMessage(Text: string);
68    procedure AppendMessage(Text: string);
69    property OnChange: TNotifyEvent read FOnChange write FOnChange;
70  end;
71
72  TLogEvent = procedure (Lines: TStrings) of object;
73
74  { TTarget }
75
76  TTarget = class
77  private
78    FOnLog: TLogEvent;
79  protected
80    FCompiled: Boolean;
81    function SourceReadNext: Char;
82  protected
83    FSourceCode: string;
84    FTargetCode: string;
85    FTargetIndex: Integer;
86    Indent: Integer;
87    FState: TRunState;
88    FOnChangeState: TNotifyEvent;
89    procedure LoadProgram; virtual;
90    procedure SetSourceCode(AValue: string); virtual;
91    function GetTargetCode: string; virtual;
92    procedure AddLine(Text: string = '');
93    function LongFileName(FileName: string): string;
94    function GetExecutionPosition: Integer; virtual;
95    procedure SetState(AValue: TRunState); virtual;
96  public
97    Name: string;
98    ProgramName: string;
99    ImageIndex: Integer;
100    OptimizationLevel: TCompilerOptimization;
101    CompilerPath: string;
102    ExecutorPath: string;
103    SourceExtension: string;
104    RunExtension: string;
105    CompiledExtension: string;
106    ProjectFileName: string;
107    Capabilities: TTargetCapabilities;
108    BreakPoints: TBreakPointList;
109    DebugSteps: TDebugStepList;
110    Messages: TMessageList;
111    constructor Create; virtual;
112    destructor Destroy; override;
113    procedure Reset; virtual;
114    procedure OptimizeSource; virtual;
115    procedure Compile; virtual;
116    procedure CompileToFile; virtual;
117    procedure RunFromFile; virtual;
118    procedure Run; virtual;
119    procedure Pause; virtual;
120    procedure Stop; virtual;
121    procedure StepOver; virtual;
122    procedure StepInto; virtual;
123    procedure StepOut; virtual;
124    procedure RunToCursor(Pos: Integer); virtual;
125    procedure LoadFromRegistry(Context: TRegistryContext); virtual;
126    procedure SaveToRegistry(Context: TRegistryContext); virtual;
127    property State: TRunState read FState write SetState;
128    property SourceCode: string write SetSourceCode;
129    property TargetCode: string read GetTargetCode;
130    property Compiled: Boolean read FCompiled write FCompiled;
131    property ExecutionPosition: Integer read GetExecutionPosition;
132    property OnChangeState: TNotifyEvent read FOnChangeState write FOnChangeState;
133    property OnLog: TLogEvent read FOnLog write FOnLog;
134  end;
135
136  { TTargetList }
137
138  TTargetList = class(TFPGObjectList<TTarget>)
139    procedure LoadFromRegistry(Context: TRegistryContext);
140    procedure SaveToRegistry(Context: TRegistryContext);
141    function FindByName(Name: string): TTarget;
142    procedure LoadToMenuItem(MenuItem: TMenuItem; Action: TNotifyEvent;
143      CurrentTarget: TTarget);
144  end;
145
146
147resourcestring
148  SCompilerNotFound = 'Compiler "%s" not found';
149  SExecutorNotFound = 'Executor "%s" not found';
150  SCompiledFileNotFound = 'Program compiled file "%s" not found';
151
152
153implementation
154
155{ TMessageList }
156
157procedure TMessageList.DoChange;
158begin
159  if Assigned(FOnChange) then FOnChange(Self);
160end;
161
162procedure TMessageList.AddMessage(Text: string);
163var
164  NewItem: TMessage;
165begin
166  NewItem := TMessage.Create;
167  NewItem.Text := Text;
168  Add(NewItem);
169  DoChange;
170end;
171
172procedure TMessageList.AppendMessage(Text: string);
173begin
174  if Count > 0 then begin
175    TMessage(Last).Text := TMessage(Last).Text + Text;
176    DoChange;
177  end else AddMessage(Text);
178end;
179
180{ TBreakPointList }
181
182procedure TBreakPointList.AddItem(TargetAddress: Integer);
183var
184  NewItem: TBreakPoint;
185begin
186  NewItem := TBreakPoint.Create;
187  NewItem.TargetAddress := TargetAddress;
188  Add(NewItem);
189end;
190
191procedure TBreakPointList.SetSystem(TargetAddress: Integer);
192begin
193  ClearSystem;
194  AddSystem(TargetAddress);
195end;
196
197procedure TBreakPointList.AddSystem(TargetAddress: Integer);
198var
199  NewItem: TBreakPoint;
200begin
201  NewItem := TBreakPoint.Create;
202  NewItem.TargetAddress := TargetAddress;
203  NewItem.System := True;
204  Add(NewItem);
205end;
206
207procedure TBreakPointList.ClearSystem;
208var
209  I: Integer;
210begin
211  for I := Count - 1 downto 0 do
212    if TBreakPoint(Items[I]).System then Delete(I);
213end;
214
215function TBreakPointList.SearchByTargetPos(Pos: Integer): TBreakPoint;
216var
217  I: Integer;
218begin
219  I := 0;
220  while (I < Count) and (TBreakPoint(Items[I]).TargetAddress < Pos) do Inc(I);
221  if I < Count then Result := TBreakPoint(Items[I])
222    else Result := nil;
223end;
224
225{ TDebugStepList }
226
227function TDebugStepList.SearchBySourcePos(Pos: Integer
228  ): TDebugStep;
229var
230  I: Integer;
231begin
232  I := 0;
233  while (I < Count) and (TDebugStep(Items[I]).SourcePosition < Pos) do Inc(I);
234  if I < Count then Result := TDebugStep(Items[I])
235    else Result := nil;
236end;
237
238function TDebugStepList.SearchByProgramPos(Pos: Integer): TDebugStep;
239var
240  I: Integer;
241begin
242  I := 0;
243  while (I < Count) and (TDebugStep(Items[I]).ProgramPosition < Pos) do Inc(I);
244  if I < Count then Result := TDebugStep(Items[I])
245    else Result := nil;
246end;
247
248function TDebugStepList.SearchByTargetPos(Pos: Integer
249  ): TDebugStep;
250var
251  I: Integer;
252begin
253  I := 0;
254  while (I < Count) and (TDebugStep(Items[I]).TargetPosition < Pos) do Inc(I);
255  if I < Count then Result := TDebugStep(Items[I])
256    else Result := nil;
257end;
258
259function TDebugStepList.SearchIndexByProgramPos(Pos: Integer): Integer;
260var
261  I: Integer;
262begin
263  I := 0;
264  while (I < Count) and (TDebugStep(Items[I]).ProgramPosition < Pos) do Inc(I);
265  if I < Count then Result := I
266    else Result := -1;
267end;
268
269procedure TDebugStepList.AddStep(SourcePos, TargetPos: Integer;
270  Operation: TStepOperation);
271var
272  NewItem: TDebugStep;
273begin
274  NewItem := TDebugStep.Create;
275  NewItem.SourcePosition := SourcePos;
276  NewItem.ProgramPosition := TargetPos;
277  NewItem.TargetPosition := TargetPos;
278  NewItem.Operation := Operation;
279  Add(NewItem);
280end;
281
282procedure TDebugStepList.UpdateTargetPos(OldProgramFrom, OldProgramTo, NewProgram, NewTarget: Integer);
283var
284  I: Integer;
285  First: Integer;
286  Last: Integer;
287begin
288  First := SearchIndexByProgramPos(OldProgramFrom);
289  Last := SearchIndexByProgramPos(OldProgramTo);
290  for I := Last downto First + 1 do Delete(I);
291  TDebugStep(Items[First]).ProgramPosition := NewProgram;
292  TDebugStep(Items[First]).TargetPosition := NewTarget;
293end;
294
295
296{ TTargetList }
297
298procedure TTargetList.LoadFromRegistry(Context: TRegistryContext);
299var
300  I: Integer;
301begin
302  with TRegistryEx.Create do
303  try
304    CurrentContext := Context;
305    for I := 0 to Count - 1 do
306      TTarget(Items[I]).LoadFromRegistry(TRegistryContext.Create(Context.RootKey, Context.Key + '\' + TTarget(Items[I]).Name));
307  finally
308    Free;
309  end;
310end;
311
312procedure TTargetList.SaveToRegistry(Context: TRegistryContext);
313var
314  I: Integer;
315begin
316  with TRegistryEx.Create do
317  try
318    CurrentContext := Context;
319    for I := 0 to Count - 1 do
320    with TTarget(Items[I]) do
321      TTarget(Items[I]).SaveToRegistry(TRegistryContext.Create(Context.RootKey, Context.Key + '\' + TTarget(Items[I]).Name));
322  finally
323    Free;
324  end;
325end;
326
327function TTargetList.FindByName(Name: string): TTarget;
328var
329  I: Integer;
330begin
331  I := 0;
332  while (I < Count) and (TTarget(Items[I]).Name <> Name) do Inc(I);
333  if I < Count then Result := TTarget(Items[I])
334    else Result := nil;
335end;
336
337procedure TTargetList.LoadToMenuItem(MenuItem: TMenuItem; Action: TNotifyEvent
338  ; CurrentTarget: TTarget);
339var
340  NewMenuItem: TMenuItem;
341  I: Integer;
342begin
343  if Assigned(MenuItem) then begin
344    MenuItem.Clear;
345    for I := 0 to Count - 1 do begin
346      NewMenuItem := TMenuItem.Create(MenuItem);
347      NewMenuItem.Caption := TTarget(Items[I]).Name;
348      NewMenuItem.OnClick := Action;
349      NewMenuItem.ImageIndex := TTarget(Items[I]).ImageIndex;
350      if TTarget(Items[I]) = CurrentTarget then NewMenuItem.Checked := True;
351      MenuItem.Add(NewMenuItem);
352    end;
353  end;
354end;
355
356{ TTarget }
357
358function TTarget.GetTargetCode: string;
359begin
360  Result := FTargetCode;
361end;
362
363function TTarget.GetExecutionPosition: Integer;
364begin
365  Result := 0;
366end;
367
368procedure TTarget.SetState(AValue: TRunState);
369begin
370  if FState = AValue then Exit;
371  FState := AValue;
372end;
373
374procedure TTarget.SetSourceCode(AValue: string);
375begin
376  FSourceCode := AValue;
377end;
378
379procedure TTarget.AddLine(Text: string = '');
380begin
381  FTargetCode := FTargetCode + DupeString('  ', Indent) + Text + LineEnding;
382end;
383
384function TTarget.LongFileName(FileName: string): string;
385begin
386  Result := FileName;
387  {$IFDEF Windows}
388  Result := '"' + FileName + '"';
389  {$ENDIF}
390  {$IFDEF Linux}
391  Result := StringReplace(FileName, ' ', '\ ', [rfReplaceAll]);
392  {$ENDIF}
393end;
394
395constructor TTarget.Create;
396begin
397  inherited;
398  OptimizationLevel := coNormal;
399  BreakPoints := TBreakPointList.Create;
400  DebugSteps := TDebugStepList.Create;
401  Messages := TMessageList.Create;
402end;
403
404destructor TTarget.Destroy;
405begin
406  FreeAndNil(Messages);
407  FreeAndNil(DebugSteps);
408  FreeAndNil(BreakPoints);
409  inherited Destroy;
410end;
411
412procedure TTarget.Reset;
413begin
414  Messages.Clear;
415end;
416
417procedure TTarget.OptimizeSource;
418begin
419end;
420
421procedure TTarget.Compile;
422begin
423  LoadProgram;
424  if OptimizationLevel = coNormal then OptimizeSource;
425  Compiled := True;
426end;
427
428procedure TTarget.CompileToFile;
429var
430  Process: TProcess;
431  CompiledFile: string;
432  Lines: TStringList;
433  I: Integer;
434begin
435  CompiledFile := ExtractFilePath(ProjectFileName) +
436    'compiled' + DirectorySeparator + Name + DirectorySeparator +
437    ExtractFileNameOnly(ProjectFileName) + SourceExtension;
438  ForceDirectories(ExtractFilePath(CompiledFile));
439  with TStringList.Create do
440  try
441    Text := FTargetCode;
442    SaveToFile(CompiledFile);
443  finally
444    Free;
445  end;
446  if CompilerPath <> '' then begin;
447    if FileExists(CompilerPath) then
448    try
449      Process := TProcess.Create(nil);
450      Process.CurrentDirectory := ExtractFilePath(CompiledFile);
451      Process.Executable := LongFileName(CompilerPath);
452      Process.Parameters.Add(LongFileName(CompiledFile));
453      for I := 0 to GetEnvironmentVariableCount - 1 do
454        Process.Environment.Add(GetEnvironmentString(I));
455      Process.Options := [poWaitOnExit, poUsePipes];
456      Process.Execute;
457      if Assigned(FOnLog) then begin
458        Lines := TStringList.Create;
459        Lines.LoadFromStream(Process.Output);
460        Lines.Insert(0, Process.Executable + ' ' + Process.Parameters.Text);
461        FOnLog(Lines);
462        Lines.Free;
463      end;
464    finally
465      Process.Free;
466    end else raise Exception.Create(Format(SCompilerNotFound, [CompilerPath]));
467  end;
468end;
469
470procedure TTarget.RunFromFile;
471var
472  Process: TProcess;
473  CompiledFile: string;
474  RunFile: string;
475begin
476  if ExecutorPath = '' then Exit;
477
478  CompiledFile := ExtractFilePath(ProjectFileName) +
479    'compiled' + DirectorySeparator + Name + DirectorySeparator +
480    ExtractFileNameOnly(ProjectFileName) + CompiledExtension;
481  RunFile := ExtractFilePath(ProjectFileName) +
482    'compiled' + DirectorySeparator + Name + DirectorySeparator +
483    ExtractFileNameOnly(ProjectFileName) + RunExtension;
484  if not FileExists(ExecutorPath) then
485    raise Exception.Create(Format(SExecutorNotFound, [ExecutorPath]));
486  if FileExists(CompiledFile) then
487  try
488    Process := TProcess.Create(nil);
489    if ExecutorPath <> '' then begin
490      Process.Executable := LongFileName(ExecutorPath);
491      Process.Parameters.Add(LongFileName(RunFile));
492    end else Process.Executable := LongFileName(RunFile);
493    Process.ShowWindow := swoShow;
494    Process.Options := [poWaitOnExit, poNewConsole];
495    Process.Execute;
496  finally
497    Process.Free;
498  end else raise Exception.Create(Format(SCompiledFileNotFound, [CompiledFile]));
499end;
500
501procedure TTarget.Run;
502begin
503end;
504
505procedure TTarget.Pause;
506begin
507
508end;
509
510procedure TTarget.Stop;
511begin
512end;
513
514procedure TTarget.StepOver;
515begin
516
517end;
518
519procedure TTarget.StepInto;
520begin
521
522end;
523
524procedure TTarget.StepOut;
525begin
526
527end;
528
529procedure TTarget.RunToCursor(Pos: Integer);
530begin
531
532end;
533
534procedure TTarget.LoadFromRegistry(Context: TRegistryContext);
535begin
536  with TRegistryEx.Create do
537  try
538    CurrentContext := Context;
539    CompilerPath := ReadStringWithDefault('CompilerPath', CompilerPath);
540    ExecutorPath := ReadStringWithDefault('ExecutorPath', ExecutorPath);
541  finally
542    Free;
543  end;
544end;
545
546procedure TTarget.SaveToRegistry(Context: TRegistryContext);
547begin
548  with TRegistryEx.Create do
549  try
550    CurrentContext := Context;
551    if CompilerPath <> '' then WriteString('CompilerPath', CompilerPath)
552      else DeleteValue('CompilerPath');
553    if ExecutorPath <> '' then WriteString('ExecutorPath', ExecutorPath)
554      else DeleteValue('ExecutorPath');
555  finally
556    Free;
557  end;
558end;
559
560procedure TTarget.LoadProgram;
561begin
562end;
563
564function TTarget.SourceReadNext: Char;
565begin
566  Result := ' ';
567end;
568
569end.
570
Note: See TracBrowser for help on using the repository browser.