source: branches/xpascal/Source.pas

unit Source;

interface

uses
  Classes, SysUtils, Generics.Collections, SourceNode;

type
  TExpressions = class;
  TFunctions = class;
  TBeginEnd = class;
  TBlock = class;

  { TValue }

  TValue = class
    function Clone: TValue; virtual;
  end;

  { TValueString }

  TValueString = class(TValue)
    Value: string;
    function Clone: TValue; override;
  end;

  { TValueInteger }

  TValueInteger = class(TValue)
    Value: Integer;
    function Clone: TValue; override;
  end;

  { TValueBoolean }

  TValueBoolean = class(TValue)
    Value: Boolean;
    function Clone: TValue; override;
  end;

  TValueClass = class of TValue;

  { TType }

  TType = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    Functions: TFunctions;
    ValueClass: TValueClass;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TTypes }

  TTypes = class(TSourceNodeList<TType>)
    function SearchByName(Name: string): TType;
    function AddNew(Name: string): TType;
  end;

  { TVariable }

  TVariable = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    TypeRef: TType;
    Internal: Boolean;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
  end;

  { TVariables }

  TVariables = class(TSourceNodeList<TVariable>)
    function SearchByName(Name: string): TVariable;
  end;

  { TConstant }

  TConstant = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    TypeRef: TType;
    Value: TValue;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    destructor Destroy; override;
  end;

  { TConstants }

  TConstants = class(TSourceNodeList<TConstant>)
    function SearchByName(Name: string): TConstant;
    function AddNew(Name: string): TConstant;
  end;

  TFunctionParamKind = (pkNormal, pkVar, pkConst);

  TFunctionParameter = class(TSourceNode)
    Name: string;
    TypeRef: TType;
    Kind: TFunctionParamKind;
  end;

  { TFunctionParameters }

  TFunctionParameters = class(TSourceNodeList<TFunctionParameter>)
    function SearchByName(Name: string): TFunctionParameter;
    function AddNew(Name: string; TypeRef: TType): TFunctionParameter;
  end;

  { TFunction }

  TFunction = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    InternalName: string;
    Params: TFunctionParameters;
    ResultType: TType;
    Block: TBlock;
    ParentType: TType;
    procedure InitVariables;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TFunctions }

  TFunctions = class(TSourceNodeList<TFunction>)
    ParentType: TType;
    function SearchByName(Name: string): TFunction;
    function AddNew(Name: string): TFunction;
  end;

  { TProcedure }

  TProcedure = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    InternalName: string;
    Params: TFunctionParameters;
    Block: TBlock;
    ParentType: TType;
    procedure InitVariables;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TProcedures }

  TProcedures = class(TSourceNodeList<TProcedure>)
    ParentType: TType;
    function SearchByName(Name: string): TProcedure;
    function AddNew(Name: string): TProcedure;
  end;

  TCommand = class(TSourceNode)
  end;

  TCommands = class(TSourceNodeList<TCommand>)
  end;

  TEmptyCommand = class(TCommand)
  end;

  { TFunctionCall }

  TFunctionCall = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    FunctionDef: TFunction;
    Params: TExpressions;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TProcedureCall }

  TProcedureCall = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    ProcedureDef: TProcedure;
    Params: TExpressions;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TBeginEnd }

  TBeginEnd = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    Commands: TCommands;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  TExpressionOperator = (eoNone, eoAdd, eoSub, eoMultiply, eoDivide, eoIntDivide,
    eoModulo, eoAnd, eoXor, eoOr, eoShl, eoShr, eoEqual, eoNotEqual, eoLesser,
    eoHigher, eoLesserOrEqual, eoHigherOrEqual, eoNot);

  { TExpression }

  TExpression = class(TSourceNode)
    function GetType: TType; virtual;
  end;

  { TExpressionOperation }

  TExpressionOperation = class(TExpression)
  protected
    function GetFieldsCount: Integer; override;
  public
    TypeRef: TType;
    FunctionRef: TFunction;
    Operation: TExpressionOperator;
    Items: TExpressions;
    function GetFunctionName: string;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
    function GetType: TType; override;
  end;

  TExpressionOperandType = (otVariableRef, otConstantRef, otConstantDirect,
    otFunctionCall);

  { TExpressionOperand }

  TExpressionOperand = class(TExpression)
  protected
    function GetFieldsCount: Integer; override;
  public
    OperandType: TExpressionOperandType;
    VariableRef: TVariable;
    ConstantRef: TConstant;
    ConstantDirect: TConstant;
    FunctionCall: TFunctionCall;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    function GetType: TType; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TExpressionBrackets }

  TExpressionBrackets = class(TExpression)
    Expression: TExpression;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    function GetType: TType; override;
    destructor Destroy; override;
  end;

  TExpressions = class(TSourceNodeList<TExpression>)
  end;

  { TAssignment }

  TAssignment = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    Variable: TVariable;
    Expression: TExpression;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TReturn }

  TReturn = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    Expression: TExpression;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TIfThenElse }

  TIfThenElse = class(TCommand)
  protected
    function GetFieldsCount: Integer; override;
  public
    Expression: TExpression;
    CommandThen: TCommand;
    CommandElse: TCommand;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  TLoop = class(TCommand)
    DoBreak: Boolean;
    DoContinue: Boolean;
  end;

  { TWhileDo }

  TWhileDo = class(TLoop)
  protected
    function GetFieldsCount: Integer; override;
  public
    Expression: TExpression;
    Command: TCommand;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TRepeatUntil }

  TRepeatUntil = class(TLoop)
  protected
    function GetFieldsCount: Integer; override;
  public
    Expression: TExpression;
    Commands: TCommands;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  TBreak = class(TCommand)
  end;

  TContinue = class(TCommand)
  end;

  { TForToDo }

  TForToDo = class(TLoop)
  protected
    function GetFieldsCount: Integer; override;
  public
    VariableRef: TVariable;
    ExpressionFrom: TExpression;
    ExpressionTo: TExpression;
    Command: TCommand;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TBlock }

  TBlock = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    ParentBlock: TBlock;
    Variables: TVariables;
    Constants: TConstants;
    Functions: TFunctions;
    Procedures: TProcedures;
    Types: TTypes;
    BeginEnd: TBeginEnd;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    procedure Clear;
    function GetType(Name: string): TType;
    function GetConstant(Name: string): TConstant;
    function GetVariable(Name: string): TVariable;
    function GetFunction(Name: string): TFunction;
    function GetProcedure(Name: string): TProcedure;
    constructor Create;
    destructor Destroy; override;
  end;

  { TProgram }

  TProgram = class(TSourceNode)
  protected
    function GetFieldsCount: Integer; override;
  public
    Name: string;
    SystemBlock: TBlock;
    Block: TBlock;
    procedure GetValue(Index: Integer; out Value); override;
    function GetField(Index: Integer): TField; override;
    procedure SetValue(Index: Integer; var Value); override;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  const
    ExpressionOperatorText: array[TExpressionOperator] of string = ('', '+',
      '-', '*', '/', 'div', 'mod', 'and', 'xor', 'or', 'shl',
      'shr', '=', '<>', '<', '>', '<=','>=', 'not');
    ExpressionOperatorFuncText: array[TExpressionOperator] of string = ('', '_Add',
      '_Sub', '_Mul', '_Div', '_IntDiv', '_Mod', '_And', '_Xor', '_Or', '_Shl',
      '_Shr', '_Equal', '_NotEqual', '_Lesser', '_Higher', '_LesserOrEqual',
      '_HigherOrEqual', '_Not');

  function GetOperatorByName(Name: string): TExpressionOperator;


