source: tags/1.2.0/Target/UTargetInterpretter.pas

unit UTargetInterpretter;

{$mode Delphi}{$H+}

interface

uses
  Classes, SysUtils, Dialogs, Forms, UTarget, UBFTarget, Math;

type
  TTargetInterpretter = class;

  { TTargetInterpretterThread }

  TTargetInterpretterThread = class(TThread)
  private
    FNewState: TRunState;
    FMessage: string;
    procedure DoMessage;
    procedure DoSetState;
    procedure SetStateSafe(State: TRunState);
  public
    Parent: TTargetInterpretter;
    procedure Execute; override;
  end;

  TCommandHandler = procedure of object;

  { TTargetInterpretter }

  TTargetInterpretter = class(TBFTarget)
  private
    FThreadState: Boolean;
    FThread: TTargetInterpretterThread;
    FStepCount: Integer;
    FCommandTable: array[TMachineCommand] of TCommandHandler;
    procedure SetThread(State: Boolean);
    procedure PrepareJumpTable;
    procedure CommandInc;
    procedure CommandDec;
    procedure CommandPointerInc;
    procedure CommandPointerDec;
    procedure CommandInput;
    procedure CommandOutput;
    procedure CommandLoopStart;
    procedure CommandLoopEnd;
    procedure CommandSet;
    procedure CommandMultiply;
    procedure PrepareBreakPoints;
    procedure CheckMemoryBounds(Address: Integer);
  protected
    procedure SetState(AValue: TRunState); override;
    procedure EmitTargetCode;
    function GetExecutionPosition: Integer; override;
  public
    FProgramBreakpoints: array of Boolean;
    SourceBreakpoint: array of Boolean;
    Memory: array of Integer;
    MemoryPosition: Integer;
    MemoryChanged: Boolean;
    Output: string;
    OutputPosition: Integer;
    OutputChanged: Boolean;
    Input: string;
    InputPosition: Integer;
    procedure OptimizeSource; override;
    procedure Reset; override;
    procedure Compile; override;
    procedure Run; override;
    procedure Pause; override;
    procedure Stop; override;
    procedure StepInto; override;
    procedure StepOver; override;
    procedure StepOut; override;
    procedure RunToCursor(Pos: Integer); override;
    constructor Create; override;
    destructor Destroy; override;
    property StepCount: Integer read FStepCount;
  end;


implementation

resourcestring
  SProgramLowerMemoryLimit = 'Program run over lower memory limit';
  SProgramUpperMemoryLimit = 'Program run over upper memory limit';
  SJumpTableInconsistent = 'Jump table is inconsistent';
  SJumpTableCollision = 'Jump table collision';
  SProgramNotRunning = 'Program not running';
  SUnsupportedCommand = 'Unsupported command';
  SBreakPointIndexError = 'Break point index error: %d';

{ TTargetInterpretterThread }

procedure TTargetInterpretterThread.Execute;
var
  BreakPoint: TBreakPoint;
  Index: Integer;
begin
  try
  with Parent do
  repeat
    while (FProgramIndex < FProgram.Count) and (State <> rsStopped) do begin
      if State = rsRunning then begin
        if FProgramBreakpoints[FProgramIndex] then begin
          BreakPoint := BreakPoints.SearchByTargetPos(FProgramIndex);
          if BreakPoint.System then begin
            Index := BreakPoints.IndexOf(BreakPoint);
            if Index <> -1 then BreakPoints.Delete(Index)
            else raise Exception.Create(Format(SBreakPointIndexError, [Index]));
          end;
          SetStateSafe(rsPaused);
        end else begin
          if Assigned(FCommandTable[FProgram[FProgramIndex].Command]) then
            FCommandTable[FProgram[FProgramIndex].Command]
            else raise Exception.Create(SUnsupportedCommand);
          Inc(FProgramIndex);
          Inc(FStepCount);
        end;
      end else
      if State = rsPaused then Sleep(1);
    end;
    if State <> rsStopped then SetStateSafe(rsStopped);
  until Terminated or (State = rsStopped);

  except
    on E: Exception do begin
      FMessage := E.Message;
      Synchronize(DoMessage);
    end;
  end;
end;

