gcc/ada/prj-attr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . A T T R                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --             Copyright (C) 2001-2002 Free Software Foundation, Inc.       --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Characters.Handling; use Ada.Characters.Handling;
  29 with Namet;     use Namet;
  30 with Output;    use Output;
  31
  32 package body Prj.Attr is
  33
  34    --  Names end with '#'
  35
  36    --  Package names are preceded by 'P'
  37
  38    --  Attribute names are preceded by two letters
  39
  40    --  The first letter is one of
  41    --    'S' for Single
  42    --    'L' for list
  43
  44    --  The second letter is one of
  45    --    'V' for single variable
  46    --    'A' for associative array
  47    --    'a' for case insensitive associative array
  48
  49    --  End is indicated by two consecutive '#'.
  50
  51    Initialization_Data : constant String :=
  52
  53    --  project attributes
  54
  55      "SVobject_dir#" &
  56      "SVexec_dir#" &
  57      "LVsource_dirs#" &
  58      "LVsource_files#" &
  59      "SVsource_list_file#" &
  60      "SVlibrary_dir#" &
  61      "SVlibrary_name#" &
  62      "SVlibrary_kind#" &
  63      "SVlibrary_elaboration#" &
  64      "SVlibrary_version#" &
  65      "LVmain#" &
  66      "LVlanguages#" &
  67
  68    --  package Naming
  69
  70      "Pnaming#" &
  71      "Saspecification_suffix#" &
  72      "Saimplementation_suffix#" &
  73      "SVseparate_suffix#" &
  74      "SVcasing#" &
  75      "SVdot_replacement#" &
  76      "SAspecification#" &
  77      "SAimplementation#" &
  78      "LAspecification_exceptions#" &
  79      "LAimplementation_exceptions#" &
  80
  81    --  package Compiler
  82
  83      "Pcompiler#" &
  84      "Ladefault_switches#" &
  85      "LAswitches#" &
  86      "SVlocal_configuration_pragmas#" &
  87
  88    --  package Builder
  89
  90      "Pbuilder#" &
  91      "Ladefault_switches#" &
  92      "LAswitches#" &
  93      "SVglobal_configuration_pragmas#" &
  94
  95    --  package gnatls
  96
  97      "Pgnatls#" &
  98      "LVswitches#" &
  99
 100    --  package Binder
 101
 102      "Pbinder#" &
 103      "Ladefault_switches#" &
 104      "LAswitches#" &
 105
 106    --  package Linker
 107
 108      "Plinker#" &
 109      "Ladefault_switches#" &
 110      "LAswitches#" &
 111
 112    --  package Cross_Reference
 113
 114      "Pcross_reference#" &
 115      "Ladefault_switches#" &
 116      "LAswitches#" &
 117
 118    --  package Finder
 119
 120      "Pfinder#" &
 121      "Ladefault_switches#" &
 122      "LAswitches#" &
 123
 124    --  package Gnatstub
 125
 126      "Pgnatstub#" &
 127      "LVswitches#" &
 128
 129    --  package Ide
 130
 131      "Pide#" &
 132      "SVremote_host#" &
 133      "Sacompiler_command#" &
 134      "SVdebugger_command#" &
 135      "SVgnatlist#" &
 136      "SVvcs_kind#" &
 137      "SVvcs_file_check#" &
 138      "SVvcs_log_check#" &
 139
 140      "#";
 141
 142    ----------------
 143    -- Initialize --
 144    ----------------
 145
 146    procedure Initialize is
 147       Start             : Positive           := Initialization_Data'First;
 148       Finish            : Positive           := Start;
 149       Current_Package   : Package_Node_Id    := Empty_Package;
 150       Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
 151       Is_An_Attribute   : Boolean            := False;
 152       Kind_1            : Variable_Kind      := Undefined;
 153       Kind_2            : Attribute_Kind     := Single;
 154       Package_Name      : Name_Id            := No_Name;
 155       Attribute_Name    : Name_Id            := No_Name;
 156       First_Attribute   : Attribute_Node_Id  := Attribute_First;
 157
 158    begin
 159       --  Make sure the two tables are empty
 160
 161       Attributes.Set_Last (Attributes.First);
 162       Package_Attributes.Set_Last (Package_Attributes.First);
 163
 164       while Initialization_Data (Start) /= '#' loop
 165          Is_An_Attribute := True;
 166          case Initialization_Data (Start) is
 167             when 'P' =>
 168
 169                --  New allowed package
 170
 171                Start := Start + 1;
 172
 173                Finish := Start;
 174                while Initialization_Data (Finish) /= '#' loop
 175                   Finish := Finish + 1;
 176                end loop;
 177
 178                Name_Len := Finish - Start;
 179                Name_Buffer (1 .. Name_Len) :=
 180                  To_Lower (Initialization_Data (Start .. Finish - 1));
 181                Package_Name := Name_Find;
 182
 183                for Index in Package_First .. Package_Attributes.Last loop
 184                   if Package_Name = Package_Attributes.Table (Index).Name then
 185                      Write_Line ("Duplicate package name """ &
 186                                  Initialization_Data (Start .. Finish - 1) &
 187                                  """ in Prj.Attr body.");
 188                      raise Program_Error;
 189                   end if;
 190                end loop;
 191
 192                Is_An_Attribute := False;
 193                Current_Attribute := Empty_Attribute;
 194                Package_Attributes.Increment_Last;
 195                Current_Package := Package_Attributes.Last;
 196                Package_Attributes.Table (Current_Package).Name :=
 197                  Package_Name;
 198                Start := Finish + 1;
 199
 200             when 'S' =>
 201                Kind_1 := Single;
 202
 203             when 'L' =>
 204                Kind_1 := List;
 205
 206             when others =>
 207                raise Program_Error;
 208          end case;
 209
 210          if Is_An_Attribute then
 211
 212             --  New attribute
 213
 214             Start := Start + 1;
 215             case Initialization_Data (Start) is
 216                when 'V' =>
 217                   Kind_2 := Single;
 218                when 'A' =>
 219                   Kind_2 := Associative_Array;
 220                when 'a' =>
 221                   Kind_2 := Case_Insensitive_Associative_Array;
 222                when others =>
 223                   raise Program_Error;
 224             end case;
 225
 226             Start := Start + 1;
 227             Finish := Start;
 228
 229             while Initialization_Data (Finish) /= '#' loop
 230                Finish := Finish + 1;
 231             end loop;
 232
 233             Name_Len := Finish - Start;
 234             Name_Buffer (1 .. Name_Len) :=
 235               To_Lower (Initialization_Data (Start .. Finish - 1));
 236             Attribute_Name := Name_Find;
 237             Attributes.Increment_Last;
 238             if Current_Attribute = Empty_Attribute then
 239                First_Attribute := Attributes.Last;
 240
 241                if Current_Package /= Empty_Package then
 242                   Package_Attributes.Table (Current_Package).First_Attribute
 243                     := Attributes.Last;
 244                end if;
 245
 246             else
 247                --  Check that there are no duplicate attributes
 248
 249                for Index in First_Attribute .. Attributes.Last - 1 loop
 250                   if Attribute_Name =
 251                     Attributes.Table (Index).Name then
 252                      Write_Line ("Duplicate attribute name """ &
 253                                  Initialization_Data (Start .. Finish - 1) &
 254                                  """ in Prj.Attr body.");
 255                      raise Program_Error;
 256                   end if;
 257                end loop;
 258
 259                Attributes.Table (Current_Attribute).Next :=
 260                  Attributes.Last;
 261             end if;
 262
 263             Current_Attribute := Attributes.Last;
 264             Attributes.Table (Current_Attribute) :=
 265               (Name    => Attribute_Name,
 266                Kind_1  => Kind_1,
 267                Kind_2  => Kind_2,
 268                Next    => Empty_Attribute);
 269             Start := Finish + 1;
 270          end if;
 271       end loop;
 272    end Initialize;
 273
 274 end Prj.Attr;