Tested on x86_64-pc-linux-gnu, committed on trunk
2012-01-30 Vincent Pucci <pu...@adacore.com>
* sem_dim.adb (Expand_Put_Call_With_Dimension_Symbol): Rewritten.
* snames.ads-tmpl: Name_Item and Name_Symbols added.
* s-diflio.adb, s-diflio.ads, s-diinio.adb, s-diinio.ads: Rename
and change the position of parameter Symbols in every Put routine.
* s-dimmks.ads: Convert long float type Mks_Type into long
long float.
* s-llflex.ads: Modifications in comments.
Index: s-diinio.adb
===================================================================
--- s-diinio.adb (revision 183694)
+++ s-diinio.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,40 +38,40 @@
---------
procedure Put
- (File : File_Type;
- Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
- Base : Number_Base := Default_Base)
+ (File : File_Type;
+ Item : Num_Dim_Integer;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "")
is
begin
Num_Dim_Integer_IO.Put (File, Item, Width, Base);
- Ada.Text_IO.Put (File, Unit);
+ Ada.Text_IO.Put (File, Symbols);
end Put;
procedure Put
- (Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
- Base : Number_Base := Default_Base)
+ (Item : Num_Dim_Integer;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "")
is
begin
Num_Dim_Integer_IO.Put (Item, Width, Base);
- Ada.Text_IO.Put (Unit);
+ Ada.Text_IO.Put (Symbols);
end Put;
procedure Put
- (To : out String;
- Item : Num_Dim_Integer;
- Unit : String := "";
- Base : Number_Base := Default_Base)
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "")
is
begin
Num_Dim_Integer_IO.Put (To, Item, Base);
- To := To & Unit;
+ To := To & Symbols;
end Put;
end System.Dim_Integer_IO;
Index: s-diinio.ads
===================================================================
--- s-diinio.ads (revision 183694)
+++ s-diinio.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,23 +47,23 @@
Default_Base : Number_Base := 10;
procedure Put
- (File : File_Type;
- Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
- Base : Number_Base := Default_Base);
+ (File : File_Type;
+ Item : Num_Dim_Integer;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "");
procedure Put
- (Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
- Base : Number_Base := Default_Base);
+ (Item : Num_Dim_Integer;
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "");
procedure Put
- (To : out String;
- Item : Num_Dim_Integer;
- Unit : String := "";
- Base : Number_Base := Default_Base);
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Base : Number_Base := Default_Base;
+ Symbols : String := "");
pragma Inline (Put);
Index: sem_dim.adb
===================================================================
--- sem_dim.adb (revision 183694)
+++ sem_dim.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2160,22 +2160,64 @@
Actuals : constant List_Id := Parameter_Associations (N);
Loc : constant Source_Ptr := Sloc (N);
Name_Call : constant Node_Id := Name (N);
+ New_Actuals : constant List_Id := New_List;
Actual : Node_Id;
- Base_Typ : Node_Id;
Dims_Of_Actual : Dimension_Type;
Etyp : Entity_Id;
- First_Actual : Node_Id;
- New_Actuals : List_Id;
- New_Str_Lit : Node_Id;
+ New_Str_Lit : Node_Id := Empty;
Package_Name : Name_Id;
System : System_Type;
+ function Has_Dimension_Symbols return Boolean;
+ -- Return True if the current Put call already has a parameter
+ -- association for parameter "Symbols" with the correct string of
+ -- symbols.
+
function Is_Procedure_Put_Call return Boolean;
-- Return True if the current call is a call of an instantiation of a
-- procedure Put defined in the package System.Dim_Float_IO and
-- System.Dim_Integer_IO.
+ function Item_Actual return Node_Id;
+ -- Return the item actual parameter node in the put call
+
---------------------------
+ -- Has_Dimension_Symbols --
+ ---------------------------
+
+ function Has_Dimension_Symbols return Boolean is
+ Actual : Node_Id;
+
+ begin
+ Actual := First (Actuals);
+
+ -- Look for a symbols parameter association in the list of actuals
+
+ while Present (Actual) loop
+ if Nkind (Actual) = N_Parameter_Association
+ and then Chars (Selector_Name (Actual)) = Name_Symbols
+ then
+
+ -- return True if the actual comes from source or if the string
+ -- of symbols doesn't have the default value (i.e "").
+
+ return Comes_From_Source (Actual)
+ or else String_Length
+ (Strval
+ (Explicit_Actual_Parameter (Actual))) /= 0;
+ end if;
+
+ Next (Actual);
+ end loop;
+
+ -- At this point, the call has no parameter association
+ -- Look to the last actual since the symbols parameter is the last
+ -- one.
+
+ return Nkind (Last (Actuals)) = N_String_Literal;
+ end Has_Dimension_Symbols;
+
+ ---------------------------
-- Is_Procedure_Put_Call --
---------------------------
@@ -2214,100 +2256,116 @@
return False;
end Is_Procedure_Put_Call;
- -- Start of processing for Expand_Put_Call_With_Dimension_Symbol
+ -----------------
+ -- Item_Actual --
+ -----------------
- begin
- if Is_Procedure_Put_Call then
+ function Item_Actual return Node_Id is
+ Actual : Node_Id;
- -- Get the first parameter
+ begin
+ Actual := First (Actuals);
- First_Actual := First (Actuals);
+ -- Look for the item actual as a parameter association
- -- Case when the Put routine has four (System.Dim_Integer_IO) or five
- -- (System.Dim_Float_IO) parameters.
+ while Present (Actual) loop
+ if Nkind (Actual) = N_Parameter_Association
+ and then Chars (Selector_Name (Actual)) = Name_Item
+ then
+ return Explicit_Actual_Parameter (Actual);
+ end if;
- if List_Length (Actuals) = 5
- or else List_Length (Actuals) = 4
- then
- Actual := Next (First_Actual);
+ Next (Actual);
+ end loop;
- if Nkind (Actual) = N_Parameter_Association then
+ -- Case where the item has been defined without an association
- -- Get the dimensions and the corresponding dimension system
- -- from the first actual.
+ Actual := First (Actuals);
- Actual := First_Actual;
- end if;
+ -- Depending on the procedure Put, Item actual could be first or
+ -- second in the list of actuals.
- -- Case when the Put routine has six parameters
-
+ if Has_Dimension_System (Base_Type (Etype (Actual))) then
+ return Actual;
else
- Actual := Next (First_Actual);
+ return Next (Actual);
end if;
+ end Item_Actual;
- Base_Typ := Base_Type (Etype (Actual));
- System := System_Of (Base_Typ);
+ -- Start of processing for Expand_Put_Call_With_Dimension_Symbol
- -- Check the base type of Actual is a dimensioned type
+ begin
+ if Is_Procedure_Put_Call
+ and then not Has_Dimension_Symbols
+ then
+ Actual := Item_Actual;
+ Dims_Of_Actual := Dimensions_Of (Actual);
+ Etyp := Etype (Actual);
- if Exists (System) then
- Dims_Of_Actual := Dimensions_Of (Actual);
- Etyp := Etype (Actual);
+ -- Add the symbol as a suffix of the value if the subtype has a
+ -- dimension symbol or if the parameter is not dimensionless.
- -- Add the symbol as a suffix of the value if the subtype has a
- -- dimension symbol or if the parameter is not dimensionless.
+ if Symbol_Of (Etyp) /= No_String then
+ Start_String;
- if Exists (Dims_Of_Actual)
- or else Symbol_Of (Etyp) /= No_String
- then
- New_Actuals := New_List;
+ -- Put a space between the value and the dimension
- -- Add to the list First_Actual and Actual if they differ
+ Store_String_Char (' ');
+ Store_String_Chars (Symbol_Of (Etyp));
+ New_Str_Lit := Make_String_Literal (Loc, End_String);
- if Actual /= First_Actual then
- Append (New_Copy (First_Actual), New_Actuals);
- end if;
+ -- Check that the item is not dimensionless
+ -- Create the new String_Literal with the new String_Id generated by
+ -- the routine From_Dimension_To_String.
- Append (New_Copy (Actual), New_Actuals);
+ elsif Exists (Dims_Of_Actual) then
+ System := System_Of (Base_Type (Etyp));
+ New_Str_Lit :=
+ Make_String_Literal (Loc,
+ From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System));
+ end if;
- -- Look to the next parameter
+ if Present (New_Str_Lit) then
+ -- Insert all actuals in New_Actuals
- Next (Actual);
+ Actual := First (Actuals);
- -- Check if the type of N is a subtype that has a symbol of
- -- dimensions in Aspect_Dimension_String_Id_Hash_Table.
+ while Present (Actual) loop
+ -- Copy every comes from source actuals in New_Actuals
- if Symbol_Of (Etyp) /= No_String then
- Start_String;
+ if Comes_From_Source (Actual) then
+ if Nkind (Actual) = N_Parameter_Association then
+ Append (
+ Make_Parameter_Association (Loc,
+ Selector_Name => New_Copy (Selector_Name (Actual)),
+ Explicit_Actual_Parameter =>
+ New_Copy (Explicit_Actual_Parameter (Actual))),
+ New_Actuals);
+ else
+ Append (New_Copy (Actual), New_Actuals);
+ end if;
+ end if;
- -- Put a space between the value and the dimension
+ Next (Actual);
+ end loop;
- Store_String_Char (' ');
- Store_String_Chars (Symbol_Of (Etyp));
- New_Str_Lit := Make_String_Literal (Loc, End_String);
+ -- Create the new Symbols parameter association and append it in
+ -- New_Actuals.
- -- Rewrite the String_Literal of the second actual with the
- -- new String_Id created by the routine
- -- From_Dimension_To_String.
+ Append (
+ Make_Parameter_Association (Loc,
+ Selector_Name => Make_Identifier (Loc, Name_Symbols),
+ Explicit_Actual_Parameter => New_Str_Lit),
+ New_Actuals);
- else
- New_Str_Lit :=
- Make_String_Literal (Loc,
- From_Dimension_To_String_Of_Symbols (Dims_Of_Actual,
- System));
- end if;
+ -- Rewrite and analyze the procedure call
- Append (New_Str_Lit, New_Actuals);
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Copy (Name_Call),
+ Parameter_Associations => New_Actuals));
- -- Rewrite the procedure call with the new list of parameters
-
- Rewrite (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Copy (Name_Call),
- Parameter_Associations => New_Actuals));
-
- Analyze (N);
- end if;
+ Analyze (N);
end if;
end if;
end Expand_Put_Call_With_Dimension_Symbol;
Index: s-diflio.adb
===================================================================
--- s-diflio.adb (revision 183694)
+++ s-diflio.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,40 +38,40 @@
---------
procedure Put
- (File : File_Type;
- Item : Num_Dim_Float;
- Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ (File : File_Type;
+ Item : Num_Dim_Float;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "")
is
begin
Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp);
- Ada.Text_IO.Put (File, Unit);
+ Ada.Text_IO.Put (File, Symbols);
end Put;
procedure Put
- (Item : Num_Dim_Float;
- Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ (Item : Num_Dim_Float;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "")
is
begin
Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp);
- Ada.Text_IO.Put (Unit);
+ Ada.Text_IO.Put (Symbols);
end Put;
procedure Put
- (To : out String;
- Item : Num_Dim_Float;
- Unit : String := "";
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ (To : out String;
+ Item : Num_Dim_Float;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "")
is
begin
Num_Dim_Float_IO.Put (To, Item, Aft, Exp);
- To := To & Unit;
+ To := To & Symbols;
end Put;
end System.Dim_Float_IO;
Index: s-diflio.ads
===================================================================
--- s-diflio.ads (revision 183694)
+++ s-diflio.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,26 +48,26 @@
Default_Exp : Field := 3;
procedure Put
- (File : File_Type;
- Item : Num_Dim_Float;
- Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp);
+ (File : File_Type;
+ Item : Num_Dim_Float;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "");
procedure Put
- (Item : Num_Dim_Float;
- Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp);
+ (Item : Num_Dim_Float;
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "");
procedure Put
- (To : out String;
- Item : Num_Dim_Float;
- Unit : String := "";
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp);
+ (To : out String;
+ Item : Num_Dim_Float;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp;
+ Symbols : String := "");
pragma Inline (Put);
Index: s-dimmks.ads
===================================================================
--- s-dimmks.ads (revision 183694)
+++ s-dimmks.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,7 +44,7 @@
-- Dimensioned type Mks_Type
- type Mks_Type is new Long_Float
+ type Mks_Type is new Long_Long_Float
with
Dimension_System => ((Meter, 'm'),
(Kilogram, "kg"),
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 183698)
+++ snames.ads-tmpl (working copy)
@@ -228,7 +228,9 @@
Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12
Name_Dim_Integer_IO : constant Name_Id := N + $; -- Ada 12
Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12
+ Name_Item : constant Name_Id := N + $; -- Ada 12
Name_Sqrt : constant Name_Id := N + $; -- Ada 12
+ Name_Symbols : constant Name_Id := N + $; -- Ada 12
-- Some miscellaneous names used for error detection/recovery
Index: s-llflex.ads
===================================================================
--- s-llflex.ads (revision 183694)
+++ s-llflex.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,8 +29,8 @@
-- --
------------------------------------------------------------------------------
--- This package contains an instantiation of the functions "**" and Sqrt
--- between two long long floats.
+-- This package contains an instantiation of the exponentiation between two
+-- long long floats.
with Ada.Numerics.Long_Long_Elementary_Functions;