procedure TTargetInterpretterThread.DoMessage;
begin
  Parent.SendMessage(FMessage);
end;

procedure TTargetInterpretterThread.DoSetState;
begin
  Parent.State := FNewState;
end;

procedure TTargetInterpretterThread.SetStateSafe(State: TRunState);
begin
  if Parent.State = State then Exit;
  FNewState := State;
  Synchronize(DoSetState);
end;

{ TTargetInterpretter }

procedure TTargetInterpretter.SetState(AValue: TRunState);
begin
  if FState = AValue then Exit;
  FState := AValue;
  if Assigned(FOnChangeState) then FOnChangeState(Self);
end;

procedure TTargetInterpretter.SetThread(State: Boolean);
begin
  if FThreadState = State then Exit;
  FThreadState := State;
  if State then begin
    FThread := TTargetInterpretterThread.Create(True);
    FThread.Parent := Self;
    FThread.FreeOnTerminate := False;
    FThread.Start;
  end else begin
    FreeAndNil(FThread);
  end;
end;

procedure TTargetInterpretter.PrepareJumpTable;
var
  Loop: array of Integer;
  I: Integer;
begin
  for I := 0 to FProgram.Count - 1 do begin
    case FProgram[I].Command of
      cmLoopStart: FProgram.Operations[I].Parameter := 0;
      cmLoopEnd: FProgram.Operations[I].Parameter := 0;
    end;
  end;

  SetLength(Loop, 0);
  for I := 0 to FProgram.Count - 1 do begin
    case FProgram[I].Command of
      cmLoopStart: begin
        SetLength(Loop, Length(Loop) + 1);
        Loop[High(Loop)] := I;
      end;
      cmLoopEnd: begin
        if FProgram[I].Parameter > 0 then
          raise Exception.Create(SJumpTableCollision);
        FProgram.Operations[I].Parameter := Loop[High(Loop)];
        if FProgram[Loop[High(Loop)]].Parameter > 0 then
          raise Exception.Create(SJumpTableCollision);
        FProgram.Operations[Loop[High(Loop)]].Parameter := I;
        SetLength(Loop, Length(Loop) - 1);
      end;
    end;
  end;
  if Length(Loop) > 0 then raise Exception.Create(SJumpTableInconsistent);
end;

procedure TTargetInterpretter.CommandInput;
var
  Addr: Integer;
begin
  Addr := MemoryPosition + FProgram[FProgramIndex].RelIndex;
  while (InputPosition > Length(Input)) and (FState <> rsStopped) do begin
    Sleep(1);
  end;
  if InputPosition <= Length(Input) then begin
    Memory[Addr] := Ord(Input[InputPosition]);
    Inc(InputPosition);
    MemoryMaxUsedAddr := Max(Addr, MemoryMaxUsedAddr);
    MemoryChanged := True;
  end;
end;

procedure TTargetInterpretter.CommandOutput;
begin
  if OutputPosition > Length(Output) then
    SetLength(Output, Length(Output) + 1);
  Output[OutputPosition] := Char(Memory[MemoryPosition +
    FProgram[FProgramIndex].RelIndex]);
  Inc(OutputPosition);
  OutputChanged := True;
end;

procedure TTargetInterpretter.CommandLoopStart;
begin
  if Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] = 0 then
    FProgramIndex := FProgram[FProgramIndex].Parameter - 1;
end;

procedure TTargetInterpretter.CommandLoopEnd;
begin
  if Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] > 0 then
    FProgramIndex := FProgram[FProgramIndex].Parameter - 1;
end;

procedure TTargetInterpretter.CommandInc;
var
  Addr: Integer;
begin
  Addr := MemoryPosition + FProgram[FProgramIndex].RelIndex;
  Memory[Addr] := ((Memory[Addr] + FProgram[FProgramIndex].Parameter) mod CellSize);
  MemoryMaxUsedAddr := Max(Addr, MemoryMaxUsedAddr);
  MemoryChanged := True;
end;

procedure TTargetInterpretter.CommandDec;
var
  Addr: Integer;
begin
  Addr := MemoryPosition + FProgram[FProgramIndex].RelIndex;
  Memory[Addr] := ((Memory[Addr] - FProgram[FProgramIndex].Parameter) mod CellSize);
  MemoryMaxUsedAddr := Max(Addr, MemoryMaxUsedAddr);
  MemoryChanged := True;
