source: trunk/Compiler/Modules/Delphi/ProducerDelphi.pas

unit ProducerDelphi;

interface

uses
  SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, SourceCodePascal, Producer, StrUtils, SourceConvertor;

type

  { TProducerPascal }

  TProducerPascal = class(TConvertor)
  private
    Producer: TProducer;
    procedure GenerateUses(UsedModules: TUsedModules);
    procedure GenerateModule(Module: TSourceModule);
    procedure GenerateUnit(Module: TSourceModule);
    procedure GenerateLibrary(Module: TSourceModule);
    procedure GeneratePackage(Module: TSourceModule);
    procedure GenerateType(AType: TType; AssignSymbol: Char = ':');
    procedure GenerateTypes(Types: TTypes);
    procedure GenerateCommonBlockInterface(CommonBlock: TCommonBlock;
      LabelPrefix: string);
    procedure GenerateCommonBlockImplementation(CommonBlock: TCommonBlock;
      LabelPrefix: string);
    procedure GenerateFunctions(Functions: TFunctions);
    procedure GenerateFunction(AFunction: TFunction);
    procedure GenerateFunctionHead(AFunction: TFunction);
    procedure GenerateConstants(Constants: TConstants);
    procedure GenerateConstant(Constant: TConstant);
    procedure GenerateBeginEnd(BeginEnd: TBeginEnd);
    procedure GenerateVariableList(Variables: TVariables);
    procedure GenerateVariable(Variable: TVariable);
    procedure GenerateCommand(Command: TCommand);
    procedure GenerateWhileDo(WhileDo: TWhileDo);
    procedure GenerateForToDo(ForToDo: TForToDo);
    procedure GenerateIfThenElse(IfThenElse: TIfThenElse);
    procedure GenerateAssignment(Assignment: TAssignment);
    procedure GenerateFunctionCall(ConstantCall: TFunctionCall);
    function GenerateExpression(Expression: TExpression): string;
  public
    procedure AssignToStringList(Target: TStringList);
    procedure Produce(Module: TSourceModule);
    constructor Create;
    destructor Destroy; override;
  end;


implementation

{ TProducerPascal }

constructor TProducerPascal.Create;
begin
  inherited;
  Name := 'PascalToDelphi';
  InputType := TProgram;
  OutputType := TSourceFileLink;

  Producer := TProducer.Create;
  {$IFDEF Windows}
  Producer.CompilerPath := 'c:\Program Files\Embarcadero\RAD Studio\9.0\bin\DCC32.EXE';
  Producer.CompilerParameters := '"%0:s"';
  {$ENDIF}
  {$IFDEF Linux}
  Producer.CompilerPath := '';
  {$ENDIF}
end;

destructor TProducerPascal.Destroy;
begin
  FreeAndNil(Producer);
  inherited;
end;

procedure TProducerPascal.GenerateUses(UsedModules: TUsedModules);
var
  I: Integer;
  ModuleName: string;
begin
  with Producer do begin
  if UsedModules.Count = 0 then Exit;
  EmitLn('uses');
  Inc(Indentation);
  for I := 0 to UsedModules.Count - 1 do begin
    if Assigned(TUsedModule(UsedModules[I]).Module) then
      ModuleName := TUsedModule(UsedModules[I]).Module.Name
      else ModuleName := '(' + TUsedModule(UsedModules[I]).Name + ')';
    if UsedModules.ParentModule is TModuleProgram then begin
      Emit(ModuleName + ' in ''' + ModuleName + '.pas''');
      if I < UsedModules.Count - 1 then EmitLn(', ');
    end else begin
      Emit(ModuleName);
      if I < UsedModules.Count - 1 then Emit(', ');
    end;
  end;
  EmitLn(';');
  Dec(Indentation);
  EmitLn;
  end;
end;

procedure TProducerPascal.GenerateModule(Module: TSourceModule);
begin
  with Producer do begin
  Module.TargetFile := Module.Name + '.pas';
  if Module is TModuleProgram then
  with TModuleProgram(Module) do begin
    Module.TargetFile := Module.Name + '.dpr';
    EmitLn('program ' + Name + ';');
    EmitLn;
    EmitLn('{$APPTYPE Console}');
    EmitLn;
    GenerateUses(UsedModules);
    GenerateCommonBlockImplementation(Body, '');
    EmitLn('.');
  end else
  if Module is TModuleUnit then GenerateUnit(Module)
  else if Module is TModuleLibrary then GenerateLibrary(Module)
  else if Module is TModulePackage then GeneratePackage(Module);
  end;
