* Tests for procedure/function declarations, fixes in parsing of those

git-svn-id: trunk@22157 -

.gitattributes

@@ -2333,6 +2333,7 @@ packages/fcl-passrc/tests/tcclasstype.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcexprparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
+packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcstatements.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tctypeparser.pas svneol=native#text/plain

packages/fcl-passrc/examples/test_parser.pp

@@ -1157,7 +1157,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
           begin
            pv:=TPasVariant(prct.Variants[i]);
            write(s1,pv.Name);
-           for k:=0 to pv.Values.Count-1 do write(pv.Values[k]);
+           for k:=0 to pv.Values.Count-1 do write(TPasElement(pv.Values[k]).GetDeclaration(true));
            write(': (');
            if GetVariantRecord(TPasElement(pv.Members),j+1) then
              writeln(s1,');')
@@ -1245,7 +1245,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
           begin
            pv:=TPasVariant(prct.Variants[i]);
            write(s2,pv.Name);
-           for k:=0 to pv.Values.Count-1 do write(pv.Values[k]);
+           for k:=0 to pv.Values.Count-1 do write(TPasElement(pv.Values[k]).GetDeclaration(true));
            write(': (');
            if GetVariantRecord(TPasElement(pv.Members),j+2) then
              writeln(s2,');')

packages/fcl-passrc/src/pastree.pp

@@ -692,11 +692,11 @@ type
   end;
 
   TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
-                        pmExported, pmOverload, pmMessage, pmReintroduce,
+                        pmExport, pmOverload, pmMessage, pmReintroduce,
                         pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
                         pmCompilerProc,pmExternal,pmForward);
   TProcedureModifiers = Set of TProcedureModifier;
-  TProcedureMessageType = (pmtInteger,pmtString);
+  TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
                         
   TProcedureBody = class;
 
@@ -705,6 +705,7 @@ type
     FModifiers : TProcedureModifiers;
     FMessageName : String;
     FMessageType : TProcedureMessageType;
+    FPublicName: String;
     function GetCallingConvention: TCallingConvention;
     procedure SetCallingConvention(AValue: TCallingConvention);
   public
@@ -716,6 +717,9 @@ type
   public
     ProcType : TPasProcedureType;
     Body : TProcedureBody;
+    PublicName,
+    LibrarySymbolName,
+    LibraryExpr : TPasExpr;
     Procedure AddModifier(AModifier : TProcedureModifier);
     Function IsVirtual : Boolean;
     Function IsDynamic : Boolean;
@@ -735,10 +739,13 @@ type
   end;
 
   TPasFunction = class(TPasProcedure)
+  private
+    function GetFT: TPasFunctionType;
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
     function GetDeclaration (full : boolean) : string; override;
+    Property FuncType : TPasFunctionType Read GetFT;
   end;
 
   { TPasOperator }
@@ -1138,6 +1145,11 @@ const
   cCallingConventions : array[TCallingConvention] of string =
       ( '', 'Register','Pascal','CDecl','StdCall','OldFPCCall','SafeCall');
 
+  ModifierNames : Array[TProcedureModifier] of string
+                = ('virtual', 'dynamic','abstract', 'override',
+                   'export', 'overload', 'message', 'reintroduce',
+                   'static','inline','assembler','varargs', 'public',
+                   'compilerproc','external','forward');
 
 implementation
 
@@ -1317,6 +1329,12 @@ function TPasConst.ElementTypeName: string; begin Result := SPasTreeConst end;
 function TPasProperty.ElementTypeName: string; begin Result := SPasTreeProperty end;
 function TPasOverloadedProc.ElementTypeName: string; begin Result := SPasTreeOverloadedProcedure end;
 function TPasProcedure.ElementTypeName: string; begin Result := SPasTreeProcedure end;
+
+function TPasFunction.GetFT: TPasFunctionType;
+begin
+  Result:=ProcType as TPasFunctionType;
+end;
+
 function TPasFunction.ElementTypeName: string; begin Result := SPasTreeFunction end;
 function TPasClassProcedure.ElementTypeName: string; begin Result := SPasTreeClassProcedure; end;
 function TPasClassFunction.ElementTypeName: string; begin Result := SPasTreeClassFunction; end;
@@ -1821,6 +1839,9 @@ begin
     ProcType.Release;
   if Assigned(Body) then
     Body.Release;
+  FreeAndNil(PublicName);
+  FreeAndNil(LibraryExpr);
+  FreeAndNil(LibrarySymbolName);
   inherited Destroy;
 end;
 
@@ -2579,7 +2600,7 @@ end;
 
 Function TPasProcedure.IsExported : Boolean;
 begin
-  Result:=pmExported in FModifiers;
+  Result:=pmExport in FModifiers;
 end;
 
 function TPasProcedure.IsExternal: Boolean;

