Jedi Code Format: Support generic types with const. Issue #38088, patch from Domingo Galmés.

git-svn-id: trunk@64149 -

components/jcf2/Parse/BuildParseTree.pas

@@ -65,6 +65,7 @@ type
     fiTokenCount: integer;
     procedure RecogniseTypeHelper;
     procedure SplitGreaterThanOrEqual;
+    procedure SplitShr_gg;
 
     procedure RecogniseGoal;
     procedure RecogniseUnit;
@@ -1260,6 +1261,9 @@ begin
   PopNode;
 end;
 
+const
+  CONST_GENERIC_TOKENS = [ttAt, ttOpenBracket, ttOpenSquareBracket, ttIdentifier, ttPlus, ttMinus,
+        ttNot, ttNumber, ttQuotedLiteralString, ttNil, ttTrue, ttFalse];
 
 function TBuildParseTree.GenericAhead: boolean;
 var
@@ -1287,7 +1291,7 @@ begin
     if liTokenIndex mod 2 = 0 then
     begin
       // should be id
-      if (lcToken.WordType <> wtBuiltInType) and (not IsIdentifierToken(lcToken, idAny)) then
+      if (lcToken.WordType <> wtBuiltInType) and (not IsIdentifierToken(lcToken, idAny)) and (not (lcToken.TokenType in CONST_GENERIC_TOKENS)) then
       begin
         break;
       end;
@@ -1320,26 +1324,85 @@ end;
 
 
 const
-  ConstraintTokens = [ttClass, ttRecord, ttConstructor];
+  ConstraintTokens = [ttClass, ttRecord, ttConstructor, ttInterface, ttObject];
 
 procedure TBuildParseTree.RecogniseGenericType;
+var
+  lbHasConst: boolean;
+  lbIsGenericType:boolean;
+
+  procedure RecogniseP;
+  var
+    liNestLevel: integer;
+  begin
+    if fcTokenList.FirstSolidTokenType = ttConst then
+    begin
+      Recognise(ttConst);
+      lbHasConst := True;
+    end;
+    if lbHasConst = False then //can be a expresion like    h: specialize TNames<[Blaise,Pascal]>;
+    begin
+      lbisGenericType:=(fcTokenList.FirstSolidTokenType=ttIdentifier) and (fcTokenList.SolidTokenType(2)=ttLessThan); //is generic type
+      if fcTokenList.FirstSolidTokenType=ttSpecialize then
+        lbIsGenericType:=true;
+      if (fcTokenList.FirstSolidTokenType in CONST_GENERIC_TOKENS) and (not lbIsGenericType) then
+      begin //hack. recognise tokens until ; , or >
+        liNestLevel := 0;
+        while (liNestLevel > 0) or (not (fcTokenList.FirstTokenType in [ttComma, ttGreaterThan, ttSemiColon, ttGreaterThanOrEqual, ttShr_gg])) do
+        begin
+          if fcTokenList.FirstTokenType in [ttOpenSquareBracket, ttOpenBracket] then
+            Inc(liNestLevel);
+          if fcTokenList.FirstTokenType in [ttCloseSquareBracket, ttCloseBracket] then
+            Dec(liNestLevel);
+          Recognise(fcTokenList.FirstTokenType);
+          if fcTokenList.EOF then
+          begin
+            raise TEParseError.Create('Unexpected EOF. ',nil);
+          end;
+        end;
+      end
+      else
+        RecogniseType;
+    end
+    else
+      RecogniseType;
+
+    if lbHasConst then
+    begin
+      if fcTokenList.FirstSolidTokenType = ttColon then
+        RecogniseGenericConstraints;
+    end;
+  end;
+
 begin
   PushNode(nGeneric);
 
   // angle brackets
   Recognise(ttLessThan);
-  RecogniseType;
+
+  while True do
+  begin
+    lbHasConst := False;
+    PushNode(nType);
+    RecogniseP;
+    // more types after commas
+    while fcTokenList.FirstSolidTokenType = ttComma do
+    begin
+      Recognise(ttComma);
+      RecogniseP;
+    end;
 
     if fcTokenList.FirstSolidTokenType = ttColon then
     begin
       RecogniseGenericConstraints;
     end;
-
+    if fcTokenList.FirstSolidTokenType <> ttSemiColon then
-   // more types after commas
-   while fcTokenList.FirstSolidTokenType = ttComma do
     begin
