Jedi Code Format: Prevent choking on some new and rare language syntax. Issue #39945, patch by Bruno K.

components/jcf2/Parse/BuildParseTree.pas

@@ -61,6 +61,8 @@ type
     fbMadeTree: boolean;
     fiTokenIndex: integer;
 
+    fcIsIncFile: boolean;
+
     fcRoot: TParseTreeNode;
     fcStack: TStack;
     fcTokenList: TSourceTokenList;
@@ -76,6 +78,7 @@ type
     procedure RecogniseProgram;
     procedure RecognisePackage;
     procedure RecogniseLibrary;
+    procedure RecogniseInclude;
 
     procedure RecogniseFileEnd;
 
@@ -164,6 +167,7 @@ type
     procedure RecogniseObjectType;
     procedure RecogniseVariantSection;
     procedure RecogniseVarDecl(aInClassBody:boolean=false);
+    procedure RecogniseVarExpPubDir;
     procedure RecogniseAddOp;
     procedure RecogniseDesignator;
     procedure RecogniseDesignatorTail;
@@ -205,6 +209,7 @@ type
 
     procedure RecogniseFunctionDecl(const pbAnon: boolean);
     procedure RecogniseProcedureDecl(const pbAnon: boolean);
+    procedure RecogniseSquareBracketDir;
     procedure RecogniseConstructorDecl;
     procedure RecogniseDestructorDecl;
 
@@ -287,6 +292,7 @@ type
     procedure BuildParseTree;
     procedure Clear;
 
+    property IsIncFile : boolean Read fcIsIncFile Write fcIsIncFile;
     property Root: TParseTreeNode Read fcRoot;
     property TokenList: TSourceTokenList Read fcTokenList Write fcTokenList;
   end;
@@ -305,6 +311,7 @@ begin
   fcStack := TStack.Create;
   fcRoot  := nil;
   fiTokenCount := 0;
+  AllProcDirectives := ProcedureDirectives + [ttOpenSquareBracket];
 end;
 
 destructor TBuildParseTree.Destroy;
