source: branches/easy compiler/USourceExecutor.pas

unit USourceExecutor;

{$mode delphi}

interface

uses
  Classes, SysUtils, USourceCode, Contnrs;

type
  TOutputEvent = procedure (Text: string) of object;
  TInputEvent = function: string of object;

  { TExecutorVariable }

  TExecutorVariable = class
    Variable: TSourceVariable;
    Value: TSourceValue;

    destructor Destroy; override;
  end;

  TExecutorVariables = class(TObjectList)
    function Search(Variable: TSourceVariable): TExecutorVariable;
  end;

  TExecutorRepeat = class
    RepeatCommand: TCommandRepeat;
    Terminated: Boolean;
  end;

  { TExecutorRepeats }

  TExecutorRepeats = class(TObjectList)
    function Search(RepeatCommand: TCommandRepeat): TExecutorRepeat;
  end;

  { TSourceExecutor }

  TSourceExecutor = class
  private
    FOnInput: TInputEvent;
    FOnOutput: TOutputEvent;
    Variables: TExecutorVariables;
    RepeatBlocks: TExecutorRepeats;
    SkipNext: Boolean;
    procedure ExecuteAssign(CommandAssign: TCommandFunctionCall);
    procedure ExecuteBeginEnd(BeginEnd: TCommandBeginEnd);
    procedure ExecuteCommand(Command: TSourceCommand);
    procedure ExecuteBreak(CommandBreak: TCommandBreak);
    procedure ExecuteIfEqual(IfEqual: TCommandIfEqual);
    procedure ExecuteIfNotEqual(IfNotEqual: TCommandIfNotEqual);
    procedure ExecuteRepeat(CommandRepeat: TCommandRepeat);
    function ReadValueReference(Reference: TSourceReference): TSourceValue;
    function ReadVarReference(Reference: TSourceReference): TSourceValue;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute(SourceCode: TSourceCode);
    property OnOutput: TOutputEvent read FOnOutput write FOnOutput;
    property OnInput: TInputEvent read FOnInput write FOnInput;
  end;


implementation

{ TExecutorRepeat }

function TExecutorRepeats.Search(RepeatCommand: TCommandRepeat): TExecutorRepeat;
var
  Item: TExecutorRepeat;
begin
  Result := nil;
  for Item in Self do
  if Item.RepeatCommand = RepeatCommand then begin
    Result := Item;
    Break;
  end;
end;

{ TExecutorVariable }

destructor TExecutorVariable.Destroy;
begin
  Value.Free;
  inherited Destroy;
end;


{ TExecutorVariables }

function TExecutorVariables.Search(Variable: TSourceVariable): TExecutorVariable;
var
  Item: TExecutorVariable;
begin
  Result := nil;
  for Item in Self do
  if Item.Variable = Variable then begin
    Result := Item;
    Break;
  end;
end;

{ TSourceExecutor }

constructor TSourceExecutor.Create;
begin
  Variables := TExecutorVariables.Create;
  RepeatBlocks := TExecutorRepeats.Create;
end;

destructor TSourceExecutor.Destroy;
begin
  RepeatBlocks.Free;
  Variables.Free;
  inherited Destroy;
end;

procedure TSourceExecutor.Execute(SourceCode: TSourceCode);
begin
  SkipNext := False;
  ExecuteBeginEnd(SourceCode.Main);
end;

function TSourceExecutor.ReadValueReference(Reference: TSourceReference): TSourceValue;
var
  ArrayIndex: TSourceValue;
begin
  Result := nil;
  if Reference is TSourceReferenceConstant then begin
    Result := TSourceReferenceConstant(Reference).Constant.Value;
  end else
  if Reference is TSourceReferenceVariable then begin
    Result := Variables.Search(TSourceReferenceVariable(Reference).Variable).Value;
  end else
  if Reference is TSourceReferenceArray then begin
    ArrayIndex := ReadValueReference(TSourceReferenceArray(Reference).Index);
    if not (ArrayIndex is TSourceValueInteger) then
      raise Exception.Create('Only integer array index supported');
    Result := TSourceValue(TSourceValueArray(Variables.Search(TSourceReferenceArray(Reference).ArrayRef).Value).Items[TSourceValueInteger(ArrayIndex).Value]);
  end else
  raise Exception.Create('Unsupported reference');
end;

function TSourceExecutor.ReadVarReference(Reference: TSourceReference): TSourceValue;
var
  ArrayIndex: TSourceValue;
  Variable: TSourceVariable;
  ExecutorVar: TExecutorVariable;
  I: Integer;
