source: trunk/Compiler/Modules/GCC/ProducerGCC.pas

unit ProducerGCC;

interface

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

type

  { TProducerGCCC }

  TProducerGCCC = class(TProducer)
  private
    function TranslateType(Name: string): string;
    function TranslateOperator(Name: string): string;
    procedure Emit(AText: string);
    procedure EmitLn(AText: string = '');
    procedure GenerateUses(UsedModules: TUsedModules);
    procedure GenerateModule(Module: TSourceModule);
    procedure GenerateCommonBlock(CommonBlock: TCommonBlock;
      LabelPrefix: string);
    procedure GenerateType(AType: TType);
    procedure GenerateTypes(Types: TTypes);
    procedure GenerateProgram(ProgramBlock: TProgram);
    procedure GenerateFunctions(Functions: TFunctions;
      Prefix: string = '');
    procedure GenerateBeginEnd(BeginEnd: TBeginEnd);
    procedure GenerateVariableList(VariableList: 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(FunctionCall: TFunctionCall);
    function GenerateExpression(Expression: TExpression): string;
  public
    TextSource: TStringList;
    IndentationLength: Integer;
    Indetation: Integer;
    procedure AssignToStringList(Target: TStringList); override;
    procedure Produce(Module: TSourceModule); override;
    constructor Create;
    destructor Destroy; override;
  end;


implementation

{ TProducerGCCC }

constructor TProducerGCCC.Create;
begin
  TextSource := TStringList.Create;
  IndentationLength := 2;
  {$IFDEF Windows}
  CompilerPath := 'c:\Program Files\MinGW\bin\gcc.exe -o %1:s';
  {$ENDIF}
  {$IFDEF Linux}
  CompilerPath := '/usr/bin/gcc';
  {$ENDIF}
end;

destructor TProducerGCCC.Destroy;
begin
  FreeAndNil(TextSource);
  inherited;
end;

function TProducerGCCC.TranslateType(Name: string): string;
begin
  if Name = 'Byte' then Result := 'uint8'
  else if Name = 'ShortInt' then Result := 'int8'
  else if Name = 'Word' then Result := 'int16'
  else if Name = 'SmallInt' then Result := 'int16'
  else if Name = 'Cardinal' then Result := 'uint32'
  else if Name = 'Integer' then Result := 'int32'
  else if Name = 'Void' then Result := 'void'
  else Result := Name;
end;

function TProducerGCCC.TranslateOperator(Name: string): string;
begin
  if Name = '=' then Result := '=='
  else if Name = 'shl' then Result := '<<'
  else if Name = 'shr' then Result := '>>'
  else if Name = 'not' then Result := '!'
  else if Name = 'mod' then Result := '^'
  else if Name = ':=' then Result := '='
  else if Name = '@' then Result := '*'
  else if Name = 'and' then Result := '&'
  else if Name = 'or' then Result := '|'
  else if Name = 'xor' then Result := '^'
  else Result := Name;
end;

procedure TProducerGCCC.EmitLn(AText: string = '');
begin
  Emit(AText);
  TextSource.Add('');
end;

procedure TProducerGCCC.Emit(AText: string);
begin
  with TextSource do begin
    if Count = 0 then Add('');
    if Strings[Count - 1] = '' then
      Strings[Count - 1] := Strings[Count - 1] + DupeString(' ', IndentationLength * Indetation);
    Strings[Count - 1] := Strings[Count - 1] + AText;
  end;
end;

procedure TProducerGCCC.GenerateUses(UsedModules: TUsedModules);
var
  I: Integer;
begin
  for I := 0 to UsedModules.Count - 1 do
    EmitLn('#include "' + TUsedModule(UsedModules[I]).Name + '.h"');
  EmitLn;
end;

procedure TProducerGCCC.GenerateModule(Module: TSourceModule);
begin
  Module.TargetFile := Module.Name + '.c';
  EmitLn('#include "platform.h"');
  EmitLn;
  if Module is TModuleProgram then begin
    TModuleProgram(Module).Body.Name := 'main';
    GenerateUses(TModuleProgram(Module).UsedModules);
    GenerateCommonBlock(TModuleProgram(Module).Body, '');
  end else
  if Module is TModuleUnit then begin
    GenerateUses(TModuleProgram(Module).UsedModules);
    GenerateCommonBlock(TModuleUnit(Module).Body, '');
  end;
end;

procedure TProducerGCCC.Produce(Module: TSourceModule);
begin
  inherited;
  TextSource.Clear;
  GenerateModule(Module);
end;

procedure TProducerGCCC.GenerateProgram(ProgramBlock: TProgram);
var
  I: Integer;
begin
  Indetation := 0;
  with ProgramBlock do
  for I := 0 to Modules.Count - 1 do
    GenerateModule(TSourceModule(Modules[I]));
end;

procedure TProducerGCCC.GenerateFunctions(Functions: TFunctions;
  Prefix: string = '');
var
  I: Integer;
  J: Integer;
  Line: string;
begin
  for I := 0 to Functions.Count - 1 do
  with TFunction(Functions[I]) do
  if not Internal then begin
    if (FunctionType = ftFunction) and Assigned(ResultType) then
      Line := TranslateType(ResultType.Name) + ' '
      else Line := 'void ';
    Line := Line + Prefix + Name + '(';
    if Parameters.Count > 0 then
    for J := 0 to Parameters.Count - 1 do begin
      Line := Line + TranslateType(TParameter(Parameters[J]).ValueType.Name) +
        ' ' + TParameter(Parameters[J]).Name;
      if J < Parameters.Count - 1 then Line := Line + ', ';
    end;
    Line := Line + ')';
    EmitLn(Line);
    GenerateBeginEnd(Code);
    EmitLn;
  end;
end;

procedure TProducerGCCC.GenerateBeginEnd(BeginEnd: TBeginEnd);
var
  I: Integer;
begin
  EmitLn('{');
  Inc(Indetation);

  // Variables
  if BeginEnd.Parent is TCommonBlock then begin
    GenerateVariableList(BeginEnd.CommonBlock.Variables);
  end;

  // Commands
  for I := 0 to BeginEnd.Commands.Count - 1 do
    GenerateCommand(TCommand(BeginEnd.Commands[I]));

  Dec(Indetation);
  EmitLn('}');
end;

procedure TProducerGCCC.GenerateVariableList(VariableList: TVariables);
var
  I: Integer;
begin
  for I := 0 to VariableList.Count - 1 do
    GenerateVariable(TVariable(VariableList[I]));
//  EmitLn;
end;

procedure TProducerGCCC.GenerateVariable(Variable: TVariable);
begin
  with Variable do
    EmitLn(TranslateType(ValueType.Name) + ' ' + Name + ';');
end;

procedure TProducerGCCC.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 TProducerGCCC.GenerateWhileDo(WhileDo: TWhileDo);
begin
  EmitLn('while (' + GenerateExpression(WhileDo.Condition) + ')');
  if Assigned(WhileDo.Command) then GenerateCommand(WhileDo.Command);
end;

procedure TProducerGCCC.GenerateForToDo(ForToDo: TForToDo);
begin
  with ForToDo do begin
    if Assigned(ControlVariable) then
    EmitLn('for(' + ControlVariable.Name + ' = ' +
      GenerateExpression(Start) + '; ' + ControlVariable.Name + ' < ' +
      GenerateExpression(Stop) + '; ' + ControlVariable.Name + '++)');
    GenerateCommand(Command);
  end;
end;

procedure TProducerGCCC.GenerateIfThenElse(IfThenElse: TIfThenElse);
begin
  EmitLn('if(' + GenerateExpression(IfThenElse.Condition) + ')');
  GenerateCommand(IfThenElse.Command);
  if Assigned(IfThenElse.ElseCommand) then begin
    EmitLn('else ');
    GenerateCommand(IfThenElse.ElseCommand);
  end;
end;

procedure TProducerGCCC.GenerateAssignment(Assignment: TAssignment);
begin
  if Assignment.Target.Name = 'Result' then EmitLn('return(' + GenerateExpression(Assignment.Source) + ');')
    else EmitLn(Assignment.Target.Name + ' = ' + GenerateExpression(Assignment.Source) + ';');
end;

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

function TProducerGCCC.GenerateExpression(Expression: TExpression): string;
begin
  case Expression.NodeType of
    ntConstant: 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))
        + ' ' + TranslateOperator(Expression.OperatorName) + ' ' +
        GenerateExpression(TExpression(Expression.SubItems.Last));
    end;
    ntNone: ;
  end;
