diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 73 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/projects.texi | 52 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.ads | 121 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.ads | 117 | ||||
| -rw-r--r-- | gcc/ada/s-dim.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/s-dimmks.ads | 75 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 923 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_elim.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 9 |
18 files changed, 1115 insertions, 526 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 816d901..0654b27 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,76 @@ +2012-06-14 Vincent Pucci <pucci@adacore.com> + + * exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_Symbol + call replaced by Expand_Put_Call_With_Symbol call. + * sem_dim.adb: New fields Unit_Names, Unit_Symbols + and Dim_Symbols for record type System_Type. + (From_Dimension_To_String_Of_Symbols): Removed. + (From_Dim_To_Str_Of_Dim_Symbols): Renames previous + routine From_Dimension_To_String_Of_Symbols. + (From_Dim_To_Str_Of_Unit_Symbols): New routine. + (Analyze_Aspect_Dimension): argument Symbol in aspect + Dimension aggregate is optional. Named association implemented. + (Has_Compile_Time_Known_Expressions): Removed. + (Analyze_Aspect_Dimension_System): New + component Dim_Symbol in each Dimension aggregate in + aspect Dimension_System. Named associations implemented. + (Add_Dimension_Vector_To_Buffer): Removed. + (Add_Whole_To_Buffer): Removed. + (Expand_Put_Call_With_Dimension_Symbol.): Removed. + (Expand_Put_Call_With_Symbol): Renames previous routine + Expand_Put_Call_With_Dimension_Symbol. + (Has_Dimension_Symbols): Removed. + (Has_Symbols): Renames previous routine + Has_Dimension_Symbols. (Store_String_Oexpon): New routine. + * sem_dim.ads (Expand_Put_Call_With_Dimension_Symbol.): Removed. + (Expand_Put_Call_With_Symbol): Renames previous routine + Expand_Put_Call_With_Dimension_Symbol. + * s-diflio.adb, s-diinio.adb (Put): Symbol renames Symbols. + (Put_Dim_Of): New routines. + * s-diflio.ads, s-diinio.ads: documentation updated. + (Put): Symbol renames Symbols. + (Put_Dim_Of): New routines. + * s-dim.ads: documentation updated. + * s-dimmks.ads: dimensioned type and subtypes updated. + * snames.ads-tmpl: Name_Dim_Symbol, Name_Put_Dim_Of, Name_Symbol, + and Name_Unit_Symbol added. Name_Symbols removed. + +2012-06-14 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (In_Exp_Body): Expression function case added. + (Freeze_Expression): Insert the Freeze_Nodes + list before the correct current scope in case of a quantified + expression. + +2012-06-14 Pascal Obry <obry@adacore.com> + + * projects.texi: Document the Install package for gprinstall. +2012-06-14 Ed Schonberg <schonberg@adacore.com> + + * sem_elim.adb (Check_For_Eliminated_Subprogram): Do not check within + a default expression. + * sem_res.adb (Resolve_Call): simplify code. + +2012-06-14 Ed Schonberg <schonberg@adacore.com> + + * sem_case.adb (Check, Issue_Msg): within an instance, non-other + values in a variant part or a case expression do not have to + belong to the actual subtype. + +2012-06-14 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Validate_Derived_Type_Instance): If parent is + an interface type, check whether it is itself a previous formal + already instantiated in the current list of actuals. + +2012-06-14 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): The + expression for a stream attribute is a name that may be overloaded + with other declarations. To determine whether it matches the + aspect at the freeze point, it is necessary to verify that one + of its interpretations matches. + 2012-06-14 Robert Dewar <dewar@adacore.com> * exp_ch7.adb, exp_util.adb, sem_aux.ads, exp_ch9.adb, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index da89f70..eb37fa3 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2389,7 +2389,7 @@ package body Exp_Ch6 is and then Nkind (Call_Node) = N_Procedure_Call_Statement and then Present (Parameter_Associations (Call_Node)) then - Expand_Put_Call_With_Dimension_Symbol (Call_Node); + Expand_Put_Call_With_Symbol (Call_Node); end if; -- Remove the dimensions of every parameters in call diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f0e643d..ca8c336 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4698,13 +4698,15 @@ package body Freeze is Id := Defining_Unit_Name (Specification (P)); if Nkind (Id) = N_Defining_Identifier - and then (Is_Init_Proc (Id) or else - Is_TSS (Id, TSS_Stream_Input) or else - Is_TSS (Id, TSS_Stream_Output) or else - Is_TSS (Id, TSS_Stream_Read) or else - Is_TSS (Id, TSS_Stream_Write) or else + and then (Is_Init_Proc (Id) or else + Is_TSS (Id, TSS_Stream_Input) or else + Is_TSS (Id, TSS_Stream_Output) or else + Is_TSS (Id, TSS_Stream_Read) or else + Is_TSS (Id, TSS_Stream_Write) or else Nkind (Original_Node (P)) = - N_Subprogram_Renaming_Declaration) + N_Subprogram_Renaming_Declaration or else + Nkind (Original_Node (P)) = + N_Expression_Function) then return True; else @@ -5091,9 +5093,9 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - N : constant Node_Id := Current_Scope; - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + N : constant Node_Id := Current_Scope; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; begin if Present (Desig_Typ) then @@ -5109,13 +5111,18 @@ package body Freeze is end if; -- The current scope may be that of a constrained component of - -- an enclosing record declaration, which is above the current - -- scope in the scope stack. + -- an enclosing record declaration, or of a loop of an enclosing + -- quantified expression, which is above the current scope in the + -- scope stack. Indeed in the context of a quantified expression, + -- a scope is created and pushed above the current scope in order + -- to emulate the loop-like behavior of the quantified expression. -- If the expression is within a top-level pragma, as for a pre- -- condition on a library-level subprogram, nothing to do. if not Is_Compilation_Unit (Current_Scope) - and then Is_Record_Type (Scope (Current_Scope)) + and then (Is_Record_Type (Scope (Current_Scope)) + or else Nkind (Parent (Current_Scope)) = + N_Quantified_Expression) then Pos := Pos - 1; end if; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index a1cdb69..1c0c593 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -226,6 +226,7 @@ should contain the following code: * Executable File Names:: * Avoid Duplication With Variables:: * Naming Schemes:: +* Installation:: @end menu @c --------------------------------------------- @@ -1024,6 +1025,54 @@ names in lower case) @end ifset @c --------------------------------------------- +@node Installation +@subsection Installation +@c --------------------------------------------- + +@noindent +After building an application or a library it is often required to +install it into the development environment. This installation is +required if the library is to be used by another application for +example. The @code{gprinstall} tool provide an easy way to install +libraries, executable or object code generated durting the build. The +@b{Install} package can be used to change the default locations. + +The following attributes can be defined in package @code{Install}: + +@table @asis + +@item @b{Active} + +Whether the project is to be installed, values are @code{true} +(default) or @code{false}. + +@item @b{Prefix}: +@cindex @code{Prefix} + +Root directory for the installation. + +@item @b{Exec_Subdir} + +Subdirectory of @b{Prefix} where executables are to be +installed. Default is @b{bin}. + +@item @b{Lib_Subdir} + +Subdirectory of @b{Prefix} where directory with the library or object +files is to be installed. Default is @b{lib}. + +@item @b{Sources_Subdir} + +Subdirectory of @b{Prefix} where directory with sources is to be +installed. Default is @b{include}. + +@item @b{Project_Subdir} + +Subdirectory of @b{Prefix} where the installed project is to be +installed. Default is @b{share/gpr}. +@end table + +@c --------------------------------------------- @node Organizing Projects into Subsystems @section Organizing Projects into Subsystems @c --------------------------------------------- @@ -3039,6 +3088,9 @@ The following packages are currently supported in project files This package specifies the options used when starting an integrated development environment, for instance @command{GPS} or @command{Gnatbench}. @xref{The Development Environments}. +@item Install + This package specifies the options used when installing a project + with @command{gprinstall}. @xref{Installation}. @item Linker This package specifies the options used by the linker. @xref{Main Subprograms}. diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb index 644018a..527d7bb 100644 --- a/gcc/ada/s-diflio.adb +++ b/gcc/ada/s-diflio.adb @@ -38,40 +38,72 @@ package body System.Dim.Float_IO is --------- procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := "") + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") is begin Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); - Ada.Text_IO.Put (File, Symbols); + Ada.Text_IO.Put (File, Symbol); end Put; procedure Put - (Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := "") + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") is begin Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); - Ada.Text_IO.Put (Symbols); + Ada.Text_IO.Put (Symbol); end Put; procedure Put - (To : out String; - Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := "") + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") is begin Num_Dim_Float_IO.Put (To, Item, Aft, Exp); - To := To & Symbols; + To := To & Symbol; end Put; + ---------------- + -- Put_Dim_Of -- + ---------------- + + pragma Warnings (Off); + -- kill warnings on unreferenced formals + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Float; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (File, Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (Item : Num_Dim_Float; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Float; + Symbol : String := "") + is + begin + To := Symbol; + end Put_Dim_Of; end System.Dim.Float_IO; diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads index e914af0..f866f4a 100644 --- a/gcc/ada/s-diflio.ads +++ b/gcc/ada/s-diflio.ads @@ -31,33 +31,63 @@ -- This package provides output routines for float dimensioned types. All Put -- routines are modelled after those in package Ada.Text_IO.Float_IO with the --- addition of an extra default parameter. +-- addition of an extra default parameter. All Put_Dim_Of routines +-- output the dimension of Item in a symbolic manner. -- Parameter Symbol may be used in the following manner (all the examples are --- based on the MKS system of units as defined in package System.Dim.Mks): +-- based on the MKS system of units defined in package System.Dim.Mks): + +-- type Mks_Type is new Long_Long_Float +-- with +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); -- Case 1. A value is supplied for Symbol --- The string appears as a suffix of Item +-- * Put : The string appears as a suffix of Item + +-- * Put_Dim_Of : The string appears alone -- Obj : Mks_Type := 2.6; -- Put (Obj, 1, 1, 0, " dimensionless"); +-- Put_Dim_Of (Obj, "dimensionless"); --- The corresponding output is: 2.6 dimensionless +-- The corresponding outputs are: +-- $2.6 dimensionless +-- $dimensionless -- Case 2. No value is supplied for Symbol and Item is dimensionless --- Item appears without a suffix +-- * Put : Item appears without a suffix + +-- * Put_Dim_Of : the output is [] -- Obj : Mks_Type := 2.6; -- Put (Obj, 1, 1, 0); +-- Put_Dim_Of (Obj); --- The corresponding output is: 2.6 +-- The corresponding outputs are: +-- $2.6 +-- $[] -- Case 3. No value is supplied for Symbol and Item has a dimension --- If the type of Item is a dimensioned subtype whose symbolic name is not --- empty, then the symbolic name appears as a suffix. +-- * Put : If the type of Item is a dimensioned subtype whose +-- symbol is not empty, then the symbol appears as a suffix. +-- Otherwise, a new string is created and appears as a +-- suffix of Item. This string results in the successive +-- concatenations between each unit symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- * Put_Dim_Of : The output is a new string resulting in the successive +-- concatenations between each dimension symbol raised by its +-- corresponding dimension power from the dimensions of Item. -- subtype Length is Mks_Type -- with @@ -67,29 +97,33 @@ -- Obj : Length := 2.3 * dm; -- Put (Obj, 1, 2, 0); +-- Put_Dim_Of (Obj); --- The corresponding output is: 0.23 m - --- Otherwise, a new string is created and appears as a suffix of Item. --- This string results in the successive concatanations between each --- dimension symbolic name raised by its corresponding dimension power from --- the dimensions of Item. +-- The corresponding outputs are: +-- $0.23 m +-- $[L] -- subtype Random is Mks_Type -- with --- Dimension => ("", --- Meter => 3, --- Candela => -1, --- others => 0); +-- Dimension => ( +-- Meter => 3, +-- Candela => -1, +-- others => 0); -- Obj : Random := 5.0; -- Put (Obj); +-- Put_Dim_Of (Obj); --- The corresponding output is: 5.0 m**3.cd**(-1) +-- The corresponding outputs are: +-- $5.0 m**3.cd**(-1) +-- $[l**3.J**(-1)] -- Put (3.3 * km * dm * min, 5, 1, 0); +-- Put_Dim_Of (3.3 * km * dm * min); --- The corresponding output is: 19800.0 m**2.s +-- The corresponding outputs are: +-- $19800.0 m**2.s +-- $[L**2.T] with Ada.Text_IO; use Ada.Text_IO; @@ -103,27 +137,42 @@ package System.Dim.Float_IO is Default_Exp : Field := 3; procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := ""); + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); procedure Put - (Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := ""); + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); procedure Put - (To : out String; - Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbols : String := ""); + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Float; + Symbol : String := ""); + + procedure Put_Dim_Of + (Item : Num_Dim_Float; + Symbol : String := ""); + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Float; + Symbol : String := ""); pragma Inline (Put); + pragma Inline (Put_Dim_Of); end System.Dim.Float_IO; diff --git a/gcc/ada/s-diinio.adb b/gcc/ada/s-diinio.adb index 42ad688..d8f4fcc 100644 --- a/gcc/ada/s-diinio.adb +++ b/gcc/ada/s-diinio.adb @@ -38,40 +38,72 @@ package body System.Dim.Integer_IO is --------- procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbols : String := "") + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := "") is begin Num_Dim_Integer_IO.Put (File, Item, Width, Base); - Ada.Text_IO.Put (File, Symbols); + Ada.Text_IO.Put (File, Symbol); end Put; procedure Put - (Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbols : String := "") + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := "") is begin Num_Dim_Integer_IO.Put (Item, Width, Base); - Ada.Text_IO.Put (Symbols); + Ada.Text_IO.Put (Symbol); end Put; procedure Put - (To : out String; - Item : Num_Dim_Integer; - Base : Number_Base := Default_Base; - Symbols : String := "") + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbol : String := "") is begin Num_Dim_Integer_IO.Put (To, Item, Base); - To := To & Symbols; + To := To & Symbol; end Put; + ---------------- + -- Put_Dim_Of -- + ---------------- + + pragma Warnings (Off); + -- kill warnings on unreferenced formals + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (File, Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + To := Symbol; + end Put_Dim_Of; end System.Dim.Integer_IO; diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads index eab6a52..e5e8c44 100644 --- a/gcc/ada/s-diinio.ads +++ b/gcc/ada/s-diinio.ads @@ -31,44 +31,63 @@ -- This package provides output routines for integer dimensioned types. All -- Put routines are modelled after those in package Ada.Text_IO.Integer_IO --- with the addition of an extra default parameter. +-- with the addition of an extra default parameter. All Put_Dim_Of routines +-- output the dimension of Item in a symbolic manner. --- All the examples in this package are based on the MKS system of units: +-- Parameter Symbol may be used in the following manner (all the examples are +-- based on the MKS system of units as defined in package System.Dim.Mks): -- type Mks_Type is new Integer -- with --- Dimension_System => ((Meter, 'm'), --- (Kilogram, "kg"), --- (Second, 's'), --- (Ampere, 'A'), --- (Kelvin, 'K'), --- (Mole, "mol"), --- (Candela, "cd")); - --- Parameter Symbol may be used in the following manner: +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); -- Case 1. A value is supplied for Symbol --- The string appears as a suffix of Item +-- * Put : The string appears as a suffix of Item + +-- * Put_Dim_Of : The string appears alone -- Obj : Mks_Type := 2; --- Put (Obj, Symbols => " dimensionless"); +-- Put (Obj, Symbols => "dimensionless"); +-- Put_Dim_Of (Obj, Symbols => "dimensionless"); --- The corresponding output is: 2 dimensionless +-- The corresponding outputs are: +-- $2 dimensionless +-- $dimensionless -- Case 2. No value is supplied for Symbol and Item is dimensionless --- Item appears without a suffix +-- * Put : Item appears without a suffix + +-- * Put_Dim_Of : the output is [] -- Obj : Mks_Type := 2; -- Put (Obj); +-- Put_Dim_Of (Obj); --- The corresponding output is: 2 +-- The corresponding outputs are: +-- $2 +-- $[] -- Case 3. No value is supplied for Symbol and Item has a dimension --- If the type of Item is a dimensioned subtype whose symbolic name is not --- empty, then the symbolic name appears as a suffix. +-- * Put : If the type of Item is a dimensioned subtype whose +-- symbol is not empty, then the symbol appears as a suffix. +-- Otherwise, a new string is created and appears as a +-- suffix of Item. This string results in the successive +-- concatenations between each unit symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- * Put_Dim_Of : The output is a new string resulting in the successive +-- concatenations between each dimension symbol raised by its +-- corresponding dimension power from the dimensions of Item. -- subtype Length is Mks_Type -- with @@ -78,25 +97,26 @@ -- Obj : Length := 2; -- Put (Obj); +-- Put_Dim_Of (Obj); --- The corresponding output is: 2 m - --- Otherwise, a new string is created and appears as a suffix of Item. --- This string results in the successive concatanations between each --- dimension symbolic name raised by its corresponding dimension power from --- the dimensions of Item. +-- The corresponding outputs are: +-- $2 m +-- $[L] -- subtype Random is Mks_Type -- with -- Dimension => ("", --- Meter => 3, --- Candela => 2, --- others => 0); +-- Meter => 3, +-- Candela => 2, +-- others => 0); -- Obj : Random := 5; -- Put (Obj); +-- Put_Dim_Of (Obj); --- The corresponding output is: 5 m**3.cd**2 +-- The corresponding outputs are: +-- $5 m**3.cd**2 +-- $[L**3.J**2] with Ada.Text_IO; use Ada.Text_IO; @@ -109,24 +129,39 @@ package System.Dim.Integer_IO is Default_Base : Number_Base := 10; procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbols : String := ""); + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := ""); procedure Put - (Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbols : String := ""); + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := ""); procedure Put - (To : out String; - Item : Num_Dim_Integer; - Base : Number_Base := Default_Base; - Symbols : String := ""); + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbol : String := ""); + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Integer; + Symbol : String := ""); + + procedure Put_Dim_Of + (Item : Num_Dim_Integer; + Symbol : String := ""); + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Integer; + Symbol : String := ""); pragma Inline (Put); + pragma Inline (Put_Dim_Of); end System.Dim.Integer_IO; diff --git a/gcc/ada/s-dim.ads b/gcc/ada/s-dim.ads index ceb10d4..9896de8 100644 --- a/gcc/ada/s-dim.ads +++ b/gcc/ada/s-dim.ads @@ -42,15 +42,14 @@ -- type Mks_Type is new Long_Long_Float -- with --- Dimension_System => ((Meter, 'm'), --- (Kilogram, "kg"), --- (Second, 's'), --- (Ampere, 'A'), --- (Kelvin, 'K'), --- (Mole, "mol"), --- (Candela, "cd")); - --- 'm' is the symbolic name of dimension Meter +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); -- * Dimensioned subtype @@ -59,12 +58,10 @@ -- subtype Length is Mks_Type -- with --- Dimension => ('m', +-- Dimension => (Symbol => 'm', -- Meter => 1, -- others => 0); --- 'm' is the symbolic name of dimensioned subtype Length - package System.Dim is pragma Pure; diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads index 28e8563..50553d1 100644 --- a/gcc/ada/s-dimmks.ads +++ b/gcc/ada/s-dimmks.ads @@ -48,49 +48,50 @@ package System.Dim.Mks is type Mks_Type is new Long_Long_Float with - Dimension_System => ((Meter, 'm'), - (Kilogram, "kg"), - (Second, 's'), - (Ampere, 'A'), - (Kelvin, 'K'), - (Mole, "mol"), - (Candela, "cd")); + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); -- SI Base dimensioned subtype subtype Length is Mks_Type with - Dimension => ('m', - Meter => 1, + Dimension => (Symbol => 'm', + Meter => 1, others => 0); subtype Mass is Mks_Type with - Dimension => ("kg", + Dimension => (Symbol => "kg", Kilogram => 1, others => 0); subtype Time is Mks_Type with - Dimension => ('s', + Dimension => (Symbol => 's', Second => 1, others => 0); subtype Electric_Current is Mks_Type with - Dimension => ('A', + Dimension => (Symbol => 'A', Ampere => 1, others => 0); subtype Thermodynamic_Temperature is Mks_Type with - Dimension => ('K', + Dimension => (Symbol => 'K', Kelvin => 1, others => 0); subtype Amount_Of_Substance is Mks_Type with - Dimension => ("mol", + Dimension => (Symbol => "mol", Mole => 1, others => 0); subtype Luminous_Intensity is Mks_Type with - Dimension => ("cd", + Dimension => (Symbol => "cd", Candela => 1, others => 0); @@ -108,56 +109,56 @@ package System.Dim.Mks is subtype Angle is Mks_Type with - Dimension => ("rad", + Dimension => (Symbol => "rad", others => 0); subtype Solid_Angle is Mks_Type with - Dimension => ("sr", + Dimension => (Symbol => "sr", others => 0); subtype Frequency is Mks_Type with - Dimension => ("Hz", + Dimension => (Symbol => "Hz", Second => -1, others => 0); subtype Force is Mks_Type with - Dimension => ('N', + Dimension => (Symbol => 'N', Meter => 1, Kilogram => 1, Second => -2, others => 0); subtype Pressure is Mks_Type with - Dimension => ("Pa", + Dimension => (Symbol => "Pa", Meter => -1, Kilogram => 1, Second => -2, others => 0); subtype Energy is Mks_Type with - Dimension => ('J', + Dimension => (Symbol => 'J', Meter => 2, Kilogram => 1, Second => -2, others => 0); subtype Power is Mks_Type with - Dimension => ('W', + Dimension => (Symbol => 'W', Meter => 2, Kilogram => 1, Second => -3, others => 0); subtype Electric_Charge is Mks_Type with - Dimension => ('C', + Dimension => (Symbol => 'C', Second => 1, Ampere => 1, others => 0); subtype Electric_Potential_Difference is Mks_Type with - Dimension => ('V', + Dimension => (Symbol => 'V', Meter => 2, Kilogram => 1, Second => -3, @@ -165,7 +166,7 @@ package System.Dim.Mks is others => 0); subtype Electric_Capacitance is Mks_Type with - Dimension => ('F', + Dimension => (Symbol => 'F', Meter => -2, Kilogram => -1, Second => 4, @@ -173,7 +174,7 @@ package System.Dim.Mks is others => 0); subtype Electric_Resistance is Mks_Type with - Dimension => ("Ω", + Dimension => (Symbol => "Ω", Meter => 2, Kilogram => 1, Second => -3, @@ -181,7 +182,7 @@ package System.Dim.Mks is others => 0); subtype Electric_Conductance is Mks_Type with - Dimension => ('S', + Dimension => (Symbol => 'S', Meter => -2, Kilogram => -1, Second => 3, @@ -189,7 +190,7 @@ package System.Dim.Mks is others => 0); subtype Magnetic_Flux is Mks_Type with - Dimension => ("Wb", + Dimension => (Symbol => "Wb", Meter => 2, Kilogram => 1, Second => -2, @@ -197,14 +198,14 @@ package System.Dim.Mks is others => 0); subtype Magnetic_Flux_Density is Mks_Type with - Dimension => ('T', + Dimension => (Symbol => 'T', Kilogram => 1, Second => -2, Ampere => -1, others => 0); subtype Inductance is Mks_Type with - Dimension => ('H', + Dimension => (Symbol => 'H', Meter => 2, Kilogram => 1, Second => -2, @@ -212,40 +213,40 @@ package System.Dim.Mks is others => 0); subtype Celsius_Temperature is Mks_Type with - Dimension => ("°C", + Dimension => (Symbol => "°C", Kelvin => 1, others => 0); subtype Luminous_Flux is Mks_Type with - Dimension => ("lm", + Dimension => (Symbol => "lm", Candela => 1, others => 0); subtype Illuminance is Mks_Type with - Dimension => ("lx", + Dimension => (Symbol => "lx", Meter => -2, Candela => 1, others => 0); subtype Radioactivity is Mks_Type with - Dimension => ("Bq", + Dimension => (Symbol => "Bq", Second => -1, others => 0); subtype Absorbed_Dose is Mks_Type with - Dimension => ("Gy", + Dimension => (Symbol => "Gy", Meter => 2, Second => -2, others => 0); subtype Equivalent_Dose is Mks_Type with - Dimension => ("Sv", + Dimension => (Symbol => "Sv", Meter => 2, Second => -2, others => 0); subtype Catalytic_Activity is Mks_Type with - Dimension => ("kat", + Dimension => (Symbol => "kat", Second => -1, Mole => 1, others => 0); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 3e37440..8fa3074 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -159,6 +159,15 @@ package body Sem_Case is Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); begin + -- AI05-0188 : within an instance the non-others choices do not + -- have to belong to the actual subtype. + + if Ada_Version >= Ada_2012 + and then In_Instance + then + return; + end if; + -- In some situations, we call this with a null range, and -- obviously we don't want to complain in this case! @@ -718,6 +727,14 @@ package body Sem_Case is Raises_CE := True; return; + -- AI05-0188 : within an instance the non-others choices do not + -- have to belong to the actual subtype. + + elsif Ada_Version >= Ada_2012 + and then In_Instance + then + return; + -- Otherwise we have an OK static choice else diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 579acb7..c4351fc 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10811,6 +10811,11 @@ package body Sem_Ch12 is pragma Assert (Present (Ancestor)); + -- the ancestor itself may be a previous formal that + -- has been instantiated. + + Ancestor := Get_Instance_Of (Ancestor); + else Ancestor := Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ddfa7e7..bca3782 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6136,7 +6136,11 @@ package body Sem_Ch13 is if A_Id = Aspect_Synchronization then return; - -- Case of stream attributes, just have to compare entities + -- Case of stream attributes, just have to compare entities. However, + -- the expression is just a name (possibly overloaded), and there may + -- be stream operations declared for unrelated types, so we just need + -- to verify that one of these interpretations is the one available at + -- at the freeze point. elsif A_Id = Aspect_Input or else A_Id = Aspect_Output or else @@ -6144,7 +6148,29 @@ package body Sem_Ch13 is A_Id = Aspect_Write then Analyze (End_Decl_Expr); - Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + + if not Is_Overloaded (End_Decl_Expr) then + Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + + else + Err := True; + + declare + Index : Interp_Index; + It : Interp; + + begin + Get_First_Interp (End_Decl_Expr, Index, It); + while Present (It.Typ) loop + if It.Nam = Entity (Freeze_Expr) then + Err := False; + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + end; + end if; elsif A_Id = Aspect_Variable_Indexing or else A_Id = Aspect_Constant_Indexing or else diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 7e0d5d4..49f29a3 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -117,14 +117,15 @@ package body Sem_Dim is No_Symbols : constant Symbol_Array := (others => No_String); type System_Type is record - Type_Decl : Node_Id; - Names : Name_Array; - Symbols : Symbol_Array; - Count : Dimension_Position; + Type_Decl : Node_Id; + Unit_Names : Name_Array; + Unit_Symbols : Symbol_Array; + Dim_Symbols : Symbol_Array; + Count : Dimension_Position; end record; Null_System : constant System_Type := - (Empty, No_Names, No_Symbols, Invalid_Position); + (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position); subtype System_Id is Nat; @@ -290,8 +291,8 @@ package body Sem_Dim is -- Return the dimension vector of node N function Dimensions_Msg_Of (N : Node_Id) return String; - -- Given a node, return "has dimension" followed by the dimension vector of - -- N or "is dimensionless" if N is dimensionless. + -- Given a node, return "has dimension" followed by the dimension symbols + -- of N or "is dimensionless" if N is dimensionless. procedure Eval_Op_Expon_With_Rational_Exponent (N : Node_Id; @@ -304,11 +305,21 @@ package body Sem_Dim is function Exists (Sys : System_Type) return Boolean; -- Returns True iff Sys does not denote the null system - function From_Dimension_To_String_Of_Symbols + function From_Dim_To_Str_Of_Dim_Symbols + (Dims : Dimension_Type; + System : System_Type; + In_Error_Msg : Boolean := False) return String_Id; + -- Given a dimension vector and a dimension system, return the proper + -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id + -- will be used to issue an error message) then this routine has a special + -- handling for the insertion character asterisk * which must be precede by + -- a quote ' to to be placed literally into the message. + + function From_Dim_To_Str_Of_Unit_Symbols (Dims : Dimension_Type; System : System_Type) return String_Id; -- Given a dimension vector and a dimension system, return the proper - -- string of symbols. + -- string of unit symbols. function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean; -- Return True if E is the package entity of System.Dim.Float_IO or @@ -403,6 +414,7 @@ package body Sem_Dim is return Reduce (Rational'(Numerator => L.Numerator * R.Denominator, Denominator => L.Denominator * R.Numerator)); end "/"; + ----------- -- "abs" -- ----------- @@ -417,15 +429,27 @@ package body Sem_Dim is -- Analyze_Aspect_Dimension -- ------------------------------ - -- with Dimension => DIMENSION_FOR_SUBTYPE - -- DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS) - -- DIMENSION_RATIONALS ::= - -- RATIONAL, {, RATIONAL} - -- | RATIONAL {, RATIONAL}, others => RATIONAL + -- with Dimension => ( + -- [Symbol =>] SYMBOL, + -- DIMENSION_VALUE + -- [, DIMENSION_VALUE] + -- [, DIMENSION_VALUE] + -- [, DIMENSION_VALUE] + -- [, DIMENSION_VALUE] + -- [, DIMENSION_VALUE] + -- [, DIMENSION_VALUE]); + -- + -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL + + -- DIMENSION_VALUE ::= + -- RATIONAL + -- | others => RATIONAL -- | DISCRETE_CHOICE_LIST => RATIONAL + -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] - -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar) + -- Note that when the dimensioned type is an integer type, then any + -- dimension value must be an integer literal. procedure Analyze_Aspect_Dimension (N : Node_Id; @@ -446,11 +470,6 @@ package body Sem_Dim is -- Given an expression with denotes a rational number, read the number -- and associate it with Position in Dimensions. - function Has_Compile_Time_Known_Expressions - (Aggr : Node_Id) return Boolean; - -- Determine whether aggregate Aggr contains only expressions that are - -- known at compile time. - function Position_In_System (Id : Node_Id; System : System_Type) return Dimension_Position; @@ -466,8 +485,19 @@ package body Sem_Dim is Position : Dimension_Position) is begin + -- Integer case + if Is_Integer_Type (Def_Id) then - Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr))); + -- Dimension value must be an integer literal + + if Nkind (Expr) = N_Integer_Literal then + Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr))); + else + Error_Msg_N ("integer literal expected", Expr); + end if; + + -- Float case + else Dimensions (Position) := Create_Rational_From (Expr, True); end if; @@ -475,51 +505,6 @@ package body Sem_Dim is Processed (Position) := True; end Extract_Power; - ---------------------------------------- - -- Has_Compile_Time_Known_Expressions -- - ---------------------------------------- - - function Has_Compile_Time_Known_Expressions - (Aggr : Node_Id) return Boolean - is - Comp : Node_Id; - Expr : Node_Id; - - begin - Expr := First (Expressions (Aggr)); - if Present (Expr) then - - -- The first expression within the aggregate describes the - -- symbolic name of a dimension, skip it. - - Next (Expr); - while Present (Expr) loop - Analyze_And_Resolve (Expr); - - if not Compile_Time_Known_Value (Expr) then - return False; - end if; - - Next (Expr); - end loop; - end if; - - Comp := First (Component_Associations (Aggr)); - while Present (Comp) loop - Expr := Expression (Comp); - - Analyze_And_Resolve (Expr); - - if not Compile_Time_Known_Value (Expr) then - return False; - end if; - - Next (Comp); - end loop; - - return True; - end Has_Compile_Time_Known_Expressions; - ------------------------ -- Position_In_System -- ------------------------ @@ -531,8 +516,8 @@ package body Sem_Dim is Dimension_Name : constant Name_Id := Chars (Id); begin - for Position in System.Names'Range loop - if Dimension_Name = System.Names (Position) then + for Position in System.Unit_Names'Range loop + if Dimension_Name = System.Unit_Names (Position) then return Position; end if; end loop; @@ -550,15 +535,16 @@ package body Sem_Dim is Others_Seen : Boolean := False; Position : Nat := 0; Sub_Ind : Node_Id; - Symbol : String_Id; - Symbol_Decl : Node_Id; + Symbol : String_Id := No_String; + Symbol_Expr : Node_Id; System : System_Type; Typ : Entity_Id; Errors_Count : Nat; -- Errors_Count is a count of errors detected by the compiler so far - -- just before the extraction of names and values in the aggregate - -- (Step 3). + -- just before the extraction of symbol, names and values in the + -- aggregate + -- (Step 2). -- -- At the end of the analysis, there is a check to verify that this -- count equals to Serious_Errors_Detected i.e. no erros have been @@ -585,18 +571,6 @@ package body Sem_Dim is return; end if; - if Nkind (Aggr) /= N_Aggregate then - Error_Msg_N ("aggregate expected", Aggr); - return; - end if; - - -- Each expression in dimension aggregate must be known at compile time - - if not Has_Compile_Time_Known_Expressions (Aggr) then - Error_Msg_N ("values of aggregate must be static", Aggr); - return; - end if; - -- The dimension declarations are useless if the parent type does not -- declare a valid system. @@ -606,30 +580,88 @@ package body Sem_Dim is return; end if; - -- STEP 2: Structural verification of the dimension aggregate + if Nkind (Aggr) /= N_Aggregate then + Error_Msg_N ("aggregate expected", Aggr); + return; + end if; + + -- STEP 2: Symbol, Names and values extraction + + -- Get the number of errors detected by the compiler so far + + Errors_Count := Serious_Errors_Detected; + + -- STEP 2a: Symbol extraction + + -- The first entry in the aggregate may be the symbolic representation + -- of the quantity. - -- The first entry in the aggregate is the symbolic representation of - -- the dimension. + -- Positional symbol argument - Symbol_Decl := First (Expressions (Aggr)); + Symbol_Expr := First (Expressions (Aggr)); - if No (Symbol_Decl) - or else not Nkind_In (Symbol_Decl, N_Character_Literal, + -- Named symbol argument + + if No (Symbol_Expr) + or else not Nkind_In (Symbol_Expr, N_Character_Literal, N_String_Literal) then - Error_Msg_N ("first argument must be character or string", Aggr); - return; - end if; + Symbol_Expr := Empty; - -- STEP 3: Name and value extraction + -- Component associations present - -- Get the number of errors detected by the compiler so far + if Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + Choice := First (Choices (Assoc)); - Errors_Count := Serious_Errors_Detected; + if No (Next (Choice)) + and then Nkind (Choice) = N_Identifier + then + -- Symbol component association is present + + if Chars (Choice) = Name_Symbol then + Num_Choices := Num_Choices + 1; + Symbol_Expr := Expression (Assoc); + + -- Verify symbol expression is a string or a character + + if not Nkind_In (Symbol_Expr, N_Character_Literal, + N_String_Literal) + then + Symbol_Expr := Empty; + Error_Msg_N ("symbol expression must be character or " & + "string", + Symbol_Expr); + end if; + + -- Special error if no Symbol choice but expression is string + -- or character. + + elsif Nkind_In (Expression (Assoc), N_Character_Literal, + N_String_Literal) + then + Num_Choices := Num_Choices + 1; + Error_Msg_N ("optional component Symbol expected, found&", + Choice); + end if; + end if; + end if; + end if; + + -- STEP 2b: Names and values extraction -- Positional elements - Expr := Next (Symbol_Decl); + Expr := First (Expressions (Aggr)); + + -- Skip the symbol expression when present + + if Present (Symbol_Expr) + and then Num_Choices = 0 + then + Expr := Next (Expr); + end if; + Position := Low_Position_Bound; while Present (Expr) loop if Position > High_Position_Bound then @@ -649,9 +681,17 @@ package body Sem_Dim is -- Named elements Assoc := First (Component_Associations (Aggr)); + + -- Skip the symbol association when present + + if Num_Choices = 1 then + Next (Assoc); + end if; + while Present (Assoc) loop Expr := Expression (Assoc); Choice := First (Choices (Assoc)); + while Present (Choice) loop -- Identifier case: NAME => EXPRESSION @@ -747,43 +787,56 @@ package body Sem_Dim is Next (Assoc); end loop; - -- STEP 4: Consistency of system and dimensions + -- STEP 3: Consistency of system and dimensions - if Present (Next (Symbol_Decl)) + if Present (First (Expressions (Aggr))) + and then (First (Expressions (Aggr)) /= Symbol_Expr + or else Present (Next (Symbol_Expr))) and then (Num_Choices > 1 or else (Num_Choices = 1 and then not Others_Seen)) then Error_Msg_N ("named associations cannot follow positional associations", Aggr); + end if; - elsif Num_Dimensions > System.Count then + if Num_Dimensions > System.Count then Error_Msg_N ("type& has more dimensions than system allows", Def_Id); elsif Num_Dimensions < System.Count and then not Others_Seen then Error_Msg_N ("type& has less dimensions than system allows", Def_Id); end if; - -- STEP 5: Dimension symbol extraction + -- STEP 4: Dimension symbol extraction - if Nkind (Symbol_Decl) = N_Character_Literal then - Start_String; - Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl))); - Symbol := End_String; + if Present (Symbol_Expr) then + if Nkind (Symbol_Expr) = N_Character_Literal then + Start_String; + Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr))); + Symbol := End_String; - else - Symbol := Strval (Symbol_Decl); - end if; + else + Symbol := Strval (Symbol_Expr); + end if; - if String_Length (Symbol) = 0 and then not Exists (Dimensions) then - Error_Msg_N ("useless dimension declaration", Aggr); + if String_Length (Symbol) = 0 then + Error_Msg_N ("empty string not allowed here", Symbol_Expr); + end if; end if; - -- STEP 6: Storage of extracted values + -- STEP 5: Storage of extracted values -- Check that no errors have been detected during the analysis if Errors_Count = Serious_Errors_Detected then - if String_Length (Symbol) /= 0 then + -- useless declaration + + if Symbol = No_String + and then not Exists (Dimensions) + then + Error_Msg_N ("useless dimension declaration", Aggr); + end if; + + if Symbol /= No_String then Set_Symbol (Def_Id, Symbol); end if; @@ -797,19 +850,19 @@ package body Sem_Dim is -- Analyze_Aspect_Dimension_System -- ------------------------------------- - -- with Dimension_System => DIMENSION_PAIRS + -- with Dimension_System => ( + -- DIMENSION + -- [, DIMENSION] + -- [, DIMENSION] + -- [, DIMENSION] + -- [, DIMENSION] + -- [, DIMENSION] + -- [, DIMENSION]); - -- DIMENSION_PAIRS ::= - -- (DIMENSION_PAIR - -- [, DIMENSION_PAIR] - -- [, DIMENSION_PAIR] - -- [, DIMENSION_PAIR] - -- [, DIMENSION_PAIR] - -- [, DIMENSION_PAIR] - -- [, DIMENSION_PAIR]) - -- DIMENSION_PAIR ::= (DIMENSION_IDENTIFIER, DIMENSION_STRING) - -- DIMENSION_IDENTIFIER ::= IDENTIFIER - -- DIMENSION_STRING ::= STRING_LITERAL | CHARACTER_LITERAL + -- DIMENSION ::= ( + -- [Unit_Name =>] IDENTIFIER, + -- [Unit_Symbol =>] SYMBOL, + -- [Dim_Symbol =>] SYMBOL) procedure Analyze_Aspect_Dimension_System (N : Node_Id; @@ -834,13 +887,17 @@ package body Sem_Dim is -- Local variables - Dim_Name : Node_Id; - Dim_Pair : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Dim_Aggr : Node_Id; Dim_Symbol : Node_Id; + Dim_Symbols : Symbol_Array := No_Symbols; Dim_System : System_Type := Null_System; - Names : Name_Array := No_Names; Position : Nat := 0; - Symbols : Symbol_Array := No_Symbols; + Unit_Name : Node_Id; + Unit_Names : Name_Array := No_Names; + Unit_Symbol : Node_Id; + Unit_Symbols : Symbol_Array := No_Symbols; Errors_Count : Nat; -- Errors_Count is a count of errors detected by the compiler so far @@ -877,9 +934,9 @@ package body Sem_Dim is -- STEP 3: Name and Symbol extraction - Dim_Pair := First (Expressions (Aggr)); + Dim_Aggr := First (Expressions (Aggr)); Errors_Count := Serious_Errors_Detected; - while Present (Dim_Pair) loop + while Present (Dim_Aggr) loop Position := Position + 1; if Position > High_Position_Bound then @@ -888,68 +945,163 @@ package body Sem_Dim is exit; end if; - if Nkind (Dim_Pair) /= N_Aggregate then - Error_Msg_N ("aggregate expected", Dim_Pair); + if Nkind (Dim_Aggr) /= N_Aggregate then + Error_Msg_N ("aggregate expected", Dim_Aggr); else - if Present (Component_Associations (Dim_Pair)) then - Error_Msg_N ("expected positional aggregate", Dim_Pair); + if Present (Component_Associations (Dim_Aggr)) + and then Present (Expressions (Dim_Aggr)) + then + Error_Msg_N ("mixed positional/named aggregate not allowed " & + "here", + Dim_Aggr); + + -- Verify each dimension aggregate has three arguments + + elsif List_Length (Component_Associations (Dim_Aggr)) /= 3 + and then List_Length (Expressions (Dim_Aggr)) /= 3 + then + Error_Msg_N + ("three components expected in aggregate", Dim_Aggr); else - if List_Length (Expressions (Dim_Pair)) = 2 then - Dim_Name := First (Expressions (Dim_Pair)); - Dim_Symbol := Next (Dim_Name); + -- Named dimension aggregate - -- Check the first argument for each pair is a name + if Present (Component_Associations (Dim_Aggr)) then + -- Check first argument denotes the unit name - if Nkind (Dim_Name) = N_Identifier then - Names (Position) := Chars (Dim_Name); - else - Error_Msg_N ("expected dimension name", Dim_Name); + Assoc := First (Component_Associations (Dim_Aggr)); + Choice := First (Choices (Assoc)); + Unit_Name := Expression (Assoc); + + if Present (Next (Choice)) + or else Nkind (Choice) /= N_Identifier + then + Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); + + elsif Chars (Choice) /= Name_Unit_Name then + Error_Msg_N ("expected Unit_Name, found&", Choice); end if; - -- Check the second argument for each pair is a string or a - -- character. + -- Check the second argument denotes the unit symbol + + Next (Assoc); + Choice := First (Choices (Assoc)); + Unit_Symbol := Expression (Assoc); - if not Nkind_In - (Dim_Symbol, - N_String_Literal, - N_Character_Literal) + if Present (Next (Choice)) + or else Nkind (Choice) /= N_Identifier then - Error_Msg_N ("expected dimension string or character", - Dim_Symbol); + Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); - else - -- String case + elsif Chars (Choice) /= Name_Unit_Symbol then + Error_Msg_N ("expected Unit_Symbol, found&", Choice); + end if; - if Nkind (Dim_Symbol) = N_String_Literal then - Symbols (Position) := Strval (Dim_Symbol); + -- Check the third argument denotes the dimension symbol - -- Character case + Next (Assoc); + Choice := First (Choices (Assoc)); + Dim_Symbol := Expression (Assoc); - else - Start_String; - Store_String_Char - (UI_To_CC (Char_Literal_Value (Dim_Symbol))); - Symbols (Position) := End_String; - end if; + if Present (Next (Choice)) + or else Nkind (Choice) /= N_Identifier + then + Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); - -- Verify that the string is not empty + elsif Chars (Choice) /= Name_Dim_Symbol then + Error_Msg_N ("expected Dim_Symbol, found&", Choice); + end if; - if String_Length (Symbols (Position)) = 0 then - Error_Msg_N - ("empty string not allowed here", Dim_Symbol); - end if; + -- Positional dimension aggregate + + else + Unit_Name := First (Expressions (Dim_Aggr)); + Unit_Symbol := Next (Unit_Name); + Dim_Symbol := Next (Unit_Symbol); + end if; + + -- Check the first argument for each dimension aggregate is + -- a name. + + if Nkind (Unit_Name) = N_Identifier then + Unit_Names (Position) := Chars (Unit_Name); + else + Error_Msg_N ("expected unit name", Unit_Name); + end if; + + -- Check the second argument for each dimension aggregate is + -- a string or a character. + + if not Nkind_In + (Unit_Symbol, + N_String_Literal, + N_Character_Literal) + then + Error_Msg_N ("expected unit symbol (string or character)", + Unit_Symbol); + + else + -- String case + + if Nkind (Unit_Symbol) = N_String_Literal then + Unit_Symbols (Position) := Strval (Unit_Symbol); + + -- Character case + + else + Start_String; + Store_String_Char + (UI_To_CC (Char_Literal_Value (Unit_Symbol))); + Unit_Symbols (Position) := End_String; end if; + -- Verify that the string is not empty + + if String_Length (Unit_Symbols (Position)) = 0 then + Error_Msg_N + ("empty string not allowed here", Unit_Symbol); + end if; + end if; + + -- Check the third argument for each dimension aggregate is + -- a string or a character. + + if not Nkind_In + (Dim_Symbol, + N_String_Literal, + N_Character_Literal) + then + Error_Msg_N ("expected dimension symbol (string or " & + "character)", + Dim_Symbol); + else - Error_Msg_N - ("two expressions expected in aggregate", Dim_Pair); + -- String case + + if Nkind (Dim_Symbol) = N_String_Literal then + Dim_Symbols (Position) := Strval (Dim_Symbol); + + -- Character case + + else + Start_String; + Store_String_Char + (UI_To_CC (Char_Literal_Value (Dim_Symbol))); + Dim_Symbols (Position) := End_String; + end if; + + -- Verify that the string is not empty + + if String_Length (Dim_Symbols (Position)) = 0 then + Error_Msg_N + ("empty string not allowed here", Dim_Symbol); + end if; end if; end if; end if; - Next (Dim_Pair); + Next (Dim_Aggr); end loop; -- STEP 4: Storage of extracted values @@ -957,10 +1109,11 @@ package body Sem_Dim is -- Check that no errors have been detected during the analysis if Errors_Count = Serious_Errors_Detected then - Dim_System.Type_Decl := N; - Dim_System.Names := Names; - Dim_System.Count := Position; - Dim_System.Symbols := Symbols; + Dim_System.Type_Decl := N; + Dim_System.Unit_Names := Unit_Names; + Dim_System.Unit_Symbols := Unit_Symbols; + Dim_System.Dim_Symbols := Dim_Symbols; + Dim_System.Count := Position; System_Table.Append (Dim_System); end if; end Analyze_Aspect_Dimension_System; @@ -1822,7 +1975,7 @@ package body Sem_Dim is -- generate an error message. if Complain and then Result = No_Rational then - Error_Msg_N ("must be a rational", Expr); + Error_Msg_N ("rational expected", Expr); end if; return Result; @@ -1846,61 +1999,6 @@ package body Sem_Dim is Dimensions_Msg : Name_Id; System : System_Type; - procedure Add_Dimension_Vector_To_Buffer - (Dims : Dimension_Type; - System : System_Type); - -- Given a Dims and System, add to Name_Buffer the string representation - -- of a dimension vector. - - procedure Add_Whole_To_Buffer (W : Whole); - -- Add image of Whole to Name_Buffer - - ------------------------------------ - -- Add_Dimension_Vector_To_Buffer -- - ------------------------------------ - - procedure Add_Dimension_Vector_To_Buffer - (Dims : Dimension_Type; - System : System_Type) - is - Dim_Power : Rational; - First_Dim : Boolean := True; - - begin - Add_Char_To_Name_Buffer ('('); - - for Position in Dims_Of_N'First .. System.Count loop - Dim_Power := Dims (Position); - - if First_Dim then - First_Dim := False; - else - Add_Str_To_Name_Buffer (", "); - end if; - - Add_Whole_To_Buffer (Dim_Power.Numerator); - - if Dim_Power.Denominator /= 1 then - Add_Char_To_Name_Buffer ('/'); - Add_Whole_To_Buffer (Dim_Power.Denominator); - end if; - end loop; - - Add_Char_To_Name_Buffer (')'); - end Add_Dimension_Vector_To_Buffer; - - ------------------------- - -- Add_Whole_To_Buffer -- - ------------------------- - - procedure Add_Whole_To_Buffer (W : Whole) is - begin - UI_Image (UI_From_Int (Int (W))); - Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); - end Add_Whole_To_Buffer; - - -- Start of processing for Dimensions_Msg_Of - begin -- Initialization of Name_Buffer @@ -1908,8 +2006,9 @@ package body Sem_Dim is if Exists (Dims_Of_N) then System := System_Of (Base_Type (Etype (N))); - Add_Str_To_Name_Buffer ("has dimensions "); - Add_Dimension_Vector_To_Buffer (Dims_Of_N, System); + Add_Str_To_Name_Buffer ("has dimension "); + Add_String_To_Name_Buffer + (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); else Add_Str_To_Name_Buffer ("is dimensionless"); end if; @@ -2014,7 +2113,7 @@ package body Sem_Dim is -- subtype T is Btyp_Of_L -- with - -- Dimension => ("", + -- Dimension => ( -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator, -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator, -- ... @@ -2025,7 +2124,6 @@ package body Sem_Dim is New_Aspects := Empty_List; List_Of_Dims := New_List; - Append (Make_String_Literal (Loc, ""), List_Of_Dims); for Position in Dims_Of_N'First .. System.Count loop Dim_Power := Dims_Of_N (Position); @@ -2133,41 +2231,61 @@ package body Sem_Dim is return Sys /= Null_System; end Exists; - ------------------------------------------- - -- Expand_Put_Call_With_Dimension_Symbol -- - ------------------------------------------- + --------------------------------- + -- Expand_Put_Call_With_Symbol -- + --------------------------------- + + -- For procedure Put (resp. Put_Dim_Of) defined in + -- System.Dim.Float_IO/System.Dim.Integer_IO, the default string parameter + -- must be rewritten to include the unit symbols (resp. dimension symbols) + -- in the output of a dimensioned object. Note that if a value is already + -- supplied for parameter Symbol, this routine doesn't do anything. + + -- Case 1. Item is dimensionless + + -- * Put : Item appears without a suffix - -- For procedure Put defined in System.Dim.Float_IO/System.Dim.Integer_IO, - -- the default string parameter must be rewritten to include the dimension - -- symbols in the output of a dimensioned object. + -- * Put_Dim_Of : the output is [] - -- Case 1: the parameter is a variable + -- Obj : Mks_Type := 2.6; + -- Put (Obj, 1, 1, 0); + -- Put_Dim_Of (Obj); - -- The default string parameter is replaced by the symbol defined in the - -- aspect Dimension of the subtype. For instance to output a speed: + -- The corresponding outputs are: + -- $2.6 + -- $[] - -- subtype Force is Mks_Type - -- with - -- Dimension => ("N", - -- Meter => 1, - -- Kilogram => 1, - -- Second => -2, - -- others => 0); - -- F : Force := 2.1 * m * kg * s**(-2); - -- Put (F); - -- > 2.1 N + -- Case 2. Item has a dimension - -- Case 2: the parameter is an expression + -- * Put : If the type of Item is a dimensioned subtype whose + -- symbol is not empty, then the symbol appears as a + -- suffix. Otherwise, a new string is created and appears + -- as a suffix of Item. This string results in the + -- successive concatanations between each unit symbol + -- raised by its corresponding dimension power from the + -- dimensions of Item. - -- In this case we call the procedure Expand_Put_Call_With_Dimension_Symbol - -- that creates the string of symbols (for instance "m.s**(-1)") and - -- rewrites the default string parameter of Put with the corresponding - -- the String_Id. For instance: + -- * Put_Dim_Of : The output is a new string resulting in the successive + -- concatanations between each dimension symbol raised by + -- its corresponding dimension power from the dimensions of + -- Item. - -- Put (2.1 * m * kg * s**(-2)); - -- > 2.1 m.kg.s**(-2) + -- subtype Random is Mks_Type + -- with + -- Dimension => ( + -- Meter => 3, + -- Candela => -1, + -- others => 0); - procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id) is + -- Obj : Random := 5.0; + -- Put (Obj); + -- Put_Dim_Of (Obj); + + -- The corresponding outputs are: + -- $5.0 m**3.cd**(-1) + -- $[l**3.J**(-1)] + + procedure Expand_Put_Call_With_Symbol (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); Loc : constant Source_Ptr := Sloc (N); Name_Call : constant Node_Id := Name (N); @@ -2178,7 +2296,12 @@ package body Sem_Dim is New_Str_Lit : Node_Id := Empty; System : System_Type; - function Has_Dimension_Symbols return Boolean; + Is_Put_Dim_Of : Boolean := False; + -- This flag is used in order to differentiate routines Put and + -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of + -- defined in System.Dim.Float_IO or System.Dim.Integer_IO. + + function Has_Symbols return Boolean; -- Return True if the current Put call already has a parameter -- association for parameter "Symbols" with the correct string of -- symbols. @@ -2189,13 +2312,13 @@ package body Sem_Dim is -- System.Dim.Integer_IO. function Item_Actual return Node_Id; - -- Return the item actual parameter node in the put call + -- Return the item actual parameter node in the output call - --------------------------- - -- Has_Dimension_Symbols -- - --------------------------- + ----------------- + -- Has_Symbols -- + ----------------- - function Has_Dimension_Symbols return Boolean is + function Has_Symbols return Boolean is Actual : Node_Id; begin @@ -2205,7 +2328,7 @@ package body Sem_Dim is while Present (Actual) loop if Nkind (Actual) = N_Parameter_Association - and then Chars (Selector_Name (Actual)) = Name_Symbols + and then Chars (Selector_Name (Actual)) = Name_Symbol then -- return True if the actual comes from source or if the string @@ -2225,7 +2348,7 @@ package body Sem_Dim is -- one. return Nkind (Last (Actuals)) = N_String_Literal; - end Has_Dimension_Symbols; + end Has_Symbols; --------------------------- -- Is_Procedure_Put_Call -- @@ -2236,8 +2359,9 @@ package body Sem_Dim is Loc : Source_Ptr; begin - -- There are three different Put routines in each generic dim IO - -- package. Verify the current procedure call is one of them. + -- There are three different Put (resp. Put_Dim_Of) routines in each + -- generic dim IO package. Verify the current procedure call is one + -- of them. if Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); @@ -2250,14 +2374,22 @@ package body Sem_Dim is Loc := Sloc (Ent); - -- Check the name of the entity subprogram is Put and verify this - -- entity is located in either System.Dim.Float_IO or - -- System.Dim.Integer_IO. + -- Check the name of the entity subprogram is Put (resp. + -- Put_Dim_Of) and verify this entity is located in either + -- System.Dim.Float_IO or System.Dim.Integer_IO. - return Chars (Ent) = Name_Put - and then Loc > No_Location + if Loc > No_Location and then Is_Dim_IO_Package_Entity - (Cunit_Entity (Get_Source_Unit (Loc))); + (Cunit_Entity (Get_Source_Unit (Loc))) + then + if Chars (Ent) = Name_Put_Dim_Of then + Is_Put_Dim_Of := True; + return True; + + elsif Chars (Ent) = Name_Put then + return True; + end if; + end if; end if; return False; @@ -2298,36 +2430,61 @@ package body Sem_Dim is end if; end Item_Actual; - -- Start of processing for Expand_Put_Call_With_Dimension_Symbol + -- Start of processing for Expand_Put_Call_With_Symbol begin - if Is_Procedure_Put_Call and then not Has_Dimension_Symbols then + if Is_Procedure_Put_Call and then not Has_Symbols then Actual := Item_Actual; 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. + -- Put_Dim_Of case - if Symbol_Of (Etyp) /= No_String then - Start_String; + if Is_Put_Dim_Of then + -- Check that the item is not dimensionless + + -- Create the new String_Literal with the new String_Id generated + -- by the routine From_Dim_To_Str_Of_Dim_Symbols. + + if Exists (Dims_Of_Actual) then + System := System_Of (Base_Type (Etyp)); + New_Str_Lit := + Make_String_Literal (Loc, + From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_Actual, System)); + + -- If dimensionless, the output is [] + + else + New_Str_Lit := + Make_String_Literal (Loc, "[]"); + end if; + + -- Put case + + else + -- Add the symbol as a suffix of the value if the subtype has a + -- unit symbol or if the parameter is not dimensionless. + + if Symbol_Of (Etyp) /= No_String then + Start_String; - -- Put a space between the value and the dimension + -- Put a space between the value and the dimension - Store_String_Char (' '); - Store_String_Chars (Symbol_Of (Etyp)); - New_Str_Lit := Make_String_Literal (Loc, End_String); + Store_String_Char (' '); + Store_String_Chars (Symbol_Of (Etyp)); + New_Str_Lit := Make_String_Literal (Loc, End_String); - -- Check that the item is not dimensionless + -- 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. + -- Create the new String_Literal with the new String_Id generated + -- by the routine From_Dim_To_Str_Of_Unit_Symbols. - 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)); + elsif Exists (Dims_Of_Actual) then + System := System_Of (Base_Type (Etyp)); + New_Str_Lit := + Make_String_Literal (Loc, + From_Dim_To_Str_Of_Unit_Symbols (Dims_Of_Actual, System)); + end if; end if; if Present (New_Str_Lit) then @@ -2341,7 +2498,7 @@ package body Sem_Dim is -- parameter association. if Nkind (Actual) = N_Parameter_Association - and then Chars (Selector_Name (Actual)) /= Name_Symbols + and then Chars (Selector_Name (Actual)) /= Name_Symbol then Append_To (New_Actuals, Make_Parameter_Association (Loc, @@ -2360,7 +2517,7 @@ package body Sem_Dim is Append_To (New_Actuals, Make_Parameter_Association (Loc, - Selector_Name => Make_Identifier (Loc, Name_Symbols), + Selector_Name => Make_Identifier (Loc, Name_Symbol), Explicit_Actual_Parameter => New_Str_Lit)); -- Rewrite and analyze the procedure call @@ -2373,22 +2530,133 @@ package body Sem_Dim is Analyze (N); end if; end if; - end Expand_Put_Call_With_Dimension_Symbol; + end Expand_Put_Call_With_Symbol; - ----------------------------------------- - -- From_Dimension_To_String_Of_Symbols -- - ----------------------------------------- + ------------------------------------ + -- From_Dim_To_Str_Of_Dim_Symbols -- + ------------------------------------ -- Given a dimension vector and the corresponding dimension system, - -- create a String_Id to output the dimension symbols corresponding to - -- the dimensions Dims. + -- create a String_Id to output the dimension symbols corresponding to the + -- dimensions Dims. If In_Error_Msg is True, there is a special handling + -- for character asterisk * which is an insertion character in error + -- messages. + + function From_Dim_To_Str_Of_Dim_Symbols + (Dims : Dimension_Type; + System : System_Type; + In_Error_Msg : Boolean := False) return String_Id + is + Dim_Power : Rational; + First_Dim : Boolean := True; + + procedure Store_String_Oexpon; + -- Store the expon operator symbol "**" to the string. In error + -- messages, asterisk * is a special character and must be precede by a + -- quote ' to be placed literally into the message. + + ------------------------- + -- Store_String_Oexpon -- + ------------------------- + + procedure Store_String_Oexpon is + begin + if In_Error_Msg then + Store_String_Chars ("'*'*"); + + else + Store_String_Chars ("**"); + end if; + end Store_String_Oexpon; + + -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols - function From_Dimension_To_String_Of_Symbols + begin + -- Initialization of the new String_Id + + Start_String; + + -- Store the dimension symbols inside boxes + + Store_String_Char ('['); + + for Position in Dimension_Type'Range loop + Dim_Power := Dims (Position); + if Dim_Power /= Zero then + + if First_Dim then + First_Dim := False; + else + Store_String_Char ('.'); + end if; + + Store_String_Chars (System.Dim_Symbols (Position)); + + -- Positive dimension case + + if Dim_Power.Numerator > 0 then + -- Integer case + + if Dim_Power.Denominator = 1 then + if Dim_Power.Numerator /= 1 then + Store_String_Oexpon; + Store_String_Int (Int (Dim_Power.Numerator)); + end if; + + -- Rational case when denominator /= 1 + + else + Store_String_Oexpon; + Store_String_Char ('('); + Store_String_Int (Int (Dim_Power.Numerator)); + Store_String_Char ('/'); + Store_String_Int (Int (Dim_Power.Denominator)); + Store_String_Char (')'); + end if; + + -- Negative dimension case + + else + Store_String_Oexpon; + Store_String_Char ('('); + Store_String_Char ('-'); + Store_String_Int (Int (-Dim_Power.Numerator)); + + -- Integer case + + if Dim_Power.Denominator = 1 then + Store_String_Char (')'); + + -- Rational case when denominator /= 1 + + else + Store_String_Char ('/'); + Store_String_Int (Int (Dim_Power.Denominator)); + Store_String_Char (')'); + end if; + end if; + end if; + end loop; + + Store_String_Char (']'); + + return End_String; + end From_Dim_To_Str_Of_Dim_Symbols; + + ------------------------------------- + -- From_Dim_To_Str_Of_Unit_Symbols -- + ------------------------------------- + + -- Given a dimension vector and the corresponding dimension system, + -- create a String_Id to output the unit symbols corresponding to the + -- dimensions Dims. + + function From_Dim_To_Str_Of_Unit_Symbols (Dims : Dimension_Type; System : System_Type) return String_Id is - Dimension_Power : Rational; - First_Symbol_In_Str : Boolean := True; + Dim_Power : Rational; + First_Dim : Boolean := True; begin -- Initialization of the new String_Id @@ -2400,31 +2668,26 @@ package body Sem_Dim is Store_String_Char (' '); for Position in Dimension_Type'Range loop - Dimension_Power := Dims (Position); - if Dimension_Power /= Zero then + Dim_Power := Dims (Position); + if Dim_Power /= Zero then - if First_Symbol_In_Str then - First_Symbol_In_Str := False; + if First_Dim then + First_Dim := False; else Store_String_Char ('.'); end if; - -- Positive dimension case + Store_String_Chars (System.Unit_Symbols (Position)); - if Dimension_Power.Numerator > 0 then - if System.Symbols (Position) = No_String then - Store_String_Chars - (Get_Name_String (System.Names (Position))); - else - Store_String_Chars (System.Symbols (Position)); - end if; + -- Positive dimension case + if Dim_Power.Numerator > 0 then -- Integer case - if Dimension_Power.Denominator = 1 then - if Dimension_Power.Numerator /= 1 then + if Dim_Power.Denominator = 1 then + if Dim_Power.Numerator /= 1 then Store_String_Chars ("**"); - Store_String_Int (Int (Dimension_Power.Numerator)); + Store_String_Int (Int (Dim_Power.Numerator)); end if; -- Rational case when denominator /= 1 @@ -2432,37 +2695,30 @@ package body Sem_Dim is else Store_String_Chars ("**"); Store_String_Char ('('); - Store_String_Int (Int (Dimension_Power.Numerator)); + Store_String_Int (Int (Dim_Power.Numerator)); Store_String_Char ('/'); - Store_String_Int (Int (Dimension_Power.Denominator)); + Store_String_Int (Int (Dim_Power.Denominator)); Store_String_Char (')'); end if; -- Negative dimension case else - if System.Symbols (Position) = No_String then - Store_String_Chars - (Get_Name_String (System.Names (Position))); - else - Store_String_Chars (System.Symbols (Position)); - end if; - Store_String_Chars ("**"); Store_String_Char ('('); Store_String_Char ('-'); - Store_String_Int (Int (-Dimension_Power.Numerator)); + Store_String_Int (Int (-Dim_Power.Numerator)); -- Integer case - if Dimension_Power.Denominator = 1 then + if Dim_Power.Denominator = 1 then Store_String_Char (')'); -- Rational case when denominator /= 1 else Store_String_Char ('/'); - Store_String_Int (Int (Dimension_Power.Denominator)); + Store_String_Int (Int (Dim_Power.Denominator)); Store_String_Char (')'); end if; end if; @@ -2470,7 +2726,7 @@ package body Sem_Dim is end loop; return End_String; - end From_Dimension_To_String_Of_Symbols; + end From_Dim_To_Str_Of_Unit_Symbols; --------- -- GCD -- @@ -2700,5 +2956,4 @@ package body Sem_Dim is return Null_System; end System_Of; - end Sem_Dim; diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index b339ff6..3799651 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -137,7 +137,7 @@ package Sem_Dim is -- restricted to Integer exponent. This routine deals only with rational -- exponent which is not an integer if Btyp is a dimensioned type. - procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id); + procedure Expand_Put_Call_With_Symbol (N : Node_Id); -- Determine whether N denotes a subprogram call to one of the routines -- defined in System.Dim.Float_IO or System.Dim.Integer_IO and add an -- extra actual to the call to represent the symbolic representation of diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index aa6bbed..3d1bd14 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -724,6 +724,14 @@ package body Sem_Elim is Enclosing_Subp : Entity_Id; begin + -- No check needed within a default expression for a formal, since this + -- is not really a use, and the expression (a call or attribute) may + -- never be used if the enclosing subprogram is itself eliminated. + + if In_Spec_Expression then + return; + end if; + if Is_Eliminated (Ultimate_Subp) and then not Inside_A_Generic and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit)) @@ -823,10 +831,10 @@ package body Sem_Elim is Arg_Uname : Node_Id; function OK_Selected_Component (N : Node_Id) return Boolean; - -- Test if N is a selected component with all identifiers, or a - -- selected component whose selector is an operator symbol. As a - -- side effect if result is True, sets Num_Names to the number - -- of names present (identifiers and operator if any). + -- Test if N is a selected component with all identifiers, or a selected + -- component whose selector is an operator symbol. As a side effect if + -- result is True, sets Num_Names to the number of names present + -- (identifiers, and operator if any). --------------------------- -- OK_Selected_Component -- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index eda8583..2883223 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5839,14 +5839,11 @@ package body Sem_Res is Check_Restriction (No_Relative_Delay, N); end if; - -- Issue an error for a call to an eliminated subprogram. We skip this - -- in a spec expression, e.g. a call in a default parameter value, since - -- we are not really doing a call at this time. That's important because - -- the spec expression may itself belong to an eliminated subprogram. + -- Issue an error for a call to an eliminated subprogram. + -- The routine will not perform the check if the call appears within + -- a default expression. - if not In_Spec_Expression then - Check_For_Eliminated_Subprogram (Subp, Nam); - end if; + Check_For_Eliminated_Subprogram (Subp, Nam); -- In formal mode, the primitive operations of a tagged type or type -- extension do not include functions that return the tagged type. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 38bab59..bffc420 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -225,9 +225,12 @@ package Snames is -- Names used by the analyzer and expander for aspect Dimension and -- Dimension_System to deal with Sqrt and IO routines. - Name_Item : constant Name_Id := N + $; -- Ada 12 - Name_Sqrt : constant Name_Id := N + $; -- Ada 12 - Name_Symbols : constant Name_Id := N + $; -- Ada 12 + Name_Dim_Symbol : constant Name_Id := N + $; -- Ada 12 + Name_Item : constant Name_Id := N + $; -- Ada 12 + Name_Put_Dim_Of : constant Name_Id := N + $; -- Ada 12 + Name_Sqrt : constant Name_Id := N + $; -- Ada 12 + Name_Symbol : constant Name_Id := N + $; -- Ada 12 + Name_Unit_Symbol : constant Name_Id := N + $; -- Ada 12 -- Some miscellaneous names used for error detection/recovery |