end;

procedure TProducerPascal.GenerateUnit(Module: TSourceModule);
begin
  with Producer do begin
  EmitLn('unit ' + TModuleUnit(Module).Name + ';');
  EmitLn;
  EmitLn('interface');
  EmitLn;
  GenerateCommonBlockInterface(TModuleUnit(Module).Body, '.');
  EmitLn;
  EmitLn('implementation');
  EmitLn;
  GenerateCommonBlockImplementation(TModuleUnit(Module).Body, '.');
  EmitLn('.');
  end;
end;

procedure TProducerPascal.GenerateLibrary(Module: TSourceModule);
begin
end;

procedure TProducerPascal.GeneratePackage(Module: TSourceModule);
begin
end;

procedure TProducerPascal.GenerateType(AType: TType; AssignSymbol: Char = ':');
var
  I: Integer;
begin
  with Producer do begin
  if AType is TTypeRecord then begin
    EmitLn('record');
    Inc(Indentation);
    with TTypeRecord(AType).CommonBlock do
    for I := 0 to Variables.Count - 1 do begin
      Emit(TVariable(Variables[I]).Name + ': ');
      GenerateType(TVariable(Variables[I]).ValueType);
      EmitLn(';');
    end;
    Dec(Indentation);
    Emit('end');
  end else
  if AType is TTypeSubRange then begin
    Emit(TTypeSubRange(AType).Bottom + '..' + TTypeSubRange(AType).Top);
  end else
  if AType is TTypeArray then begin
    Emit('array ');
    if Assigned(TTypeArray(AType).IndexType) then begin
      Emit('[');
      GenerateType(TTypeArray(AType).IndexType);
      Emit(']');
    end;
    Emit(' of ');
    if Assigned(TTypeArray(AType).ItemType) then
      GenerateType(TTypeArray(AType).ItemType);
  end else
  if AType is TTypePointer then begin
    Emit('^' + TTypePointer(AType).UsedType.Name);
  end else begin
    Emit(AType.Name);
    if AType.Name = '' then begin
      GenerateType(AType.UsedType);
    end;
  end;
  end;
end;

procedure TProducerPascal.GenerateTypes(Types: TTypes);
var
  I: Integer;
begin
  with Producer do begin
  if Types.Count > 0 then begin
    EmitLn('type');
    Inc(Indentation);
    for I := 0 to Types.Count - 1 do
    with TType(Types[I]) do
    if (not Internal) then begin
      Emit(TType(Types[I]).Name + ' = ');
      GenerateType(TType(Types[I]));
      EmitLn(';');
    end;
    Dec(Indentation);
    EmitLn;
  end;
  end;
end;

procedure TProducerPascal.Produce(Module: TSourceModule);
var
  I: Integer;
begin
  inherited;
  with Producer do begin
  TextSource.Clear;

  // Check unit names
  with Module.ParentProgram do
  for I := 0 to Modules.Count - 1 do
    if TSourceModule(Modules[I]).Name = 'System' then
      TSourceModule(Modules[I]).Name := 'System2';

  GenerateModule(Module);
  end;
end;

procedure TProducerPascal.GenerateFunctions(Functions: TFunctions);
var
  I: Integer;
begin
  for I := 0 to Functions.Count - 1 do
    GenerateFunction(TFunction(Functions[I]));
end;

procedure TProducerPascal.GenerateFunction(AFunction: TFunction);
var
  I: Integer;
  P: Integer;
  Line: string;
begin
  with Producer do
  with AFunction do
  if not Internal then
  begin
    GenerateFunctionHead(AFunction);
    GenerateBeginEnd(Code);
    EmitLn(';');
    EmitLn;
  end;
end;

procedure TProducerPascal.GenerateFunctionHead(AFunction: TFunction);
var
  Line: string;
  P: Integer;
