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-2004 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 Osint;     use Osint;
  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    --    's' for Single with optional index
  43    --    'L' for List
  44    --    'l' for List of strings with optional indexes
  45
  46    --  The second letter is one of
  47    --    'V' for single variable
  48    --    'A' for associative array
  49    --    'a' for case insensitive associative array
  50    --    'b' for associative array, case insensitive if file names are case
  51    --        insensitive
  52    --    'c' same as 'b', with optional index
  53
  54    --  End is indicated by two consecutive '#'.
  55
  56    Initialization_Data : constant String :=
  57
  58    --  project attributes
  59
  60      "SVobject_dir#" &
  61      "SVexec_dir#" &
  62      "LVsource_dirs#" &
  63      "LVsource_files#" &
  64      "LVlocally_removed_files#" &
  65      "SVsource_list_file#" &
  66      "SVlibrary_dir#" &
  67      "SVlibrary_name#" &
  68      "SVlibrary_kind#" &
  69      "SVlibrary_version#" &
  70      "LVlibrary_interface#" &
  71      "SVlibrary_auto_init#" &
  72      "LVlibrary_options#" &
  73      "SVlibrary_src_dir#" &
  74      "SVlibrary_gcc#" &
  75      "SVlibrary_symbol_file#" &
  76      "SVlibrary_symbol_policy#" &
  77      "SVlibrary_reference_symbol_file#" &
  78      "lVmain#" &
  79      "LVlanguages#" &
  80      "SVmain_language#" &
  81
  82    --  package Naming
  83
  84      "Pnaming#" &
  85      "Saspecification_suffix#" &
  86      "Saspec_suffix#" &
  87      "Saimplementation_suffix#" &
  88      "Sabody_suffix#" &
  89      "SVseparate_suffix#" &
  90      "SVcasing#" &
  91      "SVdot_replacement#" &
  92      "sAspecification#" &
  93      "sAspec#" &
  94      "sAimplementation#" &
  95      "sAbody#" &
  96      "Laspecification_exceptions#" &
  97      "Laimplementation_exceptions#" &
  98
  99    --  package Compiler
 100
 101      "Pcompiler#" &
 102      "Ladefault_switches#" &
 103      "Lcswitches#" &
 104      "SVlocal_configuration_pragmas#" &
 105
 106    --  package Builder
 107
 108      "Pbuilder#" &
 109      "Ladefault_switches#" &
 110      "Lcswitches#" &
 111      "Scexecutable#" &
 112      "SVexecutable_suffix#" &
 113      "SVglobal_configuration_pragmas#" &
 114
 115    --  package gnatls
 116
 117      "Pgnatls#" &
 118      "LVswitches#" &
 119
 120    --  package Binder
 121
 122      "Pbinder#" &
 123      "Ladefault_switches#" &
 124      "Lcswitches#" &
 125
 126    --  package Linker
 127
 128      "Plinker#" &
 129      "Ladefault_switches#" &
 130      "Lcswitches#" &
 131      "LVlinker_options#" &
 132
 133    --  package Cross_Reference
 134
 135      "Pcross_reference#" &
 136      "Ladefault_switches#" &
 137      "Lbswitches#" &
 138
 139    --  package Finder
 140
 141      "Pfinder#" &
 142      "Ladefault_switches#" &
 143      "Lbswitches#" &
 144
 145    --  package Pretty_Printer
 146
 147      "Ppretty_printer#" &
 148      "Ladefault_switches#" &
 149      "Lbswitches#" &
 150
 151    --  package gnatstub
 152
 153      "Pgnatstub#" &
 154      "Ladefault_switches#" &
 155      "Lbswitches#" &
 156
 157    --  package Eliminate
 158
 159      "Peliminate#" &
 160      "Ladefault_switches#" &
 161      "Lbswitches#" &
 162
 163    --  package Metrics
 164
 165      "Pmetrics#" &
 166      "Ladefault_switches#" &
 167      "Lbswitches#" &
 168
 169    --  package Ide
 170
 171      "Pide#" &
 172      "Ladefault_switches#" &
 173      "SVremote_host#" &
 174      "SVprogram_host#" &
 175      "SVcommunication_protocol#" &
 176      "Sacompiler_command#" &
 177      "SVdebugger_command#" &
 178      "SVgnatlist#" &
 179      "SVvcs_kind#" &
 180      "SVvcs_file_check#" &
 181      "SVvcs_log_check#" &
 182
 183      "#";
 184
 185    ----------------
 186    -- Initialize --
 187    ----------------
 188
 189    procedure Initialize is
 190       Start             : Positive           := Initialization_Data'First;
 191       Finish            : Positive           := Start;
 192       Current_Package   : Package_Node_Id    := Empty_Package;
 193       Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
 194       Is_An_Attribute   : Boolean            := False;
 195       Kind_1            : Variable_Kind      := Undefined;
 196       Optional_Index    : Boolean            := False;
 197       Kind_2            : Attribute_Kind     := Single;
 198       Package_Name      : Name_Id            := No_Name;
 199       Attribute_Name    : Name_Id            := No_Name;
 200       First_Attribute   : Attribute_Node_Id  := Attribute_First;
 201
 202    begin
 203       --  Make sure the two tables are empty
 204
 205       Attributes.Init;
 206       Package_Attributes.Init;
 207
 208       while Initialization_Data (Start) /= '#' loop
 209          Is_An_Attribute := True;
 210          case Initialization_Data (Start) is
 211             when 'P' =>
 212
 213                --  New allowed package
 214
 215                Start := Start + 1;
 216
 217                Finish := Start;
 218                while Initialization_Data (Finish) /= '#' loop
 219                   Finish := Finish + 1;
 220                end loop;
 221
 222                Name_Len := Finish - Start;
 223                Name_Buffer (1 .. Name_Len) :=
 224                  To_Lower (Initialization_Data (Start .. Finish - 1));
 225                Package_Name := Name_Find;
 226
 227                for Index in Package_First .. Package_Attributes.Last loop
 228                   if Package_Name = Package_Attributes.Table (Index).Name then
 229                      Write_Line ("Duplicate package name """ &
 230                                  Initialization_Data (Start .. Finish - 1) &
 231                                  """ in Prj.Attr body.");
 232                      raise Program_Error;
 233                   end if;
 234                end loop;
 235
 236                Is_An_Attribute := False;
 237                Current_Attribute := Empty_Attribute;
 238                Package_Attributes.Increment_Last;
 239                Current_Package := Package_Attributes.Last;
 240                Package_Attributes.Table (Current_Package).Name :=
 241                  Package_Name;
 242                Start := Finish + 1;
 243
 244             when 'S' =>
 245                Kind_1         := Single;
 246                Optional_Index := False;
 247
 248             when 's' =>
 249                Kind_1         := Single;
 250                Optional_Index := True;
 251
 252             when 'L' =>
 253                Kind_1         := List;
 254                Optional_Index := False;
 255
 256             when 'l' =>
 257                Kind_1         := List;
 258                Optional_Index := True;
 259
 260             when others =>
 261                raise Program_Error;
 262          end case;
 263
 264          if Is_An_Attribute then
 265
 266             --  New attribute
 267
 268             Start := Start + 1;
 269             case Initialization_Data (Start) is
 270                when 'V' =>
 271                   Kind_2 := Single;
 272
 273                when 'A' =>
 274                   Kind_2 := Associative_Array;
 275
 276                when 'a' =>
 277                   Kind_2 := Case_Insensitive_Associative_Array;
 278
 279                when 'b' =>
 280                   if File_Names_Case_Sensitive then
 281                      Kind_2 := Associative_Array;
 282                   else
 283                      Kind_2 := Case_Insensitive_Associative_Array;
 284                   end if;
 285
 286                when 'c' =>
 287                   if File_Names_Case_Sensitive then
 288                      Kind_2 := Optional_Index_Associative_Array;
 289                   else
 290                      Kind_2 :=
 291                        Optional_Index_Case_Insensitive_Associative_Array;
 292                   end if;
 293
 294                when others =>
 295                   raise Program_Error;
 296             end case;
 297
 298             Start := Start + 1;
 299             Finish := Start;
 300
 301             while Initialization_Data (Finish) /= '#' loop
 302                Finish := Finish + 1;
 303             end loop;
 304
 305             Name_Len := Finish - Start;
 306             Name_Buffer (1 .. Name_Len) :=
 307               To_Lower (Initialization_Data (Start .. Finish - 1));
 308             Attribute_Name := Name_Find;
 309             Attributes.Increment_Last;
 310
 311             if Current_Attribute = Empty_Attribute then
 312                First_Attribute := Attributes.Last;
 313
 314                if Current_Package /= Empty_Package then
 315                   Package_Attributes.Table (Current_Package).First_Attribute
 316                     := Attributes.Last;
 317                end if;
 318
 319             else
 320                --  Check that there are no duplicate attributes
 321
 322                for Index in First_Attribute .. Attributes.Last - 1 loop
 323                   if Attribute_Name =
 324                     Attributes.Table (Index).Name then
 325                      Write_Line ("Duplicate attribute name """ &
 326                                  Initialization_Data (Start .. Finish - 1) &
 327                                  """ in Prj.Attr body.");
 328                      raise Program_Error;
 329                   end if;
 330                end loop;
 331
 332                Attributes.Table (Current_Attribute).Next :=
 333                  Attributes.Last;
 334             end if;
 335
 336             Current_Attribute := Attributes.Last;
 337             Attributes.Table (Current_Attribute) :=
 338               (Name           => Attribute_Name,
 339                Kind_1         => Kind_1,
 340                Optional_Index => Optional_Index,
 341                Kind_2         => Kind_2,
 342                Next           => Empty_Attribute);
 343             Start := Finish + 1;
 344          end if;
 345       end loop;
 346    end Initialize;
 347
 348 end Prj.Attr;