Patchwork [Ada] String list external references in project files

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 8, 2010, 10:22 a.m.
Message ID <20101008102240.GA21944@adacore.com>
Download mbox | patch
Permalink /patch/67160/
State New
Headers show

Comments

Arnaud Charlet - Oct. 8, 2010, 10:22 a.m.
A new reserved word external_as_list is added to the project language, to
get string list from the environment or the command line. It takes two
parameters: the external name and the separator.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-08  Vincent Celier  <celier@adacore.com>

	* ali-util.adb (Get_File_Checksum): Make sure that external_as_list is
	not a reserved word.
	* prj-proc.adb (Expression): Process string list external references.
	* prj-strt.adb (External_Reference): Parse external_as_list external
	references.
	* prj-tree.ads (Expression_Kind_Of): Allowed for N_External_Value nodes
	(Set_Expression_Kind_Of): Ditto
	* prj.adb (Initialize): Set external_as_list as a reserved word
	* projects.texi: Document new string external reference external_as_list
	* scans.ads (Token_Type): New token Tok_External_As_List
	* snames.ads-tmpl: New standard name Name_External_As_List

Patch

Index: prj-proc.adb
===================================================================
--- prj-proc.adb	(revision 165080)
+++ prj-proc.adb	(working copy)
@@ -33,6 +33,8 @@  with Prj.Ext;  use Prj.Ext;
 with Prj.Nmsc; use Prj.Nmsc;
 with Snames;
 
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+
 with GNAT.Case_Util; use GNAT.Case_Util;
 with GNAT.HTable;
 
@@ -1021,15 +1023,17 @@  package body Prj.Proc is
                      From_Project_Node_Tree));
 
                declare
-                  Name    : constant Name_Id  := Name_Find;
-                  Default : Name_Id           := No_Name;
-                  Value   : Name_Id           := No_Name;
-
-                  Def_Var : Variable_Value;
+                  Name     : constant Name_Id   := Name_Find;
+                  Default  : Name_Id            := No_Name;
+                  Value    : Name_Id            := No_Name;
+                  Ext_List : Boolean            := False;
+                  Str_List : String_List_Access := null;
+                  Def_Var  : Variable_Value;
 
                   Default_Node : constant Project_Node_Id :=
-                    External_Default_Of
-                      (The_Current_Term, From_Project_Node_Tree);
+                                   External_Default_Of
+                                     (The_Current_Term,
+                                      From_Project_Node_Tree);
 
                begin
                   --  If there is a default value for the external reference,
@@ -1053,19 +1057,132 @@  package body Prj.Proc is
                      end if;
                   end if;
 
-                  Value :=
-                    Prj.Ext.Value_Of (From_Project_Node_Tree, Name, Default);
+                  Ext_List := Expression_Kind_Of
+                               (The_Current_Term,
+                                From_Project_Node_Tree) = List;
+
+                  if Ext_List then
+                     Value :=
+                       Prj.Ext.Value_Of
+                         (From_Project_Node_Tree, Name, No_Name);
 
