SynEdit: PasHighLighter, fix deprecated after in "unit Foo deprecated;" Issue #40383

components/synedit/synhighlighterpas.pp

@@ -97,6 +97,7 @@ type
     rsAtClosingBracket,   // ')'
     rsAtCaseLabel,
     rsAtProcName,    // after a procedure/function/... keyword, when the name is expected (not for types)
+                     // also after "unit unitname" to detect "deprecated"
     rsAfterProcName,
     rsInProcHeader,       // Declaration or implementation header of a Procedure, function, constructor...
     rsWasInProcHeader,    // after the semicolon that ended a "ProcHeader / proc-modifiers are possible
@@ -1707,6 +1708,7 @@ begin
   if KeyComp('Unit') then begin
     if TopPascalCodeFoldBlockType=cfbtNone then StartPascalCodeFoldBlock(cfbtUnit);
     Result := tkKey;
+    fRange := fRange + [rsAtProcName];
   end
   else if KeyComp('Uses') then begin
     if (TopPascalCodeFoldBlockType in
@@ -1937,7 +1939,9 @@ begin
            (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) and
            (fRange * [rsInProcHeader] = []) ) or
          ( (tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure]) and
-           (fRange * [rsInProcHeader] = []) )
+           (fRange * [rsInProcHeader] = []) ) or
+         ( (tbf in [cfbtUnit, cfbtNone]) and
+           (fRange * [rsInProcHeader, rsAfterProcName] = [rsAfterProcName]) )
        ) and
        ( fRange *[rsAfterEqualOrColon, rsProperty] = [] ) and
        (PasCodeFoldRange.BracketNestLevel = 0)
@@ -2254,7 +2258,9 @@ begin
            (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) and
            (fRange * [rsInProcHeader] = []) ) or
          ( (tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure]) and
-           (fRange * [rsInProcHeader] = []) )
+           (fRange * [rsInProcHeader] = []) ) or
+         ( (tbf in [cfbtUnit, cfbtNone]) and
+           (fRange * [rsInProcHeader, rsAfterProcName] = [rsAfterProcName]) )
        ) and
        ( fRange *[rsAfterEqualOrColon, rsProperty] = [] ) and
        (PasCodeFoldRange.BracketNestLevel = 0)
@@ -2604,7 +2610,9 @@ begin
            (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) and
            (fRange * [rsInProcHeader] = []) ) or
          ( (tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure]) and
-           (fRange * [rsInProcHeader] = []) )
+           (fRange * [rsInProcHeader] = []) ) or
+         ( (tbf in [cfbtUnit, cfbtNone]) and
+           (fRange * [rsInProcHeader, rsAfterProcName] = [rsAfterProcName]) )
        ) and
        ( fRange *[rsAfterEqualOrColon, rsProperty] = [] ) and
        (PasCodeFoldRange.BracketNestLevel = 0)
@@ -2681,7 +2689,9 @@ begin
            (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) and
            (fRange * [rsInProcHeader] = []) ) or
          ( (tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure]) and
-           (fRange * [rsInProcHeader] = []) )
+           (fRange * [rsInProcHeader] = []) ) or
+         ( (tbf in [cfbtUnit, cfbtNone]) and
+           (fRange * [rsInProcHeader, rsAfterProcName] = [rsAfterProcName]) )
        ) and
        ( fRange *[rsAfterEqualOrColon, rsProperty] = [] ) and
        (PasCodeFoldRange.BracketNestLevel = 0)
@@ -3547,8 +3557,9 @@ begin
     fRange := fRange + [rsAtPropertyOrReadWrite];
     FOldRange := FOldRange - [rsAtPropertyOrReadWrite];
   end;
-  if fRange * [rsInProcHeader, rsAfterProcName] = [rsInProcHeader, rsAfterProcName] then begin
-    FTokenFlags := FTokenFlags + [tfProcName];
+  if fRange * [rsAfterProcName] = [rsAfterProcName] then begin
+    if rsInProcHeader in fRange then
+      FTokenFlags := FTokenFlags + [tfProcName];
     fRange := fRange + [rsAtProcName];
   end;
 end;
@@ -3925,8 +3936,9 @@ begin
 
         fProcTable[fLine[Run]];
 
-        if (FTokenID = tkIdentifier) and (rsAtProcName in fRange) then begin
-          FTokenFlags := FTokenFlags + [tfProcName];
+        if (FTokenID = tkIdentifier) and (fRange * [rsAtProcName] = [rsAtProcName]) then begin
+          if rsInProcHeader in fRange then
+            FTokenFlags := FTokenFlags + [tfProcName];
           fRange := fRange + [rsAfterProcName];
         end;
 

components/synedit/test/testhighlightfoldbase.pas