implementation

resourcestring
  SIndexError = 'Index error';

function GetOperatorByName(Name: string): TExpressionOperator;
var
  I: TExpressionOperator;
begin
  Result := eoNone;
  for I := Succ(Low(TExpressionOperator)) to High(TExpressionOperator) do begin
    if ExpressionOperatorText[I] = Name then begin
      Result := I;
      Break;
    end;
  end;
end;

{ TProcedureCall }

function TProcedureCall.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TProcedureCall.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TProcedure(Value) := ProcedureDef
  else if Index = 1 then TExpressions(Value) := Params
  else inherited;
end;

function TProcedureCall.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Procedure')
  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
  else inherited;
end;

procedure TProcedureCall.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then ProcedureDef := TProcedure(Value)
  else if Index = 1 then Params := TExpressions(Value)
  else inherited;
end;

constructor TProcedureCall.Create;
begin
  Params := TExpressions.Create;
end;

destructor TProcedureCall.Destroy;
begin
  FreeAndNil(Params);
  inherited;
end;

{ TProcedure }

function TProcedures.SearchByName(Name: string): TProcedure;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TProcedure(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TProcedure(Items[I])
    else Result := nil;
end;

function TProcedures.AddNew(Name: string): TProcedure;
begin
  Result := TProcedure.Create;
  Result.Name := Name;
  Result.ParentType := ParentType;
  Add(Result);
end;

function TProcedure.GetFieldsCount: Integer;
begin
  Result := 3;
end;

procedure TProcedure.InitVariables;
var
  I: Integer;
  Variable: TVariable;
begin
  for I := 0 to Params.Count - 1 do begin
    Variable := TVariable.Create;
    Variable.Name := Params[I].Name;
    Variable.TypeRef := Params[I].TypeRef;
    Variable.Internal := True;
    Block.Variables.Add(Variable);
  end;
end;

procedure TProcedure.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TBlock(Value) := Block
  else if Index = 1 then TFunctionParameters(Value) := Params
  else if Index = 2 then string(Value) := Name
  else inherited;
end;

function TProcedure.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Block')
  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
  else if Index = 2 then Result := TField.Create(dtString, 'Name')
  else inherited;
end;

procedure TProcedure.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Block := TBlock(Value)
  else if Index = 1 then Params := TFunctionParameters(Value)
  else if Index = 2 then Name := string(Value)
  else inherited;
end;

constructor TProcedure.Create;
begin
  Params := TFunctionParameters.Create;
  Block := TBlock.Create;
end;

destructor TProcedure.Destroy;
begin
  FreeAndNil(Block);
  FreeAndNil(Params);
  inherited;
end;

{ TExpressionBrackets }

procedure TExpressionBrackets.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then begin
    TExpression(Value) := Expression;
  end
  else inherited;
end;

function TExpressionBrackets.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else inherited;
end;

procedure TExpressionBrackets.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then begin
    Expression := TExpression(Value);
  end
  else inherited;
end;

function TExpressionBrackets.GetType: TType;
begin
  Result := Expression.GetType;
end;

destructor TExpressionBrackets.Destroy;
begin
  FreeAndNil(Expression);
  inherited;
end;

{ TReturn }

function TReturn.GetFieldsCount: Integer;
begin
  Result := 1;
end;

procedure TReturn.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TExpression(Value) := Expression
  else inherited;
end;

function TReturn.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else inherited;
end;

procedure TReturn.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Expression := TExpression(Value)
  else inherited;
end;

constructor TReturn.Create;
begin
  Expression := TExpression.Create;
end;

destructor TReturn.Destroy;
begin
  FreeAndNil(Expression);
  inherited;
end;

{ TVariable }

procedure TVariable.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then string(Value) := Name
  else if Index = 1 then TType(Value) := TypeRef
  else inherited;
end;

function TVariable.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtString, 'Name')
  else if Index = 1 then Result := TField.Create(dtObject, 'Type')
  else inherited;