begin
  with Producer, AFunction do begin
    if FunctionType = ftFunction then
      Line := 'function ' + Name
      else Line := 'procedure ' + Name;
    if Parameters.Count > 0 then begin
      Line := Line + '(';
      for P := 0 to Parameters.Count - 1 do begin
        with TParameter(Parameters[P]) do
          Line := Line + Name + ': ' + ValueType.Name;
        if P < (Parameters.Count - 1) then Line := Line + '; ';
      end;
      Line := Line + ')';
    end;
    if (FunctionType = ftFunction) and Assigned(ResultType) then
      Line := Line + ': ' + ResultType.Name;
    EmitLn(Line + ';');
  end;
end;

procedure TProducerPascal.GenerateConstants(Constants: TConstants);
var
  I: Integer;
begin
  with Producer do
  if Constants.Count > 0 then begin
    EmitLn('const');
    Inc(Indentation);
    for I := 0 to Constants.Count - 1 do
      GenerateConstant(TConstant(Constants[I]));
    Dec(Indentation);
    Emit('');
  end;
end;

procedure TProducerPascal.GenerateConstant(Constant: TConstant);
begin
  with Producer, Constant do begin
    Emit(Name);
    //if Assigned(ValueType) then Emit(': ' + ValueType.Name);
    EmitLn(' = ' + Value + ';');
  end;
end;

procedure TProducerPascal.GenerateBeginEnd(BeginEnd: TBeginEnd);
var
  I: Integer;
begin
  with Producer do begin
  EmitLn('begin');
  Inc(Indentation);
  // Commands
  for I := 0 to BeginEnd.Commands.Count - 1 do begin
    GenerateCommand(TCommand(BeginEnd.Commands[I]));
    EmitLn(';');
  end;

  Dec(Indentation);
  Emit('end');
  end;
end;

procedure TProducerPascal.GenerateVariableList(Variables: TVariables);
var
  I: Integer;
begin
  with Producer do begin
  EmitLn('var');
  Inc(Indentation);
  for I := 0 to Variables.Count - 1 do
    GenerateVariable(TVariable(Variables[I]));
  Dec(Indentation);
  EmitLn;
  end;
end;

procedure TProducerPascal.GenerateVariable(Variable: TVariable);
begin
  with Producer, Variable do
    EmitLn(Name + ': ' + ValueType.Name + ';');
end;

procedure TProducerPascal.GenerateCommand(Command: TCommand);
begin
  if Command is TBeginEnd then GenerateBeginEnd(TBeginEnd(Command))
  else if Command is TWhileDo then GenerateWhileDo(TWhileDo(Command))
  else if Command is TForToDo then GenerateForToDo(TForToDo(Command))
  else if Command is TIfThenElse then GenerateIfThenElse(TIfThenElse(Command))
  else if Command is TAssignment then GenerateAssignment(TAssignment(Command))
  else if Command is TFunctionCall then GenerateFunctionCall(TFunctionCall(Command));
end;

procedure TProducerPascal.GenerateWhileDo(WhileDo: TWhileDo);
begin
  with Producer do begin
  Emit('while ' + GenerateExpression(WhileDo.Condition) + ' do ');
  GenerateCommand(WhileDo.Command);
  end;
end;

procedure TProducerPascal.GenerateForToDo(ForToDo: TForToDo);
begin
  with Producer, ForToDo do begin
    if Assigned(ControlVariable) and Assigned(Start) and Assigned(Stop) then
    Emit('for ' + ControlVariable.Name + ' := ' +
      GenerateExpression(Start) + ' to ' + GenerateExpression(Stop) + ' do ');
    GenerateCommand(Command);
  end;
end;

procedure TProducerPascal.GenerateIfThenElse(IfThenElse: TIfThenElse);
begin
  with Producer do begin
  Emit('if ' + GenerateExpression(IfThenElse.Condition) + ' then ');
  GenerateCommand(IfThenElse.Command);
  if Assigned(IfThenElse.ElseCommand) then begin
    Emit(' else ');
    GenerateCommand(IfThenElse.ElseCommand);
  end;
  end;
end;

procedure TProducerPascal.GenerateAssignment(Assignment: TAssignment);
begin
  with Producer do begin
    Emit(Assignment.Target.Name + ' := ' + GenerateExpression(Assignment.Source));
  end;
end;

procedure TProducerPascal.GenerateFunctionCall(ConstantCall: TFunctionCall);
var
  Line: string;
  I: Integer;
