source: trunk/Compiler/Modules/DynamicC/ProducerDynamicC.pas

unit ProducerDynamicC;

interface

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

type

  { TProducerC }

  TProducerDynamicC = class(TProducer)
  private
    function TranslateType(Name: string): string;
    function TranslateOperator(Name: string): 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 = ''; HeaderOnly: Boolean = False);
    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);
    function GenerateFunctionCall(FunctionCall: TFunctionCall): string;
    function GenerateExpression(Expression: TExpression): string;
  public
    procedure AssignToStringList(Target: TStringList); override;
    procedure Produce(Module: TSourceModule); override;
    constructor Create;
    destructor Destroy; override;
  end;


implementation

{ TProducerC }

constructor TProducerDynamicC.Create;
begin
  {$IFDEF Windows}
  CompilerPath := 'c:\Program Files\Dynamic C Rabbit 9.62\Dcrab_9.62.exe';
  {$ENDIF}
end;

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

function TProducerDynamicC.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 TProducerDynamicC.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 TProducerDynamicC.GenerateUses(UsedModules: TUsedModules);
var
  I: Integer;
begin
  for I := 0 to UsedModules.Count - 1 do
    EmitLn('#use "' + TUsedModule(UsedModules[I]).Name + '.lib"');
  EmitLn;
end;

procedure TProducerDynamicC.GenerateModule(Module: TSourceModule);
begin
  if Module is TModuleProgram then begin
    Module.TargetFile := Module.Name + '.c';
    EmitLn('#use "platform.lib"');
    EmitLn;
    TModuleProgram(Module).Body.Name := 'main';
    GenerateUses(TModuleProgram(Module).UsedModules);
    GenerateCommonBlock(TModuleProgram(Module).Body, '');
  end else
  if Module is TModuleUnit then begin
    Module.TargetFile := 'Lib\' + Module.Name + '.lib';
    EmitLn('/*** BeginHeader */');
    EmitLn('#ifndef ' + UpperCase(Module.Name) + '_H');
    EmitLn('#define ' + UpperCase(Module.Name) + '_H');
    EmitLn;
    EmitLn('#use "platform.lib"');
    GenerateUses(TModuleProgram(Module).UsedModules);
    GenerateTypes(TModuleUnit(Module).Body.Types);
    EmitLn('/*** EndHeader */');
    EmitLn;
    EmitLn('/*** BeginHeader */');
    GenerateFunctions(TModuleUnit(Module).Body.Functions, '', True);
    EmitLn('/*** EndHeader */');
    EmitLn;

    GenerateFunctions(TModuleUnit(Module).Body.Functions);

    GenerateCommonBlock(TModuleUnit(Module).Body, '');

    EmitLn;
    EmitLn('/*** BeginHeader */');
    EmitLn('#endif');
    EmitLn('/*** EndHeader */');
  end;
end;

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

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

procedure TProducerDynamicC.GenerateFunctions(Functions: TFunctions;
  Prefix: string = ''; HeaderOnly: Boolean = False);
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);
    if not HeaderOnly then GenerateBeginEnd(Code);
    EmitLn;
  end;
end;

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

  // 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(Indentation);
  EmitLn('}');
end;

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

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

procedure TProducerDynamicC.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 EmitLn(GenerateFunctionCall(TFunctionCall(Command)) + ';');
end;

procedure TProducerDynamicC.GenerateWhileDo(WhileDo: TWhileDo);
begin
  EmitLn('while (' + GenerateExpression(WhileDo.Condition) + ')');
  if Assigned(WhileDo.Command) then GenerateCommand(WhileDo.Command);
end;

procedure TProducerDynamicC.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 TProducerDynamicC.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 TProducerDynamicC.GenerateAssignment(Assignment: TAssignment);
begin
  if Assignment.Target.Name = 'Result' then EmitLn('return(' + GenerateExpression(Assignment.Source) + ');')
    else EmitLn(Assignment.Target.Name + ' = ' + GenerateExpression(Assignment.Source) + ';');
end;

function TProducerDynamicC.GenerateFunctionCall(FunctionCall: TFunctionCall): string;
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 + ')';
  end;
  Result := Line;
end;

function TProducerDynamicC.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 := GenerateFunctionCall(Expression.FunctionCall);
      ntOperator: begin
        Result := GenerateExpression(TExpression(Expression.SubItems.First))
          + ' ' + TranslateOperator(Expression.OperatorName) + ' ' +
          GenerateExpression(TExpression(Expression.SubItems.Last));
      end;
      ntNone: ;
    end;
    if Expression.Braces then Result := '(' + Result + ')';
  end;
end;

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

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

procedure TProducerDynamicC.GenerateType(AType: TType);
var
  I: Integer;
begin
  if Assigned(AType) then begin
  if AType is TTypeRecord then begin
    EmitLn('struct');
    EmitLn('{');
    Inc(Indentation);
    GenerateVariableList(TTypeRecord(AType).CommonBlock.Variables);
    Dec(Indentation);
    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 TProducerDynamicC.GenerateTypes(Types: TTypes);
var
  I: Integer;
begin
  if Types.Count > 0 then begin
    Inc(Indentation);
    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(Indentation);
    EmitLn('');
  end;
end;

end.