@@ -417,32 +424,30 @@ procedure TBuildParseTree.Recognise(const peTokenTypes: TTokenTypeSet;
   end;
 
 var
-  lcCurrentToken:  TSourceToken;
+  lcToken:  TSourceToken;
 begin
   // must accept something
   Assert(peTokenTypes <> []);
 
   { read tokens up to and including the specified one.
     Add them to the parse tree at the current growing point  }
-  while not fcTokenList.EOF do
-  begin
-    lcCurrentToken := fcTokenList.Extract;
-    CheckNilInstance(lcCurrentToken, fcRoot.LastLeaf);
+  while not fcTokenList.EOF do begin
+    lcToken := fcTokenList.Extract;
+    Assert(lcToken <> nil);
 
-    TopNode.AddChild(lcCurrentToken);
+    TopNode.AddChild(lcToken);
     // the the match must be the first solid token
-    if lcCurrentToken.TokenType in peTokenTypes then
+    if lcToken.TokenType in peTokenTypes then
     begin
       // found it
       Break;
     end
     // accept any white space until we find it
-    else if not (lcCurrentToken.TokenType in NotSolidTokens) then
-      RaiseParseError('Unexpected token, expected ' +
-        DescribeTarget, lcCurrentToken);
+    else if not (lcToken.TokenType in NotSolidTokens) then
+      raise TEParseError.Create('Unexpected token "'+lcToken.SourceCode+ '" , expected ' +
+        DescribeTarget, lcToken);
   end;
   
-  
   Inc(fiTokenCount);
   {$IFnDEF LCLNOGUI}
   if (fiTokenCount mod UPDATE_INTERVAL) = 0 then
@@ -465,6 +470,9 @@ end;
 
 function TBuildParseTree.PushNode(const peNodeType: TParseTreeNodeType): TParseTreeNode;
 begin
+  if peNodeType = nProcedureDirectives then
+    Result := nil;
+
   Result := TParseTreeNode.Create;
   Result.NodeType := peNodeType;
 
@@ -529,10 +537,15 @@ begin
       RecogniseLibrary;
     ttUnit:
       RecogniseUnit;
+    else begin
+      if Self.IsIncFile then
+        RecogniseInclude
   else
-    RaiseParseError('Expected program, package, library, unit, got "' + s + '" ',
+        RaiseParseError('Expected program, package, library, unit, ''.inc'' got "' +
+          s + '" ',
       fcTokenList.FirstSolidToken);
-  end
+end;
+  end;
 end;
 
 procedure TBuildParseTree.RecogniseProgram;
@@ -650,6 +663,16 @@ begin
   PopNode;
 end;
 
+procedure TBuildParseTree.RecogniseInclude;
+begin
+  PushNode(nInclude);
+
+  RecogniseDeclSections;
+  RecogniseFileEnd;
+
+  PopNode;
+end;
+
 procedure TBuildParseTree.RecogniseFileEnd;
 var
   lcCurrentToken: TSourceToken;
@@ -2623,6 +2646,7 @@ const
   VariableModifiers: TTokenTypeSet = [ttExternal, ttExport, ttPublic];
 var
   lc: TSourceToken;
+  lct: TTokenType;
 begin
   // (* attempted EBNF definition of a variable definition *)
   // named : 'name' var_name
@@ -2688,16 +2712,42 @@ begin
       Recognise(ttEquals);
 
       { not just an expr - can be an array, record or the like
-        reuse the code from typed constant declaration as it works the same
-      }
+        reuse the code from typed constant declaration as it works the same }
       RecogniseTypedConstant;
-
       PopNode;
     end;
   end;
 
-  { yes, they can occur here too }
-  RecogniseHintDirectives;
+  { This loop will attempt to recognize HintDirectives and special directives }
+  repeat
+    lct := fcTokenList.FirstSolidTokenType;
+    if lct = ttSemicolon then   // need to look ahead
+      lct := fcTokenList.SolidTokenType(2);
+    if lct in HintDirectives then
+      RecogniseHintDirectives
+    else if lct in [ttExport, ttPublic] then
+      RecogniseVarExpPubDir
+    else
+    break;
+  until False;
+
+  PopNode;
+end;
+
+procedure TBuildParseTree.RecogniseVarExpPubDir;
+var
+  lTokenType : TTokenType;
+begin
+  PushNode(nVarExpPubl);
+
+  Recognise(ttSemicolon); // close previous term
+  { Skip checking anything until ';' }
+  while not fcTokenList.EOF do begin
+    lTokenType := fcTokenList.FirstTokenType;
+    if lTokenType = ttSemicolon then
+  break;
+    Recognise(lTokenType);
+  end;
 
   PopNode;
 end;
@@ -4014,18 +4064,18 @@ end;
 
 function IsForwardExtern(pt: TParseTreeNode): boolean;
 var
-  lcDirectives: TParseTreeNode;
+  lpt: TParseTreeNode;
 begin
   Assert(pt <> nil);
 
+  { Path to directives : <pt>/nProcedureHeading/nProcedureDirectives }
   if pt.NodeType in ProcedureNodes then
-    pt := pt.GetImmediateChild(ProcedureHeadings);
+    lpt:= pt.GetImmediateChild(nProcedureHeading);
 
-  Assert(pt <> nil);
-
-  lcDirectives := pt.GetImmediateChild(nProcedureDirectives);
-
-  Result := (lcDirectives <> nil) and lcDirectives.HasChildNode([ttExternal, ttForward])
+  if Assigned(lpt) then
+    result := lpt.HasChildNode([ttForward,ttExternal]) // This searches all sub nodes !
+  else
+    result := False;
 end;
 
 procedure TBuildParseTree.RecogniseProcedureDecl(const pbAnon: boolean);
@@ -4047,6 +4097,10 @@ begin
 
   RecogniseNotSolidTokens;
 
+  //opt
+  if fcTokenList.FirstSolidTokenType in AllProcDirectives then
+    RecogniseProcedureDirectives;
+
   { if the proc declaration has the directive external or forward,
     it will not have a body
     note that though 'forward' is a spectacularly unfortunate variable name,
@@ -4089,7 +4143,6 @@ begin
   if not IsForwardExtern(lcTop) then
   begin
     RecogniseBlock;
-
     if (not pbAnon) and (fcTokenList.FirstSolidTokenType = ttSemiColon) then
     begin
       Recognise(ttSemicolon);
@@ -4099,6 +4152,26 @@ begin
   PopNode;
 end;
 
+procedure TBuildParseTree.RecogniseSquareBracketDir;
+var
+  lTokenType : TTokenType;
+  { lNextToken : TSourceToken; }
+begin
+  { just add all tokens until the ']'  is reached ] }
+
+  PushNode(nProcedureDirBracket);
+
+  { Skip checking anything until ']' }
+  while not fcTokenList.EOF do begin
+    lTokenType := fcTokenList.FirstSolidTokenType;
+    Recognise(lTokenType);
+    if lTokenType = ttCloseSquareBracket then
+      break;
+  end;
+
+  PopNode;
+end;
+
 procedure TBuildParseTree.RecogniseConstructorDecl;
 begin
   // ProcedureDecl -> ProcedureHeading ';' [Directive] Block ';'
@@ -4324,7 +4397,7 @@ end;
 
 procedure TBuildParseTree.RecogniseProcedureDirectives;
 var
-  lbFirstPass: boolean;
+  lTokenType, lNextType: TTokenType;
 begin
   { these are semi-colon separated
 
@@ -4333,65 +4406,48 @@ begin
 
     external is more complex
   }
-  CheckEnumeratorToken(fcTokenList.FirstSolidTokenType = ttSemicolon);
-  if (fcTokenList.FirstSolidTokenType in ProcedureDirectives) or
-    ((fcTokenList.FirstSolidTokenType = ttSemicolon) and
-    (fcTokenList.SolidTokenType(2) in ProcedureDirectives)) then
-  begin
+
+  lTokenType := fcTokenList.FirstSolidTokenType;
+  lNextType := fcTokenList.SolidTokenType(2);
+  if (lTokenType in AllProcDirectives) or (lNextType in AllProcDirectives) then begin
     PushNode(nProcedureDirectives);
-
-    if fcTokenList.FirstSolidTokenType = ttSemiColon then
-      Recognise(ttSemiColon);
-    lbFirstPass := True;
-
-    CheckEnumeratorToken(fcTokenList.FirstSolidTokenType = ttSemicolon);
-    while (fcTokenList.FirstSolidTokenType in ProcedureDirectives) or
-      ((fcTokenList.FirstSolidTokenType = ttSemicolon) and
-        (fcTokenList.SolidTokenType(2) in ProcedureDirectives)) do
-    begin
-      if ( not lbFirstPass) and (fcTokenList.FirstSolidTokenType = ttSemiColon) then
-        Recognise(ttSemiColon);
-
-      case fcTokenList.FirstSolidTokenType of
-        ttExternal:
-        begin
-          RecogniseExternalProcDirective;
-        end;
-        ttPublic:
-        begin
-          { Break the loop if we have found a class visibility "public" }
-          if not RecognisePublicProcDirective then
-            break;
-        end;
-        ttDispId:
-        begin
-          Recognise(ttDispId);
-          RecogniseConstantExpression;
-        end;
-        ttMessage:
-        begin
-          Recognise(ttMessage);
-          RecogniseConstantExpression;
-        end;
-        ttEnumerator:
-        begin
-          Recognise(ttEnumerator);
-          RecogniseIdentifier(False, idStrict);
-        end;
-        ttDeprecated:
-        begin
-          Recognise(ttDeprecated);
-          if fcTokenList.FirstSolidTokenType <> ttSemicolon then
+    while (lTokenType in AllProcDirectives) or (lNextType in AllProcDirectives) do begin
+      if (lTokenType = ttSemiColon) then
+        Recognise(ttSemiColon)
+      else begin
+        case lTokenType of
+          ttOpenSquareBracket:
+            RecogniseSquareBracketDir;
+          ttExternal:
+            RecogniseExternalProcDirective;
+          ttPublic:
+            { Break the loop if we have found a class visibility "public" }
+            if not RecognisePublicProcDirective then
+              break;
+          ttDispId: begin
+            Recognise(ttDispId);
             RecogniseConstantExpression;
-        end
-        else
-          Recognise(ProcedureDirectives);
+          end;
+          ttMessage: begin
+            Recognise(ttMessage);
+            RecogniseConstantExpression;
+          end;
+          ttEnumerator: begin
+            Recognise(ttEnumerator);
+            RecogniseIdentifier(False, idStrict);
+          end;
+          ttDeprecated: begin
+            Recognise(ttDeprecated);
+            if fcTokenList.FirstSolidTokenType <> ttSemicolon then
+              RecogniseConstantExpression;
+          end
+          else
+            Recognise(ProcedureDirectives);
+        end;
       end;
-
-      lbFirstPass := False;
-      CheckEnumeratorToken();
+      lTokenType := fcTokenList.FirstSolidTokenType;
+      lNextType := fcTokenList.SolidTokenType(2);
     end;
-
     PopNode;
   end;
 end;

components/jcf2/Parse/ParseTreeNodeType.pas

@@ -45,6 +45,7 @@ type
     nUnitName,
     nPackage,
     nLibrary,
+    nInclude,
     nUses,
     nUsesItem,
     nRequires,
@@ -79,6 +80,8 @@ type
     nVarDecl,
     nVarAbsolute,
     nVariableInit,
+    nVarExpPubl,   // ( 'export' | 'public' ) [ named ] ';'
+    nVarExternal,  // ( 'external' [[ lib_name ] [named]] ';'
     nDesignator,
     nExpression,
     nTerm,
@@ -122,6 +125,7 @@ type
     nFormalParam,
     nFunctionReturnType,
     nProcedureDirectives,
+    nProcedureDirBracket,  // proc dir backet
     nExternalDirective,
     nObjectType,
     nInitSection,
@@ -198,13 +202,15 @@ uses SysUtils;
 
 const
   TreeNodeTypeNames: array[TParseTreeNodeType] of string = (
-    'UnkNown', 'Leaf', 'Program', 'Unit', 'Unit header', 'Unit name', 'Package', 'Library', 'Uses',
+    'UnkNown', 'Leaf', 'Program', 'Unit', 'Unit header', 'Unit name', 'Package', 'Library',
+    'Include', 'Uses',
     'Uses Item', 'Requires', 'Contains', 'ident list', 'Identifier', 'Interface section',
     'Implementation section', 'Block', 'Statement list', 'Decl section', 'Label decl section',
     'const section', 'Const decl', 'type section', 'Type Decl', 'Array constant', 'Record Constant',
     'Field constant', 'Type', 'Restricted type', 'Subrange type', 'Enumerated type', 'Array type',
     'record type', 'Field declarations', 'Record variant section', 'Record variant', 'Set type',
-    'procedure type', 'Var section', 'Var decl', 'Absolute var', 'Variable init', 'Designator',
+    'procedure type', 'Var section', 'Var decl', 'Absolute var', 'Variable init', 
+    'Var Export | Public', 'Var External/Lib', 'Designator',
     'Expression', 'Term', 'Unary op', 'Actual params', 'Statement', 'Assignment', 'Inline',
     'Inline item', 'Statement label', 'Compound statement', 'If Condition', 'If Block', 'Else block',
     'Case statement', 'Case selector', 'Case labels', 'Case label', 'else case', 'Repeat statement',
@@ -213,6 +219,7 @@ const
     'On exception handler', 'Procedure decl', 'Function Decl', 'Constructor decl', 'Destructor decl',
     'Function heading', 'Procedure Heading', 'Constructor Heading', 'Destructor heading',
     'Formal params', 'formal param', 'Function Return type', 'Procedure directives',
+    'Procedure [directives]',
     'external directive', 'object type', 'init section', 'class type', 'class heritage',
     'class body', 'class visiblity', 'class declarations', 'property', 'property param list',
     'property specifier', 'interface type', 'interface heritage', 'interface type guid',

components/jcf2/Parse/Tokens.pas

@@ -164,6 +164,8 @@ type
     ttStrict,
     ttStdcall,
     ttAssembler,
+    ttCompilerproc,
+    ttrtlproc,
     ttForward,
     ttProtected,
     ttStored,
@@ -225,6 +227,7 @@ type
     ttExperimental,
     ttUnimplemented,
     ttInterrupt,
+    ttAlias,
 
     { built-in constants }
     ttNil,
@@ -389,7 +392,7 @@ const
     [ttPrivate, ttProtected, ttPublic, ttPublished, ttAutomated];
 
   ProcedureDirectives: TTokenTypeSet = [ttExternal, ttPascal, ttSafecall, ttAbstract,
-    ttFar, ttStdcall, ttAssembler, ttInline, ttForward,
+    ttFar, ttStdcall, ttAssembler, ttInline, ttCompilerproc, ttrtlproc, ttForward,
     ttVirtual, ttCdecl, ttMessage, ttName, ttRegister, ttDispId,
     ttNear, ttDynamic, ttExport, ttOverride, ttResident, ttLocal,
     ttOverload, ttReintroduce,
@@ -402,6 +405,8 @@ const
   HintDirectives: TTokenTypeSet  = [ttDeprecated, ttLibrary, ttPlatform, ttCVar,
                                     ttExperimental, ttUnimplemented, ttStatic];
 
+  AllProcDirectives: TTokenTypeSet = [];
+
   AllDirectives: TTokenTypeSet =
   [ttAbsolute, ttExternal, ttPascal, ttSafecall,
     ttAbstract, ttFar, ttPrivate, ttStdcall, ttAssembler, ttForward,
@@ -695,6 +700,8 @@ begin
   AddKeyword('public', wtReservedWordDirective, ttPublic);
   AddKeyword('virtual', wtReservedWordDirective, ttVirtual);
   AddKeyword('cdecl', wtReservedWordDirective, ttCdecl);
+  AddKeyword('compilerproc', wtReservedWordDirective, ttCompilerproc);
+  AddKeyword('rtlproc', wtReservedWordDirective, ttrtlproc);
   AddKeyword('ms_abi_default', wtReservedWordDirective, ttCdecl);
   AddKeyword('ms_abi_cdecl', wtReservedWordDirective, ttCdecl);
   AddKeyword('sysv_abi_default', wtReservedWordDirective, ttCdecl);
@@ -755,6 +762,7 @@ begin
   AddKeyword('experimental', wtReservedWordDirective, ttExperimental);
   AddKeyword('unimplemented', wtReservedWordDirective, ttUnimplemented);
   AddKeyword('interrupt', wtReservedWordDirective, ttInterrupt);
+  AddKeyword('alias', wtReservedWordDirective, ttAlias);
 
   { operators that are words not symbols }
   AddKeyword('and', wtOperator, ttAnd);

components/jcf2/ReadWrite/Converter.pas

@@ -38,6 +38,8 @@ interface
 
 uses
   SysUtils, strutils,
+  // LazUtils
+  LazFileUtils,
   // LCL
   Controls, Forms,
   // local
@@ -178,6 +180,7 @@ begin
 
         // make a parse tree from it
         fcBuildParseTree.TokenList := lcTokenList;
+        fcBuildParseTree.IsIncFile := FilenameExtIs(FileName, 'inc');
         fcBuildParseTree.BuildParseTree;
         if fbShowParseTree then
            ShowParseTree;

components/jcf2/ReadWrite/EditorConverter.pas

@@ -120,6 +120,7 @@ begin
   fcConverter.InputCode := ReadFromIDE(pciUnit);
 
   // now convert
+  fcConverter.FileName := fsCurrentUnitName;
   fcConverter.Convert;
   fsCurrentUnitName := '';
   if not ConvertError then