@@ -98,7 +98,7 @@ var
   i: Integer;
 begin
   for i := 0 to FTheHighLighter.AttrCount - 1 do begin
-    DebugLn(['# ', i, ' ', FTheHighLighter.Attribute[i].StoredName]);
+    //DebugLn(['# ', i, ' ', FTheHighLighter.Attribute[i].StoredName]);
     FTheHighLighter.Attribute[i].Foreground := 10000 + i; // unique foreground colors
     FTheHighLighter.Attribute[i].Foreground := 10000 + i; // unique foreground colors
     if FTheHighLighter.Attribute[i] is TSynHighlighterAttributesModifier then begin

components/synedit/test/testhighlightpas.pas

@@ -1176,7 +1176,10 @@ begin
 end;
 
 procedure TTestHighlighterPas.TestContextForDeprecated;
-  procedure SubTest(s: String);
+  procedure SubTest(s: String;
+    AEnbledTypes: TPascalCodeFoldBlockTypes;
+    AHideTypes: TPascalCodeFoldBlockTypes = [];
+    ANoFoldTypes: TPascalCodeFoldBlockTypes = []);
 
     procedure SubTest2(struct: String);
     begin
@@ -1250,6 +1253,7 @@ procedure TTestHighlighterPas.TestContextForDeprecated;
   begin
     PushBaseName('test for '+s);
     ReCreateEdit;
+    EnableFolds(AEnbledTypes, AHideTypes, ANoFoldTypes);
     SetLines
       ([  'Unit A; interface',
           'var',
@@ -1320,13 +1324,66 @@ procedure TTestHighlighterPas.TestContextForDeprecated;
     CheckTokensForLine('after class declaration', 4,
       [tkKey, tkSpace, tkKey, tkSymbol]);
 
+
+    // after unit declaration
+    SetLines
+      ([  'Unit A nonkey;', // check wrong word - must not be key
+          'interface uses foo;',
+          ''
+      ]);
+    CheckTokensForLine('dummy word after unit', 0,
+      [tkKey, tkSpace, tkIdentifier, tkSpace, tkIdentifier, tkSymbol]);
+
+    SetLines
+      ([  'Unit A;'+s+';', // must not be key
+          'interface uses foo;',
+          ''
+      ]);
+    CheckTokensForLine('after unit, but after semicolon', 0,
+      [tkKey, tkSpace, tkIdentifier, tkSymbol, tkIdentifier, tkSymbol]);
+
+    SetLines
+      ([  'Unit A '+s+';',
+          'interface uses foo;',
+          ''
+      ]);
+    CheckTokensForLine('after unit', 0,
+      [tkKey, tkSpace, tkIdentifier, tkSpace, tkKey, tkSymbol]);
+    CheckTokensForLine('after unit - next line', 1,
+      [tkKey, tkSpace, tkKey, tkSpace, tkIdentifier, tkSymbol]);
+
+    SetLines
+      ([  'Unit A.B '+s+';',
+          'interface uses foo;',
+          ''
+      ]);
+    CheckTokensForLine('after dotted unit', 0,
+      [tkKey, tkSpace, tkIdentifier, tkSymbol, tkIdentifier, tkSpace, tkKey, tkSymbol]);
+    CheckTokensForLine('after unit - next line', 1,
+      [tkKey, tkSpace, tkKey, tkSpace, tkIdentifier, tkSymbol]);
+
+
     PopBaseName;
   end;
+
+var
+  AFolds: TPascalCodeFoldBlockTypes;
+  i: Integer;
 begin
-  SubTest('deprecated');
-  SubTest('unimplemented');
-  SubTest('experimental');
-  SubTest('platform');
+  for i := 0 to $40-1 do begin
+    AFolds := [cfbtBeginEnd..cfbtNone];
+    if (i and $01) = 0 then AFolds := AFolds - [cfbtProgram, cfbtUnit];
+    if (i and $02) = 0 then AFolds := AFolds - [cfbtUnitSection];
+    if (i and $04) = 0 then AFolds := AFolds - [cfbtVarType, cfbtLocalVarType];
+    if (i and $08) = 0 then AFolds := AFolds - [cfbtClass, cfbtRecord];
+    if (i and $10) = 0 then AFolds := AFolds - [cfbtClassSection];
+    if (i and $20) = 0 then AFolds := AFolds - [cfbtProcedure];
+    //if (i and $40) = 0 then AFolds := AFolds - [cfbtAnonynmousProcedure];
+    SubTest('deprecated'   , AFolds);
+    SubTest('unimplemented', AFolds);
+    SubTest('experimental' , AFolds);
+    SubTest('platform'     , AFolds);
+  end;
 end;
 
 procedure TTestHighlighterPas.TestContextForClassModifier;