MG: fixed parser of end blocks in initialization section added label sections

git-svn-id: trunk@1486 -

components/codetools/codetree.pas

@@ -65,7 +65,8 @@ const
   ctnVarSection      = 11;
   ctnConstSection    = 12;
   ctnResStrSection   = 13;
-  ctnUsesSection     = 14;
+  ctnLabelSection    = 14;
+  ctnUsesSection     = 15;
 
   ctnTypeDefinition  = 20;
   ctnVarDefinition   = 21;
@@ -118,7 +119,8 @@ const
   AllClassSections =
      [ctnClassPublic,ctnClassPublished,ctnClassPrivate,ctnClassProtected];
   AllDefinitionSections =
-     [ctnTypeSection,ctnVarSection,ctnConstSection,ctnResStrSection];
+     [ctnTypeSection,ctnVarSection,ctnConstSection,ctnResStrSection,
+      ctnLabelSection];
   AllIdentifierDefinitions =
      [ctnTypeDefinition,ctnVarDefinition,ctnConstDefinition];
   AllPascalTypes =

components/codetools/customcodetool.pas

@@ -109,6 +109,7 @@ type
     function DoAtom: boolean; virtual;
     procedure ReadNextAtom;
     procedure UndoReadNextAtom;
+    procedure ReadPriorAtom;
     function AtomIs(const AnAtom: shortstring): boolean;
     function UpAtomIs(const AnAtom: shortstring): boolean;
     function ReadNextAtomIs(const AnAtom: shortstring): boolean;
@@ -138,7 +139,6 @@ type
     function CompareSrcIdentifiers(CleanStartPos: integer;
       AnIdentifier: PChar): boolean;
     function ExtractIdentifier(CleanStartPos: integer): string;
-    procedure ReadPriorAtom;
 
     procedure CreateChildNode;
     procedure EndChildNode;
@@ -683,12 +683,16 @@ begin
         c2:=Src[CurPos.EndPos];
         // test for double char operators :=, +=, -=, /=, *=, <>, <=, >=, **, ><
         if ((c2='=') and  (IsEqualOperatorStartChar[c1]))
-        or ((c1='<') and (c2='>'))
+        or ((c1='<') and (c2='>')) // not equal
         or ((c1='>') and (c2='<'))
-        or ((c1='.') and (c2='.'))
+        or ((c1='.') and (c2='.')) // subrange
         or ((c1='*') and (c2='*'))
-        or ((c1='@') and (c2='@'))
         then inc(CurPos.EndPos);
+        if ((c1='@') and (c2='@')) then begin
+          repeat
+            inc(CurPos.EndPos);
+          until (CurPos.EndPos>SrcLen) or (not IsIdentChar[Src[CurPos.EndPos]]);
+        end;
       end;
   end;
 end;
@@ -887,6 +891,9 @@ begin
         while (CurPos.StartPos>1)
         and (IsIdentChar[UpperSrc[CurPos.StartPos-1]]) do
           dec(CurPos.StartPos);
