From 5f44f0d4f87c30c3ad2497ef759c0b8578851b33 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 26 Apr 2012 11:52:02 +0200 Subject: [PATCH] [multiple changes] 2012-04-26 Robert Dewar * einfo.adb, einfo.ads, sem_res.adb, sem_ch4.adb, sem_eval.adb: Minor reformatting. 2012-04-26 Thomas Quinot * freeze.adb: Minor change in error wording. 2012-04-26 Ed Schonberg * gnat_ugn.texi: Documentation on dimensional analysis. 2012-04-26 Hristian Kirtchev * einfo.adb, einfo.ads: Remove synthesized attribute Proper_First_Index along with its associations in various nodes. (Proper_First_Index): Removed. * sem_ch4.adb (Analyze_Slice): Alphabetize constants. Add new local variable Index_Type. The index type of a string literal subtype is that of the stored low bound. * sem_eval (Get_Static_Length): Remove the use of Proper_First_Index. * sem_res.adb (Resolve_Slice): Alphabetize constants. Add new local variable Index_Type. The index type of a string literal subtype is that of the stored low bound. (Set_String_Literal_Subtype): Code reformatting. From-SVN: r186868 --- gcc/ada/ChangeLog | 27 ++++++++ gcc/ada/einfo.adb | 20 ------ gcc/ada/einfo.ads | 9 --- gcc/ada/exp_util.adb | 21 +++--- gcc/ada/exp_util.ads | 4 +- gcc/ada/freeze.adb | 2 +- gcc/ada/gnat_ugn.texi | 153 ++++++++++++++++++++++++++++++++++++++++++ gcc/ada/prj-nmsc.adb | 24 ++++--- gcc/ada/sem_ch4.adb | 20 ++++-- gcc/ada/sem_eval.adb | 4 +- gcc/ada/sem_res.adb | 39 ++++++----- 11 files changed, 244 insertions(+), 79 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6a19fc7e7f5..cf0cac643e0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2012-04-26 Robert Dewar + + * einfo.adb, einfo.ads, sem_res.adb, sem_ch4.adb, + sem_eval.adb: Minor reformatting. + +2012-04-26 Thomas Quinot + + * freeze.adb: Minor change in error wording. + +2012-04-26 Ed Schonberg + + * gnat_ugn.texi: Documentation on dimensional analysis. + +2012-04-26 Hristian Kirtchev + + * einfo.adb, einfo.ads: Remove synthesized attribute + Proper_First_Index along with its associations in various nodes. + (Proper_First_Index): Removed. + * sem_ch4.adb (Analyze_Slice): Alphabetize constants. Add new + local variable Index_Type. The index type of a string literal + subtype is that of the stored low bound. + * sem_eval (Get_Static_Length): Remove the use of Proper_First_Index. + * sem_res.adb (Resolve_Slice): Alphabetize constants. Add + new local variable Index_Type. The index type of a + string literal subtype is that of the stored low bound. + (Set_String_Literal_Subtype): Code reformatting. + 2012-04-26 Robert Dewar * exp_aggr.adb: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 46d8ace5e66..0f597a1f941 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6456,26 +6456,6 @@ package body Einfo is and then Present (Prival_Link (Id))); end Is_Prival; - ------------------------ - -- Proper_First_Index -- - ------------------------ - - function Proper_First_Index (Id : E) return E is - Typ : Entity_Id; - - begin - Typ := Id; - - -- The First_Index field is always empty for string literals, use the - -- base type instead. - - if Ekind (Typ) = E_String_Literal_Subtype then - Typ := Base_Type (Typ); - end if; - - return First_Index (Typ); - end Proper_First_Index; - ---------------------------- -- Is_Protected_Component -- ---------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 1badc882d09..d07be8124cd 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3393,11 +3393,6 @@ package Einfo is -- in the shadow entity, it points to the proper location in which to -- restore the private view saved in the shadow. --- Proper_First_Index (synthesized) --- Applies to array types and subtypes. Returns the First_Index of the --- type unless it is a string literal. In that case, the First_Index is --- obtained from the base type. - -- Protected_Formal (Node22) -- Present in formal parameters (in, in out and out parameters). Used -- only for formals of protected operations. References corresponding @@ -5031,7 +5026,6 @@ package Einfo is -- Is_Constrained (Flag12) -- Next_Index (synth) -- Number_Dimensions (synth) - -- Proper_First_Index (synth) -- (plus type attributes) -- E_Block @@ -5694,7 +5688,6 @@ package Einfo is -- Is_Constrained (Flag12) -- Next_Index (synth) -- Number_Dimensions (synth) - -- Proper_First_Index (synth) -- (plus type attributes) -- E_String_Literal_Subtype @@ -5702,7 +5695,6 @@ package Einfo is -- String_Literal_Length (Uint16) -- First_Index (Node17) (always Empty) -- Packed_Array_Type (Node23) - -- Proper_First_Index (synth) -- (plus type attributes) -- E_Subprogram_Body @@ -6540,7 +6532,6 @@ package Einfo is function Number_Formals (Id : E) return Pos; function Parameter_Mode (Id : E) return Formal_Kind; function Primitive_Operations (Id : E) return L; - function Proper_First_Index (Id : E) return E; function Root_Type (Id : E) return E; function Safe_Emax_Value (Id : E) return U; function Safe_First_Value (Id : E) return R; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8d51701e1ff..3091080a8d0 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -157,9 +157,9 @@ package body Exp_Util is -- 1) controlled objects -- 2) library-level tagged types -- - -- Flag Lib_Level should be set when the list comes from a construct at - -- the library level. Flag Nested_Constructs should be set when any nested - -- packages declared in L must be processed. + -- Lib_Level is True when the list comes from a construct at the library + -- level, and False otherwise. Nested_Constructs is True when any nested + -- packages declared in L must be processed, and False otherwise. ------------------------------------- -- Activate_Atomic_Synchronization -- @@ -7042,8 +7042,10 @@ package body Exp_Util is (N : Node_Id; Lib_Level : Boolean) return Boolean is - At_Lib_Level : constant Boolean := Lib_Level and then - Nkind_In (N, N_Package_Body, N_Package_Specification); + At_Lib_Level : constant Boolean := + Lib_Level + and then Nkind_In (N, N_Package_Body, + N_Package_Specification); -- N is at the library level if the top-most context is a package and -- the path taken to reach N does not inlcude non-package constructs. @@ -7059,10 +7061,11 @@ package body Exp_Util is return Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True) or else - (Present (Handled_Statement_Sequence (N)) - and then - Requires_Cleanup_Actions (Statements - (Handled_Statement_Sequence (N)), At_Lib_Level, True)); + (Present (Handled_Statement_Sequence (N)) + and then + Requires_Cleanup_Actions + (Statements (Handled_Statement_Sequence (N)), + At_Lib_Level, True)); when N_Package_Specification => return diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e42c8a5b0d9..e25d48e66df 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -753,8 +753,8 @@ package Exp_Util is -- 1) controlled objects -- 2) library-level tagged types -- - -- The above cases require special actions on scope exit. Flag Lib_Level - -- is used to track whether a construct is at the library level. + -- These cases require special actions on scope exit. The flag Lib_Level + -- is set True if the construct is at library level, and False otherwise. function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; -- Given the node for an N_Unchecked_Type_Conversion, return True if this diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5a7d3b22dea..a4588bd9de2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2144,7 +2144,7 @@ package body Freeze is Error_Msg_Sloc := Sloc (ADC); Error_Msg_N ("scalar storage order for& specified# inconsistent with " - & "its bit order", Rec); + & "bit order", Rec); end if; -- Deal with Bit_Order aspect specifying a non-default bit order diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e8e4d6e978c..57cb020fb82 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -195,6 +195,7 @@ AdaCore@* * Verifying Properties Using gnatcheck:: * Creating Sample Bodies Using gnatstub:: * Creating Unit Tests Using gnattest:: +* Performing Dimensionality Analysis in GNAT:: * Generating Ada Bindings for C and C++ headers:: * Other Utility Programs:: * Running and Debugging Ada Programs:: @@ -837,6 +838,12 @@ a utility that generates empty but compilable bodies for library units. @ref{Creating Unit Tests Using gnattest}, discusses @code{gnattest}, a utility that generates unit testing templates for library units. +@item +@ref{Performing Dimensionality Analysis in GNAT}, describes the Ada 2012 +facilities used in GNAT to declare dimensioned objects, and to verify that +uses of these objects are consistent with their given physical dimensions +(so that meters cannot be assigned to kilograms, and so on). + @item @ref{Generating Ada Bindings for C and C++ headers}, describes how to generate automatically Ada bindings from C and C++ headers. @@ -18512,6 +18519,152 @@ The tool currently does not support following features: @end itemize +@c ********************************* +@node Performing Dimensionality Analysis in GNAT +@chapter Performing Dimensionality Analysis in GNAT +@noindent +The GNAT compiler now supports dimensionality checking. The user can +specify physical units for objects, and the compiler will verify that uses +of these objects are compatible with their dimensions, in a fashion that is +familiar to engineering practice. The dimensions of algebraic expressions +(including powers with static exponents) are computed from their consistuents. + +This feature depends on Ada 2012 aspect specifications, and is available from +version 7.0.1 of GNAT onwards. The GNAT-specific aspect Dimension_System allows +the user to define a system of units; the aspect Dimension then allows the user +to declare dimensioned quantities within a given system. + +The simplest way to impose dimensionality checking on a computation is to make +use of the package System.Dim.Mks, which is part of the GNAT library. This +package defines a floating-point type MKS_Type, for which a sequence of +dimension names are specified, together with their conventional abbreviations. +The following should be read together with the full specification of the +package, in file s-dimmks.ads. + +@smallexample @c ada + 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")); +@end smallexample + +@noindent +The package then defines a series of subtypes that correspond to these +conventional units. For example: +@smallexample @c ada + subtype Length is Mks_Type + with + Dimension => ('m', + Meter => 1, + others => 0); +@end smallexample +@noindent +and similarly for Mass, Time, Electric_Current, Thermodynamic_Temperature, +Amount_Of_Substance, and Luminous_Intensity (the standard set of units of +the SI system). + +The package also defines conventional names for values of each unit, for +example: + +@smallexample @c ada + m : constant Length := 1.0; + kg : constant Mass := 1.0; + s : constant Time := 1.0; + A : constant Electric_Current := 1.0; +@end smallexample + +@noindent +as well as useful multiples of these units: + +@smallexample @c ada + cm : constant Length := 1.0E-02; + g : constant Mass := 1.0E-03; + min : constant Time := 60.0; + day : constant TIme := 60.0 * 24.0 * min; + ... +@end smallexample + +@noindent +The user can then define a derived unit by providing the aspect that +specifies its dimensions within the MKS system: + +@smallexample @c ada + subtype Acceleration is Mks_Type + with Dimension => ("m/sec**2", 1, 0, -2, others => 0); +@end smallexample + +@noindent +Here is a complete example of use: + +@smallexample @c ada +with System.Dim.MKS; use System.Dim.Mks; +with System.Dim.Mks_IO; use System.Dim.Mks_IO; +with Text_IO; use Text_IO; +procedure Free_Fall is + subtype Acceleration is Mks_Type + with Dimension => ("m/sec**2", 1, 0, -2, others => 0); + G : constant acceleration := 9.81 * m / (s ** 2); + T : Time := 10.0*s; + Distance : Length; +begin + Distance := 0.5 * G * T ** 2; + Put ("distance travelled in 10 seconds of free fall "); + Put (Distance, Aft => 2, Exp => 0); + Put_Line (""); +end Free_Fall; +@end smallexample + +@noindent +Execution of this program yields: +@smallexample +distance travelled in 10 seconds of free fall 490.50 m +@end smallexample + +@noindent +However, incorrect assignments such as: + +@smallexample @c ada + Distance := 5.0; + Distance := 5.0 * kg: +@end smallexample + +@noindent +are rejected with the following diagnoses: + +@smallexample + Distance := 5.0; + >>> dimensions mismatch in assignment + >>> left-hand side has dimensions (1, 0, 0, 0, 0, 0, 0) + >>> right-hand side is dimensionless + + Distance := 5.0 * kg: + >>> dimensions mismatch in assignment + >>> left-hand side has dimensions (1, 0, 0, 0, 0, 0, 0) + >>> right-hand side has dimensions (0, 1, 0, 0, 0, 0, 0) +@end smallexample + +@noindent +The dimensions of an expression are properly displayed. If we add to the +program: + +@smallexample @c ada + Put ("Final velocity: "); + Put (G * T, Aft =>2, Exp =>0); + Put_Line (""); +@end smallexample + +@noindent +then the output includes: +@smallexample + Final velocity: 98.10 m.s**(-1) +@end smallexample + @c ********************************* @node Generating Ada Bindings for C and C++ headers @chapter Generating Ada Bindings for C and C++ headers diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1084ee27007..56866e4d824 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1096,22 +1096,22 @@ package body Prj.Nmsc is Element : Package_Element; procedure Process_Binder (Arrays : Array_Id); - -- Process the associate array attributes of package Binder + -- Process the associated array attributes of package Binder procedure Process_Builder (Attributes : Variable_Id); -- Process the simple attributes of package Builder procedure Process_Clean (Arrays : Array_Id); - -- Process the associate array attributes of package Clean + -- Process the associated array attributes of package Clean procedure Process_Compiler (Arrays : Array_Id); - -- Process the associate array attributes of package Compiler + -- Process the associated array attributes of package Compiler procedure Process_Naming (Attributes : Variable_Id); -- Process the simple attributes of package Naming procedure Process_Naming (Arrays : Array_Id); - -- Process the associate array attributes of package Naming + -- Process the associated array attributes of package Naming procedure Process_Linker (Attributes : Variable_Id); -- Process the simple attributes of package Linker of a @@ -1238,7 +1238,7 @@ package body Prj.Nmsc is List : String_List_Id; begin - -- Process the associative array attribute of package Clean + -- Process the associated array attributes of package Clean Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop @@ -1250,8 +1250,9 @@ package body Prj.Nmsc is -- Get the name of the language - Lang_Index := Get_Language_From_Name - (Project, Get_Name_String (Element.Index)); + Lang_Index := + Get_Language_From_Name + (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then case Current_Array.Name is @@ -1279,6 +1280,7 @@ package body Prj.Nmsc is From_List => List, In_Tree => Data.Tree); end if; + when others => null; end case; @@ -3291,8 +3293,8 @@ package body Prj.Nmsc is if Project.Library then Support_For_Libraries := Project.Config.Lib_Support; - if not Project.Externally_Built and then - Support_For_Libraries = Prj.None + if not Project.Externally_Built + and then Support_For_Libraries = Prj.None then Error_Msg (Data.Flags, @@ -3481,8 +3483,8 @@ package body Prj.Nmsc is end if; if Project.Library_Kind /= Static then - if not Project.Externally_Built and then - Support_For_Libraries = Prj.Static_Only + if not Project.Externally_Built + and then Support_For_Libraries = Prj.Static_Only then Error_Msg (Data.Flags, diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d6c12b67f41..c1e386ecbe0 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4440,9 +4440,10 @@ package body Sem_Ch4 is ------------------- procedure Analyze_Slice (N : Node_Id) is - P : constant Node_Id := Prefix (N); D : constant Node_Id := Discrete_Range (N); + P : constant Node_Id := Prefix (N); Array_Type : Entity_Id; + Index_Type : Entity_Id; procedure Analyze_Overloaded_Slice; -- If the prefix is overloaded, select those interpretations that @@ -4513,13 +4514,18 @@ package body Sem_Ch4 is Error_Msg_N ("type is not one-dimensional array in slice prefix", N); - elsif not - Has_Compatible_Type (D, Etype (Proper_First_Index (Array_Type))) - then - Wrong_Type (D, Etype (Proper_First_Index (Array_Type))); - else - Set_Etype (N, Array_Type); + if Ekind (Array_Type) = E_String_Literal_Subtype then + Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); + else + Index_Type := Etype (First_Index (Array_Type)); + end if; + + if not Has_Compatible_Type (D, Index_Type) then + Wrong_Type (D, Index_Type); + else + Set_Etype (N, Array_Type); + end if; end if; end if; end Analyze_Slice; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 6cd045823a4..27a0f629d20 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -554,7 +554,7 @@ package body Sem_Eval is if Attribute_Name (N) = Name_First then return String_Literal_Low_Bound (Xtyp); - else -- Attribute_Name (N) = Name_Last + else return Make_Integer_Literal (Sloc (N), Intval => Intval (String_Literal_Low_Bound (Xtyp)) + String_Literal_Length (Xtyp)); @@ -2747,7 +2747,7 @@ package body Sem_Eval is -- General case - T := Etype (Proper_First_Index (Etype (Op))); + T := Etype (First_Index (Etype (Op))); -- The simple case, both bounds are known at compile time diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 43e12551175..5a3c6a46292 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8880,10 +8880,10 @@ package body Sem_Res is ------------------- procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is - Name : constant Node_Id := Prefix (N); Drange : constant Node_Id := Discrete_Range (N); + Name : constant Node_Id := Prefix (N); Array_Type : Entity_Id := Empty; - Index : Node_Id; + Index_Type : Entity_Id; begin if Is_Overloaded (Name) then @@ -9003,8 +9003,13 @@ package body Sem_Res is -- necessary. Else resolve the bounds, and apply needed checks. if not Is_Entity_Name (Drange) then - Index := Proper_First_Index (Array_Type); - Resolve (Drange, Base_Type (Etype (Index))); + if Ekind (Array_Type) = E_String_Literal_Subtype then + Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); + else + Index_Type := Etype (First_Index (Array_Type)); + end if; + + Resolve (Drange, Base_Type (Index_Type)); if Nkind (Drange) = N_Range then @@ -9026,7 +9031,7 @@ package body Sem_Res is and then Entity (Selector_Name (Prefix (N))) = RTE_Record_Component (RE_Prims_Ptr)) then - Apply_Range_Check (Drange, Etype (Index)); + Apply_Range_Check (Drange, Index_Type); end if; end if; end if; @@ -10119,26 +10124,24 @@ package body Sem_Res is Set_Is_Constrained (Subtype_Id); Set_Etype (N, Subtype_Id); - if Is_OK_Static_Expression (Low_Bound) then - -- The low bound is set from the low bound of the corresponding index -- type. Note that we do not store the high bound in the string literal -- subtype, but it can be deduced if necessary from the length and the -- low bound. + if Is_OK_Static_Expression (Low_Bound) then Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); - else - -- If the lower bound is not static we create a range for the string - -- literal, using the index type and the known length of the literal. - -- The index type is not necessarily Positive, so the upper bound is - -- computed as T'Val (T'Pos (Low_Bound) + L - 1) + -- If the lower bound is not static we create a range for the string + -- literal, using the index type and the known length of the literal. + -- The index type is not necessarily Positive, so the upper bound is + -- computed as T'Val (T'Pos (Low_Bound) + L - 1). + else declare - Index_List : constant List_Id := New_List; - Index_Type : constant Entity_Id := Etype (First_Index (Typ)); - - High_Bound : constant Node_Id := + Index_List : constant List_Id := New_List; + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + High_Bound : constant Node_Id := Make_Attribute_Reference (Loc, Attribute_Name => Name_Val, Prefix => @@ -10157,9 +10160,9 @@ package body Sem_Res is String_Length (Strval (N)) - 1)))); Array_Subtype : Entity_Id; - Index_Subtype : Entity_Id; Drange : Node_Id; Index : Node_Id; + Index_Subtype : Entity_Id; begin if Is_Integer_Type (Index_Type) then @@ -10214,7 +10217,7 @@ package body Sem_Res is Rewrite (N, Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), - Expression => Relocate_Node (N))); + Expression => Relocate_Node (N))); Set_Etype (N, Array_Subtype); end; end if; -- 2.30.2