SteppingClass.pas

   1 unit SteppingClass;
   2
   3 interface
   4
   5 uses
   6   ConstantsClass, FunctionsClass, HardwareClass, ResourcesClass, TypesClass;
   7
   8 type
   9
  10   TStepping = class;
  11
  12   { TStepBlock }
  13
  14   TStepBlock = class
  15   private
  16     pCall: TInstruction;
  17     pError: String;
  18     pOwner: TStepping;
  19     pPosition: Integer;
  20     pBranch: Boolean;
  21     function pErrorSet: Boolean; virtual;
  22     procedure pSetError(Input: String = GLOB_NO_ERROR); virtual;
  23   public
  24     constructor Create(Owner: TStepping; Call: TInstruction); virtual;
  25     function ExecuteCall: Integer; virtual;
  26     function Valid: Boolean; virtual;
  27     property CallFunction: TInstruction read pCall write pCall;
  28     property LastError: String read pError;
  29     property Position: Integer read pPosition write pPosition default -1;
  30     property IsBranch: Boolean read pBranch;
  31     destructor Destroy; override;
  32   end;
  33
  34   { TStepping }
  35
  36   TStepping = class
  37   private
  38     pError: String;
  39     pSteps: array of TStepBlock;
  40     pHardware: THardware;
  41     pLength, pStepBlock: Integer;
  42     pOldOnOperand, pOnStep: TChangeEvent;
  43     pValid: Boolean;
  44     function pBlockFromCall(Position: Integer; Call: TInstruction): TStepBlock; virtual;
  45     function pErrorSet: Boolean; virtual;
  46     function pGetBlock(Position: Integer): TStepBlock; virtual;
  47     function pValidPosition(var Position: Integer): Boolean; virtual;
  48     procedure pOnOperand(Sender: TObject); virtual;
  49     procedure pSetError(Input: String = GLOB_NO_ERROR; Where: String = ''); virtual;
  50     procedure pSetHardware(Input: THardware); virtual;
  51     procedure pSetStepBlock(Input: Integer); virtual;
  52   public
  53     constructor Create; virtual;
  54     function AddStepBlock(Position: Integer; Call: TInstruction): Boolean; virtual;
  55     function ChangeStepBlock(Position: Integer; Call: TInstruction): Boolean; virtual;
  56     function RemoveStepBlock(Position: Integer): Boolean; virtual;
  57     function Valid: Boolean; virtual;
  58     procedure InitializeBlocks; virtual;
  59     procedure SingleStep; virtual;
  60     // ? function Animate(Input: Pointer); ?
  61     destructor Destroy; override;
  62     property Block[Position: Integer]: TStepBlock read pGetBlock; default;
  63     property Hardware: THardware read pHardware write pSetHardware;
  64     property LastError: String read pError;
  65     property Length: Integer read pLength default 0;
  66     property OnStep: TChangeEvent read pOnStep write pOnStep;
  67     property StepBlock: Integer read pStepBlock write pSetStepBlock;
  68   end;
  69
  70
  71 implementation
  72
  73 // ************************************************************************** //
  74 // *                      TStepBlock implementation                         * //
  75 // ************************************************************************** //
  76
  77   function TStepBlock.pErrorSet: Boolean;
  78   begin
  79     Result := not(pError = GLOB_NO_ERROR);
  80   end;
  81
  82   procedure TStepBlock.pSetError(Input: String = GLOB_NO_ERROR);
  83   begin
  84     pError := Input;
  85   end;
  86
  87   constructor TStepBlock.Create(Owner: TStepping; Call: TInstruction);
  88   begin
  89     pOwner := Owner;
  90     pCall := Call;
  91     pBranch := (not(Call = nil) and (Call.Branch = BRANCH_BRANCH));
  92     pSetError;
  93   end;
  94
  95   function TStepBlock.ExecuteCall: Integer;
  96   begin
  97     Result := -1;
  98     if not Valid then Exit;
  99     if pCall.Execute and IsBranch then
 100       Result := StringToAddress(pCall.BranchAddress, Position)
 101     else
 102       Result := Position + 1;
 103   end;
 104
 105   function TStepBlock.Valid: Boolean;
 106   var
 107     lbranch: Integer;
 108   begin
 109     pSetError;
 110     Result := False;
 111     if (pCall = nil) then pSetError(STEP_NO_CALL_FUNCTION)
 112     else if not pCall.Hardware.ValidateInstruction(pCall) then
 113       pSetError(pCall.Hardware.LastError)
 114     else if IsBranch then
 115     begin
 116       lbranch := StringToAddress(pCall.BranchAddress, Position);
 117       if (lbranch < 0) or (lbranch > pOwner.Length) then
 118         pSetError(STEP_BRANCH_OUT_OF_RANGE);
 119     end;
 120     if not pErrorSet then Result := True;
 121   end;
 122
 123   destructor TStepBlock.Destroy;
 124   begin
 125     CallFunction.Free;
 126     inherited Destroy;
 127   end;
 128
 129 // ************************************************************************** //
 130 // *                       TStepping implementation                         * //
 131 // ************************************************************************** //
 132
 133   function TStepping.pBlockFromCall(Position: Integer; Call: TInstruction
 134     ): TStepBlock;
 135   begin
 136     Result := nil;
 137     if (Call = nil) then
 138     begin
 139       pSetError(STEP_NO_CALL_FUNCTION);
 140       Exit;
 141     end;
 142     Result := TStepBlock.Create(Self, Call);
 143     Result.Position := Position;
 144     pValid := False;
 145   end;
 146
 147   function TStepping.pErrorSet: Boolean;
 148   begin
 149     Result := not(pError = GLOB_NO_ERROR);
 150   end;
 151
 152   function TStepping.pGetBlock(Position: Integer): TStepBlock;
 153   begin
 154     if pValidPosition(Position) then Result := pSteps[Position]
 155     else Result := nil;
 156   end;
 157
 158   function TStepping.pValidPosition(var Position: Integer): Boolean;
 159   begin
 160     Result := False;
 161     if (Position < STEP_FIRST) then Exit;
 162     if (Position = STEP_LAST) then Position := pLength - 1;
 163     if (Position < Length) then Result := True;
 164   end;
 165
 166   procedure TStepping.pOnOperand(Sender: TObject);
 167   begin
 168     pValid := False;
 169     if not(@pOldOnOperand = nil) then pOldOnOperand(Sender);
 170   end;
 171
 172   procedure TStepping.pSetError(Input: String = GLOB_NO_ERROR;
 173     Where: String = '');
 174   begin
 175     pError := Input;
 176     if not(Where = '') then pError := Where + ': ' + pError;
 177     if not(pError = GLOB_NO_ERROR) then LogWrite(pError, True);
 178   end;
 179
 180   procedure TStepping.pSetHardware(Input: THardware);
 181   begin
 182     if not(pHardware = nil) then pHardware.OnOperand := pOldOnOperand;
 183     pHardware := Input;
 184     if not(Input = nil) then
 185     begin
 186       pOldOnOperand := Input.OnOperand;
 187       Input.OnOperand := pOnOperand;
 188     end;
 189   end;
 190
 191   procedure TStepping.pSetStepBlock(Input: Integer);
 192   begin
 193     pSetError;
 194     if not pValidPosition(Input) then Input := -1;
 195     pStepBlock := Input;
 196     if not(@pOnStep = nil) then pOnStep(Self);
 197   end;
 198
 199   constructor TStepping.Create;
 200   begin
 201     InitializeBlocks;
 202     pSetError;
 203   end;
 204
 205   function TStepping.AddStepBlock(Position: Integer; Call: TInstruction
 206     ): Boolean;
 207   var
 208     i: Integer;
 209     lblock: TStepBlock;
 210   begin
 211     pSetError;
 212     Result := False;
 213     pLength := pLength + 1;
 214     if not pValidPosition(Position) then
 215     begin
 216       pLength := pLength - 1;
 217       Exit;
 218     end;
 219     lblock := pBlockFromCall(Position, Call);
 220     if pErrorSet then
 221     begin
 222       pLength := pLength - 1;
 223       Exit;
 224     end;
 225     SetLength(pSteps, pLength);
 226     for i := (pLength - 2) downto Position do
 227     begin
 228       pSteps[i + 1] := pSteps[i];
 229       pSteps[i + 1].Position := i + 1;
 230     end;
 231     pSteps[Position] := lblock;
 232     if not(Hardware = nil) then Hardware.MaxAddress := pLength;
 233     pValid := False;
 234     Result := True;
 235   end;
 236
 237   function TStepping.ChangeStepBlock(Position: Integer; Call: TInstruction
 238     ): Boolean;
 239   var
 240     lblock: TStepBlock;
 241   begin
 242     pSetError;
 243     Result := False;
 244     if not pValidPosition(Position) then Exit;
 245     lblock := pBlockFromCall(Position, Call);
 246     if pErrorSet then Exit;
 247     pSteps[Position].Free;
 248     pSteps[Position] := lblock;
 249     pValid := False;
 250     Result := True;
 251   end;
 252
 253   function TStepping.RemoveStepBlock(Position: Integer): Boolean;
 254   var
 255     i: Integer;
 256   begin
 257     pSetError;
 258     Result := False;
 259     if not pValidPosition(Position) then Exit;
 260     pSteps[Position].Free;
 261     for i := Position to (pLength - 2) do
 262     begin
 263       pSteps[i] := pSteps[i + 1];
 264       pSteps[i].Position := i;
 265     end;
 266     pLength := pLength - 1;
 267     SetLength(pSteps, pLength);
 268     if not(Hardware = nil) then Hardware.MaxAddress := pLength;
 269     pValid := False;
 270     Result := True;
 271   end;
 272
 273   function TStepping.Valid: Boolean;
 274   var
 275     i: Integer;
 276   begin
 277     pSetError;
 278     Result := True;
 279     if pValid then Exit;
 280     for i := 0 to (pLength - 1) do
 281     begin
 282       Result := pSteps[i].Valid and Result;
 283       if pSteps[i].pErrorSet then
 284         pSetError(pSteps[i].LastError, ZeroPaddedInteger(i, CONST_PADDING));
 285     end;
 286     pValid := Result;
 287   end;
 288
 289   procedure TStepping.InitializeBlocks;
 290   var
 291     i: Integer;
 292   begin
 293     StepBlock := -1;
 294     for i := 0 to (pLength - 1) do pSteps[i].Free;
 295     SetLength(pSteps, 0);
 296     pLength := 0;
 297     pValid := True;
 298   end;
 299
 300   procedure TStepping.SingleStep;
 301   var
 302     lpos: Integer;
 303   begin
 304     pSetError;
 305     if (StepBlock < 0) then pValid := False;
 306     if not pValid then Valid;
 307     if not pValid then
 308     begin
 309       StepBlock := -1;
 310       Exit;
 311     end;
 312     lpos := StepBlock;
 313     if not pValidPosition(lpos) then StepBlock := 0
 314     else StepBlock := pSteps[lpos].ExecuteCall;
 315   end;
 316
 317   destructor TStepping.Destroy;
 318   begin
 319     while (Length > 0) do RemoveStepBlock(STEP_LAST);
 320     inherited Destroy;
 321   end;
 322
 323 end.