diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-06-14 12:56:22 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-06-14 12:56:22 +0200 |
commit | df3781485406ededf60d901bbcbbcbeeaf0529b9 (patch) | |
tree | 4fcf9aeac898e8c5349c2120203d8e8760d546a2 /gcc/ada | |
parent | 2a290fec3d61859b69f865d1769f4e11ac1c3dc8 (diff) | |
download | gcc-df3781485406ededf60d901bbcbbcbeeaf0529b9.zip gcc-df3781485406ededf60d901bbcbbcbeeaf0529b9.tar.gz gcc-df3781485406ededf60d901bbcbbcbeeaf0529b9.tar.bz2 |
[multiple changes]
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.
From-SVN: r188610
Diffstat (limited to 'gcc/ada')
-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 |