end;

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

procedure TProducerGCCC.GenerateCommonBlock(CommonBlock: TCommonBlock; LabelPrefix: string);
var
  I: Integer;
  LabelName: string;
begin
  with CommonBlock do begin
    GenerateTypes(Types);
    GenerateFunctions(Functions);
    EmitLn('void ' + Name + '()');
    GenerateBeginEnd(Code);
  end;
end;

procedure TProducerGCCC.GenerateType(AType: TType);
var
  I: Integer;
begin
  if Assigned(AType) then begin
  if AType is TTypeRecord then begin
    EmitLn('struct');
    EmitLn('{');
    Inc(Indetation);
    GenerateVariableList(TTypeRecord(AType).CommonBlock.Variables);
    Dec(Indetation);
    EmitLn('} ' + TranslateType(AType.Name) + ';');
    EmitLn;
    GenerateFunctions(TTypeRecord(AType).CommonBlock.Functions, AType.Name + '_');
  end else
  if AType is TTypeArray then begin
    GenerateType(TTypeArray(AType).ItemType);
    EmitLn('* ');

(*    if Assigned(TTypeArray(AType).IndexType) then begin
      Emit(AType.Name + '[');
      Emit('[');
      GenerateType(TTypeArray(AType).IndexType);
      Emit(']');
    end;
    Emit(' of ');
    if Assigned(TTypeArray(AType).ItemType) then*)
    Emit(TranslateType(AType.Name));
  end else
  if AType is TTypePointer then begin
    if Assigned(AType.UsedType) then begin
      Emit(AType.UsedType.Name);
      Emit(' *');
    end;
    Emit(TranslateType(AType.Name));
  end else begin
    if Assigned(AType.UsedType) then begin
      //GenerateType(AType.UsedType);
      Emit(AType.UsedType.Name);
      Emit(' ');
    end;
    Emit(TranslateType(AType.Name));
  end;
  end;
end;

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

end.