end;

procedure TTargetInterpretter.CommandPointerInc;
begin
  if MemoryPosition < MemorySize then
    Inc(MemoryPosition, FProgram[FProgramIndex].Parameter)
    else raise Exception.Create(SProgramUpperMemoryLimit);
end;

procedure TTargetInterpretter.CommandPointerDec;
begin
  if MemoryPosition > 0 then
    Dec(MemoryPosition, FProgram[FProgramIndex].Parameter)
    else raise Exception.Create(SProgramLowerMemoryLimit);
end;

procedure TTargetInterpretter.CommandSet;
var
  Addr: Integer;
begin
  Addr := MemoryPosition + FProgram[FProgramIndex].RelIndex;
  CheckMemoryBounds(Addr);
  Memory[Addr] := FProgram[FProgramIndex].Parameter mod CellSize;
  MemoryMaxUsedAddr := Max(Addr, MemoryMaxUsedAddr);
  MemoryChanged := True;
end;

procedure TTargetInterpretter.CommandMultiply;
var
  Addr: Integer;
begin
  Addr := MemoryPosition + FProgram[FProgramIndex].RelIndex;
  CheckMemoryBounds(Addr);
  Memory[Addr] := (Memory[Addr] + Memory[MemoryPosition] *
    FProgram[FProgramIndex].Parameter) mod CellSize;
  MemoryMaxUsedAddr := Max(Addr, MemoryMaxUsedAddr);
  MemoryChanged := True;
end;

procedure TTargetInterpretter.Reset;
var
  I: Integer;
begin
  inherited;
  SetLength(Memory, MemorySize);
  PrepareJumpTable;
  FProgramIndex := 0;
  InputPosition := 1;
  Output := '';
  OutputPosition := 1;
  MemoryPosition := 0;
  MemoryMaxUsedAddr := 0;
  //FillChar(Pointer(Memory)^, Length(Memory), 0);
  for I := 0 to Length(Memory) - 1 do
    Memory[I] := 0;
  MemoryChanged := True;
  OutputChanged := True;
  FStepCount := 0;
  PrepareBreakPoints;
end;

procedure TTargetInterpretter.Compile;
begin
  inherited;
  EmitTargetCode;
end;

procedure TTargetInterpretter.PrepareBreakPoints;
var
  I: Integer;
begin
  SetLength(FProgramBreakpoints, FProgram.Count);
  for I := 0 to High(FProgramBreakpoints) do
    FProgramBreakpoints[I] := False;
  for I := 0 to BreakPoints.Count - 1 do
    if BreakPoints[I].TargetAddress < Length(FProgramBreakpoints) then
      FProgramBreakpoints[BreakPoints[I].TargetAddress] := True;
end;

procedure TTargetInterpretter.CheckMemoryBounds(Address: Integer);
begin
  if Address < 0 then raise Exception.Create(SProgramLowerMemoryLimit);
  if Address >= MemorySize then raise Exception.Create(SProgramUpperMemoryLimit);
end;

procedure TTargetInterpretter.EmitTargetCode;
var
  I: Integer;
  Code: string;
  TargetIndex: Integer;
  Step: TDebugStep;
begin
  TargetIndex := 0;
  FTargetCode := '';
  for I := 0 to FProgram.Count - 1 do begin
    Code := GetOperationText(FProgram[I]);
    FTargetCode := FTargetCode + Code;
    if DebugEnabled then begin
      Step := DebugSteps.SearchByProgramPos(I);
      if Assigned(Step) then begin
        Step.TargetPosition := TargetIndex;
      end;// else
      // raise Exception.Create(Format('Program index %d missing debug step.', [I]));
    end;
    Inc(TargetIndex, Length(Code));
  end;
end;

function TTargetInterpretter.GetExecutionPosition: Integer;
begin
  Result := FProgramIndex;
end;

procedure TTargetInterpretter.OptimizeSource;
begin
  inherited;
end;

procedure TTargetInterpretter.Run;
begin
  PrepareBreakPoints;
  if FState = rsStopped then begin
    Reset;
    SetThread(False);
    SetThread(True);
    State := rsRunning;
  end else State := rsRunning;
