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