source: trunk/Compiler/Modules/Pascal/SourceCodePascal.pas

unit SourceCodePascal;

interface

uses
  SysUtils, Variants, Classes, Dialogs, Generics.Collections, SourceConvertor;

type
  TMemoryType = (mtProgram, mtData, mtEEPROM);

  TModuleType = (mdProgram, mdUnit, mdLibrary, mdPackage);

  TNodeType = (ntNone, ntVariable, ntFunction, ntConstant, ntOperator,
    ntValue, ntTypecast, ntType);

  TTypeVisibility = (tvPublic, tvPublished, tvPrivate, tvProtected);

  TValue = Variant; //array of Byte;

  TCommonBlock = class;
  TTypes = class;
  TConstants = class;
  TVariables = class;
  TFunctions = class;
  TExpressions = class;
  TExpression = class;
  TFunction = class;
  TVariable = class;
  TConstant = class;
  TSourceModule = class;
  TProgram = class;

  TDevice = class
    Family: string;
    Memory: array[TMemoryType] of Integer;
  end;

  TContext = class
  end;

  TCommands = class;

  TCommand = class
    Parent: TObject;
    CommonBlock: TCommonBlock;
  end;

  TAssignment = class(TCommand)
    Target: TVariable;
    Source: TExpression;
    constructor Create;
    destructor Destroy; override;
  end;

  { TExpressions }

  TExpressions = class(TObjectList<TExpression>)
    procedure Assign(Source: TExpressions);
  end;

  { TFunctionCall }

  TFunctionCall = class(TCommand)
    FunctionRef: TFunction;
    ParameterExpression: TExpressions;
    constructor Create;
    destructor Destroy; override;
  end;

  TBeginEnd = class(TCommand)
    Commands: TCommands;
    CommonBlock: TCommonBlock;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  TWhileDo = class(TCommand)
    Condition: TExpression;
    Command: TCommand;
    constructor Create;
    destructor Destroy; override;
  end;

  TWithDo = class(TCommand)
    Context: TContext;
    Command: TCommand;
  end;

  TRepeatUntil = class(TCommand)
    Block: TCommands;
    Condition: TExpression;
  end;

  { TForToDo }

  TForToDo = class(TCommand)
    ControlVariable: TVariable;
    Start: TExpression;
    Stop: TExpression;
    Command: TCommand;
    constructor Create;
    destructor Destroy; override;
  end;

  { TIfThenElse }

  TIfThenElse = class(TCommand)
    Condition: TExpression;
    Command: TCommand;
    ElseCommand: TCommand;
    constructor Create;
    destructor Destroy; override;
  end;

  TCaseOfEndBranche = class
    Constant: TConstant;
    Command: TCommand;
  end;

  TListCaseOfEndBranche = class(TObjectList<TCaseOfEndBranche>);

  TCaseOfEnd = class(TCommand)
    Expression: TExpression;
    Branches: TListCaseOfEndBranche;
    ElseCommand: TCommand;
    constructor Create;
    destructor Destroy; override;
  end;

  TTryFinally = class(TCommand)
    Block: TCommands;
    FinallyBlock: TCommands;
  end;

  TTryExcept = class(TCommand)
    Block: TCommands;
    ExceptBlock: TCommands;
  end;

  TCommands = class(TObjectList<TCommand>);

  TCommonBlockSection = (cbsVariable, cbsType, cbsConstant);

  TCommonBlock = class
    Name: string;
    Parent: TCommonBlock;
    ParentModule: TSourceModule;
    Constants: TConstants;
    Types: TTypes;
    Variables: TVariables;
    Functions: TFunctions;
    Order: TObjectList<TObject>;
    Code: TBeginEnd;
    constructor Create; virtual;
    destructor Destroy; override;