end;

function TVariable.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TVariable.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Name := string(Value)
  else if Index = 1 then TypeRef := TType(Value)
  else inherited;
end;

{ TConstant }

procedure TConstant.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then string(Value) := Name
  else if Index = 1 then TType(Value) := TypeRef
  else inherited;
end;

function TConstant.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtString, 'Name')
  else if Index = 1 then Result := TField.Create(dtObject, 'Type')
  else inherited;
end;

function TConstant.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TConstant.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Name := string(Value)
  else if Index = 1 then TypeRef := TType(Value)
  else inherited;
end;

destructor TConstant.Destroy;
begin
  FreeAndNil(Value);
  inherited;
end;

{ TRepeatUntil }

procedure TRepeatUntil.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TExpression(Value) := Expression
  else if Index = 1 then TCommands(Value) := Commands
  else inherited;
end;

function TRepeatUntil.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else if Index = 1 then Result := TField.Create(dtList, 'Commands')
  else inherited;
end;

function TRepeatUntil.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TRepeatUntil.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Expression := TExpression(Value)
  else if Index = 1 then Commands := TCommands(Value)
  else inherited;
end;

constructor TRepeatUntil.Create;
begin
  Expression := TExpression.Create;
  Commands := TCommands.Create;
end;

destructor TRepeatUntil.Destroy;
begin
  FreeAndNil(Expression);
  FreeAndNil(Commands);
  inherited;