begin
  Result := nil;
  if Reference is TSourceReferenceVariable then begin
    Variable := TSourceReferenceVariable(Reference).Variable;
  end else
  if Reference is TSourceReferenceArray then begin
    Variable := TSourceReferenceArray(Reference).ArrayRef;
  end else
  raise Exception.Create('Unsupported reference');

  ExecutorVar := Variables.Search(Variable);
  if not Assigned(ExecutorVar) then begin
    ExecutorVar := TExecutorVariable.Create;
    ExecutorVar.Variable := Variable;
    Variables.Add(ExecutorVar);
    ExecutorVar.Value := Variable.ValueType.GetValueType.Create;
  end;
  if Reference is TSourceReferenceVariable then begin
    Result := ExecutorVar.Value;
  end else
  if Reference is TSourceReferenceArray then begin
    ArrayIndex := ReadValueReference(TSourceReferenceArray(Reference).Index);
    if not (ArrayIndex is TSourceValueInteger) then
      raise Exception.Create('Only integer array index supported');
    I := TSourceValueInteger(ArrayIndex).Value;
    while TSourceValueArray(ExecutorVar.Value).Items.Count < (I + 1) do begin
      TSourceValueArray(ExecutorVar.Value).Items.Add(TSourceTypeArray(TSourceReferenceArray(Reference).ArrayRef.ValueType).ItemType.GetValueType.Create);
    end;
    Result := TSourceValue(TSourceValueArray(ExecutorVar.Value).Items[I]);
  end else
  raise Exception.Create('Unsupported reference');
end;

procedure TSourceExecutor.ExecuteAssign(CommandAssign: TCommandFunctionCall);
var
  Dest: TSourceValue;
  Source: TSourceValue;
begin
  with TCommandFunctionCall(CommandAssign) do begin
    Dest := ReadVarReference(TSourceReference(Parameters[0]));
    Source := ReadValueReference(TSourceReference(Parameters[1]));
    Dest.Assign(Source);
  end;
end;

procedure TSourceExecutor.ExecuteBeginEnd(BeginEnd: TCommandBeginEnd);
var
  IP: Integer;
begin
  IP := 0;
  while IP < BeginEnd.Commands.Count do begin
    if SkipNext then begin
      SkipNext := False;
      Inc(IP);
      Continue;
    end;
    ExecuteCommand(TSourceCommand(BeginEnd.Commands[IP]));
    Inc(IP);
  end;
end;

procedure TSourceExecutor.ExecuteBreak(CommandBreak: TCommandBreak);
var
  RepeatBlock: TSourceCommand;
  ExecutorRepeat: TExecutorRepeat;
begin
  RepeatBlock := CommandBreak.Parent;
  while not (RepeatBlock is TCommandRepeat) and (RepeatBlock <> nil) do
    RepeatBlock := RepeatBlock.Parent;
  if Assigned(RepeatBlock) then begin
    ExecutorRepeat := RepeatBlocks.Search(RepeatBlock as TCommandRepeat);
    if Assigned(ExecutorRepeat) then begin
      ExecutorRepeat.Terminated := True;
    end else
    raise Exception.Create('Missing executor repeat block');
  end else
  raise Exception.Create('Used break outside repeat loop');
end;

procedure TSourceExecutor.ExecuteIfEqual(IfEqual: TCommandIfEqual);
var
  Value1: TSourceValue;
  Value2: TSourceValue;
begin
  Value1 := ReadValueReference(IfEqual.Reference1);
  Value2 := ReadValueReference(IfEqual.Reference2);
  if (Value1 is TSourceValueInteger) and (Value2 is TSourceValueInteger) then begin
    if TSourceValueInteger(Value1).Value <> TSourceValueInteger(Value2).Value then
      SkipNext := True;
  end else
  if (Value1 is TSourceValueString) and (Value2 is TSourceValueString) then begin
    if TSourceValueString(Value1).Value <> TSourceValueString(Value2).Value then
      SkipNext := True;
  end else
  raise Exception.Create('Unsupported types for comparison.');
end;

procedure TSourceExecutor.ExecuteIfNotEqual(IfNotEqual: TCommandIfNotEqual);
var
  Value1: TSourceValue;
  Value2: TSourceValue;
begin
  Value1 := ReadValueReference(IfNotEqual.Reference1);
  Value2 := ReadValueReference(IfNotEqual.Reference2);
  if (Value1 is TSourceValueInteger) and (Value2 is TSourceValueInteger) then begin
    if TSourceValueInteger(Value1).Value = TSourceValueInteger(Value2).Value then
      SkipNext := True;
  end else
  if (Value1 is TSourceValueString) and (Value2 is TSourceValueString) then begin
    if TSourceValueString(Value1).Value = TSourceValueString(Value2).Value then
      SkipNext := True;
  end else
  raise Exception.Create('Unsupported types for comparison.');