-                  if Value = No_Name then
-                     if not Quiet_Output then
-                        Error_Msg
-                          (Flags, "?undefined external reference",
-                           Location_Of
-                             (The_Current_Term, From_Project_Node_Tree),
-                           Project);
+                     if Value /= No_Name then
+                        declare
+                           Sep   : constant String :=
+                                     Get_Name_String (Default);
+                           First : Positive := 1;
+                           Lst   : Natural;
+                           Done  : Boolean := False;
+                           Nmb   : Natural;
+
+                        begin
+                           Get_Name_String (Value);
+
+                           if Name_Len = 0
+                             or else Sep'Length = 0
+                             or else Name_Buffer (1 .. Name_Len) = Sep
+                           then
+                              Done := True;
+                           end if;
+
+                           if not Done and then Name_Len < Sep'Length then
+                              Str_List :=
+                                new String_List'
+                                  (1 => new String'
+                                       (Name_Buffer (1 .. Name_Len)));
+                              Done := True;
+                           end if;
+
+                           if not Done then
+                              if Name_Buffer (1 .. Sep'Length) = Sep then
+                                 First := Sep'Length + 1;
+                              end if;
+
+                              if Name_Len - First + 1 >= Sep'Length
+                                and then
+                                  Name_Buffer (Name_Len - Sep'Length + 1 ..
+                                                   Name_Len) = Sep
+                              then
+                                 Name_Len := Name_Len - Sep'Length;
+                              end if;
+
+                              if Name_Len = 0 then
+                                 Str_List :=
+                                   new String_List'(1 => new String'(""));
+                                 Done := True;
+                              end if;
+                           end if;
+
+                           if not Done then
+                              --  Count the number of string
+
+                              declare
+                                 Saved : constant Positive := First;
+                              begin
+
+                                 Nmb := 1;
+                                 loop
+                                    Lst :=
+                                      Index
+                                        (Source  =>
+                                             Name_Buffer (First .. Name_Len),
+                                         Pattern => Sep);
+                                    exit when Lst = 0;
+                                    Nmb := Nmb + 1;
+                                    First := Lst + Sep'Length;
+                                 end loop;
+
+                                 First := Saved;
+                              end;
+
+                              Str_List := new String_List (1 .. Nmb);
+
+                              --  Populate the string list
+
+                              Nmb := 1;
+                              loop
+                                 Lst :=
+                                   Index
+                                     (Source  =>
+                                          Name_Buffer (First .. Name_Len),
+                                      Pattern => Sep);
+
+                                 if Lst = 0 then
+                                    Str_List (Nmb) :=
+                                      new String'
+                                        (Name_Buffer (First .. Name_Len));
+                                    exit;
+
+                                 else
+                                    Str_List (Nmb) :=
+                                      new String'
+                                        (Name_Buffer (First .. Lst - 1));
+                                    Nmb := Nmb + 1;
+                                    First := Lst + Sep'Length;
+                                 end if;
+                              end loop;
+                           end if;
+                        end;
                      end if;
 
-                     Value := Empty_String;
+                  else
+                     --  Get the value
+
+                     Value :=
+                       Prj.Ext.Value_Of
+                         (From_Project_Node_Tree, Name, Default);
+
+                     if Value = No_Name then
+                        if not Quiet_Output then
+                           Error_Msg
+                             (Flags, "?undefined external reference",
+                              Location_Of
+                                (The_Current_Term, From_Project_Node_Tree),
+                              Project);
+                        end if;
+
+                        Value := Empty_String;
+                     end if;
                   end if;
 
                   case Kind is
@@ -1074,34 +1191,75 @@  package body Prj.Proc is
                         null;
 
                      when Single =>
-                        Add (Result.Value, Value);
+                        if Ext_List then
+                           null; -- error
 
-                     when List =>
-                        String_Element_Table.Increment_Last
-                          (In_Tree.String_Elements);
+                        else
+                           Add (Result.Value, Value);
+                        end if;
 
-                        if Last = Nil_String then
-                           Result.Values := String_Element_Table.Last
+                     when List =>
+                        if not Ext_List or else Str_List /= null then
+                           String_Element_Table.Increment_Last
                              (In_Tree.String_Elements);
 
-                        else
-                           In_Tree.String_Elements.Table
-                             (Last).Next := String_Element_Table.Last
-                                       (In_Tree.String_Elements);
-                        end if;
+                           if Last = Nil_String then
+                              Result.Values :=
+                                String_Element_Table.Last
+                                  (In_Tree.String_Elements);
 
-                        Last := String_Element_Table.Last
+                           else
+                              In_Tree.String_Elements.Table (Last).Next :=
+                                String_Element_Table.Last
                                   (In_Tree.String_Elements);
-                        In_Tree.String_Elements.Table (Last) :=
-                          (Value    => Value,
-                           Display_Value => No_Name,
-                           Location      =>
-                             Location_Of
-                               (The_Current_Term, From_Project_Node_Tree),
-                           Flag     => False,
-                           Next     => Nil_String,
-                           Index    => 0);
+                           end if;
 