end;

{ TValueBoolean }

function TValueBoolean.Clone: TValue;
begin
  Result := TValueBoolean.Create;
  TValueBoolean(Result).Value := Value;
end;

{ TValueInteger }

function TValueInteger.Clone: TValue;
begin
  Result := TValueInteger.Create;
  TValueInteger(Result).Value := Value;
end;

{ TValueString }

function TValueString.Clone: TValue;
begin
  Result := TValueString.Create;
  TValueString(Result).Value := Value;
end;

{ TValue }

function TValue.Clone: TValue;
begin
  Result := nil;
end;

{ TForToDo }

procedure TForToDo.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TVariable(Value) := VariableRef
  else if Index = 1 then TExpression(Value) := ExpressionFrom
  else if Index = 2 then TExpression(Value) := ExpressionTo
  else if Index = 3 then TCommand(Value) := Command
  else inherited;
end;

function TForToDo.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Variable')
  else if Index = 1 then Result := TField.Create(dtObject, 'To')
  else if Index = 2 then Result := TField.Create(dtObject, 'From')
  else if Index = 3 then Result := TField.Create(dtObject, 'Do')
  else inherited;
end;

function TForToDo.GetFieldsCount: Integer;
begin
  Result := 4;
end;

procedure TForToDo.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then VariableRef := TVariable(Value)
  else if Index = 1 then ExpressionFrom := TExpression(Value)
  else if Index = 2 then ExpressionTo := TExpression(Value)
  else if Index = 3 then Command := TCommand(Value)
  else inherited;
end;

constructor TForToDo.Create;
begin
  ExpressionFrom := TExpression.Create;
  ExpressionTo := TExpression.Create;
  Command := TEmptyCommand.Create;
end;

destructor TForToDo.Destroy;
begin
  FreeAndNil(Command);
  FreeAndNil(ExpressionTo);
  FreeAndNil(ExpressionFrom);
  inherited;
end;

{ TExpression }

function TExpression.GetType: TType;
begin
  Result := nil;
end;

{ TExpressionOperand }

procedure TExpressionOperand.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then begin
    case OperandType of
      otConstantDirect: TConstant(Value) := ConstantDirect;
      otConstantRef: TConstant(Value) := ConstantRef;
      otFunctionCall: TFunctionCall(Value) := FunctionCall;
      otVariableRef: TVariable(Value) := VariableRef;
    end;
  end
  else inherited;
end;

function TExpressionOperand.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Value')
  else inherited;
end;

function TExpressionOperand.GetFieldsCount: Integer;
begin
  Result := 1;
end;

procedure TExpressionOperand.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then begin
    case OperandType of
      otConstantDirect: ConstantDirect := TConstant(Value);
      otConstantRef: ConstantRef := TConstant(Value);
      otFunctionCall: FunctionCall := TFunctionCall(Value);
      otVariableRef: VariableRef := TVariable(Value);
    end;
  end
  else inherited;
end;

function TExpressionOperand.GetType: TType;
begin
  if OperandType = otFunctionCall then Result := FunctionCall.FunctionDef.ResultType
  else if OperandType = otConstantRef then Result := ConstantRef.TypeRef
  else if OperandType = otConstantDirect then Result := ConstantDirect.TypeRef
  else if OperandType = otVariableRef then Result := VariableRef.TypeRef
  else raise Exception.Create('Unsupported operand type');
end;

constructor TExpressionOperand.Create;
begin
end;

destructor TExpressionOperand.Destroy;
begin
  if Assigned(ConstantDirect) then FreeAndNil(ConstantDirect);
  if Assigned(FunctionCall) then FreeAndNil(FunctionCall);
end;

{ TFunctionParameters }

