{------------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: SynHighlighterPas.pas, released 2000-04-17. The Original Code is based on the mwPasSyn.pas file from the mwEdit component suite by Martin Waldenburg and other developers, the Initial Author of this file is Martin Waldenburg. Portions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg. All Rights Reserved. Contributors to the SynEdit and mwEdit projects are listed in the Contributors.txt file. Alternatively, the contents of this file may be used under the terms of the GNU General Public License Version 2 or later (the "GPL"), in which case the provisions of the GPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of the GPL and not to allow others to use your version of this file under the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL. If you do not delete the provisions above, a recipient may use your version of this file under either the MPL or the GPL. $Id$ You may retrieve the latest version of this file at the SynEdit home page, located at http://SynEdit.SourceForge.net Known Issues: -------------------------------------------------------------------------------} { @abstract(Provides a Pascal/Delphi syntax highlighter for SynEdit) @author(Martin Waldenburg) @created(1998, converted to SynEdit 2000-04-07) @lastmod(2000-06-23) The SynHighlighterPas unit provides SynEdit with a Object Pascal syntax highlighter. An extra boolean property "D4Syntax" is included to enable the recognition of the advanced features found in Object Pascal in Delphi 4. } unit SynHighlighterPas; {$I synedit.inc} interface uses SysUtils, LCLProc, Classes, Registry, Graphics, SynEditHighlighterFoldBase, SynEditMiscProcs, SynEditTypes, SynEditHighlighter, SynEditTextBase, SynEditStrConst, SynEditMiscClasses; type TSynPasStringMode = (spsmDefault, spsmStringOnly, spsmNone); TtkTokenKind = (tkAsm, tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace, tkString, tkSymbol, tkDirective, tkIDEDirective, tkUnknown); TRangeState = ( // rsAnsi, rsBor, rsDirective are exclusive to each other rsAnsi, // *) comment rsBor, // { comment rsSlash, // // rsIDEDirective, // {% rsDirective, // {$ rsAsm, // assembler block rsProperty, rsAtPropertyOrReadWrite, // very first word after property (name of the property) or after read write in property rsInterface, rsImplementation, // Program or Implementation // we need to detect: type TFoo = procedure; // must not fold // var foo: procedure; // must not fold rsAfterEqualOrColon, // very first word after "=" or ":" rsAfterEqual, // between "=" and ";" (or block end) // a ^ means ctrl-char, not pointer to type // Detect if class/object is type TFoo = class; // forward declaration // TBar = class of TFoo; // or full class declaration TFoo = class ... end; // Also included after class modifiers "sealed" and "abstract" rsAtClass, rsAfterClass, rsAfterIdentifier, rsAtClosingBracket, // ')' rsAtCaseLabel, rsInProcHeader, // Declaration or implementation header of a Procedure, function, constructor... rsAfterClassMembers, // Encountered a procedure, function, property, constructor or destructor in a class rsAfterClassField, // after ";" of a field (static needs highlight) rsVarTypeInSpecification, // between ":"/"=" and ";" in a var or type section (or class members) // var a: Integer; type b = Int64; rsInTypeBlock ); TRangeStates = set of TRangeState; type TPascalCodeFoldBlockType = ( // Do *not* change the order cfbtBeginEnd, // Nested cfbtTopBeginEnd, // Begin of Procedure cfbtNestedComment, cfbtProcedure, cfbtUses, cfbtVarType, cfbtLocalVarType, cfbtClass, cfbtClassSection, cfbtUnitSection, cfbtProgram, cfbtUnit, cfbtRecord, cfbtTry, cfbtExcept, cfbtRepeat, cfbtAsm, cfbtCase, cfbtIfDef, // {$IfDef} directive, this is not counted in the Range-Node cfbtRegion, // {%Region} user folds, not counted in the Range-Node cfbtAnsiComment, // (* ... *) cfbtBorCommand, // { ... } cfbtSlashComment, // // cfbtIfThen, // Internal type / not configurable cfbtCaseElse, // "else" in case can have multiply statements cfbtPackage, //cfbtIfThen, cfbtNone ); TPascalCodeFoldBlockTypes = set of TPascalCodeFoldBlockType; const cfbtLastPublic = cfbtIfThen; cfbtFirstPrivate = cfbtCaseElse; CountPascalCodeFoldBlockOffset: Pointer = Pointer(PtrInt(Integer(high(TPascalCodeFoldBlockType))+1)); cfbtAll: TPascalCodeFoldBlockTypes = [low(TPascalCodeFoldBlockType)..high(TPascalCodeFoldBlockType)]; PascalWordTripletRanges: TPascalCodeFoldBlockTypes = [cfbtBeginEnd, cfbtTopBeginEnd, cfbtProcedure, cfbtClass, cfbtProgram, cfbtRecord, cfbtTry, cfbtExcept, cfbtRepeat, cfbtAsm, cfbtCase, cfbtCaseElse, cfbtIfDef, cfbtRegion, cfbtIfThen ]; // restrict cdecl etc to places where they can be. // this needs a better parser ProcModifierAllowed: TPascalCodeFoldBlockTypes = [cfbtNone, cfbtProcedure, cfbtProgram, cfbtClass, cfbtClassSection, cfbtRecord, cfbtUnitSection, // unitsection, actually interface only cfbtVarType, cfbtLocalVarType]; PascalStatementBlocks: TPascalCodeFoldBlockTypes = [cfbtBeginEnd, cfbtTopBeginEnd, cfbtCase, cfbtTry, cfbtExcept, cfbtRepeat, cfbtCaseElse, cfbtIfThen]; PascalFoldTypeCompatibility: Array [TPascalCodeFoldBlockType] of TPascalCodeFoldBlockType = ( cfbtBeginEnd, // Nested cfbtBeginEnd, // cfbtTopBeginEnd, // Begin of Procedure cfbtNestedComment, cfbtProcedure, cfbtUses, cfbtVarType, cfbtVarType, // cfbtLocalVarType, cfbtClass, cfbtClassSection, cfbtUnitSection, cfbtProgram, cfbtUnit, cfbtRecord, cfbtTry, cfbtExcept, cfbtRepeat, cfbtAsm, cfbtCase, cfbtIfDef, // {$IfDef} directive, this is not counted in the Range-Node cfbtRegion, // {%Region} user folds, not counted in the Range-Node cfbtNestedComment, //cfbtAnsiComment, // (* ... *) cfbtNestedComment, //cfbtBorCommand, // { ... } cfbtSlashComment, // // cfbtIfThen, // Internal type / not configurable cfbtCaseElse, cfbtPackage, cfbtNone ); FOLDGROUP_PASCAL = 1; FOLDGROUP_REGION = 2; FOLDGROUP_IFDEF = 3; type TPascalCompilerMode = ( pcmObjFPC, pcmDelphi, pcmFPC, pcmTP, pcmGPC, pcmMacPas ); TSynPasDividerDrawLocation = ( pddlUnitSection, pddlUses, pddlVarGlobal, // Var, Type, Const in global scope pddlVarLocal, // Var, Type, Const in local (procedure) scope pddlStructGlobal, // Class, Object, Record in global type block pddlStructLocal, // Class, Object, Record in local (procedure) type block pddlProcedure, pddlBeginEnd, // Includes Repeat pddlTry ); const PasDividerDrawLocationDefaults: Array [TSynPasDividerDrawLocation] of Integer = (1, 0, // unit, uses 1, 0, // var 1, 0, // struct 2, 0, // proc, begin 0); type TSynPasRangeInfo = record EndLevelIfDef: Smallint; MinLevelIfDef: Smallint; EndLevelRegion: Smallint; MinLevelRegion: Smallint; end; { TSynHighlighterPasRangeList } TSynHighlighterPasRangeList = class(TSynHighlighterRangeList) private FItemOffset: integer; function GetTSynPasRangeInfo(Index: Integer): TSynPasRangeInfo; procedure SetTSynPasRangeInfo(Index: Integer; const AValue: TSynPasRangeInfo); public constructor Create; property PasRangeInfo[Index: Integer]: TSynPasRangeInfo read GetTSynPasRangeInfo write SetTSynPasRangeInfo; end; { TSynPasSynRange } TSynPasSynRange = class(TSynCustomHighlighterRange) private FMode: TPascalCompilerMode; FBracketNestLevel : Integer; FLastLineCodeFoldLevelFix: integer; FPasFoldEndLevel: Smallint; FPasFoldFixLevel: Smallint; FPasFoldMinLevel: Smallint; public procedure Clear; override; function Compare(Range: TSynCustomHighlighterRange): integer; override; procedure Assign(Src: TSynCustomHighlighterRange); override; function Add(ABlockType: Pointer = nil; IncreaseLevel: Boolean = True): TSynCustomCodeFoldBlock; override; procedure Pop(DecreaseLevel: Boolean = True); override; function MaxFoldLevel: Integer; override; procedure IncBracketNestLevel; procedure DecBracketNestLevel; procedure DecLastLineCodeFoldLevelFix; procedure DecLastLinePasFoldFix; property Mode: TPascalCompilerMode read FMode write FMode; property BracketNestLevel: integer read FBracketNestLevel write FBracketNestLevel; property LastLineCodeFoldLevelFix: integer read FLastLineCodeFoldLevelFix write FLastLineCodeFoldLevelFix; property PasFoldEndLevel: Smallint read FPasFoldEndLevel write FPasFoldEndLevel; property PasFoldFixLevel: Smallint read FPasFoldFixLevel write FPasFoldFixLevel; property PasFoldMinLevel: Smallint read FPasFoldMinLevel write FPasFoldMinLevel; // * foldable nodes <> All nodes (pascas , not ifdef/region) * // PasFoldEndLevel <> CodeFoldStackSize // PasFoldMinLevel <> MinimumCodeFoldBlockLevel // LastLineCodeFoldLevelFix <> PasFoldFixLevel // DecLastLineCodeFoldLevelFix <> DecLastLinePasFoldFix end; TProcTableProc = procedure of object; PIdentFuncTableFunc = ^TIdentFuncTableFunc; TIdentFuncTableFunc = function: TtkTokenKind of object; { TSynPasSyn } TSynPasSyn = class(TSynCustomFoldHighlighter) private fAsmStart: Boolean; FExtendedKeywordsMode: Boolean; FNestedComments: boolean; FStartCodeFoldBlockLevel: integer; FPasStartLevel: Smallint; fRange: TRangeStates; FOldRange: TRangeStates; FStringKeywordMode: TSynPasStringMode; FSynPasRangeInfo: TSynPasRangeInfo; FAtLineStart: Boolean; // Line had only spaces or comments sofar fLineStr: string; fLine: PChar; fLineLen: integer; fLineNumber: Integer; fProcTable: array[#0..#255] of TProcTableProc; Run: LongInt;// current parser postion in fLine fStringLen: Integer;// current length of hash fToIdent: integer;// start of current identifier in fLine fIdentFuncTable: array[0..191] of TIdentFuncTableFunc; fTokenPos: Integer;// start of current token in fLine FTokenID: TtkTokenKind; FTokenIsCaseLabel: Boolean; fStringAttri: TSynHighlighterAttributes; fNumberAttri: TSynHighlighterAttributes; fKeyAttri: TSynHighlighterAttributes; fSymbolAttri: TSynHighlighterAttributes; fAsmAttri: TSynHighlighterAttributes; fCommentAttri: TSynHighlighterAttributes; FIDEDirectiveAttri: TSynHighlighterAttributesModifier; FCurIDEDirectiveAttri: TSynSelectedColorMergeResult; fIdentifierAttri: TSynHighlighterAttributes; fSpaceAttri: TSynHighlighterAttributes; FCaseLabelAttri: TSynHighlighterAttributesModifier; FCurCaseLabelAttri: TSynSelectedColorMergeResult; fDirectiveAttri: TSynHighlighterAttributes; FCompilerMode: TPascalCompilerMode; fD4syntax: boolean; FCatchNodeInfo: Boolean; FCatchNodeInfoList: TLazSynFoldNodeInfoList; // Divider FDividerDrawConfig: Array [TSynPasDividerDrawLocation] of TSynDividerDrawConfig; function GetPasCodeFoldRange: TSynPasSynRange; procedure SetCompilerMode(const AValue: TPascalCompilerMode); procedure SetExtendedKeywordsMode(const AValue: Boolean); procedure SetStringKeywordMode(const AValue: TSynPasStringMode); function TextComp(aText: PChar): Boolean; function KeyHash: Integer; function Func15: TtkTokenKind; function Func19: TtkTokenKind; function Func20: TtkTokenKind; function Func21: TtkTokenKind; function Func23: TtkTokenKind; function Func25: TtkTokenKind; function Func27: TtkTokenKind; function Func28: TtkTokenKind; function Func29: TtkTokenKind; // "on" function Func32: TtkTokenKind; function Func33: TtkTokenKind; function Func35: TtkTokenKind; function Func37: TtkTokenKind; function Func38: TtkTokenKind; function Func39: TtkTokenKind; function Func40: TtkTokenKind; function Func41: TtkTokenKind; function Func42: TtkTokenKind; // "alias", "final" function Func44: TtkTokenKind; function Func45: TtkTokenKind; function Func46: TtkTokenKind; // "sealed" function Func47: TtkTokenKind; function Func49: TtkTokenKind; function Func52: TtkTokenKind; function Func54: TtkTokenKind; function Func55: TtkTokenKind; function Func56: TtkTokenKind; function Func57: TtkTokenKind; function Func58: TtkTokenKind; function Func59: TtkTokenKind; function Func60: TtkTokenKind; function Func61: TtkTokenKind; function Func63: TtkTokenKind; function Func64: TtkTokenKind; function Func65: TtkTokenKind; function Func66: TtkTokenKind; function Func69: TtkTokenKind; function Func71: TtkTokenKind; function Func72: TtkTokenKind; function Func73: TtkTokenKind; function Func75: TtkTokenKind; function Func76: TtkTokenKind; function Func79: TtkTokenKind; function Func81: TtkTokenKind; function Func84: TtkTokenKind; function Func85: TtkTokenKind; function Func86: TtkTokenKind; function Func87: TtkTokenKind; function Func88: TtkTokenKind; function Func89: TtkTokenKind; function Func91: TtkTokenKind; function Func92: TtkTokenKind; function Func94: TtkTokenKind; function Func95: TtkTokenKind; function Func96: TtkTokenKind; function Func97: TtkTokenKind; function Func98: TtkTokenKind; function Func99: TtkTokenKind; function Func100: TtkTokenKind; function Func101: TtkTokenKind; function Func102: TtkTokenKind; function Func103: TtkTokenKind; function Func105: TtkTokenKind; function Func106: TtkTokenKind; function Func108: TtkTokenKind; // "operator" function Func112: TtkTokenKind; // "requires" function Func117: TtkTokenKind; function Func122: TtkTokenKind; // "otherwise" function Func124: TtkTokenKind; function Func125: TtkTokenKind; function Func126: TtkTokenKind; function Func128: TtkTokenKind; function Func129: TtkTokenKind; function Func130: TtkTokenKind; function Func132: TtkTokenKind; function Func133: TtkTokenKind; function Func136: TtkTokenKind; function Func139: TtkTokenKind; function Func141: TtkTokenKind; function Func142: TtkTokenKind; // "experimental" function Func143: TtkTokenKind; function Func144: TtkTokenKind; function Func151: TtkTokenKind; // "unimplemented" function Func158: TtkTokenKind; // "unicodestring" function Func166: TtkTokenKind; function Func167: TtkTokenKind; function Func168: TtkTokenKind; function Func170: TtkTokenKind; function Func181: TtkTokenKind; function Func191: TtkTokenKind; function AltFunc: TtkTokenKind; procedure InitIdent; function IdentKind(p: integer): TtkTokenKind; procedure MakeMethodTables; procedure AddressOpProc; procedure AsciiCharProc; procedure AnsiProc; procedure BorProc; procedure BraceOpenProc; procedure ColonProc; procedure GreaterProc; procedure CRProc; procedure DirectiveProc; procedure IdentProc; procedure HexProc; procedure BinaryProc; procedure OctalProc; procedure LFProc; procedure LowerProc; procedure CaretProc; procedure NullProc; procedure NumberProc; procedure PointProc; procedure RoundOpenProc; procedure RoundCloseProc; procedure SquareOpenProc; procedure SquareCloseProc; procedure EqualSignProc; procedure SemicolonProc; //mh 2000-10-08 procedure SlashProc; procedure SlashContinueProc; procedure SpaceProc; procedure StringProc; procedure SymbolProc; procedure UnknownProc; procedure SetD4syntax(const Value: boolean); procedure InitNode(out Node: TSynFoldNodeInfo; EndOffs: Integer; ABlockType: TPascalCodeFoldBlockType; aActions: TSynFoldActions; AIsFold: Boolean); // Divider procedure CreateDividerDrawConfig; procedure DestroyDividerDrawConfig; protected function KeyComp(const aKey: string): Boolean; function KeyCompEx(AText1, AText2: pchar; ALen: Integer): Boolean; function GetIdentChars: TSynIdentChars; override; function IsFilterStored: boolean; override; //mh 2000-10-08 protected // "Range" function GetRangeClass: TSynCustomHighlighterRangeClass; override; procedure CreateRootCodeFoldBlock; override; function CreateRangeList(ALines: TSynEditStringsBase): TSynHighlighterRangeList; override; function UpdateRangeInfoAtLine(Index: Integer): Boolean; override; // Returns true if range changed property PasCodeFoldRange: TSynPasSynRange read GetPasCodeFoldRange; function TopPascalCodeFoldBlockType (DownIndex: Integer = 0): TPascalCodeFoldBlockType; // Open/Close Folds function StartPascalCodeFoldBlock (ABlockType: TPascalCodeFoldBlockType; OnlyEnabled: Boolean = False): TSynCustomCodeFoldBlock; procedure EndPascalCodeFoldBlock(NoMarkup: Boolean = False); procedure CloseBeginEndBlocksBeforeProc; procedure SmartCloseBeginEndBlocks(SearchFor: TPascalCodeFoldBlockType); procedure EndPascalCodeFoldBlockLastLine; procedure StartCustomCodeFoldBlock(ABlockType: TPascalCodeFoldBlockType); procedure EndCustomCodeFoldBlock(ABlockType: TPascalCodeFoldBlockType); // Info about Folds function CreateFoldNodeInfoList: TLazSynFoldNodeInfoList; override; procedure InitFoldNodeInfo(AList: TLazSynFoldNodeInfoList; Line: TLineIdx); override; protected function LastLinePasFoldLevelFix(Index: Integer; AType: Integer = 1; AIncludeDisabled: Boolean = False): integer; // TODO deprecated; // foldable nodes // Divider function GetDrawDivider(Index: integer): TSynDividerDrawConfigSetting; override; function GetDividerDrawConfig(Index: Integer): TSynDividerDrawConfig; override; function GetDividerDrawConfigCount: Integer; override; // Fold Config function GetFoldConfigInstance(Index: Integer): TSynCustomFoldConfig; override; function GetFoldConfigCount: Integer; override; function GetFoldConfigInternalCount: Integer; override; procedure DoFoldConfigChanged(Sender: TObject); override; public class function GetCapabilities: TSynHighlighterCapabilities; override; class function GetLanguageName: string; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override; function GetEol: Boolean; override; function GetRange: Pointer; override; function GetToken: string; override; procedure GetTokenEx(out TokenStart: PChar; out TokenLength: integer); override; function GetTokenAttribute: TSynHighlighterAttributes; override; function GetTokenID: TtkTokenKind; function GetTokenKind: integer; override; function GetTokenPos: Integer; override; function IsKeyword(const AKeyword: string): boolean; override; procedure Next; override; procedure ResetRange; override; procedure SetLine(const NewValue: string; LineNumber: Integer); override; procedure SetRange(Value: Pointer); override; procedure StartAtLineIndex(LineNumber:Integer); override; // 0 based function GetEndOfLineAttribute: TSynHighlighterAttributes; override; function UseUserSettings(settingIndex: integer): boolean; override; procedure EnumUserSettings(settings: TStrings); override; function IsLineStartingInDirective(ALineIndex: TLineIdx): Boolean; // Info about Folds //function FoldBlockOpeningCount(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; override; overload; //function FoldBlockClosingCount(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; override; overload; function FoldBlockEndLevel(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; override; overload; function FoldBlockMinLevel(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; override; overload; function FoldBlockNestedTypes(ALineIndex: TLineIdx; ANestIndex: Integer; out AType: Pointer; const AFilter: TSynFoldBlockFilter): boolean; override; overload; function FoldTypeCount: integer; override; function FoldTypeAtNodeIndex(ALineIndex, FoldIndex: Integer; // accesses FoldNodeInfo UseCloseNodes: boolean = false): integer; override; function FoldLineLength(ALineIndex, FoldIndex: Integer): integer; override; // accesses FoldNodeInfo function FoldEndLine(ALineIndex, FoldIndex: Integer): integer; override; // accesses FoldNodeInfo published property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri; property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri; property IDEDirectiveAttri: TSynHighlighterAttributesModifier read FIDEDirectiveAttri write FIDEDirectiveAttri; property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri; property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri; property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri; property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri; property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri; property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri; property CaseLabelAttri: TSynHighlighterAttributesModifier read FCaseLabelAttri write FCaseLabelAttri; property DirectiveAttri: TSynHighlighterAttributes read fDirectiveAttri write fDirectiveAttri; property CompilerMode: TPascalCompilerMode read FCompilerMode write SetCompilerMode; property NestedComments: boolean read FNestedComments write FNestedComments; property D4syntax: boolean read FD4syntax write SetD4syntax default true; property ExtendedKeywordsMode: Boolean read FExtendedKeywordsMode write SetExtendedKeywordsMode default False; property StringKeywordMode: TSynPasStringMode read FStringKeywordMode write SetStringKeywordMode default spsmDefault; end; { TSynFreePascalSyn } TSynFreePascalSyn = class(TSynPasSyn) public constructor Create(AOwner: TComponent); override; procedure ResetRange; override; end; implementation const RESERVED_WORDS_TP: array [1..54] of String = ( 'absolute', 'and', 'array', 'asm', 'begin', 'case', 'const', 'constructor', 'destructor', 'div', 'do', 'downto', 'else', 'end', 'file', 'for', 'function', 'goto', 'if', 'implementation', 'in', 'inherited', 'inline', 'interface', 'label', 'mod', 'nil', 'not', 'object', 'of', 'on', 'operator', 'or', 'packed', 'procedure', 'program', 'record', 'reintroduce', 'repeat', 'self', 'set', 'shl', 'shr', 'string', 'then', 'to', 'type', 'unit', 'until', 'uses', 'var', 'while', 'with', 'xor' ); RESERVED_WORDS_DELPHI: array [1..15] of String = ( 'as', 'class', 'except', 'exports', 'finalization', 'finally', 'initialization', 'is', 'library', 'on', 'out', 'property', 'raise', 'threadvar', 'try' ); RESERVED_WORDS_FPC: array [1..5] of String = ( 'dispose', 'exit', 'false', 'new', 'true' ); var Identifiers: array[#0..#255] of ByteBool; mHashTable: array[#0..#255] of Integer; KeywordsList: TStringList; IsIntegerChar: array[char] of Boolean; IsNumberChar: array[char] of Boolean; IsSpaceChar: array[char] of Boolean; IsUnderScoreOrNumberChar: array[char] of Boolean; IsLetterChar: array[char] of Boolean; procedure MakeIdentTable; var I, J: Char; begin for I := #0 to #255 do begin case I of '_', '0'..'9', 'a'..'z', 'A'..'Z': Identifiers[I] := True; else Identifiers[I] := False; end; J := UpCase(I); case I of 'a'..'z', 'A'..'Z': mHashTable[I] := Ord(J) - 64; '_': mHashTable[I] := 27; // after Z '0'..'9': mHashTable[I] := Ord(J) - 48 + 28; // after "_" else mHashTable[Char(I)] := 0; end; IsIntegerChar[I]:=(I in ['0'..'9', 'A'..'F', 'a'..'f']); IsNumberChar[I]:=(I in ['0'..'9']); IsSpaceChar[I]:=(I in [#1..#9, #11, #12, #14..#32]); IsUnderScoreOrNumberChar[I]:=(I in ['_','0'..'9']); IsLetterChar[I]:=(I in ['a'..'z','A'..'Z']); end; end; procedure TSynPasSyn.InitIdent; var I: Integer; pF: PIdentFuncTableFunc; begin pF := PIdentFuncTableFunc(@fIdentFuncTable); for I := Low(fIdentFuncTable) to High(fIdentFuncTable) do begin pF^ := @AltFunc; Inc(pF); end; fIdentFuncTable[15] := @Func15; fIdentFuncTable[19] := @Func19; fIdentFuncTable[20] := @Func20; fIdentFuncTable[21] := @Func21; fIdentFuncTable[23] := @Func23; fIdentFuncTable[25] := @Func25; fIdentFuncTable[27] := @Func27; fIdentFuncTable[28] := @Func28; fIdentFuncTable[29] := @Func29; // "on" fIdentFuncTable[32] := @Func32; fIdentFuncTable[33] := @Func33; fIdentFuncTable[35] := @Func35; fIdentFuncTable[37] := @Func37; fIdentFuncTable[38] := @Func38; fIdentFuncTable[39] := @Func39; fIdentFuncTable[40] := @Func40; fIdentFuncTable[41] := @Func41; fIdentFuncTable[42] := @Func42; fIdentFuncTable[44] := @Func44; fIdentFuncTable[45] := @Func45; fIdentFuncTable[46] := @Func46; fIdentFuncTable[47] := @Func47; fIdentFuncTable[49] := @Func49; fIdentFuncTable[52] := @Func52; fIdentFuncTable[54] := @Func54; fIdentFuncTable[55] := @Func55; fIdentFuncTable[56] := @Func56; fIdentFuncTable[57] := @Func57; fIdentFuncTable[58] := @Func58; fIdentFuncTable[59] := @Func59; fIdentFuncTable[60] := @Func60; fIdentFuncTable[61] := @Func61; fIdentFuncTable[63] := @Func63; fIdentFuncTable[64] := @Func64; fIdentFuncTable[65] := @Func65; fIdentFuncTable[66] := @Func66; fIdentFuncTable[69] := @Func69; fIdentFuncTable[71] := @Func71; fIdentFuncTable[72] := @Func72; fIdentFuncTable[73] := @Func73; fIdentFuncTable[75] := @Func75; fIdentFuncTable[76] := @Func76; fIdentFuncTable[79] := @Func79; fIdentFuncTable[81] := @Func81; fIdentFuncTable[84] := @Func84; fIdentFuncTable[85] := @Func85; fIdentFuncTable[86] := @Func86; fIdentFuncTable[87] := @Func87; fIdentFuncTable[88] := @Func88; fIdentFuncTable[89] := @Func89; fIdentFuncTable[91] := @Func91; fIdentFuncTable[92] := @Func92; fIdentFuncTable[94] := @Func94; fIdentFuncTable[95] := @Func95; fIdentFuncTable[96] := @Func96; fIdentFuncTable[97] := @Func97; fIdentFuncTable[98] := @Func98; fIdentFuncTable[99] := @Func99; fIdentFuncTable[100] := @Func100; fIdentFuncTable[101] := @Func101; fIdentFuncTable[102] := @Func102; fIdentFuncTable[103] := @Func103; fIdentFuncTable[105] := @Func105; fIdentFuncTable[106] := @Func106; fIdentFuncTable[108] := @Func108; // "operator" fIdentFuncTable[112] := @Func112; // "requires" fIdentFuncTable[117] := @Func117; fIdentFuncTable[122] := @Func122; fIdentFuncTable[124] := @Func124; fIdentFuncTable[125] := @Func125; fIdentFuncTable[126] := @Func126; fIdentFuncTable[128] := @Func128; fIdentFuncTable[129] := @Func129; fIdentFuncTable[130] := @Func130; fIdentFuncTable[132] := @Func132; fIdentFuncTable[133] := @Func133; fIdentFuncTable[136] := @Func136; fIdentFuncTable[139] := @Func139; fIdentFuncTable[141] := @Func141; fIdentFuncTable[142] := @Func142; fIdentFuncTable[143] := @Func143; fIdentFuncTable[144] := @Func144; fIdentFuncTable[151] := @Func151; fIdentFuncTable[158] := @Func158; fIdentFuncTable[166] := @Func166; fIdentFuncTable[167] := @Func167; fIdentFuncTable[168] := @Func168; fIdentFuncTable[170] := @Func170; fIdentFuncTable[181] := @Func181; fIdentFuncTable[191] := @Func191; end; function TSynPasSyn.KeyHash: Integer; var Start, ToHash: PChar; begin Result := 0; if (fToIdent'@')) then begin Result := tkKey; fRange := fRange - [rsAsm, rsAfterClassMembers]; PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code // there may be more than on block ending here tfb := TopPascalCodeFoldBlockType; while (tfb in [cfbtIfThen]) do begin // no semicolon before end EndPascalCodeFoldBlock(True); tfb := TopPascalCodeFoldBlockType; end; if tfb = cfbtRecord then begin EndPascalCodeFoldBlock; end else if tfb = cfbtUnit then begin EndPascalCodeFoldBlock; end else if tfb = cfbtPackage then begin EndPascalCodeFoldBlock; end else if tfb = cfbtExcept then begin EndPascalCodeFoldBlock; if TopPascalCodeFoldBlockType = cfbtTry then EndPascalCodeFoldBlock; end else if tfb = cfbtTry then begin EndPascalCodeFoldBlock; end else if tfb in [cfbtTopBeginEnd, cfbtAsm] then begin EndPascalCodeFoldBlock; if TopPascalCodeFoldBlockType in [cfbtProcedure] then EndPascalCodeFoldBlock; end else if tfb in [cfbtCaseElse] then begin EndPascalCodeFoldBlock; EndPascalCodeFoldBlock; // must be cfbtCase fRange := fRange - [rsAtCaseLabel]; end else if tfb in [cfbtCase] then begin EndPascalCodeFoldBlock; fRange := fRange - [rsAtCaseLabel]; end else if tfb in [cfbtBeginEnd] then begin EndPascalCodeFoldBlock; if TopPascalCodeFoldBlockType = cfbtProgram then EndPascalCodeFoldBlock; end else if tfb = cfbtUnitSection then begin EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType = cfbtUnit then // "Unit".."end." EndPascalCodeFoldBlock; end else begin if tfb = cfbtClassSection then EndPascalCodeFoldBlockLastLine; // after class-section either a class OR a record can close with the same "end" if TopPascalCodeFoldBlockType = cfbtClass then EndPascalCodeFoldBlock else if TopPascalCodeFoldBlockType = cfbtRecord then EndPascalCodeFoldBlock; // After type declaration, allow "deprecated"? if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then fRange := fRange + [rsVarTypeInSpecification]; end; end else begin Result := tkKey; // @@end or @end label end; end else if KeyComp('In') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func25: TtkTokenKind; begin if KeyComp('Far') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func27: TtkTokenKind; begin if KeyComp('Cdecl') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func28: TtkTokenKind; begin if KeyComp('Is') then Result := tkKey else if (fRange * [rsProperty, rsAtPropertyOrReadWrite, rsAfterEqualOrColon] = [rsProperty]) and (PasCodeFoldRange.BracketNestLevel = 0) and KeyComp('Read') then begin Result := tkKey; fRange := fRange + [rsAtPropertyOrReadWrite]; end else if KeyComp('Case') then begin if TopPascalCodeFoldBlockType in PascalStatementBlocks + [cfbtUnitSection] then StartPascalCodeFoldBlock(cfbtCase); Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func29: TtkTokenKind; begin if KeyComp('On') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func32: TtkTokenKind; begin if KeyComp('Label') then begin if (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtNone, cfbtProcedure, cfbtProgram, cfbtUnit, cfbtUnitSection]) then begin if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType in [cfbtProcedure] then StartPascalCodeFoldBlock(cfbtLocalVarType) else StartPascalCodeFoldBlock(cfbtVarType); end; Result := tkKey; end else if KeyComp('Mod') then Result := tkKey else if KeyComp('File') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func33: TtkTokenKind; begin if KeyComp('Or') then Result := tkKey else if KeyComp('Asm') then begin Result := tkKey; fRange := fRange + [rsAsm]; fAsmStart := True; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtAsm); end else Result := tkIdentifier; end; function TSynPasSyn.Func35: TtkTokenKind; begin if KeyComp('Nil') then Result := tkKey else if KeyComp('To') then Result := tkKey else if KeyComp('Div') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func37: TtkTokenKind; begin if KeyComp('Begin') then begin // if we are in an include file, we may not know the state if (fRange * [rsImplementation, rsInterface] = []) then Include(fRange, rsImplementation); PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; Result := tkKey; if TopPascalCodeFoldBlockType in [cfbtProcedure] then StartPascalCodeFoldBlock(cfbtTopBeginEnd) else StartPascalCodeFoldBlock(cfbtBeginEnd); //debugln('TSynPasSyn.Func37 BEGIN ',dbgs(ord(TopPascalCodeFoldBlockType)),' LineNumber=',dbgs(fLineNumber),' ',dbgs(MinimumCodeFoldBlockLevel),' ',dbgs(CurrentCodeFoldBlockLevel)); end else if FExtendedKeywordsMode and KeyComp('Break') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func38: TtkTokenKind; begin if KeyComp('Near') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func39: TtkTokenKind; begin if KeyComp('For') then Result := tkKey else if KeyComp('Shl') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func40: TtkTokenKind; begin if KeyComp('Packed') then begin Result := tkKey; if (fRange * [rsProperty, rsAfterEqualOrColon] = [rsAfterEqualOrColon]) and (PasCodeFoldRange.BracketNestLevel = 0) then FOldRange := FOldRange - [rsAfterEqualOrColon]; // Keep flag in FRange end else Result := tkIdentifier; end; function TSynPasSyn.Func41: TtkTokenKind; begin if KeyComp('Else') then begin Result := tkKey; if (TopPascalCodeFoldBlockType = cfbtIfThen) then EndPascalCodeFoldBlock else if TopPascalCodeFoldBlockType = cfbtCase then begin StartPascalCodeFoldBlock(cfbtCaseElse); FTokenIsCaseLabel := True; end; end else if KeyComp('Var') then begin if (PasCodeFoldRange.BracketNestLevel = 0) and (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtNone, cfbtProcedure, cfbtProgram, cfbtUnit, cfbtUnitSection]) then begin if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType in [cfbtProcedure] then StartPascalCodeFoldBlock(cfbtLocalVarType) else StartPascalCodeFoldBlock(cfbtVarType); end; Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func42: TtkTokenKind; begin if KeyComp('Alias') then Result := tkKey else if KeyComp('Final') and (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection]) and (fRange * [rsAfterClassMembers, rsInProcHeader, rsProperty] = [rsAfterClassMembers]) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func44: TtkTokenKind; begin if KeyComp('Set') then Result := tkKey else if KeyComp('Package') and (TopPascalCodeFoldBlockType=cfbtNone) then begin Result := tkKey; StartPascalCodeFoldBlock(cfbtPackage); end else Result := tkIdentifier; end; function TSynPasSyn.Func45: TtkTokenKind; begin if KeyComp('Shr') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func46: TtkTokenKind; begin if (rsAfterClass in fRange) and KeyComp('Sealed') and (PasCodeFoldRange.BracketNestLevel = 0) and (TopPascalCodeFoldBlockType in [cfbtClass]) then begin Result := tkKey; fRange := fRange + [rsAtClass]; // forward, in case of further class modifiers end else Result := tkIdentifier; end; function TSynPasSyn.Func47: TtkTokenKind; begin if KeyComp('Then') then begin Result := tkKey; // in a "case", we need to distinguish a possible follwing "else" if (TopPascalCodeFoldBlockType = cfbtIfThen) then EndPascalCodeFoldBlock; //if TopPascalCodeFoldBlockType in [cfbtCase, cfbtIfThen] then StartPascalCodeFoldBlock(cfbtIfThen, not (TopPascalCodeFoldBlockType in [cfbtCase, cfbtIfThen])); end else Result := tkIdentifier; end; function TSynPasSyn.Func49: TtkTokenKind; begin if KeyComp('Not') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func52: TtkTokenKind; begin if KeyComp('Pascal') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else if KeyComp('Raise') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func54: TtkTokenKind; begin if KeyComp('Class') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass] - [rsVarTypeInSpecification]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func55: TtkTokenKind; begin if KeyComp('Object') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass] - [rsVarTypeInSpecification]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func56: TtkTokenKind; begin if KeyComp('Index') then begin if (fRange * [rsProperty, rsAtPropertyOrReadWrite, rsAfterEqualOrColon] = [rsProperty]) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else if KeyComp('Out') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func57: TtkTokenKind; begin if KeyComp('Goto') then Result := tkKey else if KeyComp('While') then Result := tkKey else if KeyComp('Xor') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func58: TtkTokenKind; begin if FExtendedKeywordsMode and KeyComp('Exit') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func59: TtkTokenKind; begin if KeyComp('Safecall') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func60: TtkTokenKind; begin if KeyComp('With') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func61: TtkTokenKind; begin if KeyComp('Dispid') or KeyComp('Generic') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func63: TtkTokenKind; begin if KeyComp('Public') then begin Result := tkKey; fRange := fRange - [rsAfterClassMembers, rsVarTypeInSpecification]; if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then begin if (TopPascalCodeFoldBlockType=cfbtClassSection) then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtClassSection); end; end else if KeyComp('Record') then begin StartPascalCodeFoldBlock(cfbtRecord); fRange := fRange - [rsVarTypeInSpecification]; if CompilerMode = pcmDelphi then fRange := fRange + [rsAtClass]; // highlight helper Result := tkKey; end else if KeyComp('Array') then Result := tkKey else if KeyComp('Try') then begin if TopPascalCodeFoldBlockType in PascalStatementBlocks + [cfbtUnitSection] then StartPascalCodeFoldBlock(cfbtTry); Result := tkKey; end else if KeyComp('Inline') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func64: TtkTokenKind; begin if KeyComp('Unit') then begin if TopPascalCodeFoldBlockType=cfbtNone then StartPascalCodeFoldBlock(cfbtUnit); Result := tkKey; end else if KeyComp('Uses') then begin if (TopPascalCodeFoldBlockType in [cfbtNone, cfbtProgram, cfbtUnit, cfbtUnitSection]) then begin StartPascalCodeFoldBlock(cfbtUses); end; Result := tkKey; end else if KeyComp('helper') then begin if (rsAtClass in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func65: TtkTokenKind; begin if KeyComp('Repeat') then begin Result := tkKey; StartPascalCodeFoldBlock(cfbtRepeat); end else Result := tkIdentifier; end; function TSynPasSyn.Func66: TtkTokenKind; begin if KeyComp('Type') then begin if (PasCodeFoldRange.BracketNestLevel = 0) and (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtNone, cfbtProcedure, cfbtProgram, cfbtUnit, cfbtUnitSection]) and not(rsAfterEqualOrColon in fRange) then begin if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType in [cfbtProcedure] then StartPascalCodeFoldBlock(cfbtLocalVarType) else StartPascalCodeFoldBlock(cfbtVarType); fRange := fRange + [rsInTypeBlock]; end; Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func69: TtkTokenKind; begin if KeyComp('Default') then begin if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then Result := tkKey else Result := tkIdentifier; end else if KeyComp('Dynamic') then Result := tkKey else if KeyComp('Message') and (fRange * [rsAfterClassMembers, rsInProcHeader, rsProperty] = [rsAfterClassMembers]) and (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection]) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func71: TtkTokenKind; begin if KeyComp('Stdcall') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else if KeyComp('Const') then begin if (PasCodeFoldRange.BracketNestLevel = 0) and (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtNone, cfbtProcedure, cfbtProgram, cfbtUnit, cfbtUnitSection]) then begin if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType in [cfbtProcedure] then StartPascalCodeFoldBlock(cfbtLocalVarType) else StartPascalCodeFoldBlock(cfbtVarType); end; Result := tkKey; end else if KeyComp('Bitpacked') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func72: TtkTokenKind; begin if KeyComp('Static') and (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection]) and (fRange * [rsAfterEqualOrColon, rsInProcHeader, rsProperty] = []) and (fRange * [rsAfterClassMembers, rsAfterClassField] <> []) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func73: TtkTokenKind; begin if KeyComp('Except') then begin Result := tkKey; while (TopPascalCodeFoldBlockType = cfbtIfThen) do // no semicolon before except EndPascalCodeFoldBlock(True); SmartCloseBeginEndBlocks(cfbtTry); if TopPascalCodeFoldBlockType = cfbtTry then StartPascalCodeFoldBlock(cfbtExcept); end else Result := tkIdentifier; end; function TSynPasSyn.Func75: TtkTokenKind; begin if (fRange * [rsProperty, rsAtPropertyOrReadWrite, rsAfterEqualOrColon] = [rsProperty]) and (PasCodeFoldRange.BracketNestLevel = 0) and KeyComp('Write') then begin Result := tkKey; fRange := fRange + [rsAtPropertyOrReadWrite]; end else Result := tkIdentifier; end; function TSynPasSyn.Func76: TtkTokenKind; begin if KeyComp('Until') then begin Result := tkKey; while (TopPascalCodeFoldBlockType = cfbtIfThen) do // no semicolon before until EndPascalCodeFoldBlock(True); SmartCloseBeginEndBlocks(cfbtRepeat); if TopPascalCodeFoldBlockType = cfbtRepeat then EndPascalCodeFoldBlock; end else Result := tkIdentifier; end; function TSynPasSyn.Func79: TtkTokenKind; begin if KeyComp('Finally') then begin Result := tkKey; while (TopPascalCodeFoldBlockType = cfbtIfThen) do // no semicolon before finally EndPascalCodeFoldBlock(True); SmartCloseBeginEndBlocks(cfbtTry); if TopPascalCodeFoldBlockType = cfbtTry then StartPascalCodeFoldBlock(cfbtExcept); end else Result := tkIdentifier; end; function TSynPasSyn.Func81: TtkTokenKind; var tbf: TPascalCodeFoldBlockType; begin if KeyComp('Stored') then begin if rsProperty in fRange then Result := tkKey else Result := tkIdentifier; end else if KeyComp('Interface') then begin if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end else if not(rsAfterEqualOrColon in fRange) and (fRange * [rsInterface, rsImplementation] = []) then begin CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType=cfbtUnitSection then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtUnitSection); fRange := fRange + [rsInterface]; // Interface has no ";", implicit end of statement end; Result := tkKey end else if KeyComp('Deprecated') then begin tbf := TopPascalCodeFoldBlockType; if ( ( (tbf in [cfbtVarType, cfbtLocalVarType]) and (rsVarTypeInSpecification in fRange) ) or ( (tbf in [cfbtClass, cfbtClassSection, cfbtRecord]) and (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) ) or ( tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure] ) ) and ( fRange *[rsAfterEqualOrColon, rsInProcHeader, rsProperty] = [] ) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func84: TtkTokenKind; begin if KeyComp('Abstract') and (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection]) then begin Result := tkKey; if (rsAfterClass in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then fRange := fRange + [rsAtClass] // forward, in case of further class modifiers end else if not (rsAfterClassMembers in fRange) then Result := tkIdentifier; end else if KeyComp('ObjcClass') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func85: TtkTokenKind; begin if KeyComp('Forward') then begin Result := tkKey; if TopPascalCodeFoldBlockType = cfbtProcedure then begin EndPascalCodeFoldBlock(True); end; end else if KeyComp('Library') then begin fRange := fRange - [rsInterface] + [rsImplementation]; if TopPascalCodeFoldBlockType=cfbtNone then StartPascalCodeFoldBlock(cfbtProgram); Result := tkKey end else Result := tkIdentifier; end; function TSynPasSyn.Func86: TtkTokenKind; begin if KeyComp('VarArgs') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func87: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault, spsmStringOnly]) and KeyComp('String') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func88: TtkTokenKind; begin if KeyComp('Program') then begin fRange := fRange - [rsInterface] + [rsImplementation]; if TopPascalCodeFoldBlockType=cfbtNone then StartPascalCodeFoldBlock(cfbtProgram); Result := tkKey; end else if KeyComp('Mwpascal') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func89: TtkTokenKind; function ScanForClassSection: Boolean; var Txt: String; NestBrace1, NestBrace2: Integer; i, l, Idx: Integer; begin Result := False; Txt := copy(fLine, Run + 7, length(fLine)); Idx := LineIndex; NestBrace1 := 0; NestBrace2 := 0; while true do begin i := 1; l := length(Txt); while i <= l do begin case Txt[i] of '{' : if (NestBrace2 = 0) and (NestedComments or (NestBrace1 = 0)) then inc(NestBrace1); '}' : if (NestBrace2 = 0) then if NestBrace1 > 0 then dec(NestBrace1) else exit; '(' : if (NestBrace1 = 0) then if (i+1 > l) or (Txt[i+1] <> '*') then exit else if NestedComments or (NestBrace2 = 0) then begin inc(NestBrace2); inc(i); end; '*' : if (NestBrace1 = 0) then if (i+1 <= l) and (Txt[i+1] = ')') and (NestBrace2 > 0) then begin dec(NestBrace2); inc(i); end else if NestBrace2 = 0 then exit; '/' : If (NestBrace1 = 0) and (NestBrace2 = 0) then begin if (i+1 <= l) and (Txt[i+1] = '/') then i := l else exit; end; #1..#32: {do nothing}; 'p', 'P' : If (NestBrace1 = 0) and (NestBrace2 = 0) then begin if ( (i+6 <= l) and ((i+6 = l) or (Txt[i+7] in [#1..#32])) and (KeyCompEx(@Txt[i+1], PChar('rivate'), 6)) ) or ( (i+8 <= l) and ((i+8 = l) or (Txt[i+9] in [#1..#32])) and (KeyCompEx(@Txt[i+1], PChar('rotected'), 8)) ) then exit(True) else exit; end; else If (NestBrace1 = 0) and (NestBrace2 = 0) then exit; end; inc(i); end; inc(Idx); if Idx < CurrentLines.Count then Txt := CurrentLines[Idx] else break; end; end; begin if KeyComp('CppClass') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; // Structural Scan / Quick if FIsInNextToEOL and not FCatchNodeInfo then exit; // Scanning for display / Look ahead if KeyComp('strict') then begin if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then if ScanForClassSection then Result := tkKey; end; end; function TSynPasSyn.Func91: TtkTokenKind; begin if KeyComp('Downto') then Result := tkKey else if KeyComp('Private') then begin Result := tkKey; fRange := fRange - [rsAfterClassMembers, rsVarTypeInSpecification]; if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then begin if (TopPascalCodeFoldBlockType=cfbtClassSection) then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtClassSection); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func92: TtkTokenKind; begin if D4syntax and KeyComp('overload') then Result := tkKey else if KeyComp('Inherited') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func94: TtkTokenKind; begin if KeyComp('Assembler') then Result := tkKey else if KeyComp('Readonly') then begin if rsProperty in fRange then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func95: TtkTokenKind; begin if KeyComp('Absolute') then Result := tkKey else if KeyComp('Contains') and (TopPascalCodeFoldBlockType=cfbtPackage) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func96: TtkTokenKind; begin if KeyComp('Published') then begin Result := tkKey; fRange := fRange - [rsAfterClassMembers, rsVarTypeInSpecification]; if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then begin if (TopPascalCodeFoldBlockType=cfbtClassSection) then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtClassSection); end; end else if KeyComp('Override') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func97: TtkTokenKind; begin if KeyComp('Threadvar') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func98: TtkTokenKind; begin if KeyComp('Export') then Result := tkKey else if KeyComp('Nodefault') then begin if rsProperty in fRange then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func99: TtkTokenKind; begin if KeyComp('External') then begin Result := tkKey; if TopPascalCodeFoldBlockType = cfbtProcedure then begin EndPascalCodeFoldBlock(True); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func100: TtkTokenKind; begin if KeyComp('Automated') then Result := tkKey else if (rsInProcHeader in fRange) and KeyComp('constref') and (PasCodeFoldRange.BracketNestLevel = 1) then Result := tkKey else Result := tkIdentifier end; function TSynPasSyn.Func101: TtkTokenKind; var tbf: TPascalCodeFoldBlockType; begin if KeyComp('Register') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else if KeyComp('Platform') then begin tbf := TopPascalCodeFoldBlockType; if ( ( (tbf in [cfbtVarType, cfbtLocalVarType]) and (rsVarTypeInSpecification in fRange) ) or ( (tbf in [cfbtClass, cfbtClassSection, cfbtRecord]) and (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) ) or ( tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure] ) ) and ( fRange *[rsAfterEqualOrColon, rsInProcHeader, rsProperty] = [] ) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else if FExtendedKeywordsMode and KeyComp('Continue') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func102: TtkTokenKind; var InClass: Boolean; begin if KeyComp('Function') then begin if not(rsAfterEqualOrColon in fRange) then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; InClass := TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]; if ( (rsImplementation in fRange) and (not InClass) ) then StartPascalCodeFoldBlock(cfbtProcedure); if InClass then fRange := fRange + [rsAfterClassMembers]; end; fRange := fRange + [rsInProcHeader]; Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func103: TtkTokenKind; begin if KeyComp('Virtual') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func105: TtkTokenKind; var InClass: Boolean; begin if KeyComp('Procedure') then begin if not(rsAfterEqualOrColon in fRange) then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; InClass := TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]; if ( (rsImplementation in fRange) and (not InClass) ) then StartPascalCodeFoldBlock(cfbtProcedure); if InClass then fRange := fRange + [rsAfterClassMembers]; end; fRange := fRange + [rsInProcHeader]; Result := tkKey; end else if KeyComp('specialize') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func106: TtkTokenKind; begin if KeyComp('Protected') then begin Result := tkKey; fRange := fRange - [rsAfterClassMembers, rsVarTypeInSpecification]; if (TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]) then begin if (TopPascalCodeFoldBlockType=cfbtClassSection) then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtClassSection); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func108: TtkTokenKind; begin if KeyComp('Operator') then begin if not(rsAfterEqualOrColon in fRange) then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if ((rsImplementation in fRange) and not(TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord])) then StartPascalCodeFoldBlock(cfbtProcedure); end; Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func112: TtkTokenKind; begin if KeyComp('Requires') and (TopPascalCodeFoldBlockType=cfbtPackage) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func117: TtkTokenKind; begin if KeyComp('Exports') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func122: TtkTokenKind; begin if KeyComp('Otherwise') then begin Result := tkKey; while (TopPascalCodeFoldBlockType = cfbtIfThen) do EndPascalCodeFoldBlock(True); if TopPascalCodeFoldBlockType = cfbtCase then begin StartPascalCodeFoldBlock(cfbtCaseElse); FTokenIsCaseLabel := True; end; end else Result := tkIdentifier; end; function TSynPasSyn.Func124: TtkTokenKind; begin if KeyComp('ObjcCategory') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func125: TtkTokenKind; begin if KeyComp('NoReturn') and (TopPascalCodeFoldBlockType in ProcModifierAllowed) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func126: TtkTokenKind; begin if D4syntax and KeyComp('Implements') then begin if rsProperty in fRange then Result := tkKey else Result := tkIdentifier; end else if KeyComp('NoStackFrame') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func128: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('Widestring') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func129: TtkTokenKind; begin if KeyComp('Dispinterface') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func130: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('Ansistring') then Result := tkKey else if KeyComp('Enumerator') and (TopPascalCodeFoldBlockType in [cfbtClassSection]) then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func132: TtkTokenKind; begin if D4syntax and KeyComp('Reintroduce') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func133: TtkTokenKind; begin if KeyComp('Property') then begin Result := tkKey; fRange := fRange + [rsProperty, rsAtPropertyOrReadWrite]; if TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord] then fRange := fRange + [rsAfterClassMembers]; end else Result := tkIdentifier; end; function TSynPasSyn.Func136: TtkTokenKind; begin if KeyComp('Finalization') then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType=cfbtUnitSection then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtUnitSection); fRange := fRange - [rsInterface] + [rsImplementation]; Result := tkKey end else Result := tkIdentifier; end; function TSynPasSyn.Func139: TtkTokenKind; begin if KeyComp('WeakExternal') then begin Result := tkKey; if TopPascalCodeFoldBlockType = cfbtProcedure then EndPascalCodeFoldBlock(True); end else Result := tkIdentifier; end; function TSynPasSyn.Func141: TtkTokenKind; begin if KeyComp('Writeonly') then begin if rsProperty in fRange then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func142: TtkTokenKind; var tbf: TPascalCodeFoldBlockType; begin if KeyComp('Experimental') then begin tbf := TopPascalCodeFoldBlockType; if ( ( (tbf in [cfbtVarType, cfbtLocalVarType]) and (rsVarTypeInSpecification in fRange) ) or ( (tbf in [cfbtClass, cfbtClassSection, cfbtRecord]) and (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) ) or ( tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure] ) ) and ( fRange *[rsAfterEqualOrColon, rsInProcHeader, rsProperty] = [] ) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func143: TtkTokenKind; var InClass: Boolean; begin if KeyComp('Destructor') then begin if not(rsAfterEqualOrColon in fRange) then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; InClass := TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]; if ( (rsImplementation in fRange) and (not InClass) ) then StartPascalCodeFoldBlock(cfbtProcedure); if InClass then fRange := fRange + [rsAfterClassMembers]; fRange := fRange + [rsInProcHeader]; end; Result := tkKey; end else if KeyComp('compilerproc') then // fpc modifier Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func144: TtkTokenKind; begin if KeyComp('ObjcProtocol') then begin Result := tkKey; if (rsAfterEqualOrColon in fRange) and (PasCodeFoldRange.BracketNestLevel = 0) then begin fRange := fRange + [rsAtClass]; StartPascalCodeFoldBlock(cfbtClass); end; end else Result := tkIdentifier; end; function TSynPasSyn.Func151: TtkTokenKind; var tbf: TPascalCodeFoldBlockType; begin if KeyComp('Unimplemented') then begin tbf := TopPascalCodeFoldBlockType; if ( ( (tbf in [cfbtVarType, cfbtLocalVarType]) and (rsVarTypeInSpecification in fRange) ) or ( (tbf in [cfbtClass, cfbtClassSection, cfbtRecord]) and (fRange * [rsAfterClassMembers, rsVarTypeInSpecification] <> []) ) or ( tbf in [cfbtUnitSection, cfbtProgram, cfbtProcedure] ) ) and ( fRange *[rsAfterEqualOrColon, rsInProcHeader, rsProperty] = [] ) and (PasCodeFoldRange.BracketNestLevel = 0) then Result := tkKey else Result := tkIdentifier; end else Result := tkIdentifier; end; function TSynPasSyn.Func158: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('UnicodeString') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func166: TtkTokenKind; var InClass: Boolean; begin if KeyComp('Constructor') then begin if not(rsAfterEqualOrColon in fRange) then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; InClass := TopPascalCodeFoldBlockType in [cfbtClass, cfbtClassSection, cfbtRecord]; if ( (rsImplementation in fRange) and (not InClass) ) then StartPascalCodeFoldBlock(cfbtProcedure); if InClass then fRange := fRange + [rsAfterClassMembers]; fRange := fRange + [rsInProcHeader]; end; Result := tkKey; end else if KeyComp('Implementation') then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType=cfbtUnitSection then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtUnitSection); fRange := fRange - [rsInterface] + [rsImplementation]; // implicit end of statement Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func167: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('Shortstring') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func168: TtkTokenKind; begin if KeyComp('Initialization') then begin PasCodeFoldRange.BracketNestLevel := 0; // Reset in case of partial code CloseBeginEndBlocksBeforeProc; if TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType] then EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType=cfbtUnitSection then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtUnitSection); fRange := fRange - [rsInterface] + [rsImplementation]; Result := tkKey; end else Result := tkIdentifier; end; function TSynPasSyn.Func170: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('UTF8String') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func181: TtkTokenKind; begin if (FStringKeywordMode in [spsmDefault]) and KeyComp('RawByteString') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.Func191: TtkTokenKind; begin if KeyComp('Resourcestring') then begin Result := tkKey; if TopPascalCodeFoldBlockType = cfbtVarType then EndPascalCodeFoldBlockLastLine; StartPascalCodeFoldBlock(cfbtVarType); end else if KeyComp('Stringresource') then Result := tkKey else Result := tkIdentifier; end; function TSynPasSyn.AltFunc: TtkTokenKind; begin Result := tkIdentifier end; function TSynPasSyn.IdentKind(p: integer): TtkTokenKind; var HashKey: Integer; begin fToIdent := p; HashKey := KeyHash; if HashKey < 192 then Result := fIdentFuncTable[HashKey]() else Result := tkIdentifier; end; procedure TSynPasSyn.MakeMethodTables; var I: Char; begin for I := #0 to #255 do case I of #0: fProcTable[I] := @NullProc; #10: fProcTable[I] := @LFProc; #13: fProcTable[I] := @CRProc; #1..#9, #11, #12, #14..#32: fProcTable[I] := @SpaceProc; '#': fProcTable[I] := @AsciiCharProc; '$': fProcTable[I] := @HexProc; '%': fProcTable[I] := @BinaryProc; '&': fProcTable[I] := @OctalProc; #39: fProcTable[I] := @StringProc; '0'..'9': fProcTable[I] := @NumberProc; 'A'..'Z', 'a'..'z', '_': fProcTable[I] := @IdentProc; '^': fProcTable[I] := @CaretProc; '{': fProcTable[I] := @BraceOpenProc; '}', '!', '"', '('..'/', ':'..'@', '[', ']', '\', '`', '~': begin case I of '(': fProcTable[I] := @RoundOpenProc; ')': fProcTable[I] := @RoundCloseProc; '[': fProcTable[I] := @SquareOpenProc; ']': fProcTable[I] := @SquareCloseProc; '=': fProcTable[I] := @EqualSignProc; '.': fProcTable[I] := @PointProc; ';': fProcTable[I] := @SemicolonProc; //mh 2000-10-08 '/': fProcTable[I] := @SlashProc; ':': fProcTable[I] := @ColonProc; '>': fProcTable[I] := @GreaterProc; '<': fProcTable[I] := @LowerProc; '@': fProcTable[I] := @AddressOpProc; else fProcTable[I] := @SymbolProc; end; end; else fProcTable[I] := @UnknownProc; end; end; constructor TSynPasSyn.Create(AOwner: TComponent); begin inherited Create(AOwner); FStringKeywordMode := spsmDefault; FExtendedKeywordsMode := False; CreateDividerDrawConfig; fD4syntax := true; fAsmAttri := TSynHighlighterAttributes.Create(@SYNS_AttrAssembler, SYNS_XML_AttrAssembler); AddAttribute(fAsmAttri); fCommentAttri := TSynHighlighterAttributes.Create(@SYNS_AttrComment, SYNS_XML_AttrComment); fCommentAttri.Style:= [fsItalic]; AddAttribute(fCommentAttri); FIDEDirectiveAttri := TSynHighlighterAttributesModifier.Create(@SYNS_AttrIDEDirective, SYNS_XML_AttrIDEDirective); AddAttribute(FIDEDirectiveAttri); // FCurIDEDirectiveAttri, FCurCaseLabelAttri // They are not available through the "Attribute" property (not added via AddAttribute // But they are returned via GetTokenAttribute, so they should have a name. FCurIDEDirectiveAttri := TSynSelectedColorMergeResult.Create(@SYNS_AttrIDEDirective, SYNS_XML_AttrIDEDirective); fIdentifierAttri := TSynHighlighterAttributes.Create(@SYNS_AttrIdentifier, SYNS_XML_AttrIdentifier); AddAttribute(fIdentifierAttri); fKeyAttri := TSynHighlighterAttributes.Create(@SYNS_AttrReservedWord, SYNS_XML_AttrReservedWord); fKeyAttri.Style:= [fsBold]; AddAttribute(fKeyAttri); fNumberAttri := TSynHighlighterAttributes.Create(@SYNS_AttrNumber, SYNS_XML_AttrNumber); AddAttribute(fNumberAttri); fSpaceAttri := TSynHighlighterAttributes.Create(@SYNS_AttrSpace, SYNS_XML_AttrSpace); AddAttribute(fSpaceAttri); fStringAttri := TSynHighlighterAttributes.Create(@SYNS_AttrString, SYNS_XML_AttrString); AddAttribute(fStringAttri); fSymbolAttri := TSynHighlighterAttributes.Create(@SYNS_AttrSymbol, SYNS_XML_AttrSymbol); AddAttribute(fSymbolAttri); FCaseLabelAttri := TSynHighlighterAttributesModifier.Create(@SYNS_AttrCaseLabel, SYNS_XML_AttrCaseLabel); AddAttribute(FCaseLabelAttri); FCurCaseLabelAttri := TSynSelectedColorMergeResult.Create(@SYNS_AttrCaseLabel, SYNS_XML_AttrCaseLabel); fDirectiveAttri := TSynHighlighterAttributes.Create(@SYNS_AttrDirective, SYNS_XML_AttrDirective); fDirectiveAttri.Style:= [fsItalic]; AddAttribute(fDirectiveAttri); CompilerMode:=pcmDelphi; SetAttributesOnChange(@DefHighlightChange); InitIdent; MakeMethodTables; fRange := []; fAsmStart := False; fDefaultFilter := SYNS_FilterPascal; end; { Create } destructor TSynPasSyn.Destroy; begin DestroyDividerDrawConfig; FreeAndNil(FCurCaseLabelAttri); FreeAndNil(FCurIDEDirectiveAttri); inherited Destroy; end; procedure TSynPasSyn.SetLine(const NewValue: string; LineNumber:Integer); begin //DebugLn(['TSynPasSyn.SetLine START LineNumber=',LineNumber,' Line="',NewValue,'"']); fLineStr := NewValue; fLineLen:=length(fLineStr); fLine:=PChar(Pointer(fLineStr)); Run := 0; Inherited SetLine(NewValue,LineNumber); FStartCodeFoldBlockLevel := PasCodeFoldRange.MinimumCodeFoldBlockLevel; PasCodeFoldRange.LastLineCodeFoldLevelFix := 0; PasCodeFoldRange.PasFoldFixLevel := 0; PasCodeFoldRange.PasFoldMinLevel := PasCodeFoldRange.PasFoldEndLevel; FPasStartLevel := PasCodeFoldRange.PasFoldMinLevel; FSynPasRangeInfo.MinLevelIfDef := FSynPasRangeInfo.EndLevelIfDef; FSynPasRangeInfo.MinLevelRegion := FSynPasRangeInfo.EndLevelRegion; fLineNumber := LineNumber; FAtLineStart := True; if not FCatchNodeInfo then Next; end; { SetLine } procedure TSynPasSyn.AddressOpProc; begin fTokenID := tkSymbol; inc(Run); if fLine[Run] = '@' then inc(Run); end; procedure TSynPasSyn.AsciiCharProc; begin fTokenID := tkString; inc(Run); case FLine[Run] of '%': begin inc(Run); if (FLine[Run] in ['0'..'1']) then while (FLine[Run] in ['0'..'1']) do inc(Run) else fTokenID := tkSymbol; end; '&': begin inc(Run); if (FLine[Run] in ['0'..'7']) then while (FLine[Run] in ['0'..'7']) do inc(Run) else fTokenID := tkSymbol; end; '$': begin inc(Run); if (IsIntegerChar[FLine[Run]]) then while (IsIntegerChar[FLine[Run]]) do inc(Run) else fTokenID := tkSymbol; end; '0'..'9': while (FLine[Run] in ['0'..'9']) do inc(Run); else fTokenID := tkSymbol; end; end; procedure TSynPasSyn.BorProc; var p: LongInt; begin p:=Run; fTokenID := tkComment; if rsIDEDirective in fRange then fTokenID := tkIDEDirective; repeat case fLine[p] of #0,#10,#13: break; '}': if TopPascalCodeFoldBlockType=cfbtNestedComment then begin Run:=p; EndPascalCodeFoldBlock; p:=Run; end else begin fRange := fRange - [rsBor, rsIDEDirective]; Inc(p); if TopPascalCodeFoldBlockType=cfbtBorCommand then EndPascalCodeFoldBlock; break; end; '{': if NestedComments then begin fStringLen := 1; Run:=p; StartPascalCodeFoldBlock(cfbtNestedComment); p:=Run; end; end; Inc(p); until (p>=fLineLen); Run:=p; end; procedure TSynPasSyn.DirectiveProc; begin fTokenID := tkDirective; if TextComp('mode') then begin // $mode directive inc(Run,4); // skip space while (fLine[Run] in [' ',#9,#10,#13]) do inc(Run); if TextComp('objfpc') then CompilerMode:=pcmObjFPC else if TextComp('delphi') then CompilerMode:=pcmDelphi else if TextComp('fpc') then CompilerMode:=pcmFPC else if TextComp('gpc') then CompilerMode:=pcmGPC else if TextComp('tp') then CompilerMode:=pcmTP else if TextComp('macpas') then CompilerMode:=pcmMacPas; end; repeat case fLine[Run] of #0,#10,#13: break; '}': if TopPascalCodeFoldBlockType=cfbtNestedComment then EndPascalCodeFoldBlock else begin fRange := fRange - [rsDirective]; Inc(Run); break; end; '{': if NestedComments then begin fStringLen := 1; StartPascalCodeFoldBlock(cfbtNestedComment); end; end; Inc(Run); until (Run>=fLineLen); //DebugLn(['TSynPasSyn.DirectiveProc Run=',Run,' fTokenPos=',fTokenPos,' fLineStr=',fLineStr,' Token=',GetToken]); end; procedure TSynPasSyn.BraceOpenProc; function ScanRegion: Boolean; var Txt: String; Idx, NestBrace, i, l: Integer; InString: Boolean; begin Result := False; Txt := copy(fLine, Run, length(fLine)); Idx := LineIndex; InString := False; NestBrace := 0; while true do begin i := 1; l := length(Txt); while i <= l do begin case Txt[i] of '{' : inc(NestBrace); '}' : if NestBrace = 0 then exit else dec(NestBrace); '''' : if (i+1 <= l) and (Txt[i+1] = '''') then inc(i) else InString := not InString; '-', '/' : If (not InString) and (i+4 <= l) and ((i=1) or (Txt[i-1] in [' ', #9, #10, #13])) and (KeyCompEx(@Txt[i+1], PChar('fold'), 4)) and ((i+4 = l) or (Txt[i+5] in [' ', #9, #10, #13, '}'])) then exit(True); end; inc(i); end; inc(Idx); if Idx < CurrentLines.Count then Txt := CurrentLines[Idx] else break; end; end; procedure StartDirectiveFoldBlock(ABlockType: TPascalCodeFoldBlockType); inline; begin dec(Run); inc(fStringLen); // include $ StartCustomCodeFoldBlock(ABlockType); inc(Run); end; procedure EndDirectiveFoldBlock(ABlockType: TPascalCodeFoldBlockType); inline; begin dec(Run); inc(fStringLen); // include $ EndCustomCodeFoldBlock(ABlockType); inc(Run); end; procedure EndStartDirectiveFoldBlock(ABlockType: TPascalCodeFoldBlockType); inline; begin dec(Run); inc(fStringLen); // include $ EndCustomCodeFoldBlock(ABlockType); StartCustomCodeFoldBlock(ABlockType); inc(Run); end; var nd: PSynFoldNodeInfo; begin if (Run < fLineLen-1) and (fLine[Run+1] = '$') then begin // compiler directive fRange := fRange + [rsDirective]; inc(Run, 2); fToIdent := Run; KeyHash; if (fLine[Run] in ['i', 'I']) and ( KeyComp('if') or KeyComp('ifc') or KeyComp('ifdef') or KeyComp('ifndef') or KeyComp('ifopt') ) then StartDirectiveFoldBlock(cfbtIfDef) else if ( (fLine[Run] in ['e', 'E']) and ( KeyComp('endif') or KeyComp('endc') ) ) or KeyComp('ifend') then EndDirectiveFoldBlock(cfbtIfDef) else if (fLine[Run] in ['e', 'E']) and ( KeyComp('else') or KeyComp('elsec') or KeyComp('elseif') or KeyComp('elifc') ) then EndStartDirectiveFoldBlock(cfbtIfDef) else if KeyComp('region') then begin StartDirectiveFoldBlock(cfbtRegion); if FCatchNodeInfo then // Scan ahead if ScanRegion then begin nd := FCatchNodeInfoList.LastItemPointer; if nd <> nil then nd^.FoldAction := nd^.FoldAction + [sfaDefaultCollapsed]; end; end else if KeyComp('endregion') then EndDirectiveFoldBlock(cfbtRegion); DirectiveProc; end else begin // curly bracket open -> borland comment fStringLen := 1; // length of "{" inc(Run); if (Run < fLineLen) and (fLine[Run] = '%') then begin fRange := fRange + [rsIDEDirective]; // IDE directive {%xxx } rsIDEDirective inc(Run); fToIdent := Run; KeyHash; if KeyComp('region') then begin StartDirectiveFoldBlock(cfbtRegion); if FCatchNodeInfo then // Scan ahead if ScanRegion then begin nd := FCatchNodeInfoList.LastItemPointer; if nd <> nil then nd^.FoldAction := nd^.FoldAction + [sfaDefaultCollapsed]; end; end else if KeyComp('endregion') then EndDirectiveFoldBlock(cfbtRegion) else begin dec(Run, 2); StartPascalCodeFoldBlock(cfbtBorCommand); inc(Run); end; end else begin fRange := fRange + [rsBor]; dec(Run); StartPascalCodeFoldBlock(cfbtBorCommand); inc(Run); end; BorProc; end; end; procedure TSynPasSyn.ColonProc; begin fTokenID := tkSymbol; inc(Run); if fLine[Run] = '=' then inc(Run) // ":=" else begin fRange := fRange + [rsAfterEqualOrColon] - [rsAtCaseLabel]; if (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtClass, cfbtClassSection, cfbtRecord]) and not(rsAfterClassMembers in fRange) then fRange := fRange + [rsVarTypeInSpecification]; end; end; procedure TSynPasSyn.GreaterProc; begin fTokenID := tkSymbol; inc(Run); if fLine[Run] = '=' then inc(Run) end; procedure TSynPasSyn.CRProc; begin fTokenID := tkSpace; inc(Run); if fLine[Run] = #10 then inc(Run); end; procedure TSynPasSyn.IdentProc; begin fTokenID := IdentKind(Run); inc(Run, fStringLen); while Identifiers[fLine[Run]] do inc(Run); end; procedure TSynPasSyn.HexProc; begin inc(Run); if (IsIntegerChar[FLine[Run]]) then begin fTokenID := tkNumber; while (IsIntegerChar[FLine[Run]]) do inc(Run); end else fTokenID := tkSymbol; end; procedure TSynPasSyn.BinaryProc; begin inc(Run); if FLine[Run] in ['0'..'1'] then begin fTokenID := tkNumber; while FLine[Run] in ['0'..'1'] do inc(Run); end else fTokenID := tkSymbol; end; procedure TSynPasSyn.OctalProc; begin inc(Run); if FLine[Run] in ['0'..'7'] then begin fTokenID := tkNumber; while FLine[Run] in ['0'..'7'] do inc(Run); end else if FLine[Run] in ['A'..'Z', 'a'..'z', '_'] then begin fTokenID := tkIdentifier; while Identifiers[fLine[Run]] do inc(Run); end else fTokenID := tkSymbol; end; procedure TSynPasSyn.LFProc; begin fTokenID := tkSpace; inc(Run); end; procedure TSynPasSyn.LowerProc; begin fTokenID := tkSymbol; inc(Run); if fLine[Run] in ['=', '>'] then inc(Run); end; procedure TSynPasSyn.CaretProc; var t: TPascalCodeFoldBlockType; begin inc(Run); fTokenID := tkSymbol; t := TopPascalCodeFoldBlockType; if ( (t in PascalStatementBlocks - [cfbtAsm]) or //cfbtClass, cfbtClassSection, ( ( (t in [cfbtVarType, cfbtLocalVarType]) or ((t in [cfbtProcedure]) and (PasCodeFoldRange.BracketNestLevel > 0)) ) and (fRange * [rsInTypeBlock, rsAfterEqual] = [rsAfterEqual]) )) and not(rsAfterIdentifier in fRange) then begin if Run=fLineLen) or (fLine[Run] in [#0, #10, #13]); end; procedure TSynPasSyn.RoundOpenProc; begin Inc(Run); if Run>=fLineLen then begin fTokenID:=tkSymbol; PasCodeFoldRange.IncBracketNestLevel; exit; end; case fLine[Run] of '*': begin // We would not be here, if we were in a comment or directive already fRange := fRange + [rsAnsi]; fTokenID := tkComment; fStringLen := 2; // length of "(*" Dec(Run); StartPascalCodeFoldBlock(cfbtAnsiComment); Inc(Run, 2); if not (fLine[Run] in [#0, #10, #13]) then begin AnsiProc; end; end; '.': begin inc(Run); fTokenID := tkSymbol; PasCodeFoldRange.IncBracketNestLevel; end; else begin fTokenID := tkSymbol; PasCodeFoldRange.IncBracketNestLevel; end; end; end; procedure TSynPasSyn.RoundCloseProc; begin inc(Run); fTokenID := tkSymbol; PasCodeFoldRange.DecBracketNestLevel; if (PasCodeFoldRange.BracketNestLevel = 0) then begin if (fRange * [rsAfterClass] <> []) then fRange := fRange + [rsAtClosingBracket]; Exclude(fRange, rsInProcHeader); end; end; procedure TSynPasSyn.SquareOpenProc; begin inc(Run); fTokenID := tkSymbol; PasCodeFoldRange.IncBracketNestLevel; end; procedure TSynPasSyn.SquareCloseProc; begin inc(Run); fTokenID := tkSymbol; PasCodeFoldRange.DecBracketNestLevel; end; procedure TSynPasSyn.EqualSignProc; begin inc(Run); fTokenID := tkSymbol; fRange := fRange + [rsAfterEqualOrColon, rsAfterEqual]; if (TopPascalCodeFoldBlockType in [cfbtVarType, cfbtLocalVarType, cfbtClass, cfbtClassSection, cfbtRecord]) and not(rsAfterClassMembers in fRange) then fRange := fRange + [rsVarTypeInSpecification]; end; procedure TSynPasSyn.SemicolonProc; var tfb: TPascalCodeFoldBlockType; begin Inc(Run); fTokenID := tkSymbol; tfb := TopPascalCodeFoldBlockType; if tfb = cfbtUses then EndPascalCodeFoldBlock; if (tfb = cfbtClass) and (rsAfterClass in fRange) then EndPascalCodeFoldBlock(True); while (tfb = cfbtIfThen) do begin EndPascalCodeFoldBlock(True); tfb := TopPascalCodeFoldBlockType; end; if (tfb = cfbtCase) then fRange := fRange + [rsAtCaseLabel]; if (tfb in [cfbtClass, cfbtClassSection]) and (fRange * [rsVarTypeInSpecification, rsAfterClassMembers] = [rsVarTypeInSpecification]) then fRange := fRange + [rsAfterClassField]; if (fRange * [rsProperty, rsInProcHeader] <> []) and (PasCodeFoldRange.BracketNestLevel = 0) then fRange := fRange - [rsProperty, rsInProcHeader]; fRange := fRange - [rsVarTypeInSpecification, rsAfterEqual]; end; procedure TSynPasSyn.SlashProc; begin if fLine[Run+1] = '/' then begin fTokenID := tkComment; if FAtLineStart then begin fRange := fRange + [rsSlash]; fStringLen := 2; // length of "//" if not(TopPascalCodeFoldBlockType = cfbtSlashComment) then StartPascalCodeFoldBlock(cfbtSlashComment); end; inc(Run, 2); while not(fLine[Run] in [#0, #10, #13]) do Inc(Run); end else begin Inc(Run); fTokenID := tkSymbol; end; end; procedure TSynPasSyn.SlashContinueProc; begin if (fLine[Run] = '/') and (fLine[Run + 1] = '/') then begin // Continue fold block fTokenID := tkComment; while not(fLine[Run] in [#0, #10, #13]) do Inc(Run); exit; end; fTokenID := tkUnknown; if IsSpaceChar[FLine[Run]] then begin fTokenID := tkSpace; inc(Run); while IsSpaceChar[FLine[Run]] do inc(Run); end; if not((fLine[Run] = '/') and (fLine[Run + 1] = '/')) then begin fRange := fRange - [rsSlash]; if TopPascalCodeFoldBlockType = cfbtSlashComment then EndPascalCodeFoldBlockLastLine; end; if FTokenID = tkUnknown then Next; end; procedure TSynPasSyn.SpaceProc; begin inc(Run); fTokenID := tkSpace; while IsSpaceChar[FLine[Run]] do inc(Run); end; procedure TSynPasSyn.StringProc; begin fTokenID := tkString; Inc(Run); while (not (fLine[Run] in [#0, #10, #13])) do begin if fLine[Run] = '''' then begin Inc(Run); if (fLine[Run] <> '''') then break; end; Inc(Run); end; end; procedure TSynPasSyn.SymbolProc; begin inc(Run); fTokenID := tkSymbol; end; procedure TSynPasSyn.UnknownProc; begin inc(Run); while (fLine[Run] in [#128..#191]) OR // continued utf8 subcode ((fLine[Run]<>#0) and (fProcTable[fLine[Run]] = @UnknownProc)) do inc(Run); fTokenID := tkUnknown; end; procedure TSynPasSyn.Next; var IsAtCaseLabel: Boolean; begin fAsmStart := False; fTokenPos := Run; FTokenIsCaseLabel := False; if Run>=fLineLen then begin NullProc; exit; end; case fLine[Run] of #0: NullProc; #10: LFProc; #13: CRProc; else if rsAnsi in fRange then AnsiProc else if fRange * [rsBor, rsIDEDirective] <> [] then BorProc else if rsDirective in fRange then DirectiveProc else if rsSlash in fRange then SlashContinueProc else begin FOldRange := fRange; //if rsAtEqual in fRange then // fRange := fRange + [rsAfterEqualOrColon] - [rsAtEqual] //else IsAtCaseLabel := rsAtCaseLabel in fRange; fProcTable[fLine[Run]]; if (IsAtCaseLabel) and (rsAtCaseLabel in fRange) then begin FTokenIsCaseLabel := True; if (FTokenID = tkKey) then fRange := fRange - [rsAtCaseLabel]; end; if not (FTokenID in [tkSpace, tkComment, tkIDEDirective, tkDirective]) then begin if (PasCodeFoldRange.BracketNestLevel = 0) and not(rsAtClosingBracket in fRange) then fRange := fRange - [rsAfterClass]; fRange := fRange - (FOldRange * [rsAfterEqualOrColon, rsAtPropertyOrReadWrite, rsAfterClassField]) - [rsAtClosingBracket, rsAfterIdentifier]; if rsAtClass in fRange then begin if FOldRange * [rsAtClass, rsAfterClass] <> [] then fRange := fRange + [rsAfterClass] - [rsAtClass] else fRange := fRange + [rsAfterClass]; end end else begin fRange := fRange - [rsAtClosingBracket]; if rsAtClass in fRange then fRange := fRange + [rsAfterClass]; end; if FTokenID = tkIdentifier then fRange := fRange + [rsAfterIdentifier]; end end; if FAtLineStart and not(FTokenID in [tkSpace, tkComment, tkIDEDirective]) then FAtLineStart := False; //DebugLn(['TSynPasSyn.Next Run=',Run,' fTokenPos=',fTokenPos,' fLineStr=',fLineStr,' Token=',GetToken]); end; function TSynPasSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; begin case Index of SYN_ATTR_COMMENT: Result := fCommentAttri; SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri; SYN_ATTR_KEYWORD: Result := fKeyAttri; SYN_ATTR_STRING: Result := fStringAttri; SYN_ATTR_WHITESPACE: Result := fSpaceAttri; SYN_ATTR_NUMBER: Result := fNumberAttri; SYN_ATTR_DIRECTIVE: Result := fDirectiveAttri; SYN_ATTR_ASM: Result := fAsmAttri; else Result := nil; end; end; function TSynPasSyn.GetEol: Boolean; begin Result := (fTokenID = tkNull) and (Run >= fLineLen); end; function TSynPasSyn.GetToken: string; var Len: LongInt; begin Len := Run - fTokenPos; SetLength(Result,Len); if Len>0 then System.Move(fLine[fTokenPos],Result[1],Len); end; procedure TSynPasSyn.GetTokenEx(out TokenStart: PChar; out TokenLength: integer); begin TokenLength:=Run-fTokenPos; if TokenLength>0 then begin TokenStart:=@fLine[fTokenPos]; end else begin TokenStart:=nil; end; end; function TSynPasSyn.GetTokenID: TtkTokenKind; begin if not fAsmStart and (fRange * [rsAnsi, rsBor, rsIDEDirective, rsDirective, rsAsm] = [rsAsm]) and not (fTokenId in [tkNull, tkComment, tkIDEDirective, tkSpace, tkDirective]) then Result := tkAsm else Result := fTokenId; end; function TSynPasSyn.GetTokenAttribute: TSynHighlighterAttributes; begin case GetTokenID of tkAsm: Result := fAsmAttri; tkComment: Result := fCommentAttri; tkIDEDirective: begin FCurIDEDirectiveAttri.Assign(FCommentAttri); FCurIDEDirectiveAttri.Merge(FIDEDirectiveAttri); Result := FCurIDEDirectiveAttri; end; tkIdentifier: Result := fIdentifierAttri; tkKey: Result := fKeyAttri; tkNumber: Result := fNumberAttri; tkSpace: Result := fSpaceAttri; tkString: Result := fStringAttri; tkSymbol: Result := fSymbolAttri; tkDirective: Result := fDirectiveAttri; tkUnknown: Result := fSymbolAttri; else Result := nil; end; if FTokenIsCaseLabel and (GetTokenID in [tkIdentifier, tkKey, tkNumber, tkString]) then begin FCurCaseLabelAttri.Assign(Result); FCurCaseLabelAttri.Merge(FCaseLabelAttri); Result := FCurCaseLabelAttri; end; end; function TSynPasSyn.GetTokenKind: integer; begin Result := Ord(GetTokenID); end; function TSynPasSyn.GetTokenPos: Integer; begin Result := fTokenPos; end; function TSynPasSyn.GetRange: Pointer; begin // For speed reasons, we work with fRange instead of CodeFoldRange.RangeType // -> update now CodeFoldRange.RangeType:=Pointer(PtrUInt(Integer(fRange))); // return a fixed copy of the current CodeFoldRange instance Result := inherited GetRange; end; procedure TSynPasSyn.SetRange(Value: Pointer); begin //DebugLn(['TSynPasSyn.SetRange START']); inherited SetRange(Value); CompilerMode := PasCodeFoldRange.Mode; fRange := TRangeStates(Integer(PtrUInt(CodeFoldRange.RangeType))); FSynPasRangeInfo := TSynHighlighterPasRangeList(CurrentRanges).PasRangeInfo[LineIndex-1]; end; procedure TSynPasSyn.StartAtLineIndex(LineNumber: Integer); begin inherited StartAtLineIndex(LineNumber); end; function TSynPasSyn.GetEndOfLineAttribute: TSynHighlighterAttributes; begin if fRange * [rsAnsi, rsBor] <> [] then Result := fCommentAttri else Result := inherited GetEndOfLineAttribute; end; procedure TSynPasSyn.ResetRange; begin fRange := []; FStartCodeFoldBlockLevel:=0; FPasStartLevel := 0; with FSynPasRangeInfo do begin EndLevelIfDef := 0; MinLevelIfDef := 0; EndLevelRegion := 0; MinLevelRegion := 0; end; Inherited ResetRange; CompilerMode:=pcmDelphi; end; procedure TSynPasSyn.EnumUserSettings(settings: TStrings); begin { returns the user settings that exist in the registry } with TRegistry.Create do begin try RootKey := HKEY_LOCAL_MACHINE; {$IFNDEF SYN_LAZARUS} // ToDo Registry if OpenKeyReadOnly('\SOFTWARE\Borland\Delphi') then begin try GetKeyNames(settings); finally CloseKey; end; end; {$ENDIF} finally Free; end; end; end; function TSynPasSyn.IsLineStartingInDirective(ALineIndex: TLineIdx): Boolean; var r: Pointer; begin Result := False; if ALineIndex < 1 then exit; r := CurrentRanges[ALineIndex-1]; if (r <> nil) and (r <> NullRange) then Result := rsDirective in TRangeStates(Integer(PtrUInt(TSynPasSynRange(r).RangeType))); end; function TSynPasSyn.FoldBlockEndLevel(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; var inf: TSynPasRangeInfo; r, r2: Pointer; begin Assert(CurrentRanges <> nil, 'TSynCustomFoldHighlighter.FoldBlockEndLevel requires CurrentRanges'); Result := 0; if (ALineIndex < 0) or (ALineIndex >= CurrentLines.Count - 1) then exit; if AFilter.FoldGroup in [0, FOLDGROUP_REGION, FOLDGROUP_IFDEF] then inf := TSynHighlighterPasRangeList(CurrentRanges).PasRangeInfo[ALineIndex]; if AFilter.FoldGroup in [0, FOLDGROUP_PASCAL] then begin // All or Pascal r := CurrentRanges[ALineIndex]; if (r <> nil) and (r <> NullRange) then begin r2 := TSynPasSynRange(CurrentRanges[ALineIndex + 1]); if sfbIncludeDisabled in AFilter.Flags then begin Result := TSynPasSynRange(r).CodeFoldStackSize; if (r2 <> nil) and (r2 <> NullRange) then Result := Result + TSynPasSynRange(r2).LastLineCodeFoldLevelFix; end else begin Result := TSynPasSynRange(r).PasFoldEndLevel; if (r2 <> nil) and (r2 <> NullRange) then Result := Result + TSynPasSynRange(r2).PasFoldFixLevel; end; end; end; if AFilter.FoldGroup in [0, FOLDGROUP_REGION] then begin // All or REGION if FFoldConfig[ord(cfbtRegion)].Enabled or (sfbIncludeDisabled in AFilter.Flags) then Result := Result + inf.EndLevelRegion; end; if AFilter.FoldGroup in [0, FOLDGROUP_IFDEF] then begin // All or IFDEF if FFoldConfig[ord(cfbtIfDef)].Enabled or (sfbIncludeDisabled in AFilter.Flags) then Result := Result + inf.EndLevelIfDef; end; end; function TSynPasSyn.FoldBlockMinLevel(ALineIndex: TLineIdx; const AFilter: TSynFoldBlockFilter): integer; var inf: TSynPasRangeInfo; r, r2: Pointer; begin Assert(CurrentRanges <> nil, 'TSynCustomFoldHighlighter.FoldBlockMinLevel requires CurrentRanges'); Result := 0; if (ALineIndex < 0) or (ALineIndex >= CurrentLines.Count - 1) then exit; if AFilter.FoldGroup in [0, FOLDGROUP_REGION, FOLDGROUP_IFDEF] then inf := TSynHighlighterPasRangeList(CurrentRanges).PasRangeInfo[ALineIndex]; if AFilter.FoldGroup in [0, FOLDGROUP_PASCAL] then begin // All or Pascal (* Range.EndLevel can be smaller. because Range.MinLevel does not know the LastLineFix Using a copy of FoldBlockEndLevel *) r := CurrentRanges[ALineIndex]; if (r <> nil) and (r <> NullRange) then begin r2 := TSynPasSynRange(CurrentRanges[ALineIndex + 1]); if sfbIncludeDisabled in AFilter.Flags then begin Result := TSynPasSynRange(r).CodeFoldStackSize; if (r2 <> nil) and (r2 <> NullRange) then Result := Result + TSynPasSynRange(r2).LastLineCodeFoldLevelFix; // now Result = FoldBlockEndLevel Result := Min(Result, TSynPasSynRange(r).MinimumCodeFoldBlockLevel); end else begin Result := TSynPasSynRange(r).PasFoldEndLevel; if (r2 <> nil) and (r2 <> NullRange) then Result := Result + TSynPasSynRange(r2).PasFoldFixLevel; // now Result = FoldBlockEndLevel Result := Min(Result, TSynPasSynRange(r).PasFoldMinLevel); end; end; end; if AFilter.FoldGroup in [0, FOLDGROUP_REGION] then begin // All or REGION Result := Result + inf.MinLevelRegion; end; if AFilter.FoldGroup in [0, FOLDGROUP_IFDEF] then begin // All or IFDEF Result := Result + inf.MinLevelIfDef; end; end; function TSynPasSyn.FoldBlockNestedTypes(ALineIndex: TLineIdx; ANestIndex: Integer; out AType: Pointer; const AFilter: TSynFoldBlockFilter): boolean; var r, r2: Pointer; c: Integer; Fold: TSynCustomCodeFoldBlock; begin Result := false; if (ALineIndex < 0) or (ALineIndex >= CurrentLines.Count - 1) then exit; if ANestIndex < 0 then exit; if AFilter.FoldGroup = FOLDGROUP_PASCAL then begin if AFilter.Flags = [] then begin r := CurrentRanges[ALineIndex]; if (r <> nil) and (r <> NullRange) then begin r2 := TSynPasSynRange(CurrentRanges[ALineIndex + 1]); c := TSynPasSynRange(r).PasFoldEndLevel; if (r2 <> nil) and (r2 <> NullRange) then c := c + TSynPasSynRange(r2).PasFoldFixLevel; if ANestIndex < c then begin c := TSynPasSynRange(r).CodeFoldStackSize - 1 - ANestIndex; Fold := TSynPasSynRange(r).Top; while (Fold <> nil) and ( (c > 0) or (Fold.BlockType >= CountPascalCodeFoldBlockOffset) ) do begin if (Fold.BlockType < CountPascalCodeFoldBlockOffset) then dec(c); Fold := Fold.Parent; end; if Fold <> nil then begin AType := Fold.BlockType; if AType >= CountPascalCodeFoldBlockOffset then AType := AType - PtrUInt(CountPascalCodeFoldBlockOffset); Result := True; end; end; end; end; if AFilter.Flags = [sfbIncludeDisabled] then begin r := CurrentRanges[ALineIndex]; if (r <> nil) and (r <> NullRange) then begin r2 := TSynPasSynRange(CurrentRanges[ALineIndex + 1]); c := TSynPasSynRange(r).CodeFoldStackSize; if (r2 <> nil) and (r2 <> NullRange) then c := c + TSynPasSynRange(r2).LastLineCodeFoldLevelFix; if ANestIndex < c then begin c := TSynPasSynRange(r).CodeFoldStackSize - 1 - ANestIndex; Fold := TSynPasSynRange(r).Top; while (Fold <> nil) and (c > 0) do begin Fold := Fold.Parent; dec(c); end; if Fold <> nil then begin AType := Fold.BlockType; if AType >= CountPascalCodeFoldBlockOffset then AType := AType - PtrUInt(CountPascalCodeFoldBlockOffset); Result := True; end; end; end; end; end; end; function TSynPasSyn.TopPascalCodeFoldBlockType(DownIndex: Integer = 0): TPascalCodeFoldBlockType; var p: Pointer; begin p := TopCodeFoldBlockType(DownIndex); if p >= CountPascalCodeFoldBlockOffset then p := p - PtrUInt(CountPascalCodeFoldBlockOffset); Result := TPascalCodeFoldBlockType(PtrUInt(p)); end; function TSynPasSyn.FoldTypeCount: integer; begin Result := 3; end; function TSynPasSyn.FoldTypeAtNodeIndex(ALineIndex, FoldIndex: Integer; UseCloseNodes: boolean): integer; var act: TSynFoldActions; begin act := [sfaOpenFold, sfaFold]; if UseCloseNodes then act := [sfaCloseFold, sfaFold]; case TPascalCodeFoldBlockType(PtrUInt(FoldNodeInfo[ALineIndex].NodeInfoEx(FoldIndex, act).FoldType)) of cfbtRegion: Result := 2; cfbtIfDef: Result := 3; else Result := 1; end; end; function TSynPasSyn.FoldLineLength(ALineIndex, FoldIndex: Integer): integer; var atype : Integer; node: TSynFoldNodeInfo; begin node := FoldNodeInfo[ALineIndex].NodeInfoEx(FoldIndex, [sfaOpenFold, sfaFold]); if sfaInvalid in node.FoldAction then exit(-1); if sfaOneLineOpen in node.FoldAction then exit(0); case TPascalCodeFoldBlockType(PtrUInt(node.FoldType)) of cfbtRegion: atype := 2; cfbtIfDef: atype := 3; else atype := 1; end; Result := FoldEndLine(ALineIndex, FoldIndex); // check if fold last line of block (not mixed "end begin") if (FoldBlockEndLevel(Result, atype) > FoldBlockMinLevel(Result, atype)) then dec(Result); // Amount of lines, that will become invisible (excludes the cfCollapsed line) Result := Result - ALineIndex; end; function TSynPasSyn.FoldEndLine(ALineIndex, FoldIndex: Integer): integer; var lvl, cnt, atype : Integer; node: TSynFoldNodeInfo; begin node := FoldNodeInfo[ALineIndex].NodeInfoEx(FoldIndex, [sfaOpenFold, sfaFold]); if sfaInvalid in node.FoldAction then exit(-1); if sfaOneLineOpen in node.FoldAction then exit(ALineIndex); case TPascalCodeFoldBlockType(PtrUInt(node.FoldType)) of cfbtRegion: atype := 2; cfbtIfDef: atype := 3; else atype := 1; end; cnt := CurrentLines.Count; lvl := node.FoldLvlEnd; Result := ALineIndex + 1; while (Result < cnt) and (FoldBlockMinLevel(Result, atype) >= lvl) do inc(Result); // check if fold last line of block (not mixed "end begin") // and not lastlinefix if (Result = cnt) then dec(Result); end; function TSynPasSyn.LastLinePasFoldLevelFix(Index: Integer; AType: Integer; AIncludeDisabled: Boolean): integer; var r: TSynPasSynRange; begin // AIncludeDisabled only works for Pascal Nodes case AType of 2: Result := 0; 3: Result := 0; else begin if (Index < 0) or (Index >= CurrentLines.Count) then exit(0); r := TSynPasSynRange(CurrentRanges[Index]); if (r <> nil) and (Pointer(r) <> NullRange) then begin if AIncludeDisabled then Result := r.LastLineCodeFoldLevelFix // all pascal nodes (incl. not folded) else Result := r.PasFoldFixLevel end else Result := 0; end; end; end; procedure TSynPasSyn.InitNode(out Node: TSynFoldNodeInfo; EndOffs: Integer; ABlockType: TPascalCodeFoldBlockType; aActions: TSynFoldActions; AIsFold: Boolean); var OneLine: Boolean; i: Integer; nd: PSynFoldNodeInfo; begin aActions := aActions + [sfaMultiLine]; Node.LineIndex := LineIndex; Node.LogXStart := Run; Node.LogXEnd := Run + fStringLen; Node.FoldType := Pointer(PtrInt(ABlockType)); Node.FoldTypeCompatible := Pointer(PtrInt(PascalFoldTypeCompatibility[ABlockType])); Node.FoldAction := aActions; case ABlockType of cfbtRegion: begin node.FoldGroup := FOLDGROUP_REGION; if AIsFold then Node.FoldLvlStart := FSynPasRangeInfo.EndLevelRegion else Node.FoldLvlStart := 0; Node.NestLvlStart := FSynPasRangeInfo.EndLevelRegion; OneLine := (EndOffs < 0) and (Node.FoldLvlStart > FSynPasRangeInfo.MinLevelRegion); end; cfbtIfDef: begin node.FoldGroup := FOLDGROUP_IFDEF; if AIsFold then Node.FoldLvlStart := FSynPasRangeInfo.EndLevelIfDef else Node.FoldLvlStart := 0; Node.NestLvlStart := FSynPasRangeInfo.EndLevelIfDef; OneLine := (EndOffs < 0) and (Node.FoldLvlStart > FSynPasRangeInfo.MinLevelIfDef); end; else begin node.FoldGroup := FOLDGROUP_PASCAL; if AIsFold then begin Node.FoldLvlStart := PasCodeFoldRange.PasFoldEndLevel; Node.NestLvlStart := PasCodeFoldRange.CodeFoldStackSize; OneLine := (EndOffs < 0) and (Node.FoldLvlStart > PasCodeFoldRange.PasFoldMinLevel); // MinimumCodeFoldBlockLevel); end else begin Node.FoldLvlStart := PasCodeFoldRange.CodeFoldStackSize; // Todo: zero? Node.NestLvlStart := PasCodeFoldRange.CodeFoldStackSize; OneLine := (EndOffs < 0) and (Node.FoldLvlStart > PasCodeFoldRange.MinimumCodeFoldBlockLevel); end; end; end; Node.NestLvlEnd := Node.NestLvlStart + EndOffs; if not (sfaFold in aActions) then EndOffs := 0; Node.FoldLvlEnd := Node.FoldLvlStart + EndOffs; if OneLine then begin // find opening node i := FCatchNodeInfoList.CountAll - 1; nd := FCatchNodeInfoList.ItemPointer[i]; while (i >= 0) and ( (nd^.FoldType <> node.FoldType) or (nd^.FoldGroup <> node.FoldGroup) or (not (sfaOpenFold in nd^.FoldAction)) or (nd^.FoldLvlEnd <> Node.FoldLvlStart) ) do begin dec(i); nd := FCatchNodeInfoList.ItemPointer[i]; end; if i >= 0 then begin nd^.FoldAction := nd^.FoldAction + [sfaOneLineOpen, sfaSingleLine] - [sfaMultiLine]; Node.FoldAction := Node.FoldAction + [sfaOneLineClose, sfaSingleLine] - [sfaMultiLine]; if (sfaFoldHide in nd^.FoldAction) then begin assert(sfaFold in nd^.FoldAction, 'sfaFoldHide without sfaFold'); // one liner: hide-able / not fold-able nd^.FoldAction := nd^.FoldAction - [sfaFoldFold]; Node.FoldAction := Node.FoldAction - [sfaFoldFold]; end else begin // one liner: nether hide-able nore fold-able nd^.FoldAction := nd^.FoldAction - [sfaOpenFold, sfaFold, sfaFoldFold]; Node.FoldAction := Node.FoldAction - [sfaCloseFold, sfaFold, sfaFoldFold]; end; end; end; end; procedure TSynPasSyn.StartCustomCodeFoldBlock(ABlockType: TPascalCodeFoldBlockType); var act: TSynFoldActions; nd: TSynFoldNodeInfo; FoldBlock, BlockEnabled: Boolean; begin BlockEnabled := FFoldConfig[ord(ABlockType)].Enabled; FoldBlock := BlockEnabled and (FFoldConfig[ord(ABlockType)].Modes * [fmFold, fmHide] <> []); //if not FFoldConfig[ord(ABlockType)].Enabled then exit; if FCatchNodeInfo then begin // exclude subblocks, because they do not increase the foldlevel yet act := [sfaOpen, sfaOpenFold]; if BlockEnabled then act := act + FFoldConfig[ord(ABlockType)].FoldActions; if not FAtLineStart then act := act - [sfaFoldHide]; InitNode(nd, +1, ABlockType, act, FoldBlock); FCatchNodeInfoList.Add(nd); end; //if not FoldBlock then // exit; case ABlockType of cfbtIfDef: inc(FSynPasRangeInfo.EndLevelIfDef); cfbtRegion: inc(FSynPasRangeInfo.EndLevelRegion); end; end; procedure TSynPasSyn.EndCustomCodeFoldBlock(ABlockType: TPascalCodeFoldBlockType); var act: TSynFoldActions; nd: TSynFoldNodeInfo; FoldBlock, BlockEnabled: Boolean; begin FoldBlock := FFoldConfig[ord(ABlockType)].Enabled; //if not FFoldConfig[ord(ABlockType)].Enabled then exit; if FCatchNodeInfo then begin // exclude subblocks, because they do not increase the foldlevel yet BlockEnabled := FFoldConfig[ord(ABlockType)].Enabled; act := [sfaClose, sfaCloseFold]; if BlockEnabled then act := act + FFoldConfig[PtrUInt(ABlockType)].FoldActions; if not FoldBlock then act := act - [sfaFold, sfaFoldFold, sfaFoldHide]; InitNode(nd, -1, ABlockType, act, FoldBlock); // + FFoldConfig[ord(ABlockType)].FoldActions); FCatchNodeInfoList.Add(nd); end; //if not FoldBlock then // exit; case ABlockType of cfbtIfDef: begin if FSynPasRangeInfo.EndLevelIfDef > 0 then dec(FSynPasRangeInfo.EndLevelIfDef); if FSynPasRangeInfo.EndLevelIfDef < FSynPasRangeInfo.MinLevelIfDef then FSynPasRangeInfo.MinLevelIfDef := FSynPasRangeInfo.EndLevelIfDef; end; cfbtRegion: begin if FSynPasRangeInfo.EndLevelRegion > 0 then dec(FSynPasRangeInfo.EndLevelRegion); if FSynPasRangeInfo.EndLevelRegion < FSynPasRangeInfo.MinLevelRegion then FSynPasRangeInfo.MinLevelRegion := FSynPasRangeInfo.EndLevelRegion; end; end; end; function TSynPasSyn.CreateFoldNodeInfoList: TLazSynFoldNodeInfoList; begin Result := TLazSynFoldNodeInfoList.Create; end; procedure TSynPasSyn.InitFoldNodeInfo(AList: TLazSynFoldNodeInfoList; Line: TLineIdx); var nd: PSynFoldNodeInfo; i: Integer; begin FCatchNodeInfo := True; FCatchNodeInfoList := TLazSynFoldNodeInfoList(AList); StartAtLineIndex(Line); fStringLen := 0; NextToEol; fStringLen := 0; i := LastLinePasFoldLevelFix(Line+1, FOLDGROUP_PASCAL, True); // all pascal nodes (incl. not folded) while i < 0 do begin EndPascalCodeFoldBlock; FCatchNodeInfoList.LastItemPointer^.FoldAction := FCatchNodeInfoList.LastItemPointer^.FoldAction + [sfaCloseForNextLine]; inc(i); end; if Line = CurrentLines.Count - 1 then begin // last line, close all folds // Run (for LogXStart) is at line-end i := FCatchNodeInfoList.CountAll; while TopPascalCodeFoldBlockType <> cfbtNone do EndPascalCodeFoldBlock(True); while FSynPasRangeInfo.EndLevelIfDef > 0 do EndCustomCodeFoldBlock(cfbtIfDef); while FSynPasRangeInfo.EndLevelRegion > 0 do EndCustomCodeFoldBlock(cfbtRegion); while i < FCatchNodeInfoList.CountAll do begin nd := FCatchNodeInfoList.ItemPointer[i]; nd^.FoldAction := nd^.FoldAction + [sfaLastLineClose]; inc(i); end; end; FCatchNodeInfo := False; end; function TSynPasSyn.StartPascalCodeFoldBlock(ABlockType: TPascalCodeFoldBlockType; OnlyEnabled: Boolean): TSynCustomCodeFoldBlock; var p: PtrInt; FoldBlock, BlockEnabled: Boolean; act: TSynFoldActions; nd: TSynFoldNodeInfo; begin BlockEnabled := FFoldConfig[ord(ABlockType)].Enabled; if (not BlockEnabled) and OnlyEnabled then exit; FoldBlock := BlockEnabled and (FFoldConfig[ord(ABlockType)].Modes * [fmFold, fmHide] <> []); p := 0; if FCatchNodeInfo then begin // exclude subblocks, because they do not increase the foldlevel yet act := [sfaOpen, sfaOpenFold]; //TODO: sfaOpenFold not for cfbtIfThen if BlockEnabled then act := act + FFoldConfig[ord(ABlockType)].FoldActions; if not FAtLineStart then act := act - [sfaFoldHide]; InitNode(nd, +1, ABlockType, act, FoldBlock); FCatchNodeInfoList.Add(nd); end; if not FoldBlock then p := PtrInt(CountPascalCodeFoldBlockOffset); Result:=TSynCustomCodeFoldBlock(StartCodeFoldBlock(p+Pointer(PtrInt(ABlockType)), FoldBlock)); end; procedure TSynPasSyn.EndPascalCodeFoldBlock(NoMarkup: Boolean = False); var DecreaseLevel, BlockEnabled: Boolean; act: TSynFoldActions; BlockType: TPascalCodeFoldBlockType; nd: TSynFoldNodeInfo; begin BlockType := TopPascalCodeFoldBlockType; if BlockType in [cfbtVarType, cfbtLocalVarType] then fRange := fRange - [rsInTypeBlock]; fRange := fRange - [rsAfterEqual]; DecreaseLevel := TopCodeFoldBlockType < CountPascalCodeFoldBlockOffset; if FCatchNodeInfo then begin // exclude subblocks, because they do not increase the foldlevel yet BlockEnabled := FFoldConfig[ord(BlockType)].Enabled; act := [sfaClose, sfaCloseFold]; if BlockEnabled then act := act + FFoldConfig[ord(BlockType)].FoldActions - [sfaFoldFold, sfaFoldHide]; // TODO: Why filter? if not DecreaseLevel then act := act - [sfaFold, sfaFoldFold, sfaFoldHide]; if NoMarkup then exclude(act, sfaMarkup); InitNode(nd, -1, BlockType, act, DecreaseLevel); FCatchNodeInfoList.Add(nd); end; EndCodeFoldBlock(DecreaseLevel); end; procedure TSynPasSyn.CloseBeginEndBlocksBeforeProc; begin if not(TopPascalCodeFoldBlockType in PascalStatementBlocks + [cfbtAsm]) then exit; while TopPascalCodeFoldBlockType in PascalStatementBlocks + [cfbtAsm] do EndPascalCodeFoldBlockLastLine; if TopPascalCodeFoldBlockType = cfbtProcedure then EndPascalCodeFoldBlockLastLine; // This procedure did have a begin/end block, so it must end too end; procedure TSynPasSyn.SmartCloseBeginEndBlocks(SearchFor: TPascalCodeFoldBlockType); var i: Integer; t: TPascalCodeFoldBlockType; begin // Close unfinished blocks, IF the expected type is found // Only check a limited deep. Otherwhise assume, that the "SearchFor"-End node may be misplaced i := 0; while (i <= 2) do begin t := TopPascalCodeFoldBlockType(i); if not (t in PascalStatementBlocks + [cfbtAsm, SearchFor]) then exit; if (t = SearchFor) then break; inc(i); end; if i > 2 then exit; while i > 0 do begin EndPascalCodeFoldBlockLastLine; // Todo: FCatchNodeInfoList.CountAll > nc can not happen //if FCatchNodeInfo and (FCatchNodeInfoList.CountAll > FCatchNodeInfoList.CountAll) then // exclude(FCatchNodeInfoList.LastItemPointer^.FoldAction, sfaMarkup); dec(i); end; end; procedure TSynPasSyn.EndPascalCodeFoldBlockLastLine; var i: Integer; nd: PSynFoldNodeInfo; begin if FCatchNodeInfo then i := FCatchNodeInfoList.CountAll; EndPascalCodeFoldBlock; if FAtLineStart then begin // If we are not at linestart, new folds could have been opened => handle as normal close if (PasCodeFoldRange.CodeFoldStackSize < FStartCodeFoldBlockLevel) and (FStartCodeFoldBlockLevel > 0) then begin PasCodeFoldRange.DecLastLineCodeFoldLevelFix; dec(FStartCodeFoldBlockLevel); if FCatchNodeInfo then FCatchNodeInfoList.Delete; end; // TODO this only happens if the above was true if (PasCodeFoldRange.PasFoldEndLevel < FPasStartLevel) and (FPasStartLevel > 0) then begin PasCodeFoldRange.DecLastLinePasFoldFix; dec(FPasStartLevel); end; end else if FCatchNodeInfo and (FCatchNodeInfoList.CountAll > i) then begin nd := FCatchNodeInfoList.LastItemPointer; exclude(nd^.FoldAction, sfaMarkup); // not markup able nd^.LogXEnd := 0; end; end; function TSynPasSyn.GetDrawDivider(Index: integer): TSynDividerDrawConfigSetting; function CheckFoldNestLevel(MaxDepth, StartLvl: Integer; CountTypes, SkipTypes: TPascalCodeFoldBlockTypes; out ResultLvl: Integer): Boolean; var i, j, m: Integer; t: TPascalCodeFoldBlockType; begin i := 0; j := StartLvl; m := PasCodeFoldRange.CodeFoldStackSize;; t := TopPascalCodeFoldBlockType(j); while (i <= MaxDepth) and (j < m) and ((t in CountTypes) or (t in SkipTypes)) do begin inc(j); if t in CountTypes then inc(i); t := TopPascalCodeFoldBlockType(j) end; ResultLvl := i; Result := i <= MaxDepth; end; var cur: TPascalCodeFoldBlockType; CloseCnt, ClosedByNextLine, ClosedInLastLine: Integer; i, top, c: Integer; t: TSynPasDividerDrawLocation; begin Result := inherited; if (index = 0) then exit; CloseCnt := FoldBlockClosingCount(Index, FOLDGROUP_PASCAL, [sfbIncludeDisabled]); if (CloseCnt = 0) or (FoldBlockMinLevel(Index, FOLDGROUP_PASCAL, [sfbIncludeDisabled]) <> FoldBlockEndLevel(Index, FOLDGROUP_PASCAL, [sfbIncludeDisabled])) then // not a mixed line exit; // SetRange[Index] has the folds at the start of this line // ClosedByNextLine: Folds closed by the next lines LastLineFix // must be taken from SetRange[Index+1] (end of this line) ClosedByNextLine := -LastLinePasFoldLevelFix(Index + 1, FOLDGROUP_PASCAL, True); // ClosedInLastLine: Folds Closed by this lines LastLineFix // must be ignored. (They are part of SetRange[Index] / this line) ClosedInLastLine := -LastLinePasFoldLevelFix(Index, FOLDGROUP_PASCAL, True); // Get the highest close-offset i := ClosedByNextLine - 1; if i >= 0 then begin SetRange(CurrentRanges[Index]); // Checking ClosedByNextLine top := 0; end else begin SetRange(CurrentRanges[Index - 1]); // Checking Closed in this Line i := CloseCnt - ClosedByNextLine + ClosedInLastLine - 1; top := ClosedInLastLine; end; cur := TopPascalCodeFoldBlockType(i + 1); while (i >= top) do begin //nxt := cur; // The "next higher" close node compared to current cur := TopPascalCodeFoldBlockType(i); Result := FDividerDrawConfig[pddlUses].TopSetting; //// xxxx case cur of cfbtUnitSection: if FDividerDrawConfig[pddlUnitSection].MaxDrawDepth > 0 then exit(FDividerDrawConfig[pddlUnitSection].TopSetting); cfbtUses: if FDividerDrawConfig[pddlUses].MaxDrawDepth > 0 then exit(FDividerDrawConfig[pddlUses].TopSetting); cfbtLocalVarType: if CheckFoldNestLevel(FDividerDrawConfig[pddlVarLocal].MaxDrawDepth - 1, i + 2, [cfbtProcedure], cfbtAll, c) then begin if c = 0 then exit(FDividerDrawConfig[pddlVarLocal].TopSetting) else exit(FDividerDrawConfig[pddlVarLocal].NestSetting); end; cfbtVarType: if FDividerDrawConfig[pddlVarGlobal].MaxDrawDepth > 0 then exit(FDividerDrawConfig[pddlVarGlobal].TopSetting); cfbtClass, cfbtRecord: begin if CheckFoldNestLevel(0, i + 1, [cfbtProcedure], cfbtAll - [cfbtVarType, cfbtLocalVarType], c) then t := pddlStructGlobal else t := pddlStructLocal; if CheckFoldNestLevel(FDividerDrawConfig[t].MaxDrawDepth - 1, i + 1, [cfbtClass, cfbtRecord], cfbtAll - [cfbtVarType, cfbtLocalVarType], c) then begin if c = 0 then exit(FDividerDrawConfig[t].TopSetting) else exit(FDividerDrawConfig[t].NestSetting); end; end; cfbtProcedure: if CheckFoldNestLevel(FDividerDrawConfig[pddlProcedure].MaxDrawDepth - 1, i + 1, [cfbtProcedure], cfbtAll, c) then begin if c = 0 then exit(FDividerDrawConfig[pddlProcedure].TopSetting) else exit(FDividerDrawConfig[pddlProcedure].NestSetting); end; cfbtTopBeginEnd: if FDividerDrawConfig[pddlBeginEnd].MaxDrawDepth > 0 then exit(FDividerDrawConfig[pddlBeginEnd].TopSetting); cfbtBeginEnd, cfbtRepeat, cfbtCase, cfbtAsm: if CheckFoldNestLevel(FDividerDrawConfig[pddlBeginEnd].MaxDrawDepth - 2, i + 1, [cfbtBeginEnd, cfbtRepeat, cfbtCase, cfbtAsm], cfbtAll - [cfbtProcedure, cfbtTopBeginEnd], c) then exit(FDividerDrawConfig[pddlBeginEnd].NestSetting); cfbtTry: if CheckFoldNestLevel(FDividerDrawConfig[pddlTry].MaxDrawDepth - 1, i + 1, [cfbtTry], cfbtAll - [cfbtProcedure], c) then begin if c = 0 then exit(FDividerDrawConfig[pddlTry].TopSetting) else exit(FDividerDrawConfig[pddlTry].NestSetting); end; end; dec(i); if (i < top) and (ClosedByNextLine > 0) then begin // Switch to blocks closed in this line SetRange(CurrentRanges[Index - 1]); i := CloseCnt - ClosedByNextLine + ClosedInLastLine - 1; ClosedByNextLine := 0; top := ClosedInLastLine; cur := TopPascalCodeFoldBlockType(i + 1); end; end; Result := inherited; end; procedure TSynPasSyn.CreateDividerDrawConfig; var i: TSynPasDividerDrawLocation; begin for i := low(TSynPasDividerDrawLocation) to high(TSynPasDividerDrawLocation) do begin FDividerDrawConfig[i] := TSynDividerDrawConfig.Create; FDividerDrawConfig[i].OnChange := @DefHighlightChange; FDividerDrawConfig[i].MaxDrawDepth := PasDividerDrawLocationDefaults[i]; end; end; procedure TSynPasSyn.DestroyDividerDrawConfig; var i: TSynPasDividerDrawLocation; begin for i := low(TSynPasDividerDrawLocation) to high(TSynPasDividerDrawLocation) do FreeAndNil(FDividerDrawConfig[i]); end; function TSynPasSyn.GetFoldConfigInstance(Index: Integer): TSynCustomFoldConfig; var m: TSynCustomFoldConfigModes; begin Result := inherited GetFoldConfigInstance(Index); Result.Enabled := TPascalCodeFoldBlockType(Index) in [cfbtBeginEnd..cfbtIfThen]; m := []; if TPascalCodeFoldBlockType(Index) in PascalWordTripletRanges then m := [fmMarkup]; case TPascalCodeFoldBlockType(Index) of cfbtRegion, cfbtNestedComment, cfbtAnsiComment, cfbtBorCommand, cfbtSlashComment: Result.SupportedModes := [fmFold, fmHide] + m; cfbtIfThen: Result.SupportedModes := m; cfbtFirstPrivate..high(TPascalCodeFoldBlockType): Result.SupportedModes := []; else Result.SupportedModes := [fmFold] + m; end; if (TPascalCodeFoldBlockType(Index) in [cfbtIfThen]) then m := []; if TPascalCodeFoldBlockType(Index) in [cfbtSlashComment] then Result.Modes := [fmFold, fmHide] + m else Result.Modes := [fmFold] + m; end; function TSynPasSyn.CreateRangeList(ALines: TSynEditStringsBase): TSynHighlighterRangeList; begin Result := TSynHighlighterPasRangeList.Create; end; function TSynPasSyn.UpdateRangeInfoAtLine(Index: Integer): Boolean; var r: TSynPasRangeInfo; begin Result := inherited; r := TSynHighlighterPasRangeList(CurrentRanges).PasRangeInfo[Index]; Result := Result or (FSynPasRangeInfo.EndLevelIfDef <> r.EndLevelIfDef) or (FSynPasRangeInfo.MinLevelIfDef <> r.MinLevelIfDef) or (FSynPasRangeInfo.EndLevelRegion <> r.EndLevelRegion) or (FSynPasRangeInfo.MinLevelRegion <> r.MinLevelRegion); TSynHighlighterPasRangeList(CurrentRanges).PasRangeInfo[Index] := FSynPasRangeInfo; end; function TSynPasSyn.GetFoldConfigCount: Integer; begin // excluded cfbtNone; Result := ord(high(TPascalCodeFoldBlockType)) - ord(low(TPascalCodeFoldBlockType)) - 1; end; function TSynPasSyn.GetFoldConfigInternalCount: Integer; begin // include cfbtNone; Result := ord(high(TPascalCodeFoldBlockType)) - ord(low(TPascalCodeFoldBlockType)) + 1; end; procedure TSynPasSyn.DoFoldConfigChanged(Sender: TObject); begin inherited DoFoldConfigChanged(Sender); end; function TSynPasSyn.GetDividerDrawConfig(Index: Integer): TSynDividerDrawConfig; begin Result := FDividerDrawConfig[TSynPasDividerDrawLocation(Index)]; end; function TSynPasSyn.GetDividerDrawConfigCount: Integer; begin Result := ord(high(TSynPasDividerDrawLocation)) - ord(low(TSynPasDividerDrawLocation)) + 1; end; function TSynPasSyn.GetRangeClass: TSynCustomHighlighterRangeClass; begin Result:=TSynPasSynRange; end; function TSynPasSyn.UseUserSettings(settingIndex: integer): boolean; // Possible parameter values: // index into TStrings returned by EnumUserSettings // Possible return values: // true : settings were read and used // false: problem reading settings or invalid version specified - old settings // were preserved function ReadDelphiSettings(settingIndex: integer): boolean; function ReadDelphiSetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean; function ReadDelphi2Or3(settingTag: string; attri: TSynHighlighterAttributes; name: string): boolean; var i: integer; begin for i := 1 to Length(name) do if name[i] = ' ' then name[i] := '_'; Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER, '\Software\Borland\Delphi\'+settingTag+'\Highlight',name,true); end; { ReadDelphi2Or3 } function ReadDelphi4OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean; begin Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER, '\Software\Borland\Delphi\'+settingTag+'\Editor\Highlight', key,false); end; { ReadDelphi4OrMore } begin { ReadDelphiSetting } try if (settingTag[1] = '2') or (settingTag[1] = '3') then Result := ReadDelphi2Or3(settingTag,attri,key) else Result := ReadDelphi4OrMore(settingTag,attri,key); except Result := false; end; end; { ReadDelphiSetting } var tmpStringAttri : TSynHighlighterAttributes; tmpNumberAttri : TSynHighlighterAttributes; tmpKeyAttri : TSynHighlighterAttributes; tmpSymbolAttri : TSynHighlighterAttributes; tmpAsmAttri : TSynHighlighterAttributes; tmpCommentAttri : TSynHighlighterAttributes; tmpDirectiveAttri : TSynHighlighterAttributes; tmpIdentifierAttri: TSynHighlighterAttributes; tmpSpaceAttri : TSynHighlighterAttributes; s : TStringList; begin { ReadDelphiSettings } s := TStringList.Create; try EnumUserSettings(s); if (settingIndex < 0) or (settingIndex >= s.Count) then Result := false else begin tmpStringAttri := TSynHighlighterAttributes.Create(nil); tmpNumberAttri := TSynHighlighterAttributes.Create(nil); tmpKeyAttri := TSynHighlighterAttributes.Create(nil); tmpSymbolAttri := TSynHighlighterAttributes.Create(nil); tmpAsmAttri := TSynHighlighterAttributes.Create(nil); tmpCommentAttri := TSynHighlighterAttributes.Create(nil); tmpDirectiveAttri := TSynHighlighterAttributes.Create(nil); tmpIdentifierAttri:= TSynHighlighterAttributes.Create(nil); tmpSpaceAttri := TSynHighlighterAttributes.Create(nil); tmpStringAttri .Assign(fStringAttri); tmpNumberAttri .Assign(fNumberAttri); tmpKeyAttri .Assign(fKeyAttri); tmpSymbolAttri .Assign(fSymbolAttri); tmpAsmAttri .Assign(fAsmAttri); tmpCommentAttri .Assign(fCommentAttri); tmpDirectiveAttri .Assign(fDirectiveAttri); tmpIdentifierAttri.Assign(fIdentifierAttri); tmpSpaceAttri .Assign(fSpaceAttri); Result := ReadDelphiSetting(s[settingIndex],fAsmAttri,'Assembler') and ReadDelphiSetting(s[settingIndex],fCommentAttri,'Comment') and ReadDelphiSetting(s[settingIndex],fDirectiveAttri,'Directive') and ReadDelphiSetting(s[settingIndex],fIdentifierAttri,'Identifier') and ReadDelphiSetting(s[settingIndex],fKeyAttri,'Reserved word') and ReadDelphiSetting(s[settingIndex],fNumberAttri,'Number') and ReadDelphiSetting(s[settingIndex],fSpaceAttri,'Whitespace') and ReadDelphiSetting(s[settingIndex],fStringAttri,'string') and ReadDelphiSetting(s[settingIndex],fSymbolAttri,'Symbol'); if not Result then begin fStringAttri .Assign(tmpStringAttri); fNumberAttri .Assign(tmpNumberAttri); fKeyAttri .Assign(tmpKeyAttri); fSymbolAttri .Assign(tmpSymbolAttri); fAsmAttri .Assign(tmpAsmAttri); fCommentAttri .Assign(tmpCommentAttri); FIDEDirectiveAttri.Assign(tmpCommentAttri); fDirectiveAttri .Assign(tmpDirectiveAttri); fIdentifierAttri.Assign(tmpIdentifierAttri); fSpaceAttri .Assign(tmpSpaceAttri); end; tmpStringAttri .Free; tmpNumberAttri .Free; tmpKeyAttri .Free; tmpSymbolAttri .Free; tmpAsmAttri .Free; tmpCommentAttri .Free; tmpDirectiveAttri .Free; tmpIdentifierAttri.Free; tmpSpaceAttri .Free; end; finally s.Free; end; end; { ReadDelphiSettings } begin Result := ReadDelphiSettings(settingIndex); end; { TSynPasSyn.UseUserSettings } function TSynPasSyn.GetIdentChars: TSynIdentChars; begin Result := ['_', '0'..'9', 'a'..'z', 'A'..'Z']; end; class function TSynPasSyn.GetLanguageName: string; begin Result := SYNS_LangPascal; end; class function TSynPasSyn.GetCapabilities: TSynHighlighterCapabilities; begin Result := inherited GetCapabilities + [hcUserSettings]; end; {begin} //mh 2000-10-08 function TSynPasSyn.IsFilterStored: boolean; begin Result := fDefaultFilter <> SYNS_FilterPascal; end; procedure TSynPasSyn.CreateRootCodeFoldBlock; begin inherited; RootCodeFoldBlock.InitRootBlockType(Pointer(PtrInt(cfbtNone))); end; function TSynPasSyn.IsKeyword(const AKeyword: string): boolean; // returns true for some common keywords // Note: this words are not always keywords (e.g. end), and some keywords are // not listed here at all (e.g. static) var i: integer; m: TPascalCompilerMode; begin if KeywordsList = nil then begin KeywordsList := TStringList.Create; for i := 1 to High(RESERVED_WORDS_TP) do KeywordsList.AddObject(RESERVED_WORDS_TP[i], TObject(pcmTP)); for i := 1 to High(RESERVED_WORDS_DELPHI) do KeywordsList.AddObject(RESERVED_WORDS_DELPHI[i], TObject(pcmDelphi)); for i := 1 to High(RESERVED_WORDS_FPC) do KeywordsList.AddObject(RESERVED_WORDS_FPC[i], TObject(pcmFPC)); KeywordsList.Sorted := true; end; Result := KeywordsList.Find(LowerCase(AKeyword), i); if not Result then exit; m := TPascalCompilerMode(PtrUInt(KeywordsList.Objects[i])); case FCompilerMode of pcmFPC, pcmObjFPC: ; pcmDelphi: Result := m in [pcmTP, pcmDelphi]; else Result := m = pcmTP; end; end; {end} //mh 2000-10-08 procedure TSynPasSyn.SetD4syntax(const Value: boolean); begin FD4syntax := Value; end; { TSynFreePascalSyn } constructor TSynFreePascalSyn.Create(AOwner: TComponent); begin inherited Create(AOwner); CompilerMode:=pcmObjFPC; end; procedure TSynFreePascalSyn.ResetRange; begin inherited ResetRange; CompilerMode:=pcmObjFPC; end; { TSynPasSynRange } procedure TSynPasSynRange.Clear; begin inherited Clear; FBracketNestLevel := 0; FLastLineCodeFoldLevelFix := 0; FPasFoldEndLevel := 0; FPasFoldFixLevel := 0; FPasFoldMinLevel := 0; end; function TSynPasSynRange.Compare(Range: TSynCustomHighlighterRange): integer; begin Result:=inherited Compare(Range); if Result<>0 then exit; Result:=ord(FMode)-ord(TSynPasSynRange(Range).FMode); if Result<>0 then exit; Result := FBracketNestLevel - TSynPasSynRange(Range).FBracketNestLevel; if Result<>0 then exit; Result := FLastLineCodeFoldLevelFix - TSynPasSynRange(Range).FLastLineCodeFoldLevelFix; if Result<>0 then exit; Result := FPasFoldEndLevel - TSynPasSynRange(Range).FPasFoldEndLevel; if Result<>0 then exit; Result := FPasFoldMinLevel - TSynPasSynRange(Range).FPasFoldMinLevel; if Result<>0 then exit; Result := FPasFoldFixLevel - TSynPasSynRange(Range).FPasFoldFixLevel; end; procedure TSynPasSynRange.Assign(Src: TSynCustomHighlighterRange); begin if (Src<>nil) and (Src<>TSynCustomHighlighterRange(NullRange)) then begin inherited Assign(Src); FMode:=TSynPasSynRange(Src).FMode; FBracketNestLevel:=TSynPasSynRange(Src).FBracketNestLevel; FLastLineCodeFoldLevelFix := TSynPasSynRange(Src).FLastLineCodeFoldLevelFix; FPasFoldEndLevel := TSynPasSynRange(Src).FPasFoldEndLevel; FPasFoldMinLevel := TSynPasSynRange(Src).FPasFoldMinLevel; FPasFoldFixLevel := TSynPasSynRange(Src).FPasFoldFixLevel; end; end; function TSynPasSynRange.Add(ABlockType: Pointer; IncreaseLevel: Boolean): TSynCustomCodeFoldBlock; begin Result := inherited Add(ABlockType, True); if IncreaseLevel and assigned(result) then inc(FPasFoldEndLevel); end; procedure TSynPasSynRange.Pop(DecreaseLevel: Boolean); begin if assigned(Top.Parent) then begin if DecreaseLevel then dec(FPasFoldEndLevel); if FPasFoldMinLevel > FPasFoldEndLevel then FPasFoldMinLevel := FPasFoldEndLevel; end; inherited Pop(True); end; function TSynPasSynRange.MaxFoldLevel: Integer; begin // Protect from overly mem consumption, by too many nested folds Result := 100; end; procedure TSynPasSynRange.IncBracketNestLevel; begin inc(FBracketNestLevel); end; procedure TSynPasSynRange.DecBracketNestLevel; begin dec(FBracketNestLevel); end; procedure TSynPasSynRange.DecLastLineCodeFoldLevelFix; begin dec(FLastLineCodeFoldLevelFix) end; procedure TSynPasSynRange.DecLastLinePasFoldFix; begin dec(FPasFoldFixLevel); end; { TSynHighlighterPasRangeList } function TSynHighlighterPasRangeList.GetTSynPasRangeInfo(Index: Integer): TSynPasRangeInfo; begin if (Index < 0) or (Index >= Count) then begin Result.MinLevelRegion := 0; Result.EndLevelRegion := 0; Result.MinLevelIfDef := 0; Result.EndLevelIfDef := 0; exit; end; Result := TSynPasRangeInfo((ItemPointer[Index] + FItemOffset)^); end; procedure TSynHighlighterPasRangeList.SetTSynPasRangeInfo(Index: Integer; const AValue: TSynPasRangeInfo); begin TSynPasRangeInfo((ItemPointer[Index] + FItemOffset)^) := AValue; end; constructor TSynHighlighterPasRangeList.Create; begin inherited; FItemOffset := ItemSize; ItemSize := FItemOffset + SizeOf(TSynPasRangeInfo); end; initialization MakeIdentTable; RegisterPlaceableHighlighter(TSynPasSyn); finalization FreeAndNil(KeywordsList); end.