//    procedure CheckReferences;
  end;

  { TType }

  TType = class
    ForwardDeclared: Boolean;
    Internal: Boolean;
    Parent: TTypes;
    Name: string;
    Size: Integer;
    UsedType: TType;
    Exported: Boolean;
    Visibility: TTypeVisibility;
    Parameters: TTypes;
    procedure Assign(Source: TType);
    constructor Create;
    destructor Destroy; override;
  end;

  { TTypes }

  TTypes = class(TObjectList<TType>)
    Parent: TCommonBlock;
    function Search(Name: string; Exported: Boolean = False): TType;
    destructor Destroy; override;
    function AddNew: TType;
  end;

  TTypeInherited = class(TType)
  end;

  TTypeRecord = class(TType)
    CommonBlock: TCommonBlock;
    constructor Create;
    destructor Destroy; override;
  end;

  TTypeSubRange = class(TType)
    Bottom: Variant;
    Top: Variant;
  end;

  TTypeArray = class(TType)
    IndexType: TType;
    ItemType: TType;
  end;

  TTypePointer = class(TType)
  end;

  TEnumItem = class
    Name: string;
    Index: Integer;
  end;

  TEnumItems = class(TObjectList<TEnumItem>);

  TTypeEnumeration = class(TType)
    Items: TEnumItems;
    constructor Create;
    destructor Destroy; override;
  end;

  { TTypeClass }

  TTypeClass = class(TType)
    CommonBlock: TCommonBlock;
    constructor Create;
    destructor Destroy; override;
  end;

  TConstant = class
    System: Boolean;
    Name: string;
    ValueType: TType;
    Value: TValue;
    Exported: Boolean;
  end;

  TConstants = class(TObjectList<TConstant>)
    Parent: TCommonBlock;
    function Search(Name: string): TConstant;
    destructor Destroy; override;
  end;

  TVariable = class
    Name: string;
    ValueType: TType;
    DefaultValue: TValue;
    Exported: Boolean;
    Value: TValue; // runtime
  end;

  TVariables = class(TObjectList<TVariable>)
    Parent: TCommonBlock;
    function Search(Name: string; Exported: Boolean = False): TVariable;
    destructor Destroy; override;
  end;

  TParameter = class(TVariable)
  end;

  TParameters = class(TObjectList<TParameter>)
    Parent: TFunction;
    function Search(Name: string): TParameter;
    destructor Destroy; override;
  end;

  { TExpression }

  TExpression = class
    CommonBlock: TCommonBlock;
    NodeType: TNodeType;
    Variable: TVariable;
    Constant: TConstant;
    UseType: TType;
    FunctionCall: TFunctionCall;
    Value: TValue;
    OperatorName: string;
    SubItems: TExpressions;
    Associated: Boolean;
    Braces: Boolean;
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TExpression);
  end;

  TFunctionType = (ftFunction, ftProcedure, ftConstructor, ftDestructor);

  TFunction = class(TCommonBlock)
  public
    Internal: Boolean;
    FunctionType: TFunctionType;
    Parameters: TParameters;
    ResultType: TType;
    Exported: Boolean;
    BodyLoaded: Boolean;
    constructor Create; override;
    destructor Destroy; override;
  end;

  { TFunctions }

  TFunctions = class(TObjectList<TFunction>)
    Parent: TCommonBlock;
    function Search(Name: string; Exported: Boolean = False): TFunction;
    destructor Destroy; override;
    function AddNew: TFunction;
  end;

  TUsedModule = class
    Name: string;
    Location: string;
    Module: TSourceModule;
    Exported: Boolean;
  end;

  TUsedModules = class(TObjectList<TUsedModule>)
    ParentModule: TSourceModule;
  end;

  { TSourceModule }

  TSourceModule = class
  public
    ParentProgram: TProgram;
    Name: string;
    TargetFile: string;
    UsedModules: TUsedModules;
    Body: TCommonBlock;
    Internal: Boolean;
    function SearchVariable(Name: string; Outside: Boolean): TVariable; virtual;
    function SearchConstant(Name: string; Outside: Boolean): TConstant; virtual;
    function SearchType(AName: string; Outside: Boolean): TType; virtual;
    function SearchFunction(Name: string; Outside: Boolean): TFunction; virtual;
    constructor Create;
    destructor Destroy; override;
  end;

  { TModuleProgram }

  TModuleProgram = class(TSourceModule)
    constructor Create;
    destructor Destroy; override;
  end;

  { TModuleUnit }

  TModuleUnit = class(TSourceModule)
    InititializeSection: TCommonBlock;
    FinalalizeSection: TCommonBlock;
    constructor Create;
    destructor Destroy; override;
  end;

  TModulePackage = class(TSourceModule)

  end;

  TModuleLibrary = class(TSourceModule)
  end;

  { TModules }

  TModules = class(TObjectList<TSourceModule>)
    function Search(Name: string): TSourceModule;
  end;

  { TProgram }

  TProgram = class(TSource)
    Device: TDevice;
    Modules: TModules;
    MainModule: TSourceModule;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