-      Recognise(ttComma);
+      PopNode;
-      RecogniseType;
+      break;
+    end;
+    Recognise(ttSemiColon);
+    PopNode;
   end;
 
   if fcTokenList.FirstSolidTokenType = ttGreaterThanOrEqual then
@@ -1347,10 +1410,17 @@ begin
     // the tokenizer got it wrong - e.g "TTestNullable<T:Record>=Class"
     // this is the same as TTestNullable<T:Record> =Class
     RecogniseWhiteSpace;
-
     SplitGreaterThanOrEqual;
   end;
 
+  if fcTokenList.FirstSolidTokenType = ttShr_gg then
+  begin
+    // >> operator
+    RecogniseWhiteSpace;
+    SplitShr_gg;
+  end;
+
+
   Recognise(ttGreaterThan);
 
   PopNode;
@@ -1421,6 +1491,35 @@ begin
   end;
 end;
 
+procedure TBuildParseTree.SplitShr_gg;
+var
+  liIndex: integer;
+  lcNewToken: TSourceToken;
+  fsFileName: string;
+begin
+  if fcTokenList.FirstTokenType = ttShr_gg then
+  begin
+    liIndex := fcTokenList.CurrentTokenIndex;
+    fsFileName := fcTokenList.SourceTokens[liIndex].FileName;
+
+    fcTokenList.Delete(liIndex);
+
+    lcNewToken := TSourceToken.Create();
+    lcNewToken.FileName := fsFileName;
+    lcNewToken.SourceCode := '>';
+    lcNewToken.TokenType := ttGreaterThan;
+
+    fcTokenList.Insert(liIndex, lcNewToken);
+
+    lcNewToken := TSourceToken.Create();
+    lcNewToken.FileName := fsFileName;
+    lcNewToken.SourceCode := '>';
+    lcNewToken.TokenType := ttGreaterThan;
+
+    fcTokenList.Insert(liIndex + 1 , lcNewToken);
+  end;
+end;
+
 
 { helper proc for RecogniseTypedConstant
   need to distinguish

components/jcf2/Parse/BuildTokenList.pas

@@ -63,6 +63,7 @@ type
     function ForwardChar(const piOffset: integer): Char;
     function ForwardChars(const piOffset, piCount: integer): String;
     procedure Consume(const piCount: integer = 1);
+    procedure UndoConsume(const piCount: integer = 1);
     function EndOfFile: boolean;
     function EndOfFileAfter(const piChars: integer): boolean;
 
@@ -820,10 +821,15 @@ function TBuildTokenList.TryPunctuation(const pcToken: TSourceToken): boolean;
     // "<<" is the start of two nested generics,
     // likewise '>>' is not an operator, it is two "end-of-generic" signs in sucession
     if (chLast = '<') and (ch = '<') then
+    begin
+      Result := True;  // <<
       exit;
+    end;
     if (chLast = '>') and (ch = '>') then
+    begin
+      Result := True; // >>
       exit;
-
+    end;
 
     Result := CharIsPuncChar(ch);
   end;
@@ -851,6 +857,12 @@ begin
     Consume;
   end;
 
+  if length(pcToken.SourceCode) > 2 then  // nested generic    specialize TC1<TC2<TC3<integer>>>=record  end;
+  begin
+    // only consume the first >
+    UndoConsume(Length(pcToken.SourceCode) - 1);
+    pcToken.SourceCode := pcToken.SourceCode[1];
+  end;
   { try to recognise the punctuation as an operator }
   TypeOfToken(pcToken.SourceCode, leWordType, leTokenType);
   if leTokenType <> ttUnknown then
@@ -932,6 +944,11 @@ begin
   inc(fiCurrentIndex, piCount);
 end;
 
+procedure TBuildTokenList.UndoConsume(const piCount: integer);
+begin
+  dec(fiCurrentIndex, piCount);
+end;
+
 function TBuildTokenList.EndOfFile: boolean;
 begin
   Result := fiCurrentIndex > Length(fsSourceCode);

components/jcf2/Parse/TokenUtils.pas

@@ -640,9 +640,12 @@ begin
 end;
 
 function IsDfmIncludeDirective(const pt: TSourceToken): boolean;
+var
+  lsToken:string;
 begin
   // form dfm comment
-  Result := (pt.TokenType = ttComment) and AnsiSameText(pt.SourceCode, '{$R *.dfm}') and
+  lsToken:=UpperCase(pt.SourceCode);
+  Result := (pt.TokenType = ttComment) and ((lsToken = '{$R *.DFM}') or (lsToken = '[$R *.LFM}')) and
     pt.HasParentNode(nImplementationSection, 4);
 end;
 

components/jcf2/Parse/Tokens.pas

@@ -295,7 +295,9 @@ type
     ttPlusAssign,     // +=
     ttMinusAssign,    // -=
     ttTimesAssign,    // *=
-    ttFloatDivAssign  // /=
+    ttFloatDivAssign, // /=
+    ttShl_ll,         // <<
+    ttShr_gg          // >>
     );
 
   TTokenTypeSet = set of TTokenType;
