From 4b646ddbf0570bdbf0351963e9901c834071d7a1 Mon Sep 17 00:00:00 2001
From: DomingoGP <dgalmesp@gmail.com>
Date: Thu, 19 Nov 2020 22:09:25 +0100
Subject: [PATCH] Add support for generic constants and operators shl  <<  shr 
 >>.

---
 components/jcf2/Parse/BuildParseTree.pas      | 135 +++++++++++++++---
 components/jcf2/Parse/BuildTokenList.pas      |  19 ++-
 components/jcf2/Parse/TokenUtils.pas          |   5 +-
 components/jcf2/Parse/Tokens.pas              |  10 +-
 .../jcf2/Process/Returns/ReturnAfter.pas      |   7 +
 .../jcf2/Process/Spacing/NoSpaceAfter.pas     |   6 +
 .../jcf2/Process/Spacing/NoSpaceBefore.pas    |   5 +
 .../jcf2/Process/Spacing/SingleSpaceAfter.pas |   4 +-
 components/jcf2/TestApplication/unit1.lfm     |   2 +-
 9 files changed, 167 insertions(+), 26 deletions(-)

diff --git a/components/jcf2/Parse/BuildParseTree.pas b/components/jcf2/Parse/BuildParseTree.pas
index a871f959ef..196b3e0fce 100644
--- a/components/jcf2/Parse/BuildParseTree.pas
+++ b/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,36 +1324,102 @@ 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;
 
-  if fcTokenList.FirstSolidTokenType = ttColon then
+  while True do
   begin
-    RecogniseGenericConstraints;
+    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
+    begin
+      PopNode;
+      break;
+    end;
+    Recognise(ttSemiColon);
+    PopNode;
   end;
 
-   // more types after commas
-   while fcTokenList.FirstSolidTokenType = ttComma do
-   begin
-      Recognise(ttComma);
-      RecogniseType;
-   end;
+  if fcTokenList.FirstSolidTokenType = ttGreaterThanOrEqual then
+  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 = ttGreaterThanOrEqual  then
-   begin
-     // the tokenizer got it wrong - e.g "TTestNullable<T:Record>=Class"
-     // this is the same as TTestNullable<T:Record> =Class
-     RecogniseWhiteSpace;
+  if fcTokenList.FirstSolidTokenType = ttShr_gg then
+  begin
+    // >> operator
+    RecogniseWhiteSpace;
+    SplitShr_gg;
+  end;
 
-     SplitGreaterThanOrEqual;
-   end;
 
   Recognise(ttGreaterThan);
 
@@ -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
diff --git a/components/jcf2/Parse/BuildTokenList.pas b/components/jcf2/Parse/BuildTokenList.pas
index e2e0fbce9f..962a5fb59e 100644
--- a/components/jcf2/Parse/BuildTokenList.pas
+++ b/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);
diff --git a/components/jcf2/Parse/TokenUtils.pas b/components/jcf2/Parse/TokenUtils.pas
index 98172b8274..83041e1050 100644
--- a/components/jcf2/Parse/TokenUtils.pas
+++ b/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;
 
diff --git a/components/jcf2/Parse/Tokens.pas b/components/jcf2/Parse/Tokens.pas
index 7e60edddd1..14c0a650b5 100644
--- a/components/jcf2/Parse/Tokens.pas
+++ b/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);
diff --git a/components/jcf2/Process/Returns/ReturnAfter.pas b/components/jcf2/Process/Returns/ReturnAfter.pas
index 3e277f4ae7..34b8e189f9 100644
--- a/components/jcf2/Process/Returns/ReturnAfter.pas
+++ b/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;
 
 
diff --git a/components/jcf2/Process/Spacing/NoSpaceAfter.pas b/components/jcf2/Process/Spacing/NoSpaceAfter.pas
index ebcea3d262..5c2d54e3ef 100644
--- a/components/jcf2/Process/Spacing/NoSpaceAfter.pas
+++ b/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;
diff --git a/components/jcf2/Process/Spacing/NoSpaceBefore.pas b/components/jcf2/Process/Spacing/NoSpaceBefore.pas
index ede1816a8b..b2220f6417 100644
--- a/components/jcf2/Process/Spacing/NoSpaceBefore.pas
+++ b/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
diff --git a/components/jcf2/Process/Spacing/SingleSpaceAfter.pas b/components/jcf2/Process/Spacing/SingleSpaceAfter.pas
index 2793470e65..50cbd1da2d 100644
--- a/components/jcf2/Process/Spacing/SingleSpaceAfter.pas
+++ b/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;
diff --git a/components/jcf2/TestApplication/unit1.lfm b/components/jcf2/TestApplication/unit1.lfm
index 6856ef7a07..3f5be659ee 100644
--- a/components/jcf2/TestApplication/unit1.lfm
+++ b/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
-- 
2.29.1.windows.1