function TFunctionParameters.SearchByName(Name: string): TFunctionParameter;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TFunctionParameter(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TFunctionParameter(Items[I])
    else Result := nil;
end;

function TFunctionParameters.AddNew(Name: string; TypeRef: TType): TFunctionParameter;
begin
  Result := TFunctionParameter.Create;
  Result.Name := Name;
  Result.TypeRef := TypeRef;
  Add(Result);
end;

{ TFunction }

procedure TFunction.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TBlock(Value) := Block
  else if Index = 1 then TFunctionParameters(Value) := Params
  else if Index = 2 then string(Value) := Name
  else if Index = 3 then TType(Value) := ResultType
  else inherited;
end;

function TFunction.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Block')
  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
  else if Index = 2 then Result := TField.Create(dtString, 'Name')
  else if Index = 3 then Result := TField.Create(dtObject, 'ResultType')
  else inherited;
end;

function TFunction.GetFieldsCount: Integer;
begin
  Result := 4;
end;

procedure TFunction.InitVariables;
var
  I: Integer;
  Variable: TVariable;
begin
  for I := 0 to Params.Count - 1 do begin
    Variable := TVariable.Create;
    Variable.Name := Params[I].Name;
    Variable.TypeRef := Params[I].TypeRef;
    Variable.Internal := True;
    Block.Variables.Add(Variable);
  end;

  Variable := TVariable.Create;
  Variable.Name := 'Result';
  Variable.TypeRef := ResultType;
  Variable.Internal := True;
  Block.Variables.Add(Variable);
end;

procedure TFunction.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Block := TBlock(Value)
  else if Index = 1 then Params := TFunctionParameters(Value)
  else if Index = 2 then Name := string(Value)
  else if Index = 3 then ResultType := TType(Value)
  else inherited;
end;

constructor TFunction.Create;
begin
  Params := TFunctionParameters.Create;
  Block := TBlock.Create;
end;

destructor TFunction.Destroy;
begin
  FreeAndNil(Block);
  FreeAndNil(Params);
  inherited;
end;

{ TType }

procedure TType.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then string(Value) := Name
  else inherited;
end;

function TType.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtString, 'Name')
  else inherited;
end;

function TType.GetFieldsCount: Integer;
begin
  Result := 1;
end;

procedure TType.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Name := string(Value)
  else inherited;
end;

constructor TType.Create;
begin
  Functions := TFunctions.Create;
  Functions.ParentType := Self;
end;

destructor TType.Destroy;
begin
  FreeAndNil(Functions);
  inherited;
end;

{ TTypes }

