source: trunk/UTarget.pas @ 111

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