source: tags/1.0.0/Target/UTargetInterpretter.pas

unit UTargetInterpretter;

{$mode Delphi}{$H+}

interface

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

type
  TTargetInterpretter = class;

  { TTargetInterpretterThread }

  TTargetInterpretterThread = class(TThread)
  private
    FNewState: TRunState;
    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;
  protected
    procedure SetState(AValue: TRunState); override;
    function GetTargetCode: string; override;
    function GetExecutionPosition: Integer; override;
  public
    FProgramBreakpoints: array of Boolean;
    SourceBreakpoint: array of Boolean;
    Memory: array of Integer;
    MemoryPosition: Integer;
    Output: string;
    OutputPosition: Integer;
    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;

const
  BrainFuckCommandText: array[TMachineCommand] of Char = (
    ' ', '+', '-', '>', '<', '.', ',', '[', ']', '@', '=', '*');


implementation

resourcestring
  SProgramLowerLimit = 'Program run over lower limit';
  SProgramUpperLimit = 'Program run over upper limit';
  SJumpTableInsistent = 'Jump table is inconsistent';
  SJumpTableColision = 'Jump table colision';
  SProgramNotRunning = 'Program not running';
  SUnsupportedCommand = 'Unsupported command';

{ TTargetInterpretterThread }

procedure TTargetInterpretterThread.Execute;
var
  BreakPoint: TBreakPoint;
begin
  with Parent do
  repeat
    while (FProgramIndex < Length(FProgram)) and (State <> rsStopped) do begin
      if State = rsRunning then begin
        if FProgramBreakpoints[FProgramIndex] then begin
          BreakPoint := BreakPoints.SearchByTargetPos(FProgramIndex);
          if BreakPoint.System then BreakPoints.Delete(BreakPoints.IndexOf(BreakPoint));
          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);
end;

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

procedure TTargetInterpretterThread.SetStateSafe(State: TRunState);
begin
  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 Length(FProgram) - 1 do begin
    case FProgram[I].Command of
      cmLoopStart: FProgram[I].Parameter := 0;
      cmLoopEnd: FProgram[I].Parameter := 0;
    end;
  end;

  SetLength(Loop, 0);
  for I := 0 to Length(FProgram) - 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(SJumpTableColision);
        FProgram[I].Parameter := Loop[High(Loop)];
        if FProgram[Loop[High(Loop)]].Parameter > 0 then
          raise Exception.Create(SJumpTableColision);
        FProgram[Loop[High(Loop)]].Parameter := I;
        SetLength(Loop, Length(Loop) - 1);
      end;
    end;
  end;
  if Length(Loop) > 0 then raise Exception.Create(SJumpTableInsistent);
end;

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

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

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

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

procedure TTargetInterpretter.CommandInc;
begin
  Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] :=
    ((Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] +
    FProgram[FProgramIndex].Parameter) mod CellSize);
end;

procedure TTargetInterpretter.CommandDec;
begin
  Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] :=
    ((Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] -
    FProgram[FProgramIndex].Parameter) mod CellSize);
end;

procedure TTargetInterpretter.CommandPointerInc;
begin
  if MemoryPosition < MemorySize then Inc(MemoryPosition, FProgram[FProgramIndex].Parameter)
    else raise Exception.Create(SProgramUpperLimit);
  if (MemoryPosition + 1) > MemoryMaxUsed then
    MemoryMaxUsed := MemoryPosition + 1;
end;

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

procedure TTargetInterpretter.CommandSet;
begin
  Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] :=
    FProgram[FProgramIndex].Parameter mod CellSize;
end;

procedure TTargetInterpretter.CommandMultiply;
begin
  Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] :=
    (Memory[MemoryPosition + FProgram[FProgramIndex].RelIndex] +
    Memory[MemoryPosition] * FProgram[FProgramIndex].Parameter) mod CellSize;
end;

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

procedure TTargetInterpretter.Compile;
begin
  inherited;
end;

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

function TTargetInterpretter.GetTargetCode: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to Length(FProgram) - 1 do begin
    Result := Result + BrainFuckCommandText[FProgram[I].Command];
    if FProgram[I].Command in [cmInc, cmDec, cmPointerInc, cmPointerDec,
      cmSet, cmMultipy] then begin
      if FProgram[I].Parameter <> 1 then
        Result := Result + IntToStr(FProgram[I].Parameter);
    end;
    if FProgram[I].RelIndex <> 0 then
      Result := Result + 'R' + IntToStr(FProgram[I].RelIndex);
  end;
end;

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

procedure TTargetInterpretter.OptimizeSource;
begin
  inherited OptimizeSource;
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.SearchByTargetPos(FProgramIndex);
    if Step.Operation = soStepOut then begin
      BreakPoints.SetSystem(Step.TargetPosition + 1);
      Step := DebugSteps.SearchByTargetPos(FProgram[Step.TargetPosition].Parameter);
      BreakPoints.AddSystem(Step.TargetPosition);
    end else
    if Step.Operation = soStepIn then begin
      BreakPoints.SetSystem(Step.TargetPosition + 1);
      Step := DebugSteps.SearchByTargetPos(FProgram[Step.TargetPosition].Parameter);
      BreakPoints.AddSystem(Step.TargetPosition);
    end else BreakPoints.SetSystem(Step.TargetPosition + 1);
    Run;
  end else raise Exception.Create(SProgramNotRunning);
end;

procedure TTargetInterpretter.StepOver;
var
  Step: TDebugStep;
begin
  if State = rsPaused then begin
    Step := DebugSteps.SearchByTargetPos(FProgramIndex);
    if Step.Operation = soStepOut then begin
      BreakPoints.SetSystem(Step.TargetPosition + 1);
      Step := DebugSteps.SearchByTargetPos(FProgram[Step.TargetPosition].Parameter);
      BreakPoints.AddSystem(Step.TargetPosition);
    end else
    if Step.Operation = soStepIn then begin
      Step := DebugSteps.SearchByTargetPos(FProgram[Step.TargetPosition].Parameter);
      BreakPoints.SetSystem(Step.TargetPosition + 1);
    end else BreakPoints.SetSystem(Step.TargetPosition + 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.SearchByTargetPos(FProgramIndex);
    StepIndex := DebugSteps.IndexOf(Step);
    Nesting := 1;
    while (StepIndex < DebugSteps.Count) and (Nesting > 0) do begin
      if TDebugStep(DebugSteps[StepIndex]).Operation = soStepIn then Inc(Nesting);
      if TDebugStep(DebugSteps[StepIndex]).Operation = soStepOut then Dec(Nesting);
      Inc(StepIndex);
    end;
    if StepIndex < DebugSteps.Count then begin
      Breakpoints.SetSystem(TDebugStep(DebugSteps[StepIndex]).TargetPosition);
    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;
  Name := 'Interpretter';
  ImageIndex := 25;
  Capabilities := [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[cmMultipy] := CommandMultiply;
end;

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

end.