const
  KeyWords: array[0..37] of string = ('program', 'unit', 'uses', 'begin', 'end',
    'type', 'const', 'var', 'array', 'record', 'absolute', 'virtual', 'class',
    'set', 'private', 'public', 'interface', 'implementation', 'finalization',
    'initialization', 'for', 'while', 'if', 'case', 'of', 'pointer',
    'object', 'packed', 'procedure', 'function', 'to', 'do', 'downto', 'repeat',
    'until', 'then', 'asm', 'else');
  Operators: array[0..22] of string = ('@', 'not', '*', 'and', '/', 'shl',
    'shr', 'as', 'div', 'mod', 'or', 'xor', '-', '+', '=', '>', '<', '<>', '<=',
     '>=', 'is', 'in', ':=');

resourcestring
  SAssignmentError = 'Assignment error';


implementation

{ TFunction }

constructor TFunction.Create;
begin
  inherited;
  Parameters := TParameters.Create;
  Parameters.Parent := Self;
  //ResultType := TType.Create;
end;

destructor TFunction.Destroy;
begin
  FreeAndNil(Parameters);
//  FreeAndNil(ResultType);
  inherited;
end;

{ TProgram }

procedure TProgram.Clear;
begin
  Modules.Clear;
  MainModule := nil;
end;

constructor TProgram.Create;
begin
  Device := TDevice.Create;
  Modules := TModules.Create;
end;

destructor TProgram.Destroy;
begin
  FreeAndNil(Modules);
  FreeAndNil(Device);
end;

{ TConstants }

destructor TConstants.Destroy;
begin
  inherited;
end;

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

{ TSourceModule }

constructor TSourceModule.Create;
begin
  inherited;
  UsedModules := TUsedModules.Create;
  UsedModules.ParentModule := Self;
  Body := TCommonBlock.Create;
  Body.ParentModule := Self;
end;

destructor TSourceModule.Destroy;
begin
  FreeAndNil(Body);
  FreeAndNil(UsedModules);
  inherited;
end;

(*
procedure TCommonBlock.CheckReferences;
var
  I: Integer;
begin
  for I := 0 to Operations.Count - 1 do
  with TOperation(Operations[I]) do begin
    if (Instruction = inJump) or (Instruction = inConditionalJump) then
      TOperation(Operations[GotoAddress]).Referenced := True;
  end;
end;
*)

constructor TCommonBlock.Create;
begin
  Constants := TConstants.Create;
  Constants.Parent := Self;
  Types := TTypes.Create;
  Types.Parent := Self;
  Variables := TVariables.Create;
  Variables.Parent := Self;
  Functions := TFunctions.Create;
  Functions.Parent := Self;
  Code := TBeginEnd.Create;
  Code.Parent := Self;
  Code.CommonBlock := Self;
  Order := TObjectList<TObject>.Create;
  Order.OwnsObjects := False;
end;

destructor TCommonBlock.Destroy;
begin
  FreeAndNil(Constants);
  FreeAndNil(Types);
  FreeAndNil(Variables);
  FreeAndNil(Functions);
  FreeAndNil(Code);
  FreeAndNil(Order);
  inherited;
end;

{ TTypes }

destructor TTypes.Destroy;
begin
  inherited;
end;

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

function TTypes.Search(Name: string; Exported: Boolean = False): TType;
var
  I: Integer;
begin
  // Search in own list
  I := 0;
  while (I < Count) and (LowerCase(TType(Items[I]).Name) <> LowerCase(Name)) do Inc(I);
  if I < Count then Result := TType(Items[I])
    else Result := nil;

  // Search in parent
  if not Assigned(Result) and Assigned(Parent.Parent) then
     Result := Parent.Parent.Types.Search(Name);

  // Search global variables
  if not Assigned(Result) and Assigned(Parent.ParentModule) and (not Exported) then begin
    Result := Parent.ParentModule.SearchType(Name, True);
  end;