@@ -419,7 +421,7 @@ const
 
   AddOperators: TTokenTypeSet = [ttPlus, ttMinus, ttOr, ttXor];
 
-  MulOperators: TTokenTypeSet = [ttTimes, ttFloatDiv, ttDiv, ttMod, ttAnd, ttShl, ttShr, ttExponent];
+  MulOperators: TTokenTypeSet = [ttTimes, ttFloatDiv, ttDiv, ttMod, ttAnd, ttShl, ttShr, ttExponent, ttShl_ll,ttShr_gg];
 
   SingleSpaceOperators = [
     // some unary operators
@@ -427,7 +429,7 @@ const
     // all operators that are always binary
     ttAnd, ttAs, ttDiv, ttIn, ttIs, ttMod, ttOr, ttShl, ttShr, ttXor,
     ttTimes, ttFloatDiv, ttExponent, ttEquals, ttGreaterThan, ttLessThan,
-    ttGreaterThanOrEqual, ttLessThanOrEqual, ttNotEqual, ttSetSymDif];
+    ttGreaterThanOrEqual, ttLessThanOrEqual, ttNotEqual, ttSetSymDif, ttShl_ll, ttShr_gg];
 
   StringWords: TTokenTypeSet = [ttString, ttAnsiString, ttWideString];
 
@@ -789,6 +791,8 @@ begin
   AddKeyword('<=', wtOperator, ttLessThanOrEqual);
   AddKeyword('<>', wtOperator, ttNotEqual);
   AddKeyword('><', wtOperator, ttSetSymDif);
+  AddKeyword('<<', wtOperator, ttShl_ll);  // in FreePascal
+  AddKeyword('>>', wtOperator, ttShr_gg);  // in FreePascal
   // these must come after the above as they are shorter
   AddKeyword('>', wtOperator, ttGreaterThan);
   AddKeyword('<', wtOperator, ttLessThan);

components/jcf2/Process/Returns/ReturnAfter.pas

@@ -128,6 +128,13 @@ begin
     Result := True;
     exit;
   end;
+  { in generic definition}
+  if pt.HasParentNode(nGeneric,2) then
+  begin
+    Result := False;
+    exit;
+  end;
+
 end;
 
 

components/jcf2/Process/Spacing/NoSpaceAfter.pas

@@ -71,6 +71,12 @@ begin
   if ptNext.TokenType = ttComment then
     exit;
 
+  if (pt.TokenType in [ttLessThan,ttGreaterThan]) and pt.HasParentNode(nGeneric,1) then
+  begin
+    Result := True;
+    Exit;
+  end;
+
   if pt.TokenType in NoSpaceAnywhere then
   begin
     Result := True;

components/jcf2/Process/Spacing/NoSpaceBefore.pas

@@ -78,6 +78,11 @@ begin
     exit;
   end;
 
+  if (pt.TokenType in [ttLessThan,ttGreaterThan]) and pt.HasParentNode(nGeneric,1) then
+  begin
+    Result := True;
+    Exit;
+  end;
 
   // '@@' in asm, e.g. "JE @@initTls" needs the space
   if pt.HasParentNode(nAsm) then

components/jcf2/Process/Spacing/SingleSpaceAfter.pas

@@ -80,9 +80,9 @@ begin
   if pt.HasParentNode(nAsm) then
     exit;
 
-  if pt.HasParentNode(nGeneric, 1) then
+  if pt.HasParentNode(nGeneric, 2) then
   begin
-    if pt.TokenType in [ttComma, ttColon] then
+    if pt.TokenType in [ttComma, ttColon, ttSemiColon] then
     begin
       Result := true;
     end;

components/jcf2/TestApplication/unit1.lfm

@@ -1150,7 +1150,7 @@ object Form1: TForm1
     Left = 18
     Height = 15
     Top = 465
-    Width = 80
+    Width = 152
     Anchors = [akLeft, akBottom]
     AutoSize = False
     ParentColor = False