+                           Last :=
+                             String_Element_Table.Last
+                               (In_Tree.String_Elements);
+
+                           if Ext_List then
+                              for Ind in Str_List'Range loop
+                                 Name_Len := 0;
+                                 Add_Str_To_Name_Buffer (Str_List (Ind).all);
+                                 Value := Name_Find;
+                                 In_Tree.String_Elements.Table (Last) :=
+                                   (Value         => Value,
+                                    Display_Value => No_Name,
+                                    Location      =>
+                                      Location_Of
+                                        (The_Current_Term,
+                                         From_Project_Node_Tree),
+                                    Flag          => False,
+                                    Next          => Nil_String,
+                                    Index         => 0);
+
+                                 if Ind /= Str_List'Last then
+                                    String_Element_Table.Increment_Last
+                                      (In_Tree.String_Elements);
+                                    In_Tree.String_Elements.Table
+                                                              (Last).Next :=
+                                        String_Element_Table.Last
+                                          (In_Tree.String_Elements);
+                                    Last :=
+                                      String_Element_Table.Last
+                                        (In_Tree.String_Elements);
+                                 end if;
+                              end loop;
+
+                           else
+                              In_Tree.String_Elements.Table (Last) :=
+                                (Value         => Value,
+                                 Display_Value => No_Name,
+                                 Location      =>
+                                   Location_Of
+                                     (The_Current_Term,
+                                      From_Project_Node_Tree),
+                                 Flag          => False,
+                                 Next          => Nil_String,
+                                 Index         => 0);
+                           end if;
+                        end if;
                   end case;
                end;
 
Index: ali-util.adb
===================================================================
--- ali-util.adb	(revision 165080)
+++ ali-util.adb	(working copy)
@@ -155,9 +155,10 @@  package body ALI.Util is
       --  recognized as reserved words, but as identifiers. The byte info for
       --  those names have been set if we are in gnatmake.
 
-      Set_Name_Table_Byte (Name_Project,  0);
-      Set_Name_Table_Byte (Name_Extends,  0);
-      Set_Name_Table_Byte (Name_External, 0);
+      Set_Name_Table_Byte (Name_Project,          0);
+      Set_Name_Table_Byte (Name_Extends,          0);
+      Set_Name_Table_Byte (Name_External,         0);
+      Set_Name_Table_Byte (Name_External_As_List, 0);
 
       --  Scan the complete file to compute its checksum
 
Index: prj-strt.adb
===================================================================
--- prj-strt.adb	(revision 165080)
+++ prj-strt.adb	(working copy)
@@ -109,6 +109,7 @@  package body Prj.Strt is
       Current_Project : Project_Node_Id;
       Current_Package : Project_Node_Id;
       External_Value  : out Project_Node_Id;
+      Expr_Kind       : in out Variable_Kind;
       Flags           : Processing_Flags);
    --  Parse an external reference. Current token is "external"
 
@@ -368,23 +369,38 @@  package body Prj.Strt is
       Current_Project : Project_Node_Id;
       Current_Package : Project_Node_Id;
       External_Value  : out Project_Node_Id;
+      Expr_Kind       : in out Variable_Kind;
       Flags           : Processing_Flags)
    is
       Field_Id : Project_Node_Id := Empty_Node;
+      Ext_List : Boolean         := False;
 
    begin
       External_Value :=
         Default_Project_Node
           (Of_Kind       => N_External_Value,
-           In_Tree       => In_Tree,
-           And_Expr_Kind => Single);
+           In_Tree       => In_Tree);
       Set_Location_Of (External_Value, In_Tree, To => Token_Ptr);
 
-      --  The current token is External
-
-      --  Get the left parenthesis
+      --  The current token is either external or external_as_list
 
+      Ext_List := Token = Tok_External_As_List;
       Scan (In_Tree);
+
+      if Ext_List then
+         Set_Expression_Kind_Of (External_Value, In_Tree, To => List);
+      else
+         Set_Expression_Kind_Of (External_Value, In_Tree, To => Single);
+      end if;
+
+      if Expr_Kind = Undefined then
+         if Ext_List then
+            Expr_Kind := List;
+         else
+            Expr_Kind := Single;
+         end if;
+      end if;
+
       Expect (Tok_Left_Paren, "`(`");
 
       --  Scan past the left parenthesis
