Ignore:
Timestamp:
Oct 22, 2010, 9:22:55 AM (15 years ago)
Author:
george
Message:
  • Compiler producer for C language separated to GCC and Dynamic C dialect.
  • Enhanced: Parse record functions body.
Location:
branches/Transpascal/Compiler
Files:
2 added
8 edited

Legend:

Unmodified
Added
Removed

  • branches/Transpascal/Compiler/Analyze/UParser.pas

    r76 r77  
    6464    procedure Expect(Code: string);
    6565    procedure ErrorMessage(const Text: string; const Arguments: array of const;
    66       TokenOffset: Integer);
     66      TokenOffset: Integer = -1);
    6767    property OnErrorMessage: TErrorMessageEvent read FOnErrorMessage write FOnErrorMessage;
    6868    property OnDebugLog: TDebugLogEvent read FOnDebugLog write FOnDebugLog;
    … …  
    8080
    8181procedure TBaseParser.ErrorMessage(const Text: string; const Arguments: array of const;
    82   TokenOffset: Integer);
     82  TokenOffset: Integer = -1);
    8383begin
    8484  if Assigned(FOnErrorMessage) then

  • branches/Transpascal/Compiler/Analyze/UPascalParser.pas

    r76 r77  
    3232    procedure ParseBeginEnd(SourceCode: TBeginEnd);
    3333    procedure ParseFunctionList(SourceCode: TFunctionList; Exported: Boolean = False);
     34    procedure ParseFunctionParameters(SourceCode: TFunction);
    3435    procedure ParseIfThenElse(SourceCode: TIfThenElse);
    3536    procedure ParseForToDo(SourceCode: TForToDo);
    … …  
    5859  SUndefinedConstant = 'Undefined constant "%s".';
    5960  SUnitNotFound = 'Unit "%s" not found.';
     61  SFunctionNotDeclared = 'Function "%s" not declared.';
     62  SUnknownProcName = 'Unknown proc name "%s".';
    6063
    6164
    … …  
    507510{ TParserParseFunctionList }
    508511
    509 procedure TPascalParser.ParseFunctionList(SourceCode: TFunctionList; Exported: Boolean = False);
    510 var
    511   Identifiers: TStringList;
     512procedure TPascalParser.ParseFunctionList(SourceCode: TFunctionList;
     513  Exported: Boolean = False);
     514var
    512515  NewValueType: TType;
    513516  TypeName: string;
     517  UseName: string;
     518  I: Integer;
     519  UseType: TType;
     520  UseFunction: TFunction;
     521  FunctionType: TFunctionType;
     522begin
     523  with SourceCode do begin
     524    if NextToken = 'procedure' then begin
     525      Expect('procedure');
     526      FunctionType := ftProcedure;
     527    end else
     528    if NextToken = 'function' then begin
     529      Expect('function');
     530      FunctionType := ftFunction;
     531    end else
     532    if NextToken = 'constructor' then begin
     533      Expect('constructor');
     534      FunctionType := ftConstructor;
     535    end else
     536    if NextToken = 'destructor' then begin
     537      Expect('destructor');
     538      FunctionType := ftDestructor;
     539    end else ErrorMessage(SUnknownProcName, [NextToken]);
     540
     541    // Read function name
     542    UseName := ReadCode;
     543    UseType := SourceCode.Parent.Types.Search(UseName);
     544    if Assigned(UseType) and ((UseType is TTypeRecord) or
     545    (UseType is TTypeClass)) then begin
     546      Expect('.');
     547      UseName := ReadCode;
     548      if UseType is TTypeRecord then begin
     549        UseFunction := TTypeRecord(UseType).CommonBlock.Functions.Search(UseName);
     550        if not Assigned(UseFunction) then begin
     551          ErrorMessage(SFunctionNotDeclared, [UseName]);
     552          Exit;
     553        end;
     554      end;
     555    end else begin
     556      // Create new function
     557      UseFunction := TFunction.Create;
     558      UseFunction.Parent := SourceCode.Parent;
     559      UseFunction.Name := UseName;
     560      UseFunction.FunctionType := FunctionType;
     561      Add(UseFunction);
     562    end;
     563    with UseFunction do begin
     564      // Parse parameters
     565      if NextToken = '(' then
     566        ParseFunctionParameters(UseFunction);
     567
     568      // Parse function result type
     569      if FunctionType = ftFunction then begin
     570        Expect(':');
     571        TypeName := ReadCode;
     572        NewValueType := Parent.Types.Search(TypeName);
     573        if not Assigned(NewValueType) then
     574          ErrorMessage(SUndefinedType, [TypeName], -1);
     575(*        else
     576          begin
     577            ResultType := NewValueType;
     578            with TVariable(Parent.Variables.Items[Parent.Variables.Add(
     579                TVariable.Create)]) do
     580            begin
     581              Name := 'Result';
     582              ValueType := NewValueType;
     583            end;
     584          end;  *)
     585      end;
     586      Expect(';');
     587
     588      // Check directives
     589      if NextToken = 'internal' then begin
     590        Expect('internal');
     591        Expect(';');
     592        Internal := True;
     593      end;
     594    end;
     595
     596    if not Exported then ParseCommonBlock(UseFunction);
     597//    if UseFunction then UseFunction.Code ;
     598  end;
     599end;
     600
     601procedure TPascalParser.ParseFunctionParameters(SourceCode: TFunction);
     602var
     603  Identifiers: TStringList;
    514604  VariableName: string;
    515   Variable: TParameter;
    516   I: integer;
    517 begin
     605  UseVariable: TParameter;
     606  TypeName: string;
     607  UseType: TType;
     608  I: Integer;
     609begin
     610  with SourceCode do
    518611  try
    519   Identifiers := TStringList.Create;
    520   with SourceCode do begin
    521     with TFunction(Items[Add(TFunction.Create)]) do begin
    522       Parent := SourceCode.Parent;
    523       if NextToken = 'procedure' then begin
    524         Expect('procedure');
    525         HaveResult := False;
    526       end else begin
    527         Expect('function');
    528         HaveResult := True;
    529       end;
    530       Name := ReadCode;
    531 
    532       if NextToken = '(' then begin
     612    Identifiers := TStringList.Create;
    533613        Expect('(');
    534614        while NextToken <> ')' do begin
    … …  
    540620            if VariableName = 'const' then begin
    541621            end else begin
    542               Variable := Search(VariableName);
    543               if not Assigned(Variable) then begin
     622              UseVariable := Search(VariableName);
     623              if not Assigned(UseVariable) then begin
    544624                Identifiers.Add(VariableName);
    545625                while NextToken = ',' do begin
    … …  
    551631              Expect(':');
    552632              TypeName := ReadCode;
    553               NewValueType := Parent.Types.Search(TypeName);
    554               if not Assigned(NewValueType) then
     633              UseType := Parent.Types.Search(TypeName);
     634              if not Assigned(UseType) then
    555635                ErrorMessage(SUndefinedType, [TypeName], -1)
    556636              else
    … …  
    559639                  begin
    560640                    Name := Identifiers[I];
    561                     ValueType := NewValueType;
     641                    ValueType := UseType;
    562642                  end;
    563643            end;
    … …  
    566646        end;
    567647        Expect(')');
    568 
    569         // Parse function result type
    570         if HaveResult then begin
    571           Expect(':');
    572           TypeName := ReadCode;
    573           NewValueType := Parent.Types.Search(TypeName);
    574           if not Assigned(NewValueType) then
    575             ErrorMessage(SUndefinedType, [TypeName], -1);
    576 (*          else
    577           begin
    578             ResultType := NewValueType;
    579             with TVariable(Parent.Variables.Items[Parent.Variables.Add(
    580                 TVariable.Create)]) do
    581             begin
    582               Name := 'Result';
    583               ValueType := NewValueType;
    584             end;
    585           end;  *)
    586         end;
    587       end;
    588       Expect(';');
    589 
    590       // Check directives
    591       if NextToken = 'internal' then begin
    592         Expect('internal');
    593         Expect(';');
    594         System := True;
    595       end;
    596     end;
    597 
    598     if not Exported then ParseCommonBlock(TFunction(Last));
    599   end;
    600648  finally
    601649    Identifiers.Free;
    … …  
    924972    if NextToken = 'var' then begin
    925973      Expect('var');
    926       SectionType := stVar
     974      SectionType := stVar;
    927975    end else
    928976    if NextToken = 'const' then begin
    929977      Expect('const');
    930       SectionType := stConst
     978      SectionType := stConst;
    931979    end else
    932980    if NextToken = 'type' then begin

  • branches/Transpascal/Compiler/Produce/UProducerPascal.pas

    r68 r77  
    144144    for I := 0 to Types.Count - 1 do
    145145    with TType(Types[I]) do
    146     if (not System) then begin
     146    if (not Internal) then begin
    147147      GenerateType(TType(Types[I]), '=');
    148148      Emit(';');
    … …  
    178178  for I := 0 to Functions.Count - 1 do
    179179  with TFunction(Functions[I]) do
    180   if not System then
     180  if not Internal then
    181181  begin
    182     if HaveResult then
     182    if FunctionType = ftFunction then
    183183      Line := 'function ' + Name
    184184      else Line := 'procedure ' + Name;
    … …  
    192192      Line := Line + ')';
    193193    end;
    194     if HaveResult and Assigned(ResultType) then
     194    if (FunctionType = ftFunction) and Assigned(ResultType) then
    195195      Line := Line + ': ' + ResultType.Name;
    196196    Emit(Line + ';');

  • branches/Transpascal/Compiler/Produce/UProducerTreeView.pas

    r68 r77  
    227227    for I := 0 to Types.Count - 1 do
    228228    with TType(Types[I]) do
    229     if not System then AddNodeType(NewNode, TType(Types[I]));
     229    if (not Internal) then AddNodeType(NewNode, TType(Types[I]));
    230230  end;
    231231end;
    … …  
    265265  for I := 0 to Methods.Count - 1 do
    266266  with TFunction(Methods[I]) do
    267   if not System then begin
    268     if HaveResult then
     267  if (not Internal) then begin
     268    if FunctionType = ftFunction then
    269269      NewNode := TreeView.Items.AddChild(Node, 'function ' + Name)
    270270      else NewNode := TreeView.Items.AddChild(Node, 'procedure ' + Name);
    … …  
    301301    for I := 0 to TypeRecord.CommonBlock.Types.Count - 1 do
    302302    with TType(TypeRecord.CommonBlock.Types[I]) do
    303     if not System then
     303    if not Internal then
    304304      AddNodeType(Node, TType(TypeRecord.CommonBlock.Types[I]));
    305305  end;

  • branches/Transpascal/Compiler/TranspascalCompiler.lpk

    r72 r77  
    1515      </Other>
    1616    </CompilerOptions>
    17     <Files Count="10">
     17    <Files Count="11">
    1818      <Item1>
    1919        <Filename Value="UCompiler.pas"/>
    … …  
    3737      </Item5>
    3838      <Item6>
    39         <Filename Value="Produce\UProducerC.pas"/>
    40         <UnitName Value="UProducerC"/>
     39        <Filename Value="Produce\UProducerDynamicC.pas"/>
     40        <UnitName Value="UProducerDynamicC"/>
    4141      </Item6>
    4242      <Item7>
    … …  
    5656        <UnitName Value="UGrammer"/>
    5757      </Item10>
     58      <Item11>
     59        <Filename Value="Produce\UProducerGCCC.pas"/>
     60        <UnitName Value="UProducerGCCC"/>
     61      </Item11>
    5862    </Files>
    5963    <Type Value="RunAndDesignTime"/>

  • branches/Transpascal/Compiler/TranspascalCompiler.pas

    r72 r77  
    99uses
    1010    UCompiler, USourceCode, UProducerTreeView, UProducer, UProducerAsm8051,
    11   UProducerC, UProducerPascal, UParser, UPascalParser, UGrammer,
    12   LazarusPackageIntf;
     11  UProducerDynamicC, UProducerPascal, UParser, UPascalParser, UGrammer,
     12  UProducerGCCC, LazarusPackageIntf;
    1313
    1414implementation

  • branches/Transpascal/Compiler/UCompiler.pas

    r76 r77  
    88  SysUtils, Variants, Classes,
    99  Dialogs, USourceCode, UProducer, UPascalParser, UParser,
    10   UProducerC, Contnrs;
     10  UProducerDynamicC, Contnrs, UProducerTreeView, UProducerASM8051,
     11  UProducerPascal, UProducerGCCC;
    1112
    1213type
     14  TProducerType = (ptGCCC, ptDynamicC, ptPascal, ptAssembler, ptXML);
    1315
    1416  TErrorMessage = class
    … …  
    3335  private
    3436    FOnErrorMessage: TErrorMessageEvent;
     37    FProducerType: TProducerType;
    3538    procedure ErrorMessage(Text: string; Position: TPoint; FileName: string);
     39    procedure SetProducerType(const AValue: TProducerType);
    3640  public
    3741    ProgramCode: TProgram;
    … …  
    4953    property OnErrorMessage: TErrorMessageEvent read FOnErrorMessage
    5054      write FOnErrorMessage;
     55    property ProducerType: TProducerType read FProducerType
     56      write SetProducerType;
    5157  end;
     58
     59const
     60  ProducerTypeName: array[TProducerType] of string = (
     61    'GCC C', 'Rabbit Dynamic C', 'Generic Pascal', 'Assembler', 'XML');
     62
    5263
    5364implementation
    … …  
    93104
    94105  ProgramCode := TProgram.Create;
    95   Producer := TProducerC.Create;
     106  Producer := TProducerGCCC.Create;
    96107  Parser := TPascalParser.Create;
    97108  Parser.OnErrorMessage := ErrorMessage;
    … …  
    127138end;
    128139
     140procedure TCompiler.SetProducerType(const AValue: TProducerType);
     141begin
     142  if FProducerType = AValue then Exit;
     143  FProducerType := AValue;
     144  Producer.Free;
     145  case AValue of
     146    ptGCCC: Producer := TProducerGCCC.Create;
     147    ptDynamicC: Producer := TProducerDynamicC.Create;
     148    ptPascal: Producer := TProducerPascal.Create;
     149    ptAssembler: Producer := TProducerGCCC.Create;
     150    ptXML: Producer := TProducerTreeView.Create;
     151  end;
     152end;
     153
    129154{ TCompilerTargetList }
    130155

  • branches/Transpascal/Compiler/USourceCode.pas

    r76 r77  
    153153
    154154  TType = class
    155     System: Boolean;
     155    Internal: Boolean;
    156156    Parent: TTypeList;
    157157    Name: string;
    … …  
    259259  end;
    260260
     261  TFunctionType = (ftFunction, ftProcedure, ftConstructor, ftDestructor);
     262
    261263  TFunction = class(TCommonBlock)
    262264  public
    263     System: Boolean;
    264     HaveResult: Boolean;
     265    Internal: Boolean;
     266    FunctionType: TFunctionType;
    265267    Parameters: TParameterList;
    266268    ResultType: TType;
    … …  
    769771    while (I < UsedModules.Count) and (not Assigned(Result)) do begin
    770772      with TUsedModule(UsedModules[I]) do
     773        if Assigned(Module) then
    771774        with Module do
    772775          Result := SearchType(AName, False);
Note: See TracChangeset for help on using the changeset viewer.