+        if (CurPos.StartPos>2)
+        and (Src[CurPos.StartPos-1]='@') and (Src[CurPos.StartPos-2]='@') then
+          dec(CurPos.StartPos,2);
       end;
     '''':
       begin
@@ -959,6 +966,17 @@ begin
                 inc(CurPos.StartPos);
               break;
             end;
+          '@':
+            begin
+              if (CurPos.StartPos=1) or (Src[CurPos.StartPos-1]<>'@')
+              or (([ntIdentifier,ntDecimal]*ForbiddenNumberTypes)=[]) then
+                // atom start found
+                inc(CurPos.StartPos)
+              else
+                // label found
+                dec(CurPos.StartPos);
+              break;
+            end;
           else
             begin
               inc(CurPos.StartPos);

components/codetools/definetemplates.pas

@@ -2503,6 +2503,8 @@ begin
       'Define makro DELPHI','DELPHI','',da_DefineRecurse));
   MainDirTempl.AddChild(TDefineTemplate.Create('Define makro FPC_DELPHI',
       'Define makro FPC_DELPHI','FPC_DELPHI','',da_DefineRecurse));
+  MainDirTempl.AddChild(TDefineTemplate.Create('Define makro VER_130',
+      'Define makro VER_130','VER_130','',da_DefineRecurse));
   MainDirTempl.AddChild(TDefineTemplate.Create(
      'Define '+ExternalMacroStart+'Compiler',
      'Define '+ExternalMacroStart+'Compiler variable',

components/codetools/finddeclarationtool.pas

@@ -1059,6 +1059,7 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] A Ident=',
         case ContextNode.Desc of
 
         ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection,
+        ctnLabelSection,
         ctnInterface, ctnImplementation,
         ctnClassPublic, ctnClassPrivate, ctnClassProtected, ctnClassPublished,
         ctnClass,
@@ -1316,6 +1317,7 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] Searching in Parent  Con
             case ContextNode.Desc of
             
             ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection,
+            ctnLabelSection,
             ctnInterface, ctnImplementation,
             ctnClassPublished,ctnClassPublic,ctnClassProtected, ctnClassPrivate,
             ctnRecordCase, ctnRecordVariant,

components/codetools/keywordfunclists.pas

@@ -84,6 +84,9 @@ var
   WordIsTermOperator,
   WordIsPropertySpecifier,
   WordIsBlockKeyWord,
+  EndKeyWordFuncList,
+  PackedTypesKeyWordFuncList,
+  BlockStatementStartKeyWordFuncList,
   WordIsLogicalBlockStart,
   WordIsBinaryOperator,
   WordIsLvl1Operator, WordIsLvl2Operator, WordIsLvl3Operator, WordIsLvl4Operator,
@@ -710,6 +713,34 @@ begin
     Add('FINALLY',{$ifdef FPC}@{$endif}AllwaysTrue);
     Add('EXCEPT',{$ifdef FPC}@{$endif}AllwaysTrue);
   end;
+  EndKeyWordFuncList:=TKeyWordFunctionList.Create;
+  KeyWordLists.Add(EndKeyWordFuncList);
+  with EndKeyWordFuncList do begin
+    Add('BEGIN',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('ASM',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('CASE',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('TRY',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('RECORD',{$ifdef FPC}@{$endif}AllwaysTrue);
+  end;
+  PackedTypesKeyWordFuncList:=TKeyWordFunctionList.Create;
+  KeyWordLists.Add(PackedTypesKeyWordFuncList);
+  with PackedTypesKeyWordFuncList do begin
+    Add('CLASS',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('OBJECT',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('DISPINTERFACE',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('ARRAY',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('SET',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('RECORD',{$ifdef FPC}@{$endif}AllwaysTrue);
+  end;
+  BlockStatementStartKeyWordFuncList:=TKeyWordFunctionList.Create;
+  KeyWordLists.Add(BlockStatementStartKeyWordFuncList);
+  with BlockStatementStartKeyWordFuncList do begin
+    Add('BEGIN' ,{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('REPEAT',{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('TRY'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('ASM'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
+    Add('CASE'  ,{$ifdef FPC}@{$endif}AllwaysTrue);
+  end;
   UnexpectedKeyWordInBeginBlock:=TKeyWordFunctionList.Create;
   KeyWordLists.Add(UnexpectedKeyWordInBeginBlock);
   with UnexpectedKeyWordInBeginBlock do begin

components/codetools/pascalparsertool.pas

@@ -101,12 +101,9 @@ type
   TPascalParserTool = class(TMultiKeyWordListCodeTool)
   private
   protected
-    EndKeyWordFuncList: TKeyWordFunctionList;
     TypeKeyWordFuncList: TKeyWordFunctionList;
-    PackedTypesKeyWordFuncList: TKeyWordFunctionList;
     InnerClassKeyWordFuncList: TKeyWordFunctionList;
     ClassVarTypeKeyWordFuncList: TKeyWordFunctionList;
-    BlockStatementStartKeyWordFuncList: TKeyWordFunctionList;
     ExtractMemStream: TMemoryStream;
     ExtractSearchPos: integer;
     ExtractFoundPos: integer;
@@ -122,6 +119,7 @@ type
     function KeyWordFuncVar: boolean;
     function KeyWordFuncConst: boolean;
     function KeyWordFuncResourceString: boolean;
+    function KeyWordFuncLabel: boolean;
     // types
     function KeyWordFuncClass: boolean;
     function KeyWordFuncTypePacked: boolean;
@@ -153,12 +151,9 @@ type
     function KeyWordFuncClassVarTypeIdent: boolean;
     // keyword lists
     procedure BuildDefaultKeyWordFunctions; override;
-    procedure BuildEndKeyWordFunctions; virtual;
     procedure BuildTypeKeyWordFunctions; virtual;
-    procedure BuildPackedTypesKeyWordFunctions; virtual;
     procedure BuildInnerClassKeyWordFunctions; virtual;
     procedure BuildClassVarTypeKeyWordFunctions; virtual;
-    procedure BuildBlockStatementStartKeyWordFuncList; virtual;
     function UnexpectedKeyWord: boolean;
     // read functions
     function ReadTilProcedureHeadEnd(IsMethod, IsFunction, IsType, IsOperator,
@@ -313,17 +308,10 @@ end;
 constructor TPascalParserTool.Create;
 begin
   inherited Create;
-  // KeyWord functions for parsing blocks (e.g. begin..end)
-  EndKeyWordFuncList:=TKeyWordFunctionList.Create;
-  BuildEndKeyWordFunctions;
-  AddKeyWordFuncList(EndKeyWordFuncList);
   // keywords for parsing types
   TypeKeyWordFuncList:=TKeyWordFunctionList.Create;
   BuildTypeKeyWordFunctions;
   AddKeyWordFuncList(TypeKeyWordFuncList);
-  PackedTypesKeyWordFuncList:=TKeyWordFunctionList.Create;
-  BuildPackedTypesKeyWordFunctions;
-  AddKeyWordFuncList(PackedTypesKeyWordFuncList);
   // KeyWord functions for parsing in a class
   InnerClassKeyWordFuncList:=TKeyWordFunctionList.Create;
   BuildInnerClassKeyWordFunctions;
@@ -331,10 +319,6 @@ begin
   ClassVarTypeKeyWordFuncList:=TKeyWordFunctionList.Create;
   BuildClassVarTypeKeyWordFunctions;
   AddKeyWordFuncList(ClassVarTypeKeyWordFuncList);
-  // keywords for statements
-  BlockStatementStartKeyWordFuncList:=TKeyWordFunctionList.Create;
-  BuildBlockStatementStartKeyWordFuncList;
-  AddKeyWordFuncList(BlockStatementStartKeyWordFuncList);
 end;
 
 destructor TPascalParserTool.Destroy;
@@ -364,6 +348,7 @@ begin
     Add('VAR',{$ifdef FPC}@{$endif}KeyWordFuncVar);
     Add('CONST',{$ifdef FPC}@{$endif}KeyWordFuncConst);
     Add('RESOURCESTRING',{$ifdef FPC}@{$endif}KeyWordFuncResourceString);
+    Add('LABEL',{$ifdef FPC}@{$endif}KeyWordFuncLabel);
 
     Add('PROCEDURE',{$ifdef FPC}@{$endif}KeyWordFuncProc);
     Add('FUNCTION',{$ifdef FPC}@{$endif}KeyWordFuncProc);
@@ -379,18 +364,6 @@ begin
   end;
 end;
 
-procedure TPascalParserTool.BuildEndKeyWordFunctions;
-// KeyWordFunctions for parsing end - blocks
-begin
-  with EndKeyWordFuncList do begin
-    Add('BEGIN',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('ASM',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('CASE',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('TRY',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('RECORD',{$ifdef FPC}@{$endif}AllwaysTrue);
-  end;
-end;
-
 procedure TPascalParserTool.BuildTypeKeyWordFunctions;
 // KeyWordFunctions for parsing types
 begin
@@ -414,19 +387,6 @@ begin
   end;
 end;
 
-procedure TPascalParserTool.BuildPackedTypesKeyWordFunctions;
-// KeyWordFunctions for valid packed types
-begin
-  with PackedTypesKeyWordFuncList do begin
-    Add('CLASS',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('OBJECT',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('DISPINTERFACE',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('ARRAY',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('SET',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('RECORD',{$ifdef FPC}@{$endif}AllwaysTrue);
-  end;
-end;
-
 procedure TPascalParserTool.BuildInnerClassKeyWordFunctions;
 // KeyWordFunctions for parsing in a class/object
 begin
@@ -468,17 +428,6 @@ begin
   end;
 end;
 
-procedure TPascalParserTool.BuildBlockStatementStartKeyWordFuncList;
-begin
-  with BlockStatementStartKeyWordFuncList do begin
-    Add('BEGIN' ,{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('REPEAT',{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('TRY'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('ASM'   ,{$ifdef FPC}@{$endif}AllwaysTrue);
-    Add('CASE'  ,{$ifdef FPC}@{$endif}AllwaysTrue);
-  end;
-end;
-
 function TPascalParserTool.UnexpectedKeyWord: boolean;
 begin
   Result:=false;
@@ -1142,7 +1091,7 @@ function TPascalParserTool.ReadTilProcedureHeadEnd(
    external <id or number> index <id>
    [alias: <string constant>]
 }
-var IsSpecifier, EndSemicolonFound: boolean;
+var IsSpecifier: boolean;
   Attr: TProcHeadAttributes;
 begin
 //writeln('[TPascalParserTool.ReadTilProcedureHeadEnd] ',
@@ -1198,12 +1147,8 @@ begin
     UndoReadNextAtom;
     exit;
   end;
-  if AtomIsChar(';') then begin
+  if AtomIsChar(';') then
     ReadNextAtom;
-    EndSemicolonFound:=true;
-  end else begin
-    EndSemicolonFound:=false;
-  end;
   if (CurPos.StartPos>SrcLen) then
     RaiseException('semicolon not found');
   repeat
@@ -1565,6 +1510,10 @@ begin
           CreateChildNode;
           CurNode.Desc:=ctnFinalization;
           CurSection:=CurNode.Desc;
+        end else if EndKeyWordFuncList.DoItUppercase(UpperSrc,CurPos.StartPos,
+          CurPos.EndPos-CurPos.StartPos) then
+        begin
+          ReadTilBlockEnd(false,false);
         end else if UpAtomIs('END') then begin
           Result:=KeyWordFuncEndPoint;
           break;
@@ -1730,6 +1679,7 @@ begin
     if (CurPos.StartPos>SrcLen) then begin
       RaiseExceptionWithBlockStartHint('"end" not found')
     end else if (UpAtomIs('END')) then begin
+
       if BlockType=ebtRepeat then
         RaiseExceptionWithBlockStartHint(
           '"until" expected, but "'+GetAtom+'" found');
@@ -2148,7 +2098,7 @@ function TPascalParserTool.KeyWordFuncType: boolean;
 }
 begin
   if not (CurSection in [ctnProgram,ctnInterface,ctnImplementation]) then
-    RaiseException('unexpected keyword '+GetAtom+' in type section');
+    RaiseException('unexpected keyword '+GetAtom);
   CreateChildNode;
   CurNode.Desc:=ctnTypeSection;
   // read all type definitions  Name = Type;
@@ -2195,7 +2145,7 @@ function TPascalParserTool.KeyWordFuncVar: boolean;
 }
 begin
   if not (CurSection in [ctnProgram,ctnInterface,ctnImplementation]) then
-    RaiseException('unexpected keyword '+GetAtom+' in var section');
+    RaiseException('unexpected keyword '+GetAtom);
   CreateChildNode;
   CurNode.Desc:=ctnVarSection;
   // read all variable definitions  Name : Type; [cvar;] [public [name '']]
@@ -2243,7 +2193,7 @@ function TPascalParserTool.KeyWordFuncConst: boolean;
 }
 begin
   if not (CurSection in [ctnProgram,ctnInterface,ctnImplementation]) then
-    RaiseException('unexpected keyword '+GetAtom+' in const section');
+    RaiseException('unexpected keyword '+GetAtom);
   CreateChildNode;
   CurNode.Desc:=ctnConstSection;
   // read all constants  Name = <Const>; or Name : type = <Const>;
@@ -2297,7 +2247,7 @@ function TPascalParserTool.KeyWordFuncResourceString: boolean;
 }
 begin
   if not (CurSection in [ctnProgram,ctnInterface,ctnImplementation]) then
-    RaiseException('unexpected keyword '+GetAtom+' in resourcestring section');
+    RaiseException('unexpected keyword '+GetAtom);
   CreateChildNode;
   CurNode.Desc:=ctnResStrSection;
   // read all string constants Name = 'abc';
@@ -2328,6 +2278,38 @@ begin
   Result:=true;
 end;
 
+function TPascalParserTool.KeyWordFuncLabel: boolean;
+{
+  examples:
+    label a, 23, b;
+}
+begin
+  if not (CurSection in [ctnProgram,ctnInterface,ctnImplementation]) then
+    RaiseException('unexpected keyword '+GetAtom);
+  CreateChildNode;
+  CurNode.Desc:=ctnLabelSection;
+  // read all constants
+  repeat
+    ReadNextAtom;  // identifier or number
+    if not AtomIsIdentifier(false) or AtomIsNumber then begin
+      RaiseException('identifier expected, but '+GetAtom+' found');
+    end;
+    CreateChildNode;
+    CurNode.Desc:=ctnLabelType;
+    CurNode.EndPos:=CurPos.EndPos;
+    EndChildNode;
+    ReadNextAtom;
+    if AtomIsChar(';') then begin
+      break;
+    end else if not AtomIsChar(',') then begin
+      RaiseException('; expected, but '+GetAtom+' found');
+    end;
+  until false;
+  CurNode.EndPos:=CurPos.EndPos;
+  EndChildNode;
+  Result:=true;
+end;
+
 function TPascalParserTool.KeyWordFuncTypePacked: boolean;
 begin
   ReadNextAtom;

lcl/graphics.pp

@@ -232,10 +232,31 @@ type
 
   TCanvas = class;
 
-  {
+  { The TGraphic class is an abstract base class for dealing with graphic images
-    TGraphic is the mother of all graphic formats like TBitmap, TPixmap and
+    such as bitmaps, pixmaps, icons, and other image formats.
-    TIcon. It defines properties and methods for width, height and streaming.
+      LoadFromFile - Read the graphic from the file system.  The old contents of
-  }
+        the graphic are lost.  If the file is not of the right format, an
+        exception will be generated.
+      SaveToFile - Writes the graphic to disk in the file provided.
+      LoadFromStream - Like LoadFromFile except source is a stream (e.g.
+        TBlobStream).
+      SaveToStream - stream analogue of SaveToFile.
+      LoadFromClipboardFormat - Replaces the current image with the data
+        provided.  If the TGraphic does not support that format it will generate
+        an exception.
+      SaveToClipboardFormats - Converts the image to a clipboard format.  If the
+        image does not support being translated into a clipboard format it
+        will generate an exception.
+      Height - The native, unstretched, height of the graphic.
+      Palette - Color palette of image.  Zero if graphic doesn't need/use palettes.
+      Transparent - Image does not completely cover its rectangular area
+      Width - The native, unstretched, width of the graphic.
+      OnChange - Called whenever the graphic changes
+      PaletteModified - Indicates in OnChange whether color palette has changed.
+        Stays true until whoever's responsible for realizing this new palette
+        (ex: TImage) sets it to False.
+      OnProgress - Generic progress indicator event. Propagates out to TPicture
+        and TImage OnProgress events.}
   TGraphic = class(TPersistent)
   private
     FModified: Boolean;
@@ -282,7 +303,7 @@ type
   { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
     graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
     polymorphic. For example, if the TPicture is holding an Icon, you can
-    LoadFromFile a bitmap file, where if the class was TIcon you could only read
+    LoadFromFile a bitmap file, where if the class is TIcon you could only read
     .ICO files.
       LoadFromFile - Reads a picture from disk.  The TGraphic class created
         determined by the file extension of the file.  If the file extension is
@@ -304,6 +325,8 @@ type
       Graphic - The TGraphic object contained by the TPicture
       Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
         contents are thrown away and a blank bitmap is returned.
+      Pixmap - Returns a pixmap.  If the contents is not already a pixmap, the
+        contents are thrown away and a blank pixmap is returned.
       Icon - Returns an icon.  If the contents is not already an icon, the
         contents are thrown away and a blank icon is returned.
       }
@@ -412,16 +435,18 @@ type
                        NumPts: Integer {$IFDEF VER1_1} = -1{$ENDIF});
     procedure Polyline(Points: PPoint; NumPts: Integer);
     Procedure FillRect(const Rect : TRect);
-    procedure Frame3d(var Rect : TRect; const FrameWidth : integer; const Style : TBevelCut);
+    procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle);
+    procedure Frame3d(var Rect : TRect; const FrameWidth : integer;
+                      const Style : TBevelCut);
     Procedure Rectangle(X1,Y1,X2,Y2 : Integer); 
     Procedure Rectangle(const Rect: TRect); 
     Procedure Line(X1,Y1,X2,Y2 : Integer);
     Procedure MoveTo(X1,Y1 : Integer);
     Procedure LineTo(X1,Y1 : Integer);
     procedure TextOut(X,Y: Integer; const Text: String);
-    procedure TextRect(Rect: TRect; X, Y: integer; const Text : string);
+    procedure TextRect(Rect: TRect; X, Y: integer; const Text : string);// overload;
- overload;
+    procedure TextRect(Rect: TRect; X, Y: integer; const Text : string;
-    procedure TextRect(Rect: TRect; X, Y: integer; const Text : string; const Style : TTextStyle); overload;
+                       const Style : TTextStyle); //overload;
     function TextExtent(const Text: string): TSize;
     function TextHeight(const Text: string): Integer;
     function TextWidth(const Text: string): Integer;
@@ -698,6 +723,9 @@ end.
 { =============================================================================
 
   $Log$
+  Revision 1.24  2002/03/08 16:16:55  lazarus
+  MG: fixed parser of end blocks in initialization section added label sections
+
   Revision 1.23  2002/03/08 09:30:30  lazarus
   MG: nicer parameter names