@@ -413,6 +429,10 @@  package body Prj.Strt is
          case Token is
 
             when Tok_Right_Paren =>
+               if Ext_List then
+                  Error_Msg (Flags, "`,` expected", Token_Ptr);
+               end if;
+
                Scan (In_Tree); -- scan past right paren
 
             when Tok_Comma =>
@@ -448,7 +468,11 @@  package body Prj.Strt is
                end if;
 
             when others =>
-               Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);
+               if Ext_List then
+                  Error_Msg (Flags, "`,` expected", Token_Ptr);
+               else
+                  Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);
+               end if;
          end case;
       end if;
    end External_Reference;
@@ -1493,19 +1517,13 @@  package body Prj.Strt is
                end if;
             end if;
 
-         when Tok_External =>
-
-            --  An external reference is always a single string
-
-            if Expr_Kind = Undefined then
-               Expr_Kind := Single;
-            end if;
-
+         when Tok_External | Tok_External_As_List  =>
             External_Reference
               (In_Tree         => In_Tree,
                Flags           => Flags,
                Current_Project => Current_Project,
                Current_Package => Current_Package,
+               Expr_Kind       => Expr_Kind,
                External_Value  => Reference);
             Set_Current_Term (Term, In_Tree, To => Reference);
 
Index: prj.adb
===================================================================
--- prj.adb	(revision 165084)
+++ prj.adb	(working copy)
@@ -620,9 +620,15 @@  package body Prj is
          The_Empty_String := Name_Find;
 
          Prj.Attr.Initialize;
