* Support for type helpers, low()..High() ranges, static fields

git-svn-id: trunk@34668 -

packages/fcl-passrc/src/pastree.pp

@@ -705,7 +705,7 @@ type
   end;
 
   { TPasVariable }
-  TVariableModifier = (vmCVar, vmExternal, vmPublic, vmExport, vmClass);
+  TVariableModifier = (vmCVar, vmExternal, vmPublic, vmExport, vmClass,vmStatic);
   TVariableModifiers = set of TVariableModifier;
 
   TPasVariable = class(TPasElement)
@@ -4138,7 +4138,11 @@ begin
   If Kind=pekRange then
     Result:='..'
   else
-    Result:=' '+OpcodeStrings[Opcode]+' ';
+    begin
+    Result:=OpcodeStrings[Opcode];
+    if Not (OpCode in [eopAddress,eopDeref,eopSubIdent]) then
+      Result:=' '+Result+' ';
+    end;
   If Assigned(Left) then
   begin
     op := Left.GetDeclaration(Full);

packages/fcl-passrc/src/pparser.pp

@@ -1063,7 +1063,7 @@ begin
       ParseExcTokenError(';');
     UnGetToken;
     end
-  else if (CurToken=tkDotDot) then // A: B..C;
+  else if (CurToken in [tkBraceOpen,tkDotDot]) then // A: B..C;
     begin
     K:=stkRange;
     UnGetToken;
@@ -1225,7 +1225,7 @@ Const
   NoHintTokens = [tkProcedure,tkFunction];
 var
   PM : TPackMode;
-  CH , ok: Boolean; // Check hint ?
+  CH , isHelper,ok: Boolean; // Check hint ?
 begin
   Result := nil;
   // NextToken and check pack mode
@@ -1246,7 +1246,16 @@ begin
       tkInterface: Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface);
       tkSpecialize: Result:=ParseSpecializeType(Parent,TypeName);
       tkClass: Result := ParseClassDecl(Parent, NamePos, TypeName, okClass, PM);
-      tkType: Result:=ParseAliasType(Parent,NamePos,TypeName);
+      tkType:
+        begin
+        NextToken;
+        isHelper:=Curtoken=tkHelper;
+        UnGetToken;
+        if isHelper then
+          Result:=ParseClassDecl(Parent,NamePos,TypeName,okTypeHelper,PM)
+        else
+          Result:=ParseAliasType(Parent,NamePos,TypeName);
+        end;
       // Always allowed
       tkIdentifier: Result:=ParseSimpleType(Parent,NamePos,TypeName,Full);
       tkCaret: Result:=ParsePointerType(Parent,NamePos,TypeName);
@@ -1552,7 +1561,7 @@ begin
       while CurToken in [tkDot] do
         begin
         NextToken;
-        if CurToken=tkIdentifier then
+        if CurToken in [tkIdentifier,tktrue,tkfalse] then // true and false are also identifiers
           begin
           AddToBinaryExprChain(Result,Last,
             CreatePrimitiveExpr(AParent,pekIdent,CurTokenString), eopSubIdent);
@@ -4498,17 +4507,32 @@ Var
   VarList: TFPList;
   Element: TPasElement;
   I : Integer;
+  isStatic : Boolean;
 
 begin
   VarList := TFPList.Create;
   try
     ParseInlineVarDecl(AType, VarList, AVisibility, False);
+    if CurToken=tkSemicolon then
+      begin
+      NextToken;
+      isStatic:=CurTokenIsIdentifier('static');
+      if isStatic then
+        ExpectToken(tkSemicolon)
+      else
+        UngetToken;
+      end;
     for i := 0 to VarList.Count - 1 do
       begin
       Element := TPasElement(VarList[i]);
       Element.Visibility := AVisibility;
-      if IsClassField and (Element is TPasVariable) then
-        TPasVariable(Element).VarModifiers:=TPasVariable(Element).VarModifiers+[vmClass];
+      if (Element is TPasVariable) then
+        begin
+        if IsClassField then
+          TPasVariable(Element).VarModifiers:=TPasVariable(Element).VarModifiers+[vmClass];
+        if isStatic then
+          TPasVariable(Element).VarModifiers:=TPasVariable(Element).VarModifiers+[vmStatic];
+        end;
       AType.Members.Add(Element);
       end;
   finally
@@ -4689,10 +4713,11 @@ function TPasParser.ParseClassDecl(Parent: TPasElement;
 
 Var
   ok: Boolean;
+  FT : TPasType;
 
 begin
   NextToken;
-
+  FT:=Nil;
   if (AObjKind = okClass) and (CurToken = tkOf) then
     begin
     Result := TPasClassOfType(CreateElement(TPasClassOfType, AClassName,
@@ -4704,15 +4729,22 @@ begin
     end;
   if (CurToken = tkHelper) then
     begin
-    if Not (AObjKind in [okClass,okRecordHelper]) then
+    if Not (AObjKind in [okClass,okTypeHelper,okRecordHelper]) then
       ParseExc(nParserHelperNotAllowed,SParserHelperNotAllowed,[ObjKindNames[AObjKind]]);
-    if (AObjKind = okClass)  then
-      AObjKind:=okClassHelper;
+    Case AObjKind of
+     okClass:
+        AObjKind:=okClassHelper;
+     okTypeHelper:
+       begin
+       ExpectToken(tkFor);
+       FT:=ParseType(Parent,Scanner.CurSourcePos,'',False);
+       end
+    end;
     NextToken;
     end;
   Result := TPasClassType(CreateElement(TPasClassType, AClassName,
     Parent, NamePos));
-
+  TPasClassType(Result).HelperForType:=FT;
   ok:=false;
   try
     TPasClassType(Result).ObjKind := AObjKind;

packages/fcl-passrc/tests/tcclasstype.pas

@@ -72,6 +72,7 @@ type
     procedure TestOneSpecializedClassInterface;
     Procedure TestOneField;
     Procedure TestOneFieldComment;
+    procedure TestOneFieldStatic;
     Procedure TestOneVarField;
     Procedure TestOneClassField;
     Procedure TestOneFieldVisibility;
@@ -513,6 +514,16 @@ begin
   AssertVisibility;
 end;
 
+procedure TTestClassType.TestOneFieldStatic;
+begin
+  AddMember('a : integer; static');
+  ParseClass;
+  AssertNotNull('Have 1 field',Field1);
+  AssertMemberName('a');
+  AssertVisibility;
+  AssertTrue('Have static field',vmStatic in TPasVariable(Field1).VarModifiers);
+end;
+
 procedure TTestClassType.TestOneFieldComment;
 begin
   AddComment:=true;

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -80,6 +80,7 @@ type
     Procedure TestFunctionOneArgDefaultExpr;
     procedure TestProcedureTwoArgsDefault;
     Procedure TestFunctionTwoArgsDefault;
+    procedure TestFunctionOneArgEnumeratedExplicit;
     procedure TestProcedureOneUntypedVarArg;
     Procedure TestFunctionOneUntypedVarArg;
     procedure TestProcedureTwoUntypedVarArgs;
@@ -562,6 +563,13 @@ begin
   AssertArg(FuncType,0,'B',argDefault,'Integer','1');
 end;
 
+procedure TTestProcedureFunction.TestFunctionOneArgEnumeratedExplicit;
+begin
+  ParseFunction('(B : TSomeEnum = TSomeEnum.False)');
+  AssertFunc([],ccDefault,1);
+  AssertArg(FuncType,0,'B',argDefault,'TSomeEnum','TSomeEnum.False');
+end;
+
 procedure TTestProcedureFunction.TestProcedureOneArgDefaultSet;
 begin
   ParseProcedure('(B : MySet = [1,2])');

packages/fcl-passrc/tests/tctypeparser.pas

@@ -33,6 +33,7 @@ type
   TTestTypeParser = Class(TBaseTestTypeParser)
   private
   Protected
+    procedure StartTypeHelper(ForType: String; AParent: String);
     Procedure DoTestAliasType(Const AnAliasType : String; Const AHint : String);
     procedure DoTestStringType(const AnAliasType: String; const AHint: String);
     procedure DoTypeError(Const AMsg,ASource : string);
@@ -139,6 +140,7 @@ type
     Procedure TestComplexSet;
     Procedure TestComplexSetDeprecated;
     Procedure TestComplexSetPlatform;
+    procedure TestRangeLowHigh;
     Procedure TestRangeSet;
     Procedure TestSubRangeSet;
     Procedure TestRangeSetDeprecated;
@@ -155,6 +157,7 @@ type
     Procedure TestReferenceArray;
     Procedure TestReferencePointer;
     Procedure TestInvalidColon;
+    Procedure TestTypeHelper;
   end;
 
   { TTestRecordTypeParser }
@@ -2326,6 +2329,7 @@ Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;
 
 Var
   D : String;
+
 begin
   Hint:=AHint;
   Add('Type');
@@ -2340,11 +2344,19 @@ begin
   Add('  '+D+';');
 //  Writeln(source.text);
   ParseDeclarations;
-  AssertEquals('One type definition',1,Declarations.Types.Count);
+  if ATypeClass.InHeritsFrom(TPasClassType) then
+    AssertEquals('One type definition',1,Declarations.Classes.Count)
+  else
+    AssertEquals('One type definition',1,Declarations.Types.Count);
   If (AtypeClass<>Nil) then
-    AssertEquals('First declaration is type definition.',ATypeClass,TObject(Declarations.Types[0]).ClassType);
-  AssertEquals('First declaration has correct name.','A',TPasType(Declarations.Types[0]).Name);
-  Result:=TPasType(Declarations.Types[0]);
+    begin
+    if ATypeClass.InHeritsFrom(TPasClassType) then
+      Result:=TPasType(Declarations.Classes[0])
+    else
+      Result:=TPasType(Declarations.Types[0]);
+    AssertEquals('First declaration is type definition.',ATypeClass,Result.ClassType);
+    end;
+  AssertEquals('First declaration has correct name.','A',Result.Name);
   FType:=Result;
   Definition:=Result;
   if (Hint<>'') then
@@ -3044,6 +3056,13 @@ begin
   DoTestComplexSet;
 end;
 
+procedure TTestTypeParser.TestRangeLowHigh;
+
+begin
+  DoParseRangeSet('low(TRange)..high(TRange)','');
+end;
+
+
 procedure TTestTypeParser.TestRangeSet;
 begin
   // TRange = (rLow, rMiddle, rHigh);
@@ -3198,6 +3217,28 @@ begin
   AssertEquals('wrong colon in type raised an error',true,ok);
 end;
 
+
+procedure TTestTypeParser.StartTypeHelper(ForType: String; AParent: String);
+Var
+  S : String;
+begin
+
+  S:='TMyClass = Type Helper';
+  if (AParent<>'') then
+    begin
+    S:=S+'('+AParent;
+    S:=S+')';
+    end;
+  S:=S+' for '+ForType;
+  Add(S);
+
+end;
+
+procedure TTestTypeParser.TestTypeHelper;
+begin
+  ParseType('Type Helper for AnsiString end',TPasClassType,'');
+end;
+
 initialization
   RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);
 end.

packages/fcl-passrc/tests/testpassrc.lpi

@@ -30,7 +30,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestTypeParser.TestGenericArray"/>
+        <CommandLineParams Value="--suite=TTestTypeParser.TestRangeLowHigh"/>
       </local>
     </RunParams>
     <RequiredPackages Count="1">