source: branches/interpreter/interpreter4/Source.pas

unit Source;

{$mode delphi}

interface

type
  PBeginEnd = ^TBeginEnd;
  PAssignment = ^TAssignment;
  PVariable = ^TVariable;
  PVariableRef = ^TVariableRef;
  PConstant = ^TConstant;
  PIfThenElse = ^TIfThenElse;
  PWhileDo = ^TWhileDo;
  PExpression = ^TExpression;
  PExecution = ^TExecution;
  PType = ^TType;
  PTypes = ^TTypes;
  PEnumerationStates = ^TEnumerationStates;
  PFunction = ^TFunction;
  PVariables = ^TVariables;
  PGetValue = ^TGetValue;

  TOperator = (opNone, opAdd, opSubtract, opAnd, opOr, opNot, opEqual, opNotEqual,
  opLess, opGreater, opLessOrEqual, opGreaterOrEqual);

  TBaseType = (btNone, btBoolean, btInteger, btChar, btShortString, btArray,
    btSimple, btPointer, btRecord, btSimpleForward, btEnumeration, btFunction,
    btRecordCase);

  TType = record
    TypeList: PTypes;
    Name: string;
    BaseType: TBaseType;
    case TBaseType of
      btPointer: (PointedType: PType);
      btRecord: (Fields: PTypes);
      btSimple: (Simple: PType);
      btSimpleForward: (ForwardType: shortstring);
      btEnumeration: (States: PEnumerationStates);
      btArray: (ArrayItemType: PType);
      btFunction: (Func: PFunction);
      btRecordCase: (CaseItems: PTypes);
  end;

  TEnumerationStates = record
    Items: array of string;
  end;

  { TTypes }

  TTypes = record
    ParentList: PTypes;
    Items: array of TType;
    procedure Add(DataType: TType);
    function GetByName(Name: string): PType;
    function GetLast: PType;
  end;

  TConstant = record
    Name: shortstring;
    DataType: PType;
    Index: Integer;
    case TBaseType of
      btChar: (ValueChar: Char);
      btInteger: (ValueInteger: Integer);
      btShortString: (ValueString: ShortString);
      btBoolean: (ValueBoolean: Boolean);
      btRecord: (ValueRecord: PVariables);
      btArray: (ValueArray: PVariables);
  end;

  { TConstants }

  TConstants = record
    Items: array of TConstant;
    procedure Add(Constant: TConstant);
    function GetByName(Name: string): PConstant;
  end;
  PConstants = ^TConstants;

  TVariable = record
    Name: string;
    DataType: PType;
    Index: Integer;
    Value: TConstant;
  end;

  { TVariables }

  TVariables = record
    ParentList: PVariables;
    Items: array of TVariable;
    procedure Add(Variable: TVariable);
    function GetByName(Name: string): PVariable;
    function GetLast: PVariable;
  end;

  TVariableRef = record
    Variable: PVariable;
    case TBaseType of
      btRecord: (Field: PType);
      btArray: (Index: PGetValue);
  end;

  TFunctionParameter = record
    Name: string;
    DataType: PType;
    Output: Boolean;
  end;

  { TFunctionParameters }

  TFunctionParameters = record
    TypeList: PTypes;
    Items: array of TFunctionParameter;
    procedure Add(Param: TFunctionParameter);
  end;
  PFunctionParameters = ^TFunctionParameters;

  TFunctionCall = procedure ;

  TCmdType = (ctNone, ctWhileDo, ctIfThenElse, ctBeginEnd, ctAssignment, ctExecution);
  TCommand = record
    CmdType: TCmdType;
    case Integer of
      0: (WhileDo: PWhileDo);
      1: (IfThenElse: PIfThenElse);
      2: (BeginEnd: PBeginEnd);
      3: (Assignment: PAssignment);
      4: (Execution: PExecution);
  end;
  PCommand = ^TCommand;

  { TBeginEnd }

  TBeginEnd = record
    Commands: array of TCommand;
    procedure Add;
    function GetLast: PCommand;
  end;

  TReadType = (rtVariable, rtConstant, rtExpression, rtFunctionCall, rtValue);
  TGetValue = record
    ReadType: TReadType;
    case TReadType of
      rtVariable: (VariableRef: PVariableRef);
      rtConstant: (Constant: PConstant);
      rtExpression: (Expression: PExpression);
      rtFunctionCall: (FunctionCall: PExecution);
      rtValue: (Value: TConstant);
  end;

  TExpNodeType = (ntNone, ntValue, ntOperator);

  TExpression = record
    NodeType: TExpNodeType;
    OperatorType: TOperator;
    Items: array of TExpression;
    Value: TGetValue;
    Parentheses: Boolean;
    Associated: Boolean;
  end;

  TAssignment = record
    Destination: PVariableRef;
    Source: TGetValue;
  end;

  TIfThenElse = record
    Condition: TGetValue;
    DoThen: TCommand;
    DoElse: TCommand;
  end;

  TWhileDo = record
    Condition: TGetValue;
    Command: TCommand;
  end;

  { TFunction }

  TFunction = record // TCommand
    Name: string;
    Parameters: TFunctionParameters;
    ReturnType: PType;
    BeginEnd: TBeginEnd;
    Variables: TVariables;
    Types: TTypes;
    ParentRecord: PType;
  end;

  { TFunctions }

  TFunctions = record
    Items: array of TFunction;
    procedure Add(Func: TFunction);
    function GetByName(Name: string): PFunction;
    function GetLast: PFunction;
  end;

  TExecutionParams = record
    Items: array of TGetValue;
  end;

  TExecution = record
    Func: PFunction;
    Parameters: TExecutionParams;
  end;

  TDirective = record
    Name: string;
    Value: string;
  end;
  PDirective = ^TDirective;

  TUses = record
    Items: array of string;
  end;
  PUses = ^TUses;

  TUnit = record
    Name: string;
    Types: TTypes;
    Variables: TVariables;
    Constants: TConstants;
    UsesSection: TUses;
    Functions: TFunctions;
  end;
  PUnit = ^TUnit;

  { TUnits }

  TUnits = record
    Items: array of TUnit;
    function GetByName(Name: string): PUnit;
  end;

  TProgramCode = record
    Name: string;
    BaseDir: string;
    Variables: TVariables;
    Constants: TConstants;
    Types: TTypes;
    Functions: TFunctions;
    BeginEnd: TBeginEnd;
    UsesSection: TUses;
    Units: TUnits;
  end;
  PProgramCode = ^TProgramCode;