end;

{ TVariables }

destructor TVariables.Destroy;
begin
  inherited;
end;

function TVariables.Search(Name: string; Exported: Boolean = False): TVariable;
var
  I: Integer;
begin
  // Search in own list
  I := 0;
  while (I < Count) and (LowerCase(TVariable(Items[I]).Name) <> LowerCase(Name)) do Inc(I);
  if I < Count then Result := TVariable(Items[I]) else Result := nil;

  if not Exported then begin
    // Search parent block variables
    if not Assigned(Result) then begin
      if Assigned(Parent.Parent) then
        Result := Parent.Parent.Variables.Search(Name)
        else Result := nil;
    end;

    // Search parent function parameters
    if not Assigned(Result) then begin
      if Assigned(Parent) and (Parent is TFunction) then
        Result := TFunction(Parent).Parameters.Search(Name)
        else Result := nil;
    end;

    if not Assigned(Result) then begin
      if Assigned(Parent.Parent) and (Parent.Parent is TFunction) then
        Result := TFunction(Parent.Parent).Parameters.Search(Name)
        else Result := nil;
    end;

    // Search global variables
    //if not Assigned(Result) then begin
    //  if Assigned(Parent.ParentModule) then
    //    Result := Parent.ParentModule.SearchVariable(Name, True);
    //end;
  end;
end;

{ TFunctions }

destructor TFunctions.Destroy;
begin
  inherited;
end;

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

function TFunctions.Search(Name: string; Exported: Boolean): TFunction;
var
  I: Integer;
begin
  // Search in own list
  I := 0;
  while (I < Count) and (LowerCase(TFunction(Items[I]).Name) <> LowerCase(Name)) do Inc(I);
  if I < Count then Result := TFunction(Items[I]) else Result := nil;

  // Search parent block list
  if not Assigned(Result) and Assigned(Parent.Parent) then
    Result := Parent.Parent.Functions.Search(Name, Exported);

  // Search global variables
  if not Assigned(Result) and Assigned(Parent.ParentModule) and (not Exported) then
    Result := Parent.ParentModule.SearchFunction(Name, True);
end;

{ TExpression }

constructor TExpression.Create;
begin
  SubItems := TExpressions.Create;
  SubItems.Count := 2;
  SubItems.OwnsObjects := False;
end;

destructor TExpression.Destroy;
begin
  FreeAndNil(SubItems);
  inherited;
end;

procedure TExpression.Assign(Source: TExpression);
begin
  CommonBlock := Source.CommonBlock;
  NodeType := Source.NodeType;
  FunctionCall := Source.FunctionCall;
  Value := Source.Value;
  Associated := Source.Associated;
  OperatorName := Source.OperatorName;
  Variable := Source.Variable;
  SubItems.Assign(Source.SubItems);
end;

{ TParameters }

destructor TParameters.Destroy;
begin
  inherited;
end;

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

{ TBeginEnd }

procedure TBeginEnd.Clear;
begin
end;

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

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

{ TAssignment }

constructor TAssignment.Create;
begin
//  Source := TExpression.Create;
end;

destructor TAssignment.Destroy;
begin
  FreeAndNil(Source);
  inherited;
end;

{ TExpressions }

procedure TExpressions.Assign(Source: TExpressions);
var
  I: Integer;
begin
  while Count > Source.Count do Delete(Count - 1);
  while Count < Source.Count do Add(TExpression.Create);
  for I := 0 to Count - 1 do
    Items[I].Assign(Source[I]);
end;

{ TWhileDo }

constructor TWhileDo.Create;
begin
  Condition := TExpression.Create;
  Command := TCommand.Create;
end;

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

{ TCaseOfEnd }

constructor TCaseOfEnd.Create;
begin
  inherited;
  Branches := TListCaseOfEndBranche.Create
end;

destructor TCaseOfEnd.Destroy;
begin
  FreeAndNil(Branches);
  inherited;
end;

{ TIfThenElse }

constructor TIfThenElse.Create;
begin
  Condition := TExpression.Create;
end;

destructor TIfThenElse.Destroy;
begin
  FreeAndNil(Condition);
  inherited;
end;

{ TFunctionCall }