-         Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
-         Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
-         Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
+
+         Set_Name_Table_Byte
+           (Name_Project,          Token_Type'Pos (Tok_Project));
+         Set_Name_Table_Byte
+           (Name_Extends,          Token_Type'Pos (Tok_Extends));
+         Set_Name_Table_Byte
+           (Name_External,         Token_Type'Pos (Tok_External));
+         Set_Name_Table_Byte
+           (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
       end if;
 
       if Tree /= No_Project_Tree then
Index: scans.ads
===================================================================
--- scans.ads	(revision 165080)
+++ scans.ads	(working copy)
@@ -192,7 +192,8 @@  package Scans is
       Tok_Project,
       Tok_Extends,
       Tok_External,
-      --  These three entries represent keywords for the project file language
+      Tok_External_As_List,
+      --  These four entries represent keywords for the project file language
       --  and can be returned only in the case of scanning project files.
 
       Tok_Comment,
Index: projects.texi
===================================================================
--- projects.texi	(revision 165080)
+++ projects.texi	(working copy)
@@ -2515,6 +2515,11 @@  An external value is an expression whose
 that invoked the processing of the current project file (typically a
 gnatmake or gprbuild command).
 
+There are two kinds of external values, one that returns a single string, and
+one that returns a string list.
+
+The syntax of a single string external value is:
+
 @smallexample
 external_value ::= @i{external} ( string_literal [, string_literal] )
 @end smallexample
@@ -2532,7 +2537,7 @@  or be specified on the command line thro
 are specified, then the command line value is used, so that a user can more
 easily override the value.
 
-The function @code{external} always returns a string, possibly empty if the
+The function @code{external} always returns a string. It is an error if the
 value was not found in the environment and no default was specified in the
 call to @code{external}.
 
@@ -2545,6 +2550,42 @@  are then used in @b{case} statements to 
 attributes in various scenarios. Thus such variables are often called
 @b{scenario variables}.
 
+The syntax for a string list external value is:
+
+@smallexample
+external_value ::= @i{external_as_list} ( string_literal , string_literal )
+@end smallexample
+
+@noindent
+The first string_literal is the string to be used on the command line or
+in the environment to specify the external value. The second string_literal is
+the separator between each component of the string list.
+
+If the external value does not exist in the environment or on the command line,
+the result is an empty list. This is also the case, if the separator is an
+empty string or if the external value is only one separator.
+
+Any separator at the beginning or at the end of the external value is
+discarded. Then, if there is no separator in the external vaue, the result is
+a string list with only one string. Otherwise, any string between the biginning
+and the first separator, between two consecutive separators and between the
+last separator and the end are components of the string list.
+
+@smallexample
+   @i{external_as_list} ("SWITCHES", ",")
+@end smallexample
+
+@noindent
+If the external value is "-O2,-g", the result is ("-O2", "-g").
+
+If the external value is ",-O2,-g,", the result is also ("-O2", "-g").
+
+if the external value is "-gnav", the result is ("-gnatv").
+
+If the external value is ",,", the result is ("").
+
+If the external value is ",", the result is (), the empty string list.
+
 @c ---------------------------------------------
 @node Typed String Declaration
 @subsection Typed String Declaration
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 165154)
+++ snames.ads-tmpl	(working copy)
@@ -1063,6 +1063,7 @@  package Snames is
    Name_Executable                       : constant Name_Id := N + $;
    Name_Executable_Suffix                : constant Name_Id := N + $;
    Name_Extends                          : constant Name_Id := N + $;
+   Name_External_As_List                 : constant Name_Id := N + $;
    Name_Externally_Built                 : constant Name_Id := N + $;
    Name_Finder                           : constant Name_Id := N + $;
    Name_Global_Compilation_Switches      : constant Name_Id := N + $;
Index: prj-tree.adb
===================================================================
--- prj-tree.adb	(revision 165080)
+++ prj-tree.adb	(working copy)
@@ -559,11 +559,12 @@  package body Prj.Tree is
 
    function Expression_Kind_Of
      (Node    : Project_Node_Id;
-      In_Tree : Project_Node_Tree_Ref) return Variable_Kind is
+      In_Tree : Project_Node_Tree_Ref) return Variable_Kind
+   is
    begin
       pragma Assert
         (Present (Node)
-           and then
+           and then -- should use Nkind_In here ??? why not???
              (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
@@ -571,7 +572,7 @@  package body Prj.Tree is
               In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind =
-                       N_Typed_Variable_Declaration
+                                                  N_Typed_Variable_Declaration
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
                 or else
@@ -581,9 +582,9 @@  package body Prj.Tree is
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
                 or else
-              In_Tree.Project_Nodes.Table (Node).Kind =
-                        N_Attribute_Reference));
-
+              In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
+                or else
+              In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
       return In_Tree.Project_Nodes.Table (Node).Expr_Kind;
    end Expression_Kind_Of;
 
@@ -1837,7 +1838,7 @@  package body Prj.Tree is
    begin
       pragma Assert
         (Present (Node)
-           and then
+           and then -- should use Nkind_In here ??? why not???
              (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
@@ -1845,7 +1846,7 @@  package body Prj.Tree is
               In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind =
-                N_Typed_Variable_Declaration
+                                                  N_Typed_Variable_Declaration
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
                 or else
@@ -1855,8 +1856,9 @@  package body Prj.Tree is
                 or else
               In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
                 or else
-              In_Tree.Project_Nodes.Table (Node).Kind =
-                N_Attribute_Reference));
+              In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
+                or else
+              In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
       In_Tree.Project_Nodes.Table (Node).Expr_Kind := To;
    end Set_Expression_Kind_Of;
 
Index: prj-tree.ads
===================================================================
--- prj-tree.ads	(revision 165080)
+++ prj-tree.ads	(working copy)
@@ -296,7 +296,8 @@  package Prj.Tree is
    pragma Inline (Expression_Kind_Of);
    --  Only valid for N_Literal_String, N_Attribute_Declaration,
    --  N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-   --  N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+   --  N_Term, N_Variable_Reference, N_Attribute_Reference nodes or
+   --  N_External_Value.
 
    function Is_Extending_All
      (Node    : Project_Node_Id;
@@ -759,7 +760,8 @@  package Prj.Tree is
    pragma Inline (Set_Expression_Kind_Of);
    --  Only valid for N_Literal_String, N_Attribute_Declaration,
    --  N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-   --  N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+   --  N_Term, N_Variable_Reference, N_Attribute_Reference or N_External_Value
+   --  nodes.
 
    procedure Set_Is_Extending_All
      (Node    : Project_Node_Id;