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: 1.4 $
  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    --  Package names are preceded by 'P'
  37    --  Attribute names are preceded by two capital letters:
  38    --    'S' for Single or 'L' for list, then
  39    --    'V' for single variable, 'A' for associative array, or 'B' for both.
  40    --  End is indicated by two consecutive '#'.
  41
  42    Initialisation_Data : constant String :=
  43
  44    --  project attributes
  45
  46      "SVobject_dir#" &
  47      "LVsource_dirs#" &
  48      "LVsource_files#" &
  49      "SVsource_list_file#" &
  50      "SVlibrary_dir#" &
  51      "SVlibrary_name#" &
  52      "SVlibrary_kind#" &
  53      "SVlibrary_elaboration#" &
  54      "SVlibrary_version#" &
  55      "LVmain#" &
  56
  57    --  package Naming
  58
  59      "Pnaming#" &
  60      "SVspecification_append#" &
  61      "SVbody_append#" &
  62      "SVseparate_append#" &
  63      "SVcasing#" &
  64      "SVdot_replacement#" &
  65      "SAspecification#" &
  66      "SAbody_part#" &
  67
  68    --  package Compiler
  69
  70      "Pcompiler#" &
  71      "LBswitches#" &
  72      "SVlocal_configuration_pragmas#" &
  73
  74    --  package gnatmake
  75
  76      "Pgnatmake#" &
  77      "LBswitches#" &
  78      "SVglobal_configuration_pragmas#" &
  79
  80    --  package gnatls
  81
  82      "Pgnatls#" &
  83      "LVswitches#" &
  84
  85    --  package gnatbind
  86
  87      "Pgnatbind#" &
  88      "LBswitches#" &
  89
  90    --  package gnatlink
  91
  92      "Pgnatlink#" &
  93      "LBswitches#" &
  94
  95      "#";
  96
  97    ----------------
  98    -- Initialize --
  99    ----------------
 100
 101    procedure Initialize is
 102       Start             : Positive           := Initialisation_Data'First;
 103       Finish            : Positive           := Start;
 104       Current_Package   : Package_Node_Id    := Empty_Package;
 105       Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
 106       Is_An_Attribute   : Boolean            := False;
 107       Kind_1            : Variable_Kind      := Undefined;
 108       Kind_2            : Attribute_Kind     := Single;
 109       Package_Name      : Name_Id            := No_Name;
 110       Attribute_Name    : Name_Id            := No_Name;
 111       First_Attribute   : Attribute_Node_Id  := Attribute_First;
 112    begin
 113
 114       --  Make sure the two tables are empty
 115
 116       Attributes.Set_Last (Attributes.First);
 117       Package_Attributes.Set_Last (Package_Attributes.First);
 118
 119       while Initialisation_Data (Start) /= '#' loop
 120          Is_An_Attribute := True;
 121          case Initialisation_Data (Start) is
 122             when 'P' =>
 123                --  New allowed package
 124                Start := Start + 1;
 125                Finish := Start;
 126                while Initialisation_Data (Finish) /= '#' loop
 127                   Finish := Finish + 1;
 128                end loop;
 129                Name_Len := Finish - Start;
 130                Name_Buffer (1 .. Name_Len) :=
 131                  To_Lower (Initialisation_Data (Start .. Finish - 1));
 132                Package_Name := Name_Find;
 133                for Index in Package_First .. Package_Attributes.Last loop
 134                   if Package_Name = Package_Attributes.Table (Index).Name then
 135                      Write_Line ("Duplicate package name """ &
 136                                  Initialisation_Data (Start .. Finish - 1) &
 137                                  """ in Prj.Attr body.");
 138                      raise Program_Error;
 139                   end if;
 140                end loop;
 141
 142                Is_An_Attribute := False;
 143                Current_Attribute := Empty_Attribute;
 144                Package_Attributes.Increment_Last;
 145                Current_Package := Package_Attributes.Last;
 146                Package_Attributes.Table (Current_Package).Name :=
 147                  Package_Name;
 148                Start := Finish + 1;
 149             when 'S' =>
 150                Kind_1 := Single;
 151             when 'L' =>
 152                Kind_1 := List;
 153             when others =>
 154                raise Program_Error;
 155          end case;
 156
 157          if Is_An_Attribute then
 158             --  New attribute
 159             Start := Start + 1;
 160             case Initialisation_Data (Start) is
 161                when 'V' =>
 162                   Kind_2 := Single;
 163                when 'A' =>
 164                   Kind_2 := Associative_Array;
 165                when 'B' =>
 166                   Kind_2 := Both;
 167                when others =>
 168                   raise Program_Error;
 169             end case;
 170             Start := Start + 1;
 171             Finish := Start;
 172             while Initialisation_Data (Finish) /= '#' loop
 173                Finish := Finish + 1;
 174             end loop;
 175             Name_Len := Finish - Start;
 176             Name_Buffer (1 .. Name_Len) :=
 177               To_Lower (Initialisation_Data (Start .. Finish - 1));
 178             Attribute_Name := Name_Find;
 179             Attributes.Increment_Last;
 180             if Current_Attribute = Empty_Attribute then
 181                First_Attribute := Attributes.Last;
 182                if Current_Package /= Empty_Package then
 183                   Package_Attributes.Table (Current_Package).First_Attribute
 184                     := Attributes.Last;
 185                end if;
 186             else
 187                --  Check that there are no duplicate attributes
 188                for Index in First_Attribute .. Attributes.Last - 1 loop
 189                   if Attribute_Name =
 190                     Attributes.Table (Index).Name then
 191                      Write_Line ("Duplicate attribute name """ &
 192                                  Initialisation_Data (Start .. Finish - 1) &
 193                                  """ in Prj.Attr body.");
 194                      raise Program_Error;
 195                   end if;
 196                end loop;
 197                Attributes.Table (Current_Attribute).Next :=
 198                  Attributes.Last;
 199             end if;
 200             Current_Attribute := Attributes.Last;
 201             Attributes.Table (Current_Attribute) :=
 202               (Name    => Attribute_Name,
 203                Kind_1  => Kind_1,
 204                Kind_2  => Kind_2,
 205                Next    => Empty_Attribute);
 206             Start := Finish + 1;
 207          end if;
 208       end loop;
 209    end Initialize;
 210
 211 end Prj.Attr;