end;

procedure TTargetInterpretter.Pause;
begin
  if State = rsRunning then State := rsPaused;
end;

procedure TTargetInterpretter.Stop;
begin
  State := rsStopped;
  SetThread(False);
end;

procedure TTargetInterpretter.StepInto;
var
  Step: TDebugStep;
begin
  if State = rsPaused then begin
    Step := DebugSteps.SearchByProgramPos(FProgramIndex);
    if Step.Operation = soStepOut then begin
      BreakPoints.SetSystem(Step.ProgramPosition + 1);
      Step := DebugSteps.SearchByProgramPos(FProgram[Step.ProgramPosition].Parameter);
      BreakPoints.AddSystem(Step.ProgramPosition);
    end else
    if Step.Operation = soStepIn then begin
      BreakPoints.SetSystem(Step.ProgramPosition + 1);
      Step := DebugSteps.SearchByProgramPos(FProgram[Step.ProgramPosition].Parameter);
      BreakPoints.AddSystem(Step.ProgramPosition);
    end else BreakPoints.SetSystem(Step.ProgramPosition + 1);
    Run;
  end else raise Exception.Create(SProgramNotRunning);
end;

procedure TTargetInterpretter.StepOver;
var
  Step: TDebugStep;
begin
  if State = rsPaused then begin
    Step := DebugSteps.SearchByProgramPos(FProgramIndex);
    if Step.Operation = soStepOut then begin
      BreakPoints.SetSystem(Step.ProgramPosition + 1);
      Step := DebugSteps.SearchByProgramPos(FProgram[Step.ProgramPosition].Parameter);
      BreakPoints.AddSystem(Step.ProgramPosition);
    end else
    if Step.Operation = soStepIn then begin
      Step := DebugSteps.SearchByProgramPos(FProgram[Step.ProgramPosition].Parameter);
      BreakPoints.SetSystem(Step.ProgramPosition + 1);
    end else BreakPoints.SetSystem(Step.ProgramPosition + 1);
    Run;
  end else raise Exception.Create(SProgramNotRunning);
end;

procedure TTargetInterpretter.StepOut;
var
  Step: TDebugStep;
  StepIndex: Integer;
  Nesting: Integer;
begin
  if State = rsPaused then begin
    Step := DebugSteps.SearchByProgramPos(FProgramIndex);
    StepIndex := DebugSteps.IndexOf(Step);
    Nesting := 1;
    while (StepIndex < DebugSteps.Count) and (Nesting > 0) do begin
      if DebugSteps[StepIndex].Operation = soStepIn then Inc(Nesting);
      if DebugSteps[StepIndex].Operation = soStepOut then Dec(Nesting);
      Inc(StepIndex);
    end;
    if StepIndex < DebugSteps.Count then begin
      Breakpoints.SetSystem(DebugSteps[StepIndex].ProgramPosition);
    end;
    Run;
  end else raise Exception.Create(SProgramNotRunning);
end;

procedure TTargetInterpretter.RunToCursor(Pos: Integer);
begin
  Breakpoints.SetSystem(Pos);
  Run;
end;

constructor TTargetInterpretter.Create;
begin
  inherited;
  FName := 'Interpretter';
  FImageIndex := 25;
  FCapabilities := [tcRun, tcPause, tcStop, tcCompile, tcStepOut, tcStepInto,
    tcStepOver, tcRunToCursor];
  // Base commands
  FCommandTable[cmInc] := CommandInc;
  FCommandTable[cmDec] := CommandDec;
  FCommandTable[cmPointerInc] := CommandPointerInc;
  FCommandTable[cmPointerDec] := CommandPointerDec;
  FCommandTable[cmOutput] := CommandOutput;
  FCommandTable[cmInput] := CommandInput;
  FCommandTable[cmLoopStart] := CommandLoopStart;
  FCommandTable[cmLoopEnd] := CommandLoopEnd;
  // Extended commands
  FCommandTable[cmSet] := CommandSet;
  FCommandTable[cmMultiply] := CommandMultiply;
end;

destructor TTargetInterpretter.Destroy;
begin
  FState := rsStopped;
  SetThread(False);
  inherited;
end;

end.