function TTypes.SearchByName(Name: string): TType;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TType(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TType(Items[I])
    else Result := nil;
end;

function TTypes.AddNew(Name: string): TType;
begin
  Result := TType.Create;
  Result.Name := Name;
  Add(Result);
end;

{ TExpressionOperation }

procedure TExpressionOperation.GetValue(Index: Integer; out Value);
begin
  TObject(Value) := Items[Index];
end;

function TExpressionOperation.GetField(Index: Integer): TField;
begin
  if Index < Items.Count then Result := TField.Create(dtObject, 'Expression')
  else inherited;
end;

function TExpressionOperation.GetFunctionName: string;
begin
  Result := ExpressionOperatorFuncText[Operation];
end;

function TExpressionOperation.GetFieldsCount: Integer;
begin
  Result := Items.Count;
end;

procedure TExpressionOperation.SetValue(Index: Integer; var Value);
begin
  Items[Index] := TExpression(Value);
end;

constructor TExpressionOperation.Create;
begin
  Items := TExpressions.Create;
end;

destructor TExpressionOperation.Destroy;
begin
  FreeAndNil(Items);
  inherited;
end;

function TExpressionOperation.GetType: TType;
begin
  Result := TypeRef;
end;

{ TAssignment }

procedure TAssignment.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TExpression(Value) := Expression
  else if Index = 1 then TVariable(Value) := Variable
  else inherited;
end;

function TAssignment.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else if Index = 1 then Result := TField.Create(dtObject, 'Variable')
  else inherited;
end;

function TAssignment.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TAssignment.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Expression := TExpression(Value)
  else if Index = 1 then Variable := TVariable(Value)
  else inherited;
end;

constructor TAssignment.Create;
begin
  Variable := nil;
  Expression := TExpression.Create;
end;

destructor TAssignment.Destroy;
begin
  Variable := nil;
  FreeAndNil(Expression);
  inherited;
end;

{ TIfThenElse }

procedure TIfThenElse.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TExpression(Value) := Expression
  else if Index = 1 then TCommand(Value) := CommandElse
  else if Index = 2 then TCommand(Value) := CommandThen
  else inherited;
end;

function TIfThenElse.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else if Index = 1 then Result := TField.Create(dtObject, 'Else')
  else if Index = 2 then Result := TField.Create(dtObject, 'Then')
  else inherited;
end;

function TIfThenElse.GetFieldsCount: Integer;
begin
  Result := 3;
end;

procedure TIfThenElse.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Expression := TExpression(Value)
  else if Index = 1 then CommandElse := TCommand(Value)
  else if Index = 2 then CommandThen := TCommand(Value)
  else inherited;
end;

constructor TIfThenElse.Create;
begin
  Expression := TExpression.Create;
  CommandThen := TEmptyCommand.Create;
  CommandElse := TEmptyCommand.Create;
end;

destructor TIfThenElse.Destroy;
begin
  FreeAndNil(Expression);
  FreeAndNil(CommandThen);
  FreeAndNil(CommandElse);
  inherited;
end;

{ TWhileDo }

procedure TWhileDo.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TExpression(Value) := Expression
  else if Index = 1 then TCommand(Value) := Command
  else inherited;
end;

function TWhileDo.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Expression')
  else if Index = 1 then Result := TField.Create(dtObject, 'Do')
  else inherited;
end;

function TWhileDo.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TWhileDo.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Expression := TExpression(Value)
  else if Index = 1 then Command := TCommand(Value)
  else inherited;
end;

constructor TWhileDo.Create;
begin
  Expression := TExpression.Create;
  Command := TEmptyCommand.Create;
end;

destructor TWhileDo.Destroy;
begin
  FreeAndNil(Expression);
  FreeAndNil(Command);
  inherited;
end;

{ TFunctionCall }

procedure TFunctionCall.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TFunction(Value) := FunctionDef
  else if Index = 1 then TExpressions(Value) := Params
  else inherited;
end;

function TFunctionCall.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'Function')
  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
  else inherited;
end;

function TFunctionCall.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TFunctionCall.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then FunctionDef := TFunction(Value)
  else if Index = 1 then Params := TExpressions(Value)
  else inherited;
end;

constructor TFunctionCall.Create;
begin
  Params := TExpressions.Create;
end;

destructor TFunctionCall.Destroy;
begin
  FreeAndNil(Params);
  inherited;
end;

{ TFunctions }