end;

procedure TSourceExecutor.ExecuteRepeat(CommandRepeat: TCommandRepeat);
var
  RepeatBlock: TExecutorRepeat;
begin
  RepeatBlock := TExecutorRepeat.Create;
  RepeatBlock.RepeatCommand := CommandRepeat;
  RepeatBlock.Terminated := False;
  RepeatBlocks.Add(RepeatBlock);
  repeat
    ExecuteCommand(CommandRepeat.Command);
  until RepeatBlock.Terminated;
  RepeatBlocks.Remove(RepeatBlock);
end;

procedure TSourceExecutor.ExecuteCommand(Command: TSourceCommand);
var
  Variable: TSourceVariable;
  Value: TSourceValue;
  ExecutorVar: TExecutorVariable;
  Text: string;
  IntValue: Integer;
  Dest: TSourceValue;
begin
  if Command is TCommandFunctionCall then
  with TCommandFunctionCall(Command) do begin
    if Name = 'print' then begin
      if Assigned(FOnOutput) then begin
        Value := ReadValueReference(TSourceReference(Parameters[0]));
        if Value is TSourceValueString then
          FOnOutput(TSourceValueString(Value).Value)
        else if Value is TSourceValueInteger then
          FOnOutput(IntToStr(TSourceValueInteger(Value).Value))
        else raise Exception.Create('Unsupported value type');
      end;
    end else
    if Name = 'println' then begin
      if Assigned(FOnOutput) then begin
        Value := ReadValueReference(TSourceReference(Parameters[0]));
        if Value is TSourceValueString then
          FOnOutput(TSourceValueString(Value).Value + LineEnding)
        else if Value is TSourceValueInteger then
          FOnOutput(IntToStr(TSourceValueInteger(Value).Value) + LineEnding)
        else raise Exception.Create('Unsupported value type');
      end;
    end else
    if Name = 'inputln' then begin
      if Assigned(FOnInput) then begin
        Value := ReadVarReference(TSourceReference(Parameters[0]));
        if Value is TSourceValueString then begin
          TSourceValueString(Value).Value := FOnInput;
          FOnOutput(TSourceValueString(Value).Value + LineEnding);
        end else
        if Value is TSourceValueInteger then begin
          Text := FOnInput;
          if TryStrToInt(Text, IntValue) then
            TSourceValueInteger(Value).Value := IntValue
            else TSourceValueInteger(Value).Value := 0;
          FOnOutput(IntToStr(TSourceValueInteger(Value).Value) + LineEnding);
        end else
        raise Exception.Create('Unsupported value type');
      end;
    end else
    if Name = 'assign' then begin
      ExecuteAssign(TCommandFunctionCall(Command));
    end else
    if Name = 'increment' then begin
      Dest := ReadVarReference(TSourceReference(Parameters[0]));
      Value := ReadValueReference(TSourceReference(Parameters[1]));
      if (Dest is TSourceValueInteger) and (Value is TSourceValueInteger) then
        Inc(TSourceValueInteger(Dest).Value, TSourceValueInteger(Value).Value)
      else raise Exception.Create('Wrong type for increment');
    end else
    if Name = 'decrement' then begin
      Dest := ReadVarReference(TSourceReference(Parameters[0]));
      Value := ReadValueReference(TSourceReference(Parameters[1]));
      if (Dest is TSourceValueInteger) and (Value is TSourceValueInteger) then
        Dec(TSourceValueInteger(Dest).Value, TSourceValueInteger(Value).Value)
      else raise Exception.Create('Wrong type for increment');
    end else
    raise Exception.Create('Unsupported function: ' + TCommandFunctionCall(Command).Name);
  end else
  if Command is TCommandBeginEnd then begin
    ExecuteBeginEnd(TCommandBeginEnd(Command));
  end else
  if Command is TCommandBreak then begin
    ExecuteBreak(TCommandBreak(Command));
  end else
  if Command is TCommandIfEqual then begin
    ExecuteIfEqual(TCommandIfEqual(Command));
  end else
  if Command is TCommandIfNotEqual then begin
    ExecuteIfNotEqual(TCommandIfNotEqual(Command));
  end else
  if Command is TCommandRepeat then begin
    ExecuteRepeat(Command as TCommandRepeat);
  end else
  raise Exception.Create('Unsupported instruction');
end;


end.