source: trunk/UTarget.pas@ 114

Last change on this file since 114 was 114, checked in by chronos, 2 years 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.