constructor TFunctionCall.Create;
begin
  inherited;
  ParameterExpression := TExpressions.Create;
end;

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

{ TForToDo }

constructor TForToDo.Create;
begin
  inherited;
  Start := TExpression.Create;
  Stop := TExpression.Create;
end;

destructor TForToDo.Destroy;
begin
  FreeAndNil(Start);
  FreeAndNil(Stop);
  inherited;
end;

{ TTypeRecord }

constructor TTypeRecord.Create;
begin
  inherited;
  CommonBlock := TCommonBlock.Create;
end;

destructor TTypeRecord.Destroy;
begin
  FreeAndNil(CommonBlock);
  inherited;
end;

{ TModules }

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

{ TModuleProgram }

function TSourceModule.SearchVariable(Name: string; Outside: Boolean): TVariable;
var
  I: Integer;
begin
  Result := Body.Variables.Search(Name, Outside);

  if not Assigned(Result) and Outside then begin
    I := 0;
    while (I < UsedModules.Count) and (not Assigned(Result)) do begin
      Result := TUsedModule(UsedModules[I]).Module.SearchVariable(Name, False);
      Inc(I);
    end;
  end;
end;

function TSourceModule.SearchConstant(Name: string; Outside: Boolean): TConstant;
begin
end;

function TSourceModule.SearchType(AName: string; Outside: Boolean): TType;
var
  I: Integer;
begin
  Result := Body.Types.Search(AName, Outside);

  if not Assigned(Result) and Outside then begin
    I := 0;
    while (I < UsedModules.Count) and (not Assigned(Result)) do begin
      with TUsedModule(UsedModules[I]) do
        if Assigned(Module) then
        with Module do
          Result := SearchType(AName, False);
      Inc(I);
    end;
  end;
end;

function TSourceModule.SearchFunction(Name: string; Outside: Boolean): TFunction;
var
  I: Integer;
begin
  Result := Body.Functions.Search(Name, Outside);

  if not Assigned(Result) and Outside then begin
    I := 0;
    while (I < UsedModules.Count) and (not Assigned(Result)) do begin
    if Assigned(TUsedModule(UsedModules[I]).Module) then
      Result := TUsedModule(UsedModules[I]).Module.SearchFunction(Name, False);
      Inc(I);
    end;
  end;
end;

constructor TModuleProgram.Create;
begin
  inherited;
end;

destructor TModuleProgram.Destroy;
begin
  inherited;
end;

{ TModuleUnit }


constructor TModuleUnit.Create;
begin
  inherited;
  InititializeSection := TCommonBlock.Create;
  InititializeSection.ParentModule := Self;
  FinalalizeSection := TCommonBlock.Create;
  FinalalizeSection.ParentModule := Self;
end;

destructor TModuleUnit.Destroy;
begin
  FreeAndNil(InititializeSection);
  FreeAndNil(FinalalizeSection);
  inherited;
end;

{ TTypeEnumeration }

constructor TTypeEnumeration.Create;
begin
  inherited;
  Items := TEnumItems.Create;
end;

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

{ TTypeClass }

constructor TTypeClass.Create;
begin
  inherited;
  CommonBlock := TCommonBlock.Create;
end;

destructor TTypeClass.Destroy;
begin
  FreeAndNil(CommonBlock);
  inherited;
end;

{ TType }

procedure TType.Assign(Source: TType);
var
  I: Integer;
  NewType: TType;
begin
  if Assigned(Source) then begin
    Name := Source.Name;
    Parameters.Clear;
    for I := 0 to Source.Parameters.Count - 1 do begin
      NewType := TType.Create;
      //NewType := TType(Source.Parameters[I].ClassType.Create);
      NewType.Assign(TType(Source.Parameters[I]));
      Parameters.Add(NewType);
    end;
    Visibility := Source.Visibility;
    Parent := Source.Parent;
    Internal := Source.Internal;
    ForwardDeclared := Source.ForwardDeclared;
    Exported := Source.Exported;
    Size := Source.Size;
    UsedType := Source.UsedType;
  end else raise Exception.Create(SAssignmentError);
end;

constructor TType.Create;
begin
  Parameters := TTypes.Create;
  //Parameters.Parent := Parent.Parent;
end;

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

end.