begin
  with Producer do begin
  with ConstantCall do begin
    Line := FunctionRef.Name;
    if ParameterExpression.Count > 0 then begin
      Line := Line + '(';
      for I := 0 to ParameterExpression.Count - 1 do begin
        Line := Line + GenerateExpression(TExpression(ParameterExpression[I]));
        if I < ParameterExpression.Count - 1 then Line := Line + ', ';
      end;
      Line := Line + ')';
    end;
  end;
  Emit(Line);
  end;
end;

function TProducerPascal.GenerateExpression(Expression: TExpression): string;
begin
  if Assigned(Expression) then begin
    case Expression.NodeType of
      ntConstant: begin
        Result := Expression.Constant.Name;
      end;
      ntValue: begin
       if VarType(Expression.Value) = varString then
          Result := '''' + Expression.Value + ''''
          else Result := Expression.Value;
      end;
      ntVariable: Result := Expression.Variable.Name;
      ntFunction: Result := Expression.FunctionCall.FunctionRef.Name;
      ntOperator: begin
        Result := GenerateExpression(TExpression(Expression.SubItems.First))
          + ' ' + Expression.OperatorName + ' ' +
          GenerateExpression(TExpression(Expression.SubItems.Last));
      end;
      ntNone: ;
    end;
    if Expression.Braces then Result := '(' + Result + ')';
  end;
end;

procedure TProducerPascal.AssignToStringList(Target: TStringList);
begin
//  Target.Assign(TextSource);
end;

procedure TProducerPascal.GenerateCommonBlockInterface(CommonBlock: TCommonBlock; LabelPrefix: string);
var
  I: Integer;
  LabelName: string;
  Section: TCommonBlockSection;
begin
  with Producer do begin
  Inc(Indentation);
  with CommonBlock do begin
    for I := 0 to Order.Count - 1 do begin
      if (Order[I] is TType) and (TType(Order[I]).Exported) then begin
        if Section <> cbsType then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('type');
          Inc(Indentation);
        end;
        Emit(TType(Order[I]).Name + ' = ');
        GenerateType(TType(Order[I]));
        EmitLn(';');
        Section := cbsType;
      end else
      if (Order[I] is TVariable) and (TVariable(Order[I]).Exported) then begin
        if Section <> cbsVariable then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('var');
          Inc(Indentation);
        end;
        GenerateVariable(TVariable(Order[I]));
        Section := cbsVariable;
      end else
      if (Order[I] is TConstant) and (TConstant(Order[I]).Exported) then begin
        if Section <> cbsConstant then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('const');
          Inc(Indentation);
        end;
        GenerateConstant(TConstant(Order[I]));
        Section := cbsConstant;
      end else
      if (Order[I] is TFunction) and (TFunction(Order[I]).Exported) then begin
        GenerateFunctionHead(TFunction(Order[I]));
      end;
    end;
  end;
  Dec(Indentation);
  end;
end;

procedure TProducerPascal.GenerateCommonBlockImplementation(
  CommonBlock: TCommonBlock; LabelPrefix: string);
var
  I: Integer;
  LabelName: string;
  Section: TCommonBlockSection;
begin
  with Producer do begin
  Inc(Indentation);
  with CommonBlock do begin
    for I := 0 to Order.Count - 1 do begin
      if (Order[I] is TType) and (not TType(Order[I]).Exported) then begin
        if Section <> cbsType then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('type');
          Inc(Indentation);
        end;
        Emit(TType(Order[I]).Name + ' = ');
        GenerateType(TType(Order[I]));
        EmitLn(';');
        Section := cbsType;
      end else
      if (Order[I] is TVariable) and (not TVariable(Order[I]).Exported) then begin
        if Section <> cbsVariable then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('var');
          Inc(Indentation);
        end;
        GenerateVariable(TVariable(Order[I]));
        Section := cbsVariable;
      end else
      if (Order[I] is TConstant) and (not TConstant(Order[I]).Exported) then begin
        if Section <> cbsConstant then begin
          EmitLn;
          Dec(Indentation);
          EmitLn('const');
          Inc(Indentation);
        end;
        GenerateConstant(TConstant(Order[I]));
        Section := cbsConstant;
      end else
      if Order[I] is TFunction then begin
        GenerateFunction(TFunction(Order[I]));
      end;
    end;
    GenerateBeginEnd(Code);
  end;
  Dec(Indentation);
  end;
end;

end.