From c2d7b57fa87c50611bed136ad040c8d5c4fe9b38 Mon Sep 17 00:00:00 2001 From: Martin Date: Tue, 18 Jul 2023 15:50:01 +0200 Subject: [PATCH] SynEdit: PasHighLighter, fix deprecated after in "unit Foo deprecated;" Issue #40383 --- components/synedit/synhighlighterpas.pp | 28 +++++--- .../synedit/test/testhighlightfoldbase.pas | 2 +- components/synedit/test/testhighlightpas.pas | 67 +++++++++++++++++-- 3 files changed, 83 insertions(+), 14 deletions(-) diff --git a/components/synedit/synhighlighterpas.pp b/components/synedit/synhighlighterpas.pp index faebb3b6e5..9418332648 100644 --- a/components/synedit/synhighlighterpas.pp +++ b/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; diff --git a/components/synedit/test/testhighlightfoldbase.pas b/components/synedit/test/testhighlightfoldbase.pas index 8ad91d5f68..8c4d31d873 100644 --- a/components/synedit/test/testhighlightfoldbase.pas +++ b/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 diff --git a/components/synedit/test/testhighlightpas.pas b/components/synedit/test/testhighlightpas.pas index e801a3bffe..e8211b437e 100644 --- a/components/synedit/test/testhighlightpas.pas +++ b/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;