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 --                            $Revision$
  10 --                                                                          --
  11 --             Copyright (C) 2001 Free Software Foundation, Inc.            --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Ada.Characters.Handling; use Ada.Characters.Handling;
  30 with Namet;     use Namet;
  31 with Output;    use Output;
  32
  33 package body Prj.Attr is
  34
  35    --  Names end with '#'
  36
  37    --  Package names are preceded by 'P'
  38
  39    --  Attribute names are preceded by two letters
  40
  41    --  The first letter is one of
  42    --    'S' for Single
  43    --    'L' for list
  44
  45    --  The second letter is one of
  46    --    'V' for single variable
  47    --    'A' for associative array
  48    --    'a' for case insensitive associative array
  49
  50    --  End is indicated by two consecutive '#'.
  51
  52    Initialisation_Data : constant String :=
  53
  54    --  project attributes
  55
  56      "SVobject_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      "#";
 125
 126    ----------------
 127    -- Initialize --
 128    ----------------
 129
 130    procedure Initialize is
 131       Start             : Positive           := Initialisation_Data'First;
 132       Finish            : Positive           := Start;
 133       Current_Package   : Package_Node_Id    := Empty_Package;
 134       Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
 135       Is_An_Attribute   : Boolean            := False;
 136       Kind_1            : Variable_Kind      := Undefined;
 137       Kind_2            : Attribute_Kind     := Single;
 138       Package_Name      : Name_Id            := No_Name;
 139       Attribute_Name    : Name_Id            := No_Name;
 140       First_Attribute   : Attribute_Node_Id  := Attribute_First;
 141
 142    begin
 143       --  Make sure the two tables are empty
 144
 145       Attributes.Set_Last (Attributes.First);
 146       Package_Attributes.Set_Last (Package_Attributes.First);
 147
 148       while Initialisation_Data (Start) /= '#' loop
 149          Is_An_Attribute := True;
 150          case Initialisation_Data (Start) is
 151             when 'P' =>
 152
 153                --  New allowed package
 154
 155                Start := Start + 1;
 156
 157                Finish := Start;
 158                while Initialisation_Data (Finish) /= '#' loop
 159                   Finish := Finish + 1;
 160                end loop;
 161
 162                Name_Len := Finish - Start;
 163                Name_Buffer (1 .. Name_Len) :=
 164                  To_Lower (Initialisation_Data (Start .. Finish - 1));
 165                Package_Name := Name_Find;
 166
 167                for Index in Package_First .. Package_Attributes.Last loop
 168                   if Package_Name = Package_Attributes.Table (Index).Name then
 169                      Write_Line ("Duplicate package name """ &
 170                                  Initialisation_Data (Start .. Finish - 1) &
 171                                  """ in Prj.Attr body.");
 172                      raise Program_Error;
 173                   end if;
 174                end loop;
 175
 176                Is_An_Attribute := False;
 177                Current_Attribute := Empty_Attribute;
 178                Package_Attributes.Increment_Last;
 179                Current_Package := Package_Attributes.Last;
 180                Package_Attributes.Table (Current_Package).Name :=
 181                  Package_Name;
 182                Start := Finish + 1;
 183
 184             when 'S' =>
 185                Kind_1 := Single;
 186
 187             when 'L' =>
 188                Kind_1 := List;
 189
 190             when others =>
 191                raise Program_Error;
 192          end case;
 193
 194          if Is_An_Attribute then
 195
 196             --  New attribute
 197
 198             Start := Start + 1;
 199             case Initialisation_Data (Start) is
 200                when 'V' =>
 201                   Kind_2 := Single;
 202                when 'A' =>
 203                   Kind_2 := Associative_Array;
 204                when 'a' =>
 205                   Kind_2 := Case_Insensitive_Associative_Array;
 206                when others =>
 207                   raise Program_Error;
 208             end case;
 209
 210             Start := Start + 1;
 211             Finish := Start;
 212
 213             while Initialisation_Data (Finish) /= '#' loop
 214                Finish := Finish + 1;
 215             end loop;
 216
 217             Name_Len := Finish - Start;
 218             Name_Buffer (1 .. Name_Len) :=
 219               To_Lower (Initialisation_Data (Start .. Finish - 1));
 220             Attribute_Name := Name_Find;
 221             Attributes.Increment_Last;
 222             if Current_Attribute = Empty_Attribute then
 223                First_Attribute := Attributes.Last;
 224
 225                if Current_Package /= Empty_Package then
 226                   Package_Attributes.Table (Current_Package).First_Attribute
 227                     := Attributes.Last;
 228                end if;
 229
 230             else
 231                --  Check that there are no duplicate attributes
 232
 233                for Index in First_Attribute .. Attributes.Last - 1 loop
 234                   if Attribute_Name =
 235                     Attributes.Table (Index).Name then
 236                      Write_Line ("Duplicate attribute name """ &
 237                                  Initialisation_Data (Start .. Finish - 1) &
 238                                  """ in Prj.Attr body.");
 239                      raise Program_Error;
 240                   end if;
 241                end loop;
 242
 243                Attributes.Table (Current_Attribute).Next :=
 244                  Attributes.Last;
 245             end if;
 246
 247             Current_Attribute := Attributes.Last;
 248             Attributes.Table (Current_Attribute) :=
 249               (Name    => Attribute_Name,
 250                Kind_1  => Kind_1,
 251                Kind_2  => Kind_2,
 252                Next    => Empty_Attribute);
 253             Start := Finish + 1;
 254          end if;
 255       end loop;
 256    end Initialize;
 257
 258 end Prj.Attr;