packages/fcl-passrc/src/pparser.pp

@@ -30,6 +30,7 @@ resourcestring
   SParserErrorAtToken = '%s at token "%s" in file %s at line %d column %d';
   SParserUngetTokenError = 'Internal error: Cannot unget more tokens, history buffer is full';
   SParserExpectTokenError = 'Expected "%s"';
+  SParserForwardNotInterface = 'The use of a FORWARD procedure modifier is not allowed in the interface';
   SParserExpectVisibility = 'Expected visibility specifier';
   SParserStrangeVisibility = 'Strange strict visibility encountered : "%s"';
   SParserExpectToken2Error = 'Expected "%s" or "%s"';
@@ -306,12 +307,6 @@ end;
 
 Function IsModifier(S : String; Out Pm : TProcedureModifier) : Boolean;
 
-Const
-  ModifierNames : Array[TProcedureModifier] of string
-                = ('virtual', 'dynamic','abstract', 'override',
-                   'exported', 'overload', 'message', 'reintroduce',
-                   'static','inline','assembler','varargs', 'public',
-                   'compilerproc','external','forward');
 
 Var
   P : TProcedureModifier;
@@ -660,7 +655,7 @@ end;
 function TPasParser.TokenIsProcedureModifier(Parent : TPasElement; S: String; out Pm: TProcedureModifier): Boolean;
 begin
   Result:=IsModifier(S,PM);
-  if result and (pm=pmPublic)then
+  if result and (pm in [pmPublic,pmForward]) then
     begin
     While (Parent<>Nil) and Not (Parent is TPasClassType) do
      Parent:=Parent.Parent;
@@ -2553,26 +2548,42 @@ procedure TPasParser.HandleProcedureModifier(Parent: TPasElement;pm : TProcedure
 
 Var
   Tok : String;
+  P : TPasProcedure;
+  E : TPasExpr;
 
 begin
   if parent is TPasProcedure then
-    TPasProcedure(Parent).AddModifier(pm);
+    P:=TPasProcedure(Parent);
+  if Assigned(P) then
+    P.AddModifier(pm);
   if (pm=pmExternal) then
     begin
     NextToken;
     if CurToken in [tkString,tkIdentifier] then
       begin
-      NextToken;
+      // extrenal libname
+      // external libname name XYZ
+      // external name XYZ
+      Tok:=UpperCase(CurTokenString);
+      if Not ((curtoken=tkIdentifier) and (Tok='NAME')) then
+        begin
+        E:=DoParseExpression(Parent);
+        if Assigned(P) then
+          P.LibraryExpr:=E;
+        end;
       if CurToken=tkSemicolon then
         UnGetToken
       else
         begin
         Tok:=UpperCase(CurTokenString);
-        if Tok='NAME' then
+        if ((curtoken=tkIdentifier) and (Tok='NAME')) then
           begin
           NextToken;
           if not (CurToken in [tkString,tkIdentifier]) then
             ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkString]]));
+          E:=DoParseExpression(Parent);
+          if Assigned(P) then
+            P.LibrarySymbolName:=E;
           end;
         end;
       end
@@ -2593,13 +2604,20 @@ begin
     else
       begin
       NextToken;  // Should be export name string.
-      ExpectToken(tkSemicolon);
+      if not (CurToken in [tkString,tkIdentifier]) then
+        ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkString]]));
+      E:=DoParseExpression(Parent);
+      if parent is TPasProcedure then
+        TPasProcedure(Parent).PublicName:=E;
+      if (CurToken <> tkSemicolon) then
+        ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkSemicolon]]));
       end;
     end
-  else if pm=pmForward then
+  else if (pm=pmForward) then
     begin
     if (Parent.Parent is TInterfaceSection) then
        begin
+       ParseExc(SParserForwardNotInterface);
        UngetToken;
        end;
     end

packages/fcl-passrc/tests/tcbaseparser.pas

@@ -40,6 +40,7 @@ Type
     FIsUnit : Boolean;
     FImplementation : Boolean;
     FEndSource: Boolean;
+    FUseImplementation: Boolean;
     function GetPL: TPasLibrary;
     function GetPP: TPasProgram;
   protected
@@ -70,6 +71,7 @@ Type
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TProcedureModifier); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TProcedureModifiers); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TAssignKind); overload;
+    Procedure AssertEquals(Const Msg : String; AExpected, AActual: TProcedureMessageType); overload;
     Procedure HaveHint(AHint : TPasMemberHint; AHints : TPasMemberHints);
     Property Resolver : TStreamResolver Read FResolver;
     Property Scanner : TPascalScanner Read FScanner;
@@ -82,7 +84,7 @@ Type
     Property Definition : TPasElement Read FDefinition Write FDefinition;
     // If set, Will be freed in teardown
     Property ParseResult : TPasElement Read FParseResult Write FParseResult;
-
+    Property UseImplementation : Boolean Read FUseImplementation Write FUseImplementation;
   end;
 
 implementation
@@ -232,9 +234,18 @@ procedure TTestParser.StartImplementation;
 begin
   if Not FImplementation then
     begin
-    Add('');
+    if UseImplementation then
-    Add('Implementation');
+      begin
-    Add('');
+      FSource.Insert(0,'');
+      FSource.Insert(0,'Implementation');
+      FSource.Insert(0,'');
+      end
+    else
+      begin
+      Add('');
+      Add('Implementation');
+      Add('');
+      end;
     FImplementation:=True;
     end;
 end;
@@ -269,14 +280,20 @@ end;
 
 procedure TTestParser.ParseDeclarations;
 begin
+  if UseImplementation then
+    StartImplementation;
   FSource.Insert(0,'');
   FSource.Insert(0,'interface');
   FSource.Insert(0,'');
   FSource.Insert(0,'unit afile;');
-  StartImplementation;
+  if Not UseImplementation then
+    StartImplementation;
   EndSource;
   ParseModule;
-  FDeclarations:=Module.InterfaceSection;
+  if UseImplementation then
+    FDeclarations:=Module.ImplementationSection
+  else
+    FDeclarations:=Module.InterfaceSection;
 end;
 
 procedure TTestParser.ParseModule;
@@ -446,6 +463,13 @@ begin
                    GetEnumName(TypeInfo(TAssignKind),Ord(AActual)));
 end;
 
+procedure TTestParser.AssertEquals(const Msg: String; AExpected,
+  AActual: TProcedureMessageType);
+begin
+  AssertEquals(Msg,GetEnumName(TypeInfo(TProcedureMessageType),Ord(AExpected)),
+                   GetEnumName(TypeInfo(TProcedureMessageType),Ord(AActual)));
+end;
+
 procedure TTestParser.HaveHint(AHint: TPasMemberHint; AHints: TPasMemberHints);
 begin
   If not (AHint in AHints) then

packages/fcl-passrc/tests/tcclasstype.pas

@@ -92,6 +92,8 @@ type
     Procedure TestMethodOverloadVisibility;
     Procedure TestMethodHint;
     Procedure TestMethodVirtualHint;
+    Procedure TestIntegerMessageMethod;
+    Procedure TestStringMessageMethod;
     Procedure Test2Methods;
     Procedure Test2MethodsDifferentVisibility;
     Procedure TestPropertyRedeclare;
@@ -717,6 +719,28 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
+procedure TTestClassType.TestIntegerMessageMethod;
+begin
+  AddMember('Procedure DoSomething(A : Integer) message 123');
+  ParseClass;
+  DefaultMethod;
+  AssertEquals('Default visibility',visDefault,Method1.Visibility);
+  AssertEquals('No modifiers',[pmMessage],Method1.Modifiers);
+  AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
+  AssertEquals('Message name','123',Method1.MessageName);
+end;
+
+procedure TTestClassType.TestStringMessageMethod;
+begin
+  AddMember('Procedure DoSomething(A : Integer) message ''aha''');
+  ParseClass;
+  DefaultMethod;
+  AssertEquals('Default visibility',visDefault,Method1.Visibility);
+  AssertEquals('No modifiers',[pmMessage],Method1.Modifiers);
+  AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
+  AssertEquals('Message name','''aha''',Method1.MessageName);
+end;
+
 procedure TTestClassType.Test2Methods;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual');

packages/fcl-passrc/tests/testpassrc.lpi

@@ -37,7 +37,7 @@
         <PackageName Value="FCL"/>
       </Item2>
     </RequiredPackages>
-    <Units Count="10">
+    <Units Count="11">
       <Unit0>
         <Filename Value="testpassrc.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -88,6 +88,11 @@
         <IsPartOfProject Value="True"/>
         <UnitName Value="tcexprparser"/>
       </Unit9>
+      <Unit10>
+        <Filename Value="tcprocfunc.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="tcprocfunc"/>
+      </Unit10>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

packages/fcl-passrc/tests/testpassrc.lpr

@@ -3,9 +3,9 @@ program testpassrc;
 {$mode objfpc}{$H+}
 
 uses
-  Classes, consoletestrunner, tcscanner, 
+  Classes, consoletestrunner, tcscanner, tctypeparser, tcstatements,
-tctypeparser, tcstatements, tcbaseparser,
+  tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype,
-  tcmoduleparser, tconstparser, tcvarparser, tcclasstype, tcexprparser;
+  tcexprparser, tcprocfunc;
 
 type