source: branches/interpreter/interpreter4/Execute.pas

unit Execute;

interface

uses
  Source;

type
  TVariableValue = record
    VarRef: PVariableRef;
    BaseType: TBaseType;
    case Integer of
      btChar: (ValueChar: Char);
      btInteger: (ValueInteger: Integer);
      btShortString: (ValueString: ShortString);
      btBoolean: (ValueBoolean: Boolean);
  end;
  PVariableValue = ^TVariableValue;

  { TVariableValues }

  TVariableValues = record
    Items: array of TVariableValue;
    function GetByName(Name: string): PVariableValue;
  end;

  { TExecutionContext }

  TExecutionContext = record
    VariableValues: TVariableValues;
    procedure LoadFromVariables(Variables: PVariables);
  end;
  PExecutionContext = ^TExecutionContext;

  { TExecutionContexts }

  TExecutionContexts = record
    Items: array of TExecutionContext;
    function Last: PExecutionContext;
    procedure Add;
    procedure RemoveLast;
  end;

var
  ExecutionContexts: TExecutionContexts;
  ExecutionContextCurrent: PExecutionContext;
  MainCode: PProgramCode;

procedure ExecuteProgram(ProgramCode: PProgramCode);


implementation

uses
  Parser;

procedure ExecuteCommand(Command: PCommand); forward;
procedure ExecuteGetValue(GetValue: PGetValue; Value: PVariableValue); forward;
procedure AssignVariable(Dest, Source: PVariableValue); forward;
procedure ExecuteExecution(Execution: PExecution; ReturnValue: PVariableValue); forward;


procedure ShowError(Text: string);
begin
  WriteLn(Text);
  Halt;
end;

procedure ExecuteBeginEnd(BeginEnd: PBeginEnd);
var
  I: Integer;
begin
  for I := 0 to Length(BeginEnd^.Commands) - 1 do
    ExecuteCommand(@BeginEnd^.Commands[I]);
end;

procedure ShowErrorType(Variable: PVariableValue);
begin
  ShowError('Not supported type')
end;

procedure VariableAdd(Result, Operand: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: ShowErrorType(Result);
    btChar: begin
      Result.BaseType := btShortString;
      Result.ValueString := Result.ValueString + Operand.ValueChar;
    end;
    btInteger: Result^.ValueInteger := Result^.ValueInteger + Operand^.ValueInteger;
    btShortString: begin
      if Operand^.BaseType = btShortString then
        Result^.ValueString := Result^.ValueString + Operand^.ValueString
      else if Operand^.BaseType = btChar then
        Result^.ValueString := Result^.ValueString + Operand^.ValueChar
      else ShowErrorType(Result);
    end;
  end;
end;

procedure VariableNot(Result, Operand: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: Result^.ValueBoolean := not Operand^.ValueBoolean;
    btChar: ShowErrorType(Result);
    btInteger: ShowErrorType(Result);
    btShortString: ShowErrorType(Result);
  end;
end;

procedure VariableSubtract(Result, Operand: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: ShowErrorType(Result);
    btChar: ShowErrorType(Result);
    btInteger: Result^.ValueInteger := Result^.ValueInteger - Operand^.ValueInteger;
    btShortString: ShowErrorType(Result);
  end;
end;

procedure VariableAnd(Result, Operand: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: Result^.ValueBoolean := Result^.ValueBoolean and Operand^.ValueBoolean;
    btChar: ShowErrorType(Result);
    btInteger: Result^.ValueInteger := Result^.ValueInteger and Operand^.ValueInteger;
    btShortString: ShowErrorType(Result);
  end;
end;

procedure VariableOr(Result, Operand: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: Result^.ValueBoolean := Result^.ValueBoolean or Operand^.ValueBoolean;
    btChar: ShowErrorType(Result);
    btInteger: Result^.ValueInteger := Result^.ValueInteger or Operand^.ValueInteger;
    btShortString: ShowErrorType(Result);
  end;
end;

procedure VariableEqual(Result, Operand1, Operand2: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: Result^.ValueBoolean := Operand1^.ValueBoolean = Operand2^.ValueBoolean;
    btChar: ShowErrorType(Result);
    btInteger: ShowErrorType(Result);
    btShortString: ShowErrorType(Result);
  end;
end;

procedure VariableNotEqual(Result, Operand1, Operand2: PVariableValue);
begin
  case Result^.BaseType of
    btBoolean: Result^.ValueBoolean := Operand1^.ValueBoolean <> Operand2^.ValueBoolean;
    btChar: ShowErrorType(Result);
    btInteger: ShowErrorType(Result);
    btShortString: ShowErrorType(Result);
  end;
end;

procedure ExecuteExpression(Expression: PExpression; Value: PVariableValue);
var
  I: Integer;
  SubValue: TVariableValue;
  Operand1: TVariableValue;
begin
  if Expression^.NodeType = ntOperator then begin
    I := 0;
    while I < Length(Expression^.Items) do begin
      if Expression^.Items[I].NodeType = ntOperator then begin
        ExecuteExpression(@Expression^.Items[I], @SubValue);
      end else
      if Expression^.Items[I].NodeType = ntValue then begin
        ExecuteGetValue(@Expression^.Items[I].Value, @SubValue);
      end;

      if I = 0 then begin
        // Just assign first operand
        case Expression^.OperatorType of
          opNot: begin
            Value.BaseType := btBoolean;
            VariableNot(Value, @SubValue);
          end;
          opAdd: AssignVariable(Value, @SubValue);
          opSubtract: AssignVariable(Value, @SubValue);
          opAnd: AssignVariable(Value, @SubValue);
          opOr: AssignVariable(Value, @SubValue);
          opEqual: AssignVariable(@Operand1, @SubValue);
          opNotEqual: AssignVariable(@Operand1, @SubValue);
          else ShowError('Unsupported operator type');
        end;
      end else begin
        case Expression^.OperatorType of
          opAdd: VariableAdd(Value, @SubValue);
          opSubtract: VariableSubtract(Value, @SubValue);
          opAnd: VariableAnd(Value, @SubValue);
          opOr: VariableOr(Value, @SubValue);
          opEqual: begin
            Value.BaseType := btBoolean;
            VariableEqual(Value, @Operand1, @SubValue);
          end;
          opNotEqual: begin
            Value.BaseType := btBoolean;
            VariableNotEqual(Value, @Operand1, @SubValue);
          end
          else ShowError('Unsupported operator type');
        end;
      end;
      I := I + 1;
    end;
  end else
  if Expression^.NodeType = ntValue then begin
    ExecuteGetValue(@Expression^.Value, Value);
  end else ShowError('Uninitialized expression');
end;

function ExecuteGetValueBoolean(GetValue: PGetValue): Boolean;
var
  Value: TVariableValue;
begin
  ExecuteGetValue(GetValue, @Value);
  Result := (Value.BaseType = btBoolean) and Value.ValueBoolean;
end;

procedure ExecuteWhileDo(WhileDo: PWhileDo);
begin
  while ExecuteGetValueBoolean(@WhileDo^.Condition) do
    ExecuteCommand(@WhileDo^.Command);
end;

procedure ExecuteIfThenElse(IfThenElse: PIfThenElse);
var
  Condition: Boolean;
begin
  Condition := ExecuteGetValueBoolean(@IfThenElse^.Condition);
  if Condition then
    ExecuteCommand(@IfThenElse^.DoThen);
  if (IfThenElse^.DoElse.CmdType <> ctNone) and not Condition then
    ExecuteCommand(@IfThenElse^.DoElse);
end;

procedure AssignConstant(Variable: PVariableValue; Constant: PConstant);
begin
  Variable^.BaseType := Constant^.DataType^.BaseType;
  case Constant^.DataType^.BaseType of
    btBoolean: Variable^.ValueBoolean := Constant^.ValueBoolean;
    btInteger: Variable^.ValueInteger := Constant^.ValueInteger;
    btShortString: Variable^.ValueString := Constant^.ValueString;
    btChar: Variable^.ValueChar := Constant^.ValueChar;
  end;
end;

procedure ExecuteGetValue(GetValue: PGetValue; Value: PVariableValue);
begin
  case GetValue.ReadType of
    rtVariable: AssignVariable(Value, ExecutionContextCurrent^.VariableValues.GetByName(GetValue.VariableRef^.Variable^.Name));
    //rtConstant: Value := ExecutionContextCurrent^.VariableValues.GetByName(GetValue.Variable^.Name);
    rtExpression: ExecuteExpression(GetValue.Expression, Value);
    rtValue: AssignConstant(Value, @GetValue.Value);
    rtFunctionCall: ExecuteExecution(GetValue.FunctionCall, Value)
  end;
end;

procedure AssignVariable(Dest, Source: PVariableValue);
begin
  Dest.BaseType := Source.BaseType;
  case Dest.BaseType of
    btInteger: Dest.ValueInteger := Source.ValueInteger;
    btChar: Dest.ValueChar := Source.ValueChar;
    btBoolean: Dest.ValueBoolean := Source.ValueBoolean;
    btShortString: Dest.ValueString := Source.ValueString;
  end;
end;

function IsBuildInFunction(Name: string): Boolean;
begin
  Result := (Name = 'WriteLn') or (Name = 'Eof') or (Name = 'Halt') or (Name = 'Read') or
    (Name = 'Length') or (Name = 'SetLength');
end;

procedure ExecuteBuildInSetResult(Execution: PExecution; TypeName: string);
var
  DataType: PType;
begin
  if Execution^.Func^.Variables.GetByName('Result') = nil then begin
    DataType := MainCode.Types.GetByName(TypeName);
    Execution^.Func^.Variables.Add(VariableCreate('Result', DataType));
    SetLength(ExecutionContextCurrent^.VariableValues.Items, Length(ExecutionContextCurrent^.VariableValues.Items) + 1);
    ExecutionContextCurrent^.VariableValues.Items[0].VarRef := @Execution^.Func^.Variables.Items[Length(Execution^.Func^.Variables.Items) - 1];
    ExecutionContextCurrent^.VariableValues.Items[0].BaseType := btBoolean;
  end;
end;

procedure ExecuteBuildIn(Execution: PExecution);
begin
  if Execution^.Func^.Name = 'WriteLn' then begin
    WriteLn('|' + ExecutionContextCurrent^.VariableValues.GetByName('Text')^.ValueString)
  end else
  if Execution^.Func^.Name = 'Halt' then begin
    Halt;
  end else
  if Execution^.Func^.Name = 'Read' then begin
    ExecutionContextCurrent^.VariableValues.GetByName('Output')^.ValueChar := InnerText[InnerTextPos.Index];
    InnerTextPos.Index := InnerTextPos.Index + 1;
  end else
  if Execution^.Func^.Name = 'Eof' then begin
    ExecuteBuildInSetResult(Execution, 'Boolean');
    ExecutionContextCurrent^.VariableValues.GetByName('Result')^.ValueBoolean := InnerTextPos.Index > Length(InnerText);
  end else ShowError('Unsupported build-in function.');
end;

procedure ExecuteExecution(Execution: PExecution; ReturnValue: PVariableValue);
var
  I: Integer;
  Param: PGetValue;
  ParamValue: TVariableValue;
  DestVar: PVariableValue;
  NewContext: TExecutionContext;
begin
  // Prepare new execution context
  FillChar(NewContext, SizeOf(TExecutionContext), 0);
  NewContext.LoadFromVariables(@Execution^.Func^.Variables);

  // Copy execution parameters to new execution context as local variables
  for I := 0 to Length(Execution^.Func^.Parameters.Items) - 1 do begin
    DestVar := NewContext.VariableValues.GetByName(
      Execution^.Func^.Parameters.Items[I].Name);
    Param := @Execution^.Parameters.Items[I];
    ExecuteGetValue(Param, @ParamValue);
    AssignVariable(DestVar, @ParamValue);
  end;

  ExecutionContexts.Add;
  ExecutionContexts.Items[Length(ExecutionContexts.Items) - 1] := NewContext;

  WriteLn('Executed ' + Execution^.Func^.Name);
  if IsBuildInFunction(Execution^.Func^.Name) then ExecuteBuildIn(Execution)
    else ExecuteBeginEnd(@Execution^.Func^.BeginEnd);
  if (ReturnValue <> nil) and (Execution^.Func^.ReturnType <> nil) then
    AssignVariable(ReturnValue, ExecutionContextCurrent^.VariableValues.GetByName('Result'));

  WriteLn('Return from ' + Execution^.Func^.Name);

  // Copy output parameters back to variable
  NewContext := ExecutionContexts.Items[Length(ExecutionContexts.Items) - 1];
  ExecutionContexts.RemoveLast;

  for I := 0 to Length(Execution^.Func^.Parameters.Items) - 1 do
  if Execution^.Func^.Parameters.Items[I].Output then begin
    DestVar := NewContext.VariableValues.GetByName(
      Execution^.Func^.Parameters.Items[I].Name);
    Param := @Execution^.Parameters.Items[I];
    if (Param.ReadType = rtVariable) then
      AssignVariable(ExecutionContextCurrent^.VariableValues.GetByName(Param.VariableRef^.Variable^.Name), DestVar)
    else ShowError('Function var parameter can be only variable');
  end;
end;

procedure ExecuteAssignment(Assignment: PAssignment);
var
  DestVariable: PVariableValue;
  SrcVariable: TVariableValue;
begin
  DestVariable := ExecutionContextCurrent^.VariableValues.GetByName(Assignment^.Destination^.Variable^.Name);
  WriteLn('Assignment to ' + Assignment^.Destination^.Variable^.Name);
  FillChar(SrcVariable, SizeOf(TVariableValue), 0);
  ExecuteGetValue(@Assignment^.Source, @SrcVariable);
  AssignVariable(DestVariable, @SrcVariable);
end;

procedure ExecuteCommand(Command: PCommand);
begin
  case Command^.CmdType of
    ctBeginEnd: ExecuteBeginEnd(Command^.BeginEnd);
    ctWhileDo: ExecuteWhileDo(Command^.WhileDo);
    ctIfThenElse: ExecuteIfThenElse(Command^.IfThenElse);
    ctExecution: ExecuteExecution(Command^.Execution, nil);
    ctAssignment: ExecuteAssignment(Command^.Assignment);
  end;
end;

procedure ExecuteProgram(ProgramCode: PProgramCode);
begin
  MainCode := ProgramCode;
  ExecutionContexts.Add;
  ExecutionContextCurrent^.LoadFromVariables(@ProgramCode^.Variables);
  ExecuteBeginEnd(@ProgramCode^.BeginEnd);
end;

{ TVariableValues }

function TVariableValues.GetByName(Name: string): PVariableValue;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].VarRef^.Variable^.Name <> Name) do Inc(I);
  if I < Length(Items) then Result := @Items[I]
    else Result := nil;
end;

{ TExecutionContext }

procedure TExecutionContext.LoadFromVariables(Variables: PVariables);
var
  I: Integer;
begin
  SetLength(VariableValues.Items, Length(Variables.Items));
  for I := 0 to Length(Variables.Items) - 1 do begin
    VariableValues.Items[I].BaseType := Variables.Items[I].DataType.BaseType;
    VariableValues.Items[I].VarRef := @Variables.Items[I];
  end;
end;

{ TExecutionContexts }

function TExecutionContexts.Last: PExecutionContext;
begin
  Result := @ExecutionContexts.Items[Length(ExecutionContexts.Items) - 1];
end;

procedure TExecutionContexts.Add;
begin
  SetLength(Items, Length(Items) + 1);
  ExecutionContextCurrent := Last;
end;

procedure TExecutionContexts.RemoveLast;
begin
  SetLength(Items, Length(Items) - 1);
  ExecutionContextCurrent := Last;
end;


end.