function ConstantCreate(Name: string; DataType: PType): TConstant;
function VariableCreate(Name: string; DataType: PType): TVariable;
function FunctionCreate(Name: string; DataType: PType): TFunction;
function TypeCreate(Name: string; BaseType: TBaseType): TType;
function FunctionParameterCreate(Name: string; DataType: PType; Output: Boolean = False): TFunctionParameter;

var
  OperatorString: array[TOperator] of string = ('', '+', '-', 'and', 'or', 'not',
    '=', '<>', '<', '>', '<=', '>=');

const
  OperatorPrecedence: array[0..10] of TOperator = (opNot, opAnd, opOr, opAdd,
    opSubtract, opEqual, opNotEqual, opLess, opGreater, opLessOrEqual, opGreaterOrEqual);
  Keywords: array[0..18] of string = ('begin', 'end', 'if', 'then', 'else', 'while',
    'do', 'type', 'var', 'const', 'uses', 'unit', 'program', 'array', 'procedure',
    'function', 'interface', 'implementation', 'record');


implementation

function ConstantCreate(Name: string; DataType: PType): TConstant;
begin
  Result.Name := Name;
  Result.DataType := DataType;
end;

function VariableCreate(Name: string; DataType: PType): TVariable;
begin
  Result.Name := Name;
  Result.DataType := DataType;
end;

function FunctionCreate(Name: string; DataType: PType): TFunction;
begin
  Result.Name := Name;
  Result.ReturnType := DataType;
end;

function TypeCreate(Name: string; BaseType:TBaseType): TType;
begin
  Result.Name := Name;
  Result.BaseType := BaseType;
end;

function FunctionParameterCreate(Name: string; DataType: PType; Output: Boolean = False): TFunctionParameter;
begin
  Result.Name := Name;
  Result.DataType := DataType;
  Result.Output := Output;
end;

{ TUnits }

function TUnits.GetByName(Name: string): PUnit;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].Name <> Name) do I := I + 1;
  if I < Length(Items) then Result := @Items[I]
    else Result := nil;
end;

{ TBeginEnd }

procedure TBeginEnd.Add;
begin
  SetLength(Commands, Length(Commands) + 1);
end;

function TBeginEnd.GetLast: PCommand;
begin
  Result := @Commands[Length(Commands) - 1];
end;

{ TConstants }

procedure TConstants.Add(Constant: TConstant);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := Constant;
  Items[Length(Items) - 1].Index := Length(Items) - 1;
end;

function TConstants.GetByName(Name: string): PConstant;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].Name <> Name) do I := I + 1;
  if I < Length(Items) then Result := @Items[I]
    else Result := nil;
end;

{ TVariables }

procedure TVariables.Add(Variable: TVariable);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := Variable;
  Items[Length(Items) - 1].Index := Length(Items) - 1;
end;

function TVariables.GetByName(Name: string): PVariable;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].Name <> Name) do I := I + 1;
  if I < Length(Items) then Result := @Items[I]
    else begin
      if ParentList <> nil then Result := ParentList^.GetByName(Name)
        else Result := nil;
    end;
end;

function TVariables.GetLast: PVariable;
begin
  Result := @Items[Length(Items) - 1];
end;

{ TFunctionParameters }

procedure TFunctionParameters.Add(Param: TFunctionParameter);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := Param;
end;

{ TTypes }

procedure TTypes.Add(DataType: TType);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := DataType;
end;

function TTypes.GetByName(Name: string): PType;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].Name <> Name) do I := I + 1;
  if I < Length(Items) then Result := @Items[I]
    else begin
      if ParentList <> nil then Result := ParentList^.GetByName(Name)
        else Result := nil;
    end;
end;

function TTypes.GetLast: PType;
begin
  Result := @Items[Length(Items) - 1];
end;

{ TFunctions }

procedure TFunctions.Add(Func: TFunction);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := Func;
end;

function TFunctions.GetByName(Name: string): PFunction;
var
  I: Integer;
begin
  I := 0;
  while (I < Length(Items)) and (Items[I].Name <> Name) do I := I + 1;
  if I < Length(Items) then Result := @Items[I]
    else Result := nil;
end;

function TFunctions.GetLast: PFunction;
begin
  Result := @Items[Length(Items) - 1];
end;

end.