function TFunctions.SearchByName(Name: string): TFunction;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TFunction(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TFunction(Items[I])
    else Result := nil;
end;

function TFunctions.AddNew(Name: string): TFunction;
begin
  Result := TFunction.Create;
  Result.Name := Name;
  Result.ParentType := ParentType;
  Add(Result);
end;

{ TConstants }

function TConstants.SearchByName(Name: string): TConstant;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TConstant(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TConstant(Items[I])
    else Result := nil;
end;

function TConstants.AddNew(Name: string): TConstant;
begin
  Result := TConstant.Create;
  Result.Name := Name;
  Add(Result);
end;

{ TVariables }

function TVariables.SearchByName(Name: string): TVariable;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TVariable(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := TVariable(Items[I])
    else Result := nil;
end;

{ TBlock }

procedure TBlock.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TBeginEnd(Value) := BeginEnd
  else if Index = 1 then TTypes(Value) := Types
  else if Index = 2 then TVariables(Value) := Variables
  else if Index = 3 then TConstants(Value) := Constants
  else if Index = 4 then TFunctions(Value) := Functions
  else if Index = 5 then TProcedures(Value) := Procedures
  else inherited;
end;

function TBlock.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtObject, 'BeginEnd')
  else if Index = 1 then Result := TField.Create(dtList, 'Types')
  else if Index = 2 then Result := TField.Create(dtList, 'Variables')
  else if Index = 3 then Result := TField.Create(dtList, 'Constants')
  else if Index = 4 then Result := TField.Create(dtList, 'Functions')
  else if Index = 5 then Result := TField.Create(dtList, 'Procedures')
  else inherited;
end;

function TBlock.GetFieldsCount: Integer;
begin
  Result := 6;
end;

procedure TBlock.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then BeginEnd := TBeginEnd(Value)
  else if Index = 1 then Types := TTypes(Value)
  else if Index = 2 then Variables := TVariables(Value)
  else if Index = 3 then Constants := TConstants(Value)
  else if Index = 4 then Functions := TFunctions(Value)
  else if Index = 5 then Procedures := TProcedures(Value)
  else inherited;
end;

procedure TBlock.Clear;
begin
  Functions.Clear;
  Procedures.Clear;
  Constants.Clear;
  Variables.Clear;
  Types.Clear;
end;

function TBlock.GetType(Name: string): TType;
begin
  Result := Types.SearchByName(Name);
  if not Assigned(Result) and Assigned(ParentBlock) then
    Result := ParentBlock.GetType(Name);
end;

function TBlock.GetConstant(Name: string): TConstant;
begin
  Result := Constants.SearchByName(Name);
  if not Assigned(Result) and Assigned(ParentBlock) then
    Result := ParentBlock.GetConstant(Name);
end;

function TBlock.GetVariable(Name: string): TVariable;
begin
  Result := Variables.SearchByName(Name);
  if not Assigned(Result) and Assigned(ParentBlock) then
    Result := ParentBlock.GetVariable(Name);
end;

function TBlock.GetFunction(Name: string): TFunction;
begin
  Result := Functions.SearchByName(Name);
  if not Assigned(Result) and Assigned(ParentBlock) then
    Result := ParentBlock.GetFunction(Name);
end;

function TBlock.GetProcedure(Name: string): TProcedure;
begin
  Result := Procedures.SearchByName(Name);
  if not Assigned(Result) and Assigned(ParentBlock) then
    Result := ParentBlock.GetProcedure(Name);
end;

constructor TBlock.Create;
begin
  Constants := TConstants.Create;
  Constants.Parent := Self;
  Variables := TVariables.Create;
  Variables.Parent := Self;
  Functions := TFunctions.Create;
  Functions.Parent := Self;
  Procedures := TProcedures.Create;
  Procedures.Parent := Self;
  Types := TTypes.Create;
  Types.Parent := Self;
  BeginEnd := TBeginEnd.Create;
  BeginEnd.Parent := Self;
end;

destructor TBlock.Destroy;
begin
  FreeAndNil(BeginEnd);
  FreeAndNil(Types);
  FreeAndNil(Variables);
  FreeAndNil(Constants);
  FreeAndNil(Functions);
  FreeAndNil(Procedures);
  inherited;
end;

{ TBeginEnd }

procedure TBeginEnd.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then TCommands(Value) := Commands
  else inherited;
end;

function TBeginEnd.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtList, 'Commands')
  else inherited;
end;

function TBeginEnd.GetFieldsCount: Integer;
begin
  Result := 1;
end;

procedure TBeginEnd.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Commands := TCommands(Value)
  else inherited;
end;

procedure TBeginEnd.Clear;
begin
  Commands.Clear;
end;

constructor TBeginEnd.Create;
begin
  Commands := TCommands.Create;
end;

destructor TBeginEnd.Destroy;
begin
  FreeAndNil(Commands);
  inherited;
end;

{ TProgram }

procedure TProgram.GetValue(Index: Integer; out Value);
begin
  if Index = 0 then string(Value) := Name
  else if Index = 1 then TBlock(Value) := Block
  else raise Exception.Create(SIndexError);
end;

function TProgram.GetField(Index: Integer): TField;
begin
  if Index = 0 then Result := TField.Create(dtString, 'Name')
  else if Index = 1 then Result := TField.Create(dtObject, 'Block')
  else inherited;
end;

function TProgram.GetFieldsCount: Integer;
begin
  Result := 2;
end;

procedure TProgram.SetValue(Index: Integer; var Value);
begin
  if Index = 0 then Name := string(Value)
  else if Index = 0 then Block := TBlock(Value)
  else raise Exception.Create(SIndexError);
end;

procedure TProgram.Clear;
begin
  Name := '';
end;

constructor TProgram.Create;
begin
  SystemBlock := TBlock.Create;
  Block := TBlock.Create;
end;

destructor TProgram.Destroy;
begin
  FreeAndNil(Block);
  FreeAndNil(SystemBlock);
  inherited;
end;

end.