diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-12-15 14:33:46 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-12-15 14:33:46 +0000 |
| commit | 8569650836011e7bfe45b3f76dd9673725785c88 (patch) | |
| tree | 20975a66444ac1e00f9193125dafa7c1e23e8fe7 | |
| parent | bace6acf1555d1d335e126a726790c388e85bc85 (diff) | |
| download | ppe42-gcc-8569650836011e7bfe45b3f76dd9673725785c88.tar.gz ppe42-gcc-8569650836011e7bfe45b3f76dd9673725785c88.zip | |
2011-12-15 Vincent Pucci <pucci@adacore.com>
* aspects.adb, aspects.ads Aspect_Dimension and
Aspect_Dimension_System added
* exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_String
case added
* gcc-interface/Make-lang.in: s-llflex, sem_dim added.
* impunit.adb :s-diflio and s-diinio defined as GNAT Defined
Additions to System.
* Makefile.rtl: s-diflio, s-diinio and s-llflex added
* par-prag.adb, sem_prag.adb: Pragma_Dimension removed
* rtsfind.ads: Expon_LLF added
* sem_aggr.adb (Resolve_Aggregate): handles aggregate for
Aspect_Dimension case
* sem_attr.adb (Resolve_Attribute): analyze dimension for
attribute
* sem_ch10.adb (Analyze_With_Clause): Avoid the warning messages
due to the use of a GNAT library for Dimension packages
* sem_ch13.adb (Analyze_Aspect_Specifications):
Aspect_Dimension and Aspect_Dimension_System cases added
(Check_Aspect_At_Freeze_Point): Aspect_Dimension and
Aspect_Dimension_System cases added
* sem_ch2.adb (Analyze_Identifier): analyze dimension for
identifier
* sem_ch3.adb (Analyze_Component_Declaration): analyze dimension
for component declaration (Analyze_Object_Declaration): analyze
dimension for object declaration (Analyze_Subtype_Declaration):
analyze dimension for subtype declaration
* sem_ch4.adb (Operator_Check): checks exponent is a rational
for dimensioned operand for a N_Op_Expon
* sem_ch5.adb (Analyze_Assignment): analyze dimension for
assignment (Analyze_Statements): removal of dimensions in all
statements
* sem_ch6.adb (Analyze_Return_Statement): analyze dimension for
return statement
* sem_ch8.adb (Analyze_Object_Renaming): analyze dimension for
object renaming
* sem_dim.adb, sem_dim.ads (Analyze_Aspect_Dimension):
analyze the expression for aspect dimension and store the
values in a Htable.
(Analyze_Aspect_Dimension_System): analyze
the expression for aspect dimension system and store the new
system in a Table.
(Analyze_Dimension): propagates dimension
(Expand_Put_Call_With_Dimension_String): add the dimension
string as a suffix of the numeric value in the output
(Has_Dimension): return True if the node has a dimension
(Remove_Dimension_In_Declaration): removal of dimension in the
expression of the declaration.
(Remove_Dimension_In_Statement): removal of dimension in statement
* sem_res.adb (Resolve): analyze dimension if the node
has already been analyzed.
(Resolve_Arithmetic_Op): analyze
dimension for arithmetic op.
(Resolve_Call): analyze dimension for function call.
(Resolve_Comparison_Op): analyze dimension for comparison op.
(Resolve_Equality_Op): analyze dimension for equality op.
(Resolve_Indexed_Component): analyze dimension for indexed component.
(Resolve_Op_Expon): analyze dimension for op expon.
(Resolve_Selected_Component): analyze dimension
for selected component.
(Resolve_Slice): analyze dimension for slice.
(Resolve_Unary_Op): analyze dimension for unary op
(Resolve_Type_Conversion): analyze dimension for type conversion
(Resolve_Unchecked_Type_Conversion): analyze dimension for
unchecked type conversion
* snames.ads-tmpl Name_Dimension, Name_Dimension_System,
Name_Dim_Float_IO, Name_Dim_Integer_IO,
Name_Generic_Elementary_Functions, Name_Sqrt added.
Pragma_Dimension removed
* s-diflio.adb, s-diflio.ads New GNAT library generic package
for dimensioned float type IO
* s-diinio.adb, s-diinio.ads New GNAT library generic package
for dimensioned integer type IO
* s-llflex.ads (Expon_LLF): exponentiation routine for long long
floats operand and exponent
2011-12-15 Robert Dewar <dewar@adacore.com>
* sem_aggr.adb: Minor comment addition.
2011-12-15 Bob Duff <duff@adacore.com>
* s-tasren.adb (Task_Count): Do not call Yield; E'Count is not a
task dispatching point.
* s-taprop-mingw.adb (Yield): Do not yield if Do_Yield is False.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182368 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/ChangeLog | 87 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 3 | ||||
| -rwxr-xr-x | gcc/ada/aspects.adb | 2 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 5 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.ads | 77 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.ads | 73 | ||||
| -rw-r--r-- | gcc/ada/s-llflex.ads | 42 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/s-tasren.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch2.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 2779 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.ads | 150 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 12 |
30 files changed, 3513 insertions, 35 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d36fdcd012b..ffc91dee409 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,90 @@ +2011-12-15 Vincent Pucci <pucci@adacore.com> + + * aspects.adb, aspects.ads Aspect_Dimension and + Aspect_Dimension_System added + * exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_String + case added + * gcc-interface/Make-lang.in: s-llflex, sem_dim added. + * impunit.adb :s-diflio and s-diinio defined as GNAT Defined + Additions to System. + * Makefile.rtl: s-diflio, s-diinio and s-llflex added + * par-prag.adb, sem_prag.adb: Pragma_Dimension removed + * rtsfind.ads: Expon_LLF added + * sem_aggr.adb (Resolve_Aggregate): handles aggregate for + Aspect_Dimension case + * sem_attr.adb (Resolve_Attribute): analyze dimension for + attribute + * sem_ch10.adb (Analyze_With_Clause): Avoid the warning messages + due to the use of a GNAT library for Dimension packages + * sem_ch13.adb (Analyze_Aspect_Specifications): + Aspect_Dimension and Aspect_Dimension_System cases added + (Check_Aspect_At_Freeze_Point): Aspect_Dimension and + Aspect_Dimension_System cases added + * sem_ch2.adb (Analyze_Identifier): analyze dimension for + identifier + * sem_ch3.adb (Analyze_Component_Declaration): analyze dimension + for component declaration (Analyze_Object_Declaration): analyze + dimension for object declaration (Analyze_Subtype_Declaration): + analyze dimension for subtype declaration + * sem_ch4.adb (Operator_Check): checks exponent is a rational + for dimensioned operand for a N_Op_Expon + * sem_ch5.adb (Analyze_Assignment): analyze dimension for + assignment (Analyze_Statements): removal of dimensions in all + statements + * sem_ch6.adb (Analyze_Return_Statement): analyze dimension for + return statement + * sem_ch8.adb (Analyze_Object_Renaming): analyze dimension for + object renaming + * sem_dim.adb, sem_dim.ads (Analyze_Aspect_Dimension): + analyze the expression for aspect dimension and store the + values in a Htable. + (Analyze_Aspect_Dimension_System): analyze + the expression for aspect dimension system and store the new + system in a Table. + (Analyze_Dimension): propagates dimension + (Expand_Put_Call_With_Dimension_String): add the dimension + string as a suffix of the numeric value in the output + (Has_Dimension): return True if the node has a dimension + (Remove_Dimension_In_Declaration): removal of dimension in the + expression of the declaration. + (Remove_Dimension_In_Statement): removal of dimension in statement + * sem_res.adb (Resolve): analyze dimension if the node + has already been analyzed. + (Resolve_Arithmetic_Op): analyze + dimension for arithmetic op. + (Resolve_Call): analyze dimension for function call. + (Resolve_Comparison_Op): analyze dimension for comparison op. + (Resolve_Equality_Op): analyze dimension for equality op. + (Resolve_Indexed_Component): analyze dimension for indexed component. + (Resolve_Op_Expon): analyze dimension for op expon. + (Resolve_Selected_Component): analyze dimension + for selected component. + (Resolve_Slice): analyze dimension for slice. + (Resolve_Unary_Op): analyze dimension for unary op + (Resolve_Type_Conversion): analyze dimension for type conversion + (Resolve_Unchecked_Type_Conversion): analyze dimension for + unchecked type conversion + * snames.ads-tmpl Name_Dimension, Name_Dimension_System, + Name_Dim_Float_IO, Name_Dim_Integer_IO, + Name_Generic_Elementary_Functions, Name_Sqrt added. + Pragma_Dimension removed + * s-diflio.adb, s-diflio.ads New GNAT library generic package + for dimensioned float type IO + * s-diinio.adb, s-diinio.ads New GNAT library generic package + for dimensioned integer type IO + * s-llflex.ads (Expon_LLF): exponentiation routine for long long + floats operand and exponent + +2011-12-15 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb: Minor comment addition. + +2011-12-15 Bob Duff <duff@adacore.com> + + * s-tasren.adb (Task_Count): Do not call Yield; E'Count is not a + task dispatching point. + * s-taprop-mingw.adb (Yield): Do not yield if Do_Yield is False. + 2011-12-15 Robert Dewar <dewar@adacore.com> * sigtramp-ppcvxw.c, sigtramp.h: Fix header. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 5c3e307f713..e04a5ff87b4 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -504,6 +504,8 @@ GNATRTL_NONTASKING_OBJS= \ s-crc32$(objext) \ s-crtl$(objext) \ s-crtrun$(objext) \ + s-diflio$(objext) \ + s-diinio$(objext) \ s-direio$(objext) \ s-dsaser$(objext) \ s-excdeb$(objext) \ @@ -554,6 +556,7 @@ GNATRTL_NONTASKING_OBJS= \ s-imgwch$(objext) \ s-imgwiu$(objext) \ s-io$(objext) \ + s-llflex$(objext) \ s-maccod$(objext) \ s-mantis$(objext) \ s-mastop$(objext) \ diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 7cc218e1d98..8dc9a12bccb 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -240,6 +240,8 @@ package body Aspects is Aspect_Default_Component_Value => Aspect_Default_Component_Value, Aspect_Default_Iterator => Aspect_Default_Iterator, Aspect_Default_Value => Aspect_Default_Value, + Aspect_Dimension => Aspect_Dimension, + Aspect_Dimension_System => Aspect_Dimension_System, Aspect_Discard_Names => Aspect_Discard_Names, Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate => Aspect_Predicate, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index c1dbe72cd3f..b701fe529df 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -54,6 +54,8 @@ package Aspects is Aspect_Default_Component_Value, Aspect_Default_Iterator, Aspect_Default_Value, + Aspect_Dimension, + Aspect_Dimension_System, Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, Aspect_External_Tag, @@ -232,6 +234,8 @@ package Aspects is Aspect_Default_Component_Value => Expression, Aspect_Default_Iterator => Name, Aspect_Default_Value => Expression, + Aspect_Dimension => Expression, + Aspect_Dimension_System => Expression, Aspect_Dispatching_Domain => Expression, Aspect_Dynamic_Predicate => Expression, Aspect_External_Tag => Expression, @@ -293,6 +297,8 @@ package Aspects is Aspect_Default_Iterator => Name_Default_Iterator, Aspect_Default_Value => Name_Default_Value, Aspect_Default_Component_Value => Name_Default_Component_Value, + Aspect_Dimension => Name_Dimension, + Aspect_Dimension_System => Name_Dimension_System, Aspect_Discard_Names => Name_Discard_Names, Aspect_Dispatching_Domain => Name_Dispatching_Domain, Aspect_Dynamic_Predicate => Name_Dynamic_Predicate, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4c9460438d3..7a55ad8b14d 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -60,9 +60,10 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; -with Sem_Eval; use Sem_Eval; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_SCIL; use Sem_SCIL; @@ -2103,6 +2104,20 @@ package body Exp_Ch6 is -- Start of processing for Expand_Call begin + -- Expand the procedure call if the first actual has a dimension and if + -- the procedure is Put (Ada 2012). + + if Ada_Version >= Ada_2012 + and then Nkind (Call_Node) = N_Procedure_Call_Statement + and then Present (Parameter_Associations (Call_Node)) + then + Expand_Put_Call_With_Dimension_String (Call_Node); + end if; + + -- Remove the dimensions of every parameters in call + + Remove_Dimension_In_Call (N); + -- Ignore if previous error if Nkind (Call_Node) in N_Has_Etype diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 35cddf75142..a79c0541c2c 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -304,6 +304,7 @@ GNAT_ADA_OBJS = \ ada/s-htable.o \ ada/s-imenne.o \ ada/s-imgenu.o \ + ada/s-llflex.o \ ada/s-mastop.o \ ada/s-memory.o \ ada/s-os_lib.o \ @@ -353,6 +354,7 @@ GNAT_ADA_OBJS = \ ada/sem_ch7.o \ ada/sem_ch8.o \ ada/sem_ch9.o \ + ada/sem_dim.o \ ada/sem_disp.o \ ada/sem_dist.o \ ada/sem_elab.o \ @@ -4307,6 +4309,9 @@ ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/warnsw.ads ada/widechar.ads +ada/sem_dim.o : ada/sem_util.ads ada/sem_util.adb ada/nmake.ads \ + ada/nmake.adb + ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 496f6ce50d4..49a44adf723 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -366,6 +366,8 @@ package body Impunit is ("s-addima", F), -- System.Address_Image ("s-assert", F), -- System.Assertions + ("s-diflio", F), -- System.Dim_Float_IO + ("s-diinio", F), -- System.Dim_Integer_IO ("s-memory", F), -- System.Memory ("s-parint", F), -- System.Partition_Interface ("s-pooglo", F), -- System.Pool_Global diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 1a126759f6b..b3d029f3e40 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1126,7 +1126,6 @@ begin Pragma_Debug_Policy | Pragma_Detect_Blocking | Pragma_Default_Storage_Pool | - Pragma_Dimension | Pragma_Disable_Atomic_Synchronization | Pragma_Discard_Names | Pragma_Dispatching_Domain | diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 8cd7771628c..64d10566067 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -262,6 +262,7 @@ package Rtsfind is System_Img_Uns, System_Img_WChar, System_Interrupts, + System_Long_Long_Float_Expon, System_Machine_Code, System_Mantissa, System_Memcop, @@ -866,6 +867,8 @@ package Rtsfind is RE_Static_Interrupt_Protection, -- System.Interrupts RE_System_Interrupt_Id, -- System.Interrupts + RE_Expon_LLF, -- System.Long_Long_Float_Expon + RE_Asm_Insn, -- System.Machine_Code RE_Asm_Input_Operand, -- System.Machine_Code RE_Asm_Output_Operand, -- System.Machine_Code @@ -2066,6 +2069,8 @@ package Rtsfind is RE_Static_Interrupt_Protection => System_Interrupts, RE_System_Interrupt_Id => System_Interrupts, + RE_Expon_LLF => System_Long_Long_Float_Expon, + RE_Asm_Insn => System_Machine_Code, RE_Asm_Input_Operand => System_Machine_Code, RE_Asm_Output_Operand => System_Machine_Code, diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb new file mode 100644 index 00000000000..7a14b8f1f94 --- /dev/null +++ b/gcc/ada/s-diflio.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . D I M _ F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Dim_Float_IO is + + package Num_Dim_Float_IO is new Ada.Text_IO.Float_IO (Num_Dim_Float); + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num_Dim_Float; + Unit : String := ""; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); + Ada.Text_IO.Put (File, Unit); + end Put; + + procedure Put + (Item : Num_Dim_Float; + Unit : String := ""; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); + Ada.Text_IO.Put (Unit); + end Put; + + procedure Put + (To : out String; + Item : Num_Dim_Float; + Unit : String := ""; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Num_Dim_Float_IO.Put (To, Item, Aft, Exp); + To := To & Unit; + end Put; + +end System.Dim_Float_IO; diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads new file mode 100644 index 00000000000..e70dc499633 --- /dev/null +++ b/gcc/ada/s-diflio.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . D I M _ F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note that this package should only be instantiated with a float dimensioned +-- type. + +-- This package is a generic package that provides IO facilities for float +-- dimensioned types. + +-- Note that there is a default string parameter in every Put routine +-- rewritten at compile time to output the corresponding dimensions as a +-- suffix of the numeric value. + +with Ada.Text_IO; use Ada.Text_IO; + +generic + type Num_Dim_Float is digits <>; + +package System.Dim_Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num_Dim_Float'Digits - 1; + Default_Exp : Field := 3; + + procedure Put + (File : File_Type; + Item : Num_Dim_Float; + Unit : String := ""; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num_Dim_Float; + Unit : String := ""; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (To : out String; + Item : Num_Dim_Float; + Unit : String := ""; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + pragma Inline (Put); + +end System.Dim_Float_IO; diff --git a/gcc/ada/s-diinio.adb b/gcc/ada/s-diinio.adb new file mode 100644 index 00000000000..b530942aeb6 --- /dev/null +++ b/gcc/ada/s-diinio.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . D I M _ I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Dim_Integer_IO is + + package Num_Dim_Integer_IO is new Ada.Text_IO.Integer_IO (Num_Dim_Integer); + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num_Dim_Integer; + Unit : String := ""; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + + is + begin + Num_Dim_Integer_IO.Put (File, Item, Width, Base); + Ada.Text_IO.Put (File, Unit); + end Put; + + procedure Put + (Item : Num_Dim_Integer; + Unit : String := ""; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + + is + begin + Num_Dim_Integer_IO.Put (Item, Width, Base); + Ada.Text_IO.Put (Unit); + end Put; + + procedure Put + (To : out String; + Item : Num_Dim_Integer; + Unit : String := ""; + Base : Number_Base := Default_Base) + + is + begin + Num_Dim_Integer_IO.Put (To, Item, Base); + To := To & Unit; + end Put; + +end System.Dim_Integer_IO; diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads new file mode 100644 index 00000000000..2325cea36bb --- /dev/null +++ b/gcc/ada/s-diinio.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . D I M _ I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note that this package should only be instantiated with an integer +-- dimensioned type + +-- This package is a generic package that provides IO facilities for integer +-- dimensioned types. + +-- Note that there is a default string parameter in every Put routine +-- rewritten at compile time to output the corresponding dimensions as a +-- suffix of the numeric value. + +with Ada.Text_IO; use Ada.Text_IO; + +generic + type Num_Dim_Integer is range <>; + +package System.Dim_Integer_IO is + + Default_Width : Field := Num_Dim_Integer'Width; + Default_Base : Number_Base := 10; + + procedure Put + (File : File_Type; + Item : Num_Dim_Integer; + Unit : String := ""; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num_Dim_Integer; + Unit : String := ""; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (To : out String; + Item : Num_Dim_Integer; + Unit : String := ""; + Base : Number_Base := Default_Base); + + pragma Inline (Put); + +end System.Dim_Integer_IO; diff --git a/gcc/ada/s-llflex.ads b/gcc/ada/s-llflex.ads new file mode 100644 index 00000000000..2ff301f0488 --- /dev/null +++ b/gcc/ada/s-llflex.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L O N G _ L O N G _ F L O A T _ E X P O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the functions "**" and Sqrt +-- between two long long floats. + +with Ada.Numerics.Long_Long_Elementary_Functions; + +package System.Long_Long_Float_Expon is + + function Expon_LLF (Left, Right : Long_Long_Float) return Long_Long_Float + renames Ada.Numerics.Long_Long_Elementary_Functions."**"; + +end System.Long_Long_Float_Expon; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 0a1a3c13003..0a976a4e8b1 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -710,10 +710,9 @@ package body System.Task_Primitives.Operations is -- Moreover, CXD8002 appears to pass on Windows (although we do not -- guarantee full Annex D compliance on Windows in any case). - -- What is not clear is why we now call SwitchToThread in the False - -- case. Other versions don't do that, is it necessary??? - - SwitchToThread; + if Do_Yield then + SwitchToThread; + end if; end Yield; ------------------ diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index e2541a106fd..04da4919c3f 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -1069,10 +1069,6 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort (Self_Id); - -- Call Yield to let other tasks get a chance to run as this is a - -- potential dispatching point. - - Yield (Do_Yield => False); return Return_Count; end Task_Count; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index ea75d48e69d..e70333cc7e6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1691,6 +1691,11 @@ package body Sem_Aggr is end if; end if; + -- If an aggregate component has a type with predicates, an explicit + -- predicate check must be applied, as for an assignment statement, + -- because the aggegate might not be expanded into individual + -- component assignments. + if Present (Predicate_Function (Component_Typ)) then Apply_Predicate_Check (Expr, Component_Typ); end if; @@ -3297,6 +3302,11 @@ package body Sem_Aggr is Aggregate_Constraint_Checks (Expr, Expr_Type); end if; + -- If an aggregate component has a type with predicates, an explicit + -- predicate check must be applied, as for an assignment statement, + -- because the aggegate might not be expanded into individual + -- component assignments. + if Present (Predicate_Function (Expr_Type)) then Apply_Predicate_Check (Expr, Expr_Type); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f72bebdba7b..6e1493afbba 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -52,6 +52,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; +with Sem_Dim; use Sem_Dim; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; @@ -9165,6 +9166,7 @@ package body Sem_Attr is -- Finally perform static evaluation on the attribute reference + Analyze_Dimension (N); Eval_Attribute (N); end Resolve_Attribute; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bd077364c2d..31bbd130903 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -46,6 +46,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -1476,6 +1477,15 @@ package body Sem_Ch13 is goto Continue; end; + + when Aspect_Dimension => + Analyze_Aspect_Dimension (N, Id, Expr); + goto Continue; + + when Aspect_Dimension_System => + Analyze_Aspect_Dimension_System (N, Id, Expr); + goto Continue; + end case; -- If a delay is required, we delay the freeze (not much point in @@ -6046,6 +6056,11 @@ package body Sem_Ch13 is Aspect_Static_Predicate | Aspect_Type_Invariant => T := Standard_Boolean; + + when Aspect_Dimension | + Aspect_Dimension_System => + raise Program_Error; + end case; -- Do the preanalyze call @@ -8777,8 +8792,8 @@ package body Sem_Ch13 is Source : constant Entity_Id := T.Source; Target : constant Entity_Id := T.Target; - Source_Siz : Uint; - Target_Siz : Uint; + Source_Siz : Uint; + Target_Siz : Uint; begin -- This validation check, which warns if we have unequal sizes for diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index 84cd62db2c6..efa965eb941 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -30,6 +30,7 @@ with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; with Sinfo; use Sinfo; with Stand; use Stand; with Uintp; use Uintp; @@ -75,6 +76,8 @@ package body Sem_Ch2 is else Find_Direct_Name (N); end if; + + Analyze_Dimension (N); end Analyze_Identifier; ----------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6c5a05573d8..9070b4505e9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -56,6 +56,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; @@ -2036,6 +2037,7 @@ package body Sem_Ch3 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; + Analyze_Dimension (N); end Analyze_Component_Declaration; -------------------------- @@ -2089,6 +2091,11 @@ package body Sem_Ch3 is -- Complete analysis of declaration Analyze (D); + + -- Removal of the dimension in the expression for object & component + -- declaration. + + Remove_Dimension_In_Declaration (D); Next_Node := Next (D); if No (Freeze_From) then @@ -3773,6 +3780,7 @@ package body Sem_Ch3 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; + Analyze_Dimension (N); end Analyze_Object_Declaration; --------------------------- @@ -4571,6 +4579,7 @@ package body Sem_Ch3 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; + Analyze_Dimension (N); end Analyze_Subtype_Declaration; -------------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7e8fed1d852..bd56eeff034 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -50,6 +50,7 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; @@ -6040,8 +6041,16 @@ package body Sem_Ch4 is First_Subtype (Base_Type (Etype (R))) /= Standard_Integer and then Base_Type (Etype (R)) /= Universal_Integer then - Error_Msg_NE - ("exponent must be of type Natural, found}", R, Etype (R)); + if Ada_Version >= Ada_2012 + and then Is_Dimensioned_Type (Etype (L)) + then + Error_Msg_NE + ("exponent for dimensioned type must be a Rational" & + ", found}", R, Etype (R)); + else + Error_Msg_NE + ("exponent must be of type Natural, found}", R, Etype (R)); + end if; return; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 073bc2b840a..62df0de17b1 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -47,6 +47,7 @@ with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; @@ -839,6 +840,7 @@ package body Sem_Ch5 is Set_Last_Assignment (Ent, Lhs); end if; end; + Analyze_Dimension (N); end Analyze_Assignment; ----------------------------- @@ -2731,6 +2733,10 @@ package body Sem_Ch5 is S := First (L); while Present (S) loop Analyze (S); + + -- Remove dimension in all statements + + Remove_Dimension_In_Statement (S); Next (S); end loop; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 92c5eed8de1..dbb4bb86e39 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -60,6 +60,7 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; @@ -1529,6 +1530,8 @@ package body Sem_Ch6 is Kill_Current_Values (Last_Assignment_Only => True); Check_Unreachable_Code (N); + + Analyze_Dimension (N); end Analyze_Return_Statement; ------------------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 296e3edfd3a..79fe3680e19 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -53,6 +53,7 @@ with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; @@ -1215,6 +1216,7 @@ package body Sem_Ch8 is end if; Set_Renamed_Object (Id, Nam); + Analyze_Dimension (N); end Analyze_Object_Renaming; ------------------------------ diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb new file mode 100644 index 00000000000..b0691695b72 --- /dev/null +++ b/gcc/ada/sem_dim.adb @@ -0,0 +1,2779 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Lib; use Lib; +with Namet; use Namet; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Table; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +with GNAT.HTable; + +package body Sem_Dim is + + -- Maximum number of dimensions in a dimension system + + Max_Dimensions : constant Int := 7; + + -- Dim_Id values are used to identify dimensions in a dimension system + -- Note that the highest value of Dim_Id is Max_Dimensions + + subtype Dim_Id is Pos range 1 .. Max_Dimensions; + + -- Record type for dimension system + -- A dimension system is defined by the number and the names of its + -- dimensions and its base type. + + subtype N_Of_Dimensions is Int range 0 .. Max_Dimensions; + + No_Dimensions : constant N_Of_Dimensions := N_Of_Dimensions'First; + + type Name_Array is array (Dim_Id) of Name_Id; + + No_Names : constant Name_Array := (others => No_Name); + + -- The symbols are used for IO purposes + + type Symbol_Array is array (Dim_Id) of String_Id; + + No_Symbols : constant Symbol_Array := (others => No_String); + + type Dimension_System is record + Base_Type : Node_Id; + Names : Name_Array; + N_Of_Dims : N_Of_Dimensions; + Symbols : Symbol_Array; + end record; + + No_Dimension_System : constant Dimension_System := + (Empty, No_Names, No_Dimensions, No_Symbols); + + -- Dim_Sys_Id values are used to identify dimension system in the Table + -- Note that the special value No_Dim_Sys has no corresponding component in + -- the Table since it represents no dimension system. + + subtype Dim_Sys_Id is Nat; + + No_Dim_Sys : constant Dim_Sys_Id := Dim_Sys_Id'First; + + -- The following table records every dimension system + + package Dim_Systems is new Table.Table ( + Table_Component_Type => Dimension_System, + Table_Index_Type => Dim_Sys_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 5, + Table_Name => "Dim_Systems"); + + -- Rational (definitions & operations) + + type Whole is new Int; + subtype Positive_Whole is Whole range 1 .. Whole'Last; + + type Rational is record + Numerator : Whole; + Denominator : Positive_Whole; + end record; + + Zero_Rational : constant Rational := (0, 1); + + -- Rational constructors + + function "+" (Right : Whole) return Rational; + function "/" (Left, Right : Whole) return Rational; + function GCD (Left, Right : Whole) return Int; + function Reduce (X : Rational) return Rational; + + -- Unary operator for Rational + + function "-" (Right : Rational) return Rational; + + -- Rational operations for Rationals + + function "+" (Left, Right : Rational) return Rational; + function "-" (Left, Right : Rational) return Rational; + function "*" (Left, Right : Rational) return Rational; + + -- Operation between Rational and Int + + function "*" (Left : Rational; Right : Whole) return Rational; + + --------- + -- GCD -- + --------- + + function GCD (Left, Right : Whole) return Int is + L : Whole := Left; + R : Whole := Right; + + begin + while R /= 0 loop + L := L mod R; + + if L = 0 then + return Int (R); + end if; + + R := R mod L; + end loop; + + return Int (L); + end GCD; + + ------------ + -- Reduce -- + ------------ + + function Reduce (X : Rational) return Rational is + begin + if X.Numerator = 0 then + return Zero_Rational; + end if; + + declare + G : constant Int := GCD (X.Numerator, X.Denominator); + + begin + return Rational'(Numerator => Whole (Int (X.Numerator) / G), + Denominator => Whole (Int (X.Denominator) / G)); + end; + end Reduce; + + --------- + -- "+" -- + --------- + + function "+" (Right : Whole) return Rational is + begin + return (Right, 1); + end "+"; + + function "+" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Denominator + + Left.Denominator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + + begin + return Reduce (R); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Right : Rational) return Rational is + begin + return Rational'(Numerator => -Right.Numerator, + Denominator => Right.Denominator); + end "-"; + + function "-" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Denominator - + Left.Denominator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + + begin + return Reduce (R); + end "-"; + + --------- + -- "*" -- + --------- + + function "*" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + + begin + return Reduce (R); + end "*"; + + function "*" (Left : Rational; Right : Whole) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right, + Denominator => Left.Denominator); + + begin + return Reduce (R); + end "*"; + + --------- + -- "/" -- + --------- + + function "/" (Left, Right : Whole) return Rational is + R : constant Int := abs Int (Right); + L : Int := Int (Left); + + begin + if Right < 0 then + L := -L; + end if; + + return Reduce (Rational'(Numerator => Whole (L), + Denominator => Whole (R))); + end "/"; + + -- Hash Table for aspect dimension. + + -- The following table provides a relation between nodes and its dimension + -- (if not dimensionless). If a node is not stored in the Hash Table, the + -- node is considered to be dimensionless. + -- A dimension is represented by an array of Max_Dimensions Rationals. + -- If the corresponding dimension system has less than Max_Dimensions + -- dimensions, the array is filled by as many as Zero_Rationals needed to + -- complete the array. + + -- Here is a list of nodes that can have entries in this Htable: + + -- N_Attribute_Reference + -- N_Defining_Identifier + -- N_Function_Call + -- N_Identifier + -- N_Indexed_Component + -- N_Integer_Literal + -- N_Op_Abs + -- N_Op_Add + -- N_Op_Divide + -- N_Op_Expon + -- N_Op_Minus + -- N_Op_Mod + -- N_Op_Multiply + -- N_Op_Plus + -- N_Op_Rem + -- N_Op_Subtract + -- N_Qualified_Expression + -- N_Real_Literal + -- N_Selected_Component + -- N_Slice + -- N_Type_Conversion + -- N_Unchecked_Type_Conversion + + type Dimensions is array (Dim_Id) of Rational; + + Zero_Dimensions : constant Dimensions := (others => Zero_Rational); + + type AD_Hash_Range is range 0 .. 511; + + function AD_Hash (F : Node_Id) return AD_Hash_Range; + + function AD_Hash (F : Node_Id) return AD_Hash_Range is + begin + return AD_Hash_Range (F mod 512); + end AD_Hash; + + -- Node_Id --> Dimensions + + package Aspect_Dimension_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AD_Hash_Range, + Element => Dimensions, + No_Element => Zero_Dimensions, + Key => Node_Id, + Hash => AD_Hash, + Equal => "="); + + -- Table to record the string of each subtype declaration + -- Note that this table is only used for IO purposes + + -- Entity_Id --> String_Id + + package Aspect_Dimension_String_Id_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AD_Hash_Range, + Element => String_Id, + No_Element => No_String, + Key => Entity_Id, + Hash => AD_Hash, + Equal => "="); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); + -- Subroutine of Analyze_Dimension for assignment statement + + procedure Analyze_Dimension_Binary_Op (N : Node_Id); + -- Subroutine of Analyze_Dimension for binary operators + + procedure Analyze_Dimension_Component_Declaration (N : Node_Id); + -- Subroutine of Analyze_Dimension for component declaration + + procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id); + -- Subroutine of Analyze_Dimension for extended return statement + + procedure Analyze_Dimension_Function_Call (N : Node_Id); + -- Subroutine of Analyze_Dimension for function call + + procedure Analyze_Dimension_Has_Etype (N : Node_Id); + -- Subroutine of Analyze_Dimension for N_Has_Etype nodes: + -- N_Attribute_Reference + -- N_Indexed_Component + -- N_Qualified_Expression + -- N_Selected_Component + -- N_Slice + -- N_Type_Conversion + -- N_Unchecked_Type_Conversion + + procedure Analyze_Dimension_Identifier (N : Node_Id); + -- Subroutine of Analyze_Dimension for identifier + + procedure Analyze_Dimension_Object_Declaration (N : Node_Id); + -- Subroutine of Analyze_Dimension for object declaration + + procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); + -- Subroutine of Analyze_Dimension for object renaming declaration + + procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id); + -- Subroutine of Analyze_Dimension for simple return statement + + procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id); + -- Subroutine of Analyze_Dimension for subtype declaration + + procedure Analyze_Dimension_Unary_Op (N : Node_Id); + -- Subroutine of Analyze_Dimension for unary operators + + procedure Copy_Dimensions (From, To : Node_Id); + -- Propagate dimensions between two nodes + + procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational); + -- Given an expression, creates a rational number + + procedure Eval_Op_Expon_With_Rational_Exponent + (N : Node_Id; + Rat : Rational); + -- Evaluate the Expon if the exponent is a rational and the operand has a + -- dimension. + + function From_Dimension_To_String_Id + (Dims : Dimensions; + Sys : Dim_Sys_Id) return String_Id; + -- Given a dimension vector and a dimension system, return the proper + -- string of symbols. + + function Get_Dimensions (N : Node_Id) return Dimensions; + -- Return the dimensions for the corresponding node + + function Get_Dimensions_String_Id (E : Entity_Id) return String_Id; + -- Return the String_Id of dimensions for the corresponding entity + + function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id; + -- Return the Dim_Id of the corresponding dimension system + + procedure Move_Dimensions (From, To : Node_Id); + -- Move Dimensions from 'From' to 'To'. Only called when 'From' has a + -- dimension. + + function Permits_Dimensions (N : Node_Id) return Boolean; + -- Return True if a node can have a dimension + + function Present (Dim : Dimensions) return Boolean; + -- Return True if Dim is not equal to Zero_Dimensions. + + procedure Remove_Dimensions (N : Node_Id); + -- Remove the node from the HTable + + procedure Set_Dimensions (N : Node_Id; Dims : Dimensions); + -- Store the dimensions of N in the Hash_Table for Dimensions + + procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id); + -- Store the string of dimensions of E in the Hash_Table for String_Id + + ------------------------------ + -- Analyze_Aspect_Dimension -- + ------------------------------ + + -- with Dimension => DIMENSION_FOR_SUBTYPE + -- DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS) + -- DIMENSION_RATIONALS ::= + -- RATIONAL, {, RATIONAL} + -- | RATIONAL {, RATIONAL}, others => RATIONAL + -- | DISCRETE_CHOICE_LIST => RATIONAL + + -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar) + + procedure Analyze_Aspect_Dimension + (N : Node_Id; + Id : Node_Id; + Expr : Node_Id) + is + Def_Id : constant Entity_Id := Defining_Identifier (N); + N_Kind : constant Node_Kind := Nkind (N); + Analyzed : array (Dimensions'Range) of Boolean := (others => False); + -- This array has been defined in order to deals with Others_Choice + -- It is a reminder of the dimensions in the aggregate that have already + -- been analyzed. + + Choice : Node_Id; + Comp_Expr : Node_Id; + Comp_Assn : Node_Id; + Dim : Dim_Id; + Dims : Dimensions := Zero_Dimensions; + Dim_Str_Lit : Node_Id; + D_Sys : Dim_Sys_Id := No_Dim_Sys; + N_Of_Dims : N_Of_Dimensions; + Str : String_Id := No_String; + + function Check_Identifier_Is_Dimension + (Id : Node_Id; + D_Sys : Dim_Sys_Id) return Boolean; + -- Return True if the identifier name is the name of a dimension in the + -- dimension system D_Sys. + + function Check_Compile_Time_Known_Expressions_In_Aggregate + (Expr : Node_Id) return Boolean; + -- Check that each expression in the aggregate is known at compile time + + function Check_Number_Dimensions_Aggregate + (Expr : Node_Id; + D_Sys : Dim_Sys_Id; + N_Of_Dims : N_Of_Dimensions) return Boolean; + -- This routine checks the number of dimensions in the aggregate. + + function Corresponding_Dimension_System (N : Node_Id) return Dim_Sys_Id; + -- Return the Dim_Sys_Id of the corresponding dimension system + + function Corresponding_Etype_Has_Dimensions (N : Node_Id) return Boolean; + -- Return True if the Etype of N has a dimension + + function Get_Dimension_Id + (Id : Node_Id; + D_Sys : Dim_Sys_Id) return Dim_Id; + -- Given an identifier and the Dim_Sys_Id of the dimension system in the + -- Table, returns the Dim_Id that has the same name as the identifier. + + ------------------------------------ + -- Corresponding_Dimension_System -- + ------------------------------------ + + function Corresponding_Dimension_System + (N : Node_Id) return Dim_Sys_Id + is + B_Typ : Node_Id; + Sub_Ind : Node_Id; + begin + -- Aspect_Dimension can only apply for subtypes + + -- Look for the dimension system corresponding to this + -- Aspect_Dimension. + + if Nkind (N) = N_Subtype_Declaration then + Sub_Ind := Subtype_Indication (N); + + if Nkind (Sub_Ind) /= N_Subtype_Indication then + B_Typ := Etype (Sub_Ind); + return Get_Dimension_System_Id (B_Typ); + + else + return No_Dim_Sys; + end if; + + else + return No_Dim_Sys; + end if; + end Corresponding_Dimension_System; + + ---------------------------------------- + -- Corresponding_Etype_Has_Dimensions -- + ---------------------------------------- + + function Corresponding_Etype_Has_Dimensions + (N : Node_Id) return Boolean + is + Dims_Typ : Dimensions; + Typ : Entity_Id; + + begin + + -- Check the type is dimensionless before assigning a dimension + + if Nkind (N) = N_Subtype_Declaration then + declare + Sub : constant Node_Id := Subtype_Indication (N); + + begin + if Nkind (Sub) /= N_Subtype_Indication then + Typ := Etype (Sub); + else + Typ := Etype (Subtype_Mark (Sub)); + end if; + + Dims_Typ := Get_Dimensions (Typ); + return Present (Dims_Typ); + end; + + else + return False; + end if; + end Corresponding_Etype_Has_Dimensions; + + --------------------------------------- + -- Check_Number_Dimensions_Aggregate -- + --------------------------------------- + + function Check_Number_Dimensions_Aggregate + (Expr : Node_Id; + D_Sys : Dim_Sys_Id; + N_Of_Dims : N_Of_Dimensions) return Boolean + is + Assoc : Node_Id; + Choice : Node_Id; + Comp_Expr : Node_Id; + N_Dims_Aggr : Int := No_Dimensions; + -- The number of dimensions in this aggregate + + begin + -- Check the size of the aggregate match with the size of the + -- corresponding dimension system. + + Comp_Expr := First (Expressions (Expr)); + + -- Skip the first argument in the aggregate since it's a character or + -- a string and not a dimension value. + + Next (Comp_Expr); + + if Present (Component_Associations (Expr)) then + + -- If the aggregate is a positional aggregate with an + -- Others_Choice, the number of expressions must be less than or + -- equal to N_Of_Dims - 1. + + if Present (Comp_Expr) then + N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; + return N_Dims_Aggr <= N_Of_Dims - 1; + + -- If the aggregate is a named aggregate, N_Dims_Aggr is used to + -- count all the dimensions referenced by the aggregate. + + else + Assoc := First (Component_Associations (Expr)); + + while Present (Assoc) loop + if Nkind (Assoc) = N_Range then + Choice := First (Choices (Assoc)); + + declare + HB : constant Node_Id := High_Bound (Choice); + LB : constant Node_Id := Low_Bound (Choice); + LB_Dim : Dim_Id; + HB_Dim : Dim_Id; + + begin + if not Check_Identifier_Is_Dimension (HB, D_Sys) + or else not Check_Identifier_Is_Dimension (LB, D_Sys) + then + return False; + end if; + + HB_Dim := Get_Dimension_Id (HB, D_Sys); + LB_Dim := Get_Dimension_Id (LB, D_Sys); + + N_Dims_Aggr := N_Dims_Aggr + HB_Dim - LB_Dim + 1; + end; + + else + N_Dims_Aggr := + N_Dims_Aggr + List_Length (Choices (Assoc)); + end if; + + Next (Assoc); + end loop; + + -- Check whether an Others_Choice is present or not + + if Nkind + (First (Choices (Last (Component_Associations (Expr))))) = + N_Others_Choice + then + return N_Dims_Aggr <= N_Of_Dims; + else + return N_Dims_Aggr = N_Of_Dims; + end if; + end if; + + -- If the aggregate is a positional aggregate without Others_Choice, + -- the number of expressions must match the number of dimensions in + -- the dimension system. + + else + N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; + return N_Dims_Aggr = N_Of_Dims; + end if; + end Check_Number_Dimensions_Aggregate; + + ----------------------------------- + -- Check_Identifier_Is_Dimension -- + ----------------------------------- + + function Check_Identifier_Is_Dimension + (Id : Node_Id; + D_Sys : Dim_Sys_Id) return Boolean + is + Na_Id : constant Name_Id := Chars (Id); + Dim_Name1 : Name_Id; + Dim_Name2 : Name_Id; + + begin + + for Dim1 in Dim_Id'Range loop + Dim_Name1 := Dim_Systems.Table (D_Sys).Names (Dim1); + + if Dim_Name1 = Na_Id then + return True; + end if; + + if Dim1 = Max_Dimensions then + + -- Check for possible misspelling + + Error_Msg_N ("& is not a dimension argument for aspect%", Id); + + for Dim2 in Dim_Id'Range loop + Dim_Name2 := Dim_Systems.Table (D_Sys).Names (Dim2); + + if Is_Bad_Spelling_Of (Na_Id, Dim_Name2) then + Error_Msg_Name_1 := Dim_Name2; + Error_Msg_N ("\possible misspelling of%", Id); + exit; + end if; + end loop; + end if; + end loop; + + return False; + end Check_Identifier_Is_Dimension; + + ---------------------- + -- Get_Dimension_Id -- + ---------------------- + + -- Given an identifier, returns the correponding position of the + -- dimension in the dimension system. + + function Get_Dimension_Id + (Id : Node_Id; + D_Sys : Dim_Sys_Id) return Dim_Id + is + Na_Id : constant Name_Id := Chars (Id); + Dim : Dim_Id; + Dim_Name : Name_Id; + + begin + for D in Dim_Id'Range loop + Dim_Name := Dim_Systems.Table (D_Sys).Names (D); + + if Dim_Name = Na_Id then + Dim := D; + end if; + + end loop; + + return Dim; + end Get_Dimension_Id; + + ------------------------------------------------------- + -- Check_Compile_Time_Known_Expressions_In_Aggregate -- + ------------------------------------------------------- + + function Check_Compile_Time_Known_Expressions_In_Aggregate + (Expr : Node_Id) return Boolean + is + Comp_Assn : Node_Id; + Comp_Expr : Node_Id; + + begin + Comp_Expr := First (Expressions (Expr)); + Next (Comp_Expr); + + while Present (Comp_Expr) loop + + -- First, analyze the expression + + Analyze_And_Resolve (Comp_Expr); + if not Compile_Time_Known_Value (Comp_Expr) then + return False; + end if; + + Next (Comp_Expr); + end loop; + + Comp_Assn := First (Component_Associations (Expr)); + + while Present (Comp_Assn) loop + Comp_Expr := Expression (Comp_Assn); + + -- First, analyze the expression + + Analyze_And_Resolve (Comp_Expr); + + if not Compile_Time_Known_Value (Comp_Expr) then + return False; + end if; + + Next (Comp_Assn); + end loop; + + return True; + end Check_Compile_Time_Known_Expressions_In_Aggregate; + + -- Start of processing for Analyze_Aspect_Dimension + + begin + -- Syntax checking + + Error_Msg_Name_1 := Chars (Id); + + if N_Kind /= N_Subtype_Declaration then + Error_Msg_N ("aspect% doesn't apply here", N); + return; + end if; + + if Nkind (Expr) /= N_Aggregate then + Error_Msg_N ("wrong syntax for aspect%", Expr); + return; + end if; + + D_Sys := Corresponding_Dimension_System (N); + + if D_Sys = No_Dim_Sys then + Error_Msg_N ("dimension system not found for aspect%", N); + return; + end if; + + if Corresponding_Etype_Has_Dimensions (N) then + Error_Msg_N ("corresponding type already has a dimension", N); + return; + end if; + + -- Check the first expression is a string or a character literal and + -- skip it. + + Dim_Str_Lit := First (Expressions (Expr)); + + if not Present (Dim_Str_Lit) + or else not Nkind_In (Dim_Str_Lit, + N_String_Literal, + N_Character_Literal) + then + Error_Msg_N + ("wrong syntax for aspect%: first argument in the aggregate must " & + "be a character or a string", + Expr); + return; + end if; + + Comp_Expr := Next (Dim_Str_Lit); + + -- Check the number of dimensions match with the dimension system + + N_Of_Dims := Dim_Systems.Table (D_Sys).N_Of_Dims; + + if not Check_Number_Dimensions_Aggregate (Expr, D_Sys, N_Of_Dims) then + Error_Msg_N ("wrong number of dimensions for aspect%", Expr); + return; + end if; + + Dim := Dim_Id'First; + Comp_Assn := First (Component_Associations (Expr)); + + if Present (Comp_Expr) then + + if List_Length (Component_Associations (Expr)) > 1 then + Error_Msg_N ("named association cannot follow " & + "positional association for aspect%", Expr); + return; + end if; + + if Present (Comp_Assn) + and then Nkind (First (Choices (Comp_Assn))) /= N_Others_Choice + then + Error_Msg_N ("named association cannot follow " & + "positional association for aspect%", Expr); + return; + end if; + end if; + + -- Check each expression in the aspect Dimension aggregate is known at + -- compile time. + + if not Check_Compile_Time_Known_Expressions_In_Aggregate (Expr) then + Error_Msg_N ("wrong syntax for aspect%", Expr); + return; + end if; + + -- Get the dimension values and store them in the Hash_Table + + -- Positional aggregate case + + while Present (Comp_Expr) loop + if Is_Integer_Type (Def_Id) then + Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); + else + Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); + end if; + + Analyzed (Dim) := True; + + exit when Dim = Max_Dimensions; + + Dim := Dim + 1; + Next (Comp_Expr); + end loop; + + -- Named aggregate case + + while Present (Comp_Assn) loop + Comp_Expr := Expression (Comp_Assn); + Choice := First (Choices (Comp_Assn)); + + if List_Length (Choices (Comp_Assn)) = 1 then + + -- N_Identifier case + + if Nkind (Choice) = N_Identifier then + + if not Check_Identifier_Is_Dimension (Choice, D_Sys) then + return; + end if; + + Dim := Get_Dimension_Id (Choice, D_Sys); + + if Is_Integer_Type (Def_Id) then + Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); + else + Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); + end if; + + Analyzed (Dim) := True; + + -- N_Range case + + elsif Nkind (Choice) = N_Range then + declare + HB : constant Node_Id := High_Bound (Choice); + LB : constant Node_Id := Low_Bound (Choice); + LB_Dim : constant Dim_Id := Get_Dimension_Id (LB, D_Sys); + HB_Dim : constant Dim_Id := Get_Dimension_Id (HB, D_Sys); + + begin + for Dim in LB_Dim .. HB_Dim loop + if Is_Integer_Type (Def_Id) then + Dims (Dim) := + +Whole (UI_To_Int (Expr_Value (Comp_Expr))); + else + Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); + end if; + + Analyzed (Dim) := True; + end loop; + end; + + -- N_Others_Choice case + + elsif Nkind (Choice) = N_Others_Choice then + + -- Check the Others_Choice is alone and last in the aggregate + + if Present (Next (Comp_Assn)) then + Error_Msg_N + ("OTHERS must appear alone and last in expression " & + "for aspect%", Choice); + return; + end if; + + -- End the filling of Dims by the Others_Choice value + -- If N_Of_Dims < Max_Dimensions then only the + -- positions that haven't been already analyzed from + -- Dim_Id'First to N_Of_Dims are filled. + + for Dim in Dim_Id'First .. N_Of_Dims loop + if not Analyzed (Dim) then + if Is_Integer_Type (Def_Id) then + Dims (Dim) := + +Whole (UI_To_Int (Expr_Value (Comp_Expr))); + else + Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); + end if; + end if; + end loop; + + else + Error_Msg_N ("wrong syntax for aspect%", Id); + end if; + + else + while Present (Choice) loop + if Nkind (Choice) = N_Identifier then + + if not Check_Identifier_Is_Dimension (Choice, D_Sys) then + return; + end if; + + Dim := Get_Dimension_Id (Choice, D_Sys); + + if Is_Integer_Type (Def_Id) then + Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); + else + Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); + end if; + + Analyzed (Dim) := True; + Next (Choice); + else + Error_Msg_N ("wrong syntax for aspect%", Id); + end if; + end loop; + end if; + + Next (Comp_Assn); + end loop; + + -- Create the string of dimensions + + if Nkind (Dim_Str_Lit) = N_Character_Literal then + Start_String; + Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Str_Lit))); + Str := End_String; + else + Str := Strval (Dim_Str_Lit); + end if; + + -- Store the dimensions in the Hash Table if not all equal to zero and + -- string is empty. + + if not Present (Dims) then + if String_Length (Str) = 0 then + Error_Msg_N + ("?dimension values all equal to zero for aspect%", Expr); + return; + end if; + else + Set_Dimensions (Def_Id, Dims); + end if; + + -- Store the string in the Hash Table + -- When the string is empty, don't store the string in the Hash Table + + if Str /= No_String + and then String_Length (Str) /= 0 + then + Set_Dimensions_String_Id (Def_Id, Str); + end if; + end Analyze_Aspect_Dimension; + + ------------------------------------- + -- Analyze_Aspect_Dimension_System -- + ------------------------------------- + + -- with Dimension_System => DIMENSION_PAIRS + -- 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 + + procedure Analyze_Aspect_Dimension_System + (N : Node_Id; + Id : Node_Id; + Expr : Node_Id) + is + Dim_Name : Node_Id; + Dim_Node : Node_Id; + Dim_Symbol : Node_Id; + D_Sys : Dimension_System := No_Dimension_System; + Names : Name_Array := No_Names; + N_Of_Dims : N_Of_Dimensions; + Symbols : Symbol_Array := No_Symbols; + + function Derived_From_Numeric_Type (N : Node_Id) return Boolean; + -- Return True if the node is a derived type declaration from any + -- numeric type. + + function Check_Dimension_System_Syntax (N : Node_Id) return Boolean; + -- Return True if the expression is an aggregate of names + + function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean; + -- Return True if the number of dimensions in the corresponding + -- dimension is positive and lower than Max_Dimensions. + + ------------------------------- + -- Derived_From_Numeric_Type -- + ------------------------------- + + function Derived_From_Numeric_Type (N : Node_Id) return Boolean is + begin + case (Nkind (N)) is + when N_Full_Type_Declaration => + declare + T_Def : constant Node_Id := Type_Definition (N); + Ent : Entity_Id; + + begin + -- Check that the node is a derived type declaration from + -- a numeric type. + + if Nkind (T_Def) /= N_Derived_Type_Definition then + return False; + else + Ent := Entity (Subtype_Indication (T_Def)); + + if Is_Numeric_Type (Ent) then + return True; + else + return False; + end if; + end if; + end; + + when others => return False; + end case; + end Derived_From_Numeric_Type; + + ----------------------------------- + -- Check_Dimension_System_Syntax -- + ----------------------------------- + + -- Check that the expression of aspect Dimension_System is an aggregate + -- which contains pairs of identifier and string or character literal. + + function Check_Dimension_System_Syntax (N : Node_Id) return Boolean is + Dim_Node : Node_Id; + Expr_Dim : Node_Id; + begin + -- Chek that the aggregate is a positional array + + if Present (Component_Associations (N)) then + return False; + else + Dim_Node := First (Expressions (N)); + + -- Check that each component of the aggregate is an aggregate + + while Present (Dim_Node) loop + + -- Verify that the aggregate is a pair of identifier and string + -- or character literal. + + if Nkind (Dim_Node) = N_Aggregate then + if not Present (Expressions (Dim_Node)) then + return False; + end if; + + if Present (Component_Associations (Dim_Node)) then + return False; + end if; + + -- First expression in the aggregate + + Expr_Dim := First (Expressions (Dim_Node)); + + if Nkind (Expr_Dim) /= N_Identifier then + return False; + end if; + + -- Second expression in the aggregate + + Next (Expr_Dim); + + if not Nkind_In (Expr_Dim, + N_String_Literal, + N_Character_Literal) + then + return False; + end if; + + -- If the aggregate has a third expression, return False + + Next (Expr_Dim); + + if Present (Expr_Dim) then + return False; + end if; + else + return False; + end if; + + Next (Dim_Node); + end loop; + + return True; + end if; + end Check_Dimension_System_Syntax; + + -------------------------------- + -- Check_Number_Of_Dimensions -- + -------------------------------- + + function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean is + List_Expr : constant List_Id := Expressions (Expr); + + begin + if List_Length (List_Expr) < Dim_Id'First + or else List_Length (List_Expr) > Max_Dimensions then + return False; + else + return True; + end if; + end Check_Number_Of_Dimensions; + + -- Start of processing for Analyze_Aspect_Dimension_System + + begin + Error_Msg_Name_1 := Chars (Id); + + -- Syntax checking + + if Nkind (Expr) /= N_Aggregate then + Error_Msg_N ("wrong syntax for aspect%", Expr); + return; + end if; + + if not Derived_From_Numeric_Type (N) then + Error_Msg_N ("aspect% only apply for type derived from numeric type", + Id); + return; + end if; + + if not Check_Dimension_System_Syntax (Expr) then + Error_Msg_N ("wrong syntax for aspect%", Expr); + return; + end if; + + if not Check_Number_Of_Dimensions (Expr) then + Error_Msg_N ("wrong number of dimensions for aspect%", Expr); + return; + end if; + + -- Number of dimensions in the system + + N_Of_Dims := List_Length (Expressions (Expr)); + + -- Create the new dimension system + + D_Sys.Base_Type := N; + Dim_Node := First (Expressions (Expr)); + + for Dim in Dim_Id'First .. N_Of_Dims loop + Dim_Name := First (Expressions (Dim_Node)); + Names (Dim) := Chars (Dim_Name); + Dim_Symbol := Next (Dim_Name); + + -- N_Character_Literal case + + if Nkind (Dim_Symbol) = N_Character_Literal then + Start_String; + Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Symbol))); + Symbols (Dim) := End_String; + + -- N_String_Literal case + + else + Symbols (Dim) := Strval (Dim_Symbol); + end if; + + Next (Dim_Node); + end loop; + + D_Sys.Names := Names; + D_Sys.N_Of_Dims := N_Of_Dims; + D_Sys.Symbols := Symbols; + + -- Store the dimension system in the Table + + Dim_Systems.Append (D_Sys); + end Analyze_Aspect_Dimension_System; + + ----------------------- + -- Analyze_Dimension -- + ----------------------- + + -- This dispatch routine propagates dimensions for each node + + procedure Analyze_Dimension (N : Node_Id) is + begin + -- Aspect is an Ada 2012 feature + + if Ada_Version < Ada_2012 then + return; + end if; + + case Nkind (N) is + + when N_Assignment_Statement => + Analyze_Dimension_Assignment_Statement (N); + + when N_Subtype_Declaration => + Analyze_Dimension_Subtype_Declaration (N); + + when N_Object_Declaration => + Analyze_Dimension_Object_Declaration (N); + + when N_Object_Renaming_Declaration => + Analyze_Dimension_Object_Renaming_Declaration (N); + + when N_Component_Declaration => + Analyze_Dimension_Component_Declaration (N); + + when N_Binary_Op => + Analyze_Dimension_Binary_Op (N); + + when N_Unary_Op => + Analyze_Dimension_Unary_Op (N); + + when N_Identifier => + Analyze_Dimension_Identifier (N); + + when N_Attribute_Reference | + N_Indexed_Component | + N_Qualified_Expression | + N_Selected_Component | + N_Slice | + N_Type_Conversion | + N_Unchecked_Type_Conversion => + Analyze_Dimension_Has_Etype (N); + + when N_Function_Call => + Analyze_Dimension_Function_Call (N); + + when N_Extended_Return_Statement => + Analyze_Dimension_Extended_Return_Statement (N); + + when N_Simple_Return_Statement => + Analyze_Dimension_Simple_Return_Statement (N); + + when others => null; + + end case; + end Analyze_Dimension; + + -------------------------------------------- + -- Analyze_Dimension_Assignment_Statement -- + -------------------------------------------- + + procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is + Lhs : constant Node_Id := Name (N); + Dim_Lhs : constant Dimensions := Get_Dimensions (Lhs); + Rhs : constant Node_Id := Expression (N); + Dim_Rhs : constant Dimensions := Get_Dimensions (Rhs); + + procedure Analyze_Dimensions_In_Assignment + (Dim_Lhs : Dimensions; + Dim_Rhs : Dimensions); + -- Subroutine to perform the dimensionnality checking for assignment + + -------------------------------------- + -- Analyze_Dimensions_In_Assignment -- + -------------------------------------- + + procedure Analyze_Dimensions_In_Assignment + (Dim_Lhs : Dimensions; + Dim_Rhs : Dimensions) + is + begin + -- Check the lhs and the rhs have the same dimension + + if not Present (Dim_Lhs) then + + if Present (Dim_Rhs) then + Error_Msg_N ("?dimensions missmatch in assignment", N); + end if; + else + + if Dim_Lhs /= Dim_Rhs then + Error_Msg_N ("?dimensions missmatch in assignment", N); + end if; + + end if; + end Analyze_Dimensions_In_Assignment; + + -- Start of processing for Analyze_Dimension_Assignment + + begin + Analyze_Dimensions_In_Assignment (Dim_Lhs, Dim_Rhs); + end Analyze_Dimension_Assignment_Statement; + + --------------------------------- + -- Analyze_Dimension_Binary_Op -- + --------------------------------- + + procedure Analyze_Dimension_Binary_Op (N : Node_Id) is + N_Kind : constant Node_Kind := Nkind (N); + + begin + if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract) + or else N_Kind in N_Multiplying_Operator + or else N_Kind in N_Op_Compare + then + declare + L : constant Node_Id := Left_Opnd (N); + L_Dims : constant Dimensions := Get_Dimensions (L); + L_Has_Dimensions : constant Boolean := Present (L_Dims); + R : constant Node_Id := Right_Opnd (N); + R_Dims : constant Dimensions := Get_Dimensions (R); + R_Has_Dimensions : constant Boolean := Present (R_Dims); + Dims : Dimensions := Zero_Dimensions; + + begin + + if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then + Error_Msg_Name_1 := Chars (N); + + -- Check both operands dimension + + if L_Has_Dimensions and R_Has_Dimensions then + + -- If dimensions missmatch + + if L_Dims /= R_Dims then + Error_Msg_N + ("?both operands for operation% must have same " & + "dimension", N); + else + Set_Dimensions (N, L_Dims); + end if; + + elsif not L_Has_Dimensions and R_Has_Dimensions then + Error_Msg_N + ("?both operands for operation% must have same dimension", + N); + + elsif L_Has_Dimensions and not R_Has_Dimensions then + Error_Msg_N + ("?both operands for operation% must have same dimension", + N); + + end if; + + elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then + + if L_Has_Dimensions and R_Has_Dimensions then + + -- Get both operands dimension and add them + + if N_Kind = N_Op_Multiply then + for Dim in Dimensions'Range loop + Dims (Dim) := L_Dims (Dim) + R_Dims (Dim); + end loop; + + -- Get both operands dimension and subtract them + + else + for Dim in Dimensions'Range loop + Dims (Dim) := L_Dims (Dim) - R_Dims (Dim); + end loop; + end if; + + elsif L_Has_Dimensions and not R_Has_Dimensions then + Dims := L_Dims; + + elsif not L_Has_Dimensions and R_Has_Dimensions then + + if N_Kind = N_Op_Multiply then + Dims := R_Dims; + else + for Dim in R_Dims'Range loop + Dims (Dim) := -R_Dims (Dim); + end loop; + end if; + end if; + + if Present (Dims) then + Set_Dimensions (N, Dims); + end if; + + -- N_Op_Expon + -- Propagation of the dimension and evaluation of the result if + -- the exponent is a rational and if the operand has a dimension. + + elsif N_Kind = N_Op_Expon then + declare + Rat : Rational := Zero_Rational; + + begin + -- Check exponent is dimensionless + + if R_Has_Dimensions then + Error_Msg_N + ("?right operand cannot have a dimension for&", + Identifier (N)); + + else + -- Check the left operand is not dimensionless + + -- Note that the value of the exponent must be know at + -- compile time. Otherwise, the exponentiation evaluation + -- will return an error message. + + if Get_Dimension_System_Id + (Base_Type (Etype (L))) /= No_Dim_Sys + and then Compile_Time_Known_Value (R) + then + -- Real exponent case + + if Is_Real_Type (Etype (L)) then + -- Define the exponent as a Rational number + + Create_Rational_From_Expr (R, Rat); + + if L_Has_Dimensions then + for Dim in Dimensions'Range loop + Dims (Dim) := L_Dims (Dim) * Rat; + end loop; + + if Present (Dims) then + Set_Dimensions (N, Dims); + end if; + end if; + + -- Evaluate the operator with rational exponent + + -- Eval_Op_Expon_With_Rational_Exponent (N, Rat); + + -- Integer exponent case + + else + for Dim in Dimensions'Range loop + Dims (Dim) := + L_Dims (Dim) * + Whole (UI_To_Int (Expr_Value (R))); + end loop; + + if Present (Dims) then + Set_Dimensions (N, Dims); + end if; + end if; + end if; + end if; + end; + + -- For relational operations, only a dimension checking is + -- performed. + -- No propagation + + elsif N_Kind in N_Op_Compare then + Error_Msg_Name_1 := Chars (N); + + if (L_Has_Dimensions or R_Has_Dimensions) + and then L_Dims /= R_Dims + then + Error_Msg_N + ("?both operands for operation% must have same dimension", + N); + end if; + end if; + + Remove_Dimensions (L); + Remove_Dimensions (R); + end; + end if; + end Analyze_Dimension_Binary_Op; + + --------------------------------------------- + -- Analyze_Dimension_Component_Declaration -- + --------------------------------------------- + + procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + Id : constant Entity_Id := Defining_Identifier (N); + E_Typ : constant Entity_Id := Etype (Id); + Dim_T : constant Dimensions := Get_Dimensions (E_Typ); + Dim_E : Dimensions; + + begin + if Present (Dim_T) then + + -- If the component type has a dimension and there is no expression, + -- propagates the dimension. + + if Present (Expr) then + Dim_E := Get_Dimensions (Expr); + + if Present (Dim_E) then + -- Return an error if the dimension of the expression and the + -- dimension of the type missmatch. + + if Dim_E /= Dim_T then + Error_Msg_N ("?dimensions missmatch in object " & + "declaration", N); + end if; + + -- If the expression is dimensionless + + else + Error_Msg_N + ("?dimensions missmatch in component declaration", N); + end if; + + -- For every other cases, propagate the dimensions + + else + Copy_Dimensions (E_Typ, Id); + end if; + end if; + end Analyze_Dimension_Component_Declaration; + + ------------------------------------------------- + -- Analyze_Dimension_Extended_Return_Statement -- + ------------------------------------------------- + + procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is + Obj_Decls : constant List_Id := Return_Object_Declarations (N); + R_Ent : constant Entity_Id := Return_Statement_Entity (N); + R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); + Dims_R : constant Dimensions := Get_Dimensions (R_Etyp); + Dims_Obj : Dimensions; + Obj_Decl : Node_Id; + Obj_Id : Entity_Id; + + begin + if Present (Obj_Decls) then + Obj_Decl := First (Obj_Decls); + + while Present (Obj_Decl) loop + if Nkind (Obj_Decl) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Obj_Decl); + + if Is_Return_Object (Obj_Id) then + Dims_Obj := Get_Dimensions (Obj_Id); + + if Dims_R /= Dims_Obj then + Error_Msg_N ("?dimensions missmatch in return statement", + N); + return; + end if; + end if; + end if; + + Next (Obj_Decl); + end loop; + end if; + end Analyze_Dimension_Extended_Return_Statement; + + ------------------------------------- + -- Analyze_Dimension_Function_Call -- + ------------------------------------- + + procedure Analyze_Dimension_Function_Call (N : Node_Id) is + Name_Call : constant Node_Id := Name (N); + Par_Ass : constant List_Id := Parameter_Associations (N); + Dims : Dimensions; + Dims_Param : Dimensions; + Param : Node_Id; + + function Is_Elementary_Function_Call (N : Node_Id) return Boolean; + -- Return True if the call is a call of an elementary function (see + -- Ada.Numerics.Generic_Elementary_Functions). + + --------------------------------- + -- Is_Elementary_Function_Call -- + --------------------------------- + + function Is_Elementary_Function_Call (N : Node_Id) return Boolean is + Ent : Entity_Id; + + begin + -- Note that the node must come from source + + if Comes_From_Source (N) + and then Is_Entity_Name (Name_Call) + then + Ent := Entity (Name_Call); + + -- Check the procedure is defined in an instantiation of a generic + -- package. + + if Is_Generic_Instance (Scope (Ent)) then + Ent := Cunit_Entity (Get_Source_Unit (Ent)); + + -- Check the name of the generic package is + -- Generic_Elementary_Functions + + if Is_Library_Level_Entity (Ent) + and then Chars (Ent) = Name_Generic_Elementary_Functions + then + return True; + end if; + end if; + end if; + + return False; + end Is_Elementary_Function_Call; + + -- Start of processing for Analyze_Dimension_Function_Call + + begin + -- Elementary function case + + if Is_Elementary_Function_Call (N) then + + -- Sqrt function call case + + if Chars (Name_Call) = Name_Sqrt then + Dims := Get_Dimensions (First (Par_Ass)); + + if Present (Dims) then + for Dim in Dims'Range loop + Dims (Dim) := Dims (Dim) * (1, 2); + end loop; + + Set_Dimensions (N, Dims); + end if; + + -- All other functions in Ada.Numerics.Generic_Elementary_Functions + -- Note that all parameters here should be dimensionless + + else + Param := First (Par_Ass); + + while Present (Param) loop + Dims_Param := Get_Dimensions (Param); + + if Present (Dims_Param) then + Error_Msg_Name_1 := Chars (Name_Call); + Error_Msg_N + ("?parameter should be dimensionless for elementary " & + "function%", + Param); + return; + end if; + + Next (Param); + end loop; + end if; + + -- General case + + else + Analyze_Dimension_Has_Etype (N); + end if; + end Analyze_Dimension_Function_Call; + + --------------------------------- + -- Analyze_Dimension_Has_Etype -- + --------------------------------- + + procedure Analyze_Dimension_Has_Etype (N : Node_Id) is + E_Typ : constant Entity_Id := Etype (N); + Dims : constant Dimensions := Get_Dimensions (E_Typ); + N_Kind : constant Node_Kind := Nkind (N); + + begin + -- Propagation of the dimensions from the type + + if Present (Dims) then + Set_Dimensions (N, Dims); + end if; + + -- Removal of dimensions in expression + + if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then + declare + Expr : Node_Id; + Exprs : constant List_Id := Expressions (N); + + begin + if Present (Exprs) then + Expr := First (Exprs); + + while Present (Expr) loop + Remove_Dimensions (Expr); + Next (Expr); + end loop; + end if; + end; + + elsif Nkind_In + (N_Kind, + N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Remove_Dimensions (Expression (N)); + + elsif N_Kind = N_Selected_Component then + Remove_Dimensions (Selector_Name (N)); + end if; + end Analyze_Dimension_Has_Etype; + + ---------------------------------- + -- Analyze_Dimension_Identifier -- + ---------------------------------- + + procedure Analyze_Dimension_Identifier (N : Node_Id) is + Ent : constant Entity_Id := Entity (N); + Dims : constant Dimensions := Get_Dimensions (Ent); + + begin + if Present (Dims) then + Set_Dimensions (N, Dims); + else + Analyze_Dimension_Has_Etype (N); + end if; + end Analyze_Dimension_Identifier; + + ------------------------------------------ + -- Analyze_Dimension_Object_Declaration -- + ------------------------------------------ + + procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + Id : constant Entity_Id := Defining_Identifier (N); + E_Typ : constant Entity_Id := Etype (Id); + Dim_T : constant Dimensions := Get_Dimensions (E_Typ); + Dim_E : Dimensions; + + begin + if Present (Dim_T) then + -- Expression is present + + if Present (Expr) then + Dim_E := Get_Dimensions (Expr); + + if Present (Dim_E) then + -- Return an error if the dimension of the expression and the + -- dimension of the type missmatch. + + if Dim_E /= Dim_T then + Error_Msg_N ("?dimensions missmatch in object " & + "declaration", N); + end if; + + -- If the expression is dimensionless + + else + -- If the node is not a real constant or an integer constant + -- (depending on the dimensioned numeric type), return an error + -- message. + + if not Nkind_In + (Original_Node (Expr), + N_Real_Literal, + N_Integer_Literal) + then + Error_Msg_N ("?dimensions missmatch in object " & + "declaration", N); + end if; + end if; + + -- For every other cases, propagate the dimensions + + else + Copy_Dimensions (E_Typ, Id); + end if; + end if; + end Analyze_Dimension_Object_Declaration; + + --------------------------------------------------- + -- Analyze_Dimension_Object_Renaming_Declaration -- + --------------------------------------------------- + + procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + Ren_Id : constant Node_Id := Name (N); + E_Typ : constant Entity_Id := Etype (Ren_Id); + Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + + begin + if Present (Dims_Typ) then + Copy_Dimensions (E_Typ, Id); + end if; + end Analyze_Dimension_Object_Renaming_Declaration; + + ----------------------------------------------- + -- Analyze_Dimension_Simple_Return_Statement -- + ----------------------------------------------- + + procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + Dims_Expr : constant Dimensions := Get_Dimensions (Expr); + R_Ent : constant Entity_Id := Return_Statement_Entity (N); + R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); + Dims_R : constant Dimensions := Get_Dimensions (R_Etyp); + + begin + if Dims_R /= Dims_Expr then + Error_Msg_N ("?dimensions missmatch in return statement", N); + Remove_Dimensions (Expr); + end if; + end Analyze_Dimension_Simple_Return_Statement; + + ------------------------------------------- + -- Analyze_Dimension_Subtype_Declaration -- + ------------------------------------------- + + procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is + Ent : constant Entity_Id := Defining_Identifier (N); + Dims_Ent : constant Dimensions := Get_Dimensions (Ent); + E_Typ : Node_Id; + + begin + if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then + E_Typ := Etype (Subtype_Indication (N)); + declare + Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + + begin + if Present (Dims_Typ) then + + -- If the subtype already has a dimension (from + -- Aspect_Dimension), it cannot inherit a dimension from its + -- subtype. + + if Present (Dims_Ent) then + Error_Msg_N ("?subtype& already has a dimension", N); + + else + Set_Dimensions (Ent, Dims_Typ); + Set_Dimensions_String_Id + (Ent, Get_Dimensions_String_Id (E_Typ)); + end if; + end if; + end; + + else + E_Typ := Etype (Subtype_Mark (Subtype_Indication (N))); + declare + Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + + begin + if Present (Dims_Typ) then + + -- If the subtype already has a dimension (from + -- Aspect_Dimension), it cannot inherit a dimension from its + -- subtype. + + if Present (Dims_Ent) then + Error_Msg_N ("?subtype& already has a dimension", N); + + else + Set_Dimensions (Ent, Dims_Typ); + Set_Dimensions_String_Id + (Ent, Get_Dimensions_String_Id (E_Typ)); + end if; + end if; + end; + end if; + end Analyze_Dimension_Subtype_Declaration; + + -------------------------------- + -- Analyze_Dimension_Unary_Op -- + -------------------------------- + + procedure Analyze_Dimension_Unary_Op (N : Node_Id) is + begin + case Nkind (N) is + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + declare + R : constant Node_Id := Right_Opnd (N); + + begin + -- Propagate the dimension if the operand is not dimensionless + + Move_Dimensions (R, N); + end; + + when others => null; + + end case; + end Analyze_Dimension_Unary_Op; + + --------------------- + -- Copy_Dimensions -- + --------------------- + + procedure Copy_Dimensions (From, To : Node_Id) is + Dims : constant Dimensions := Aspect_Dimension_Hash_Table.Get (From); + + begin + -- Propagate the dimension from one node to another + + pragma Assert (Permits_Dimensions (To)); + pragma Assert (Present (Dims)); + Aspect_Dimension_Hash_Table.Set (To, Dims); + end Copy_Dimensions; + + ------------------------------- + -- Create_Rational_From_Expr -- + ------------------------------- + + procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational) is + Or_N : constant Node_Id := Original_Node (Expr); + Left : Node_Id; + Left_Int : Int; + Ltype : Entity_Id; + Right : Node_Id; + Right_Int : Int; + R_Opnd_Minus : Node_Id; + Rtype : Entity_Id; + + begin + -- A rational number is any number that can be expressed as the quotient + -- or fraction a/b of two integers, with the denominator b not equal to + -- zero. + + -- Check the expression is either a division of two integers or an + -- integer itself. The check applies to the original node since the + -- node could have already been rewritten. + + -- Numerator is positive + + if Nkind (Or_N) = N_Op_Divide then + Left := Left_Opnd (Or_N); + Ltype := Etype (Left); + Right := Right_Opnd (Or_N); + Rtype := Etype (Right); + + if Is_Integer_Type (Ltype) + and then Is_Integer_Type (Rtype) + then + Left_Int := UI_To_Int (Expr_Value (Left)); + Right_Int := UI_To_Int (Expr_Value (Right)); + + -- Verify that the denominator of the rational is positive + + if Right_Int > 0 then + + if Left_Int mod Right_Int = 0 then + R := +Whole (UI_To_Int (Expr_Value (Expr))); + else + R := Whole (Left_Int) / Whole (Right_Int); + end if; + + else + Error_Msg_N + ("denominator in a rational number must be positive", Right); + end if; + + else + Error_Msg_N ("must be a rational", Expr); + end if; + + -- Numerator is negative + + elsif Nkind (Or_N) = N_Op_Minus + and then Nkind (Original_Node (Right_Opnd (Or_N))) = N_Op_Divide + then + R_Opnd_Minus := Original_Node (Right_Opnd (Or_N)); + Left := Left_Opnd (R_Opnd_Minus); + Ltype := Etype (Left); + Right := Right_Opnd (R_Opnd_Minus); + Rtype := Etype (Right); + + if Is_Integer_Type (Ltype) + and then Is_Integer_Type (Rtype) + then + Left_Int := UI_To_Int (Expr_Value (Left)); + Right_Int := UI_To_Int (Expr_Value (Right)); + + -- Verify that the denominator of the rational is positive + + if Right_Int > 0 then + + if Left_Int mod Right_Int = 0 then + R := +Whole (-UI_To_Int (Expr_Value (Expr))); + else + R := Whole (-Left_Int) / Whole (Right_Int); + end if; + + else + Error_Msg_N + ("denominator in a rational number must be positive", Right); + end if; + + else + Error_Msg_N ("must be a rational", Expr); + end if; + + -- Integer case + + else + if Is_Integer_Type (Etype (Expr)) then + Right_Int := UI_To_Int (Expr_Value (Expr)); + R := +Whole (Right_Int); + else + Error_Msg_N ("must be a rational", Expr); + end if; + end if; + end Create_Rational_From_Expr; + + ---------------------------------------- + -- Eval_Op_Expon_For_Dimensioned_Type -- + ---------------------------------------- + + -- Eval the expon operator for dimensioned type + + -- Note that if the exponent is an integer (denominator equals to 1) the + -- node is not evaluated here and must be evaluated by the Eval_Op_Expon + -- routine. + + procedure Eval_Op_Expon_For_Dimensioned_Type + (N : Node_Id; + B_Typ : Entity_Id) + is + R : constant Node_Id := Right_Opnd (N); + Rat : Rational := Zero_Rational; + + begin + if Compile_Time_Known_Value (R) + and then Is_Real_Type (B_Typ) + then + Create_Rational_From_Expr (R, Rat); + Eval_Op_Expon_With_Rational_Exponent (N, Rat); + end if; + end Eval_Op_Expon_For_Dimensioned_Type; + + ------------------------------------------ + -- Eval_Op_Expon_With_Rational_Exponent -- + ------------------------------------------ + + -- For dimensioned operand in exponentiation, exponent is allowed to be a + -- Rational and not only an Integer like for dimensionless operands. For + -- that particular case, the left operand is rewritten as a function call + -- using the function Expon_LLF from s-llflex.ads. + + procedure Eval_Op_Expon_With_Rational_Exponent + (N : Node_Id; + Rat : Rational) + is + Dims : constant Dimensions := Get_Dimensions (N); + L : constant Node_Id := Left_Opnd (N); + Etyp : constant Entity_Id := Etype (L); + Loc : constant Source_Ptr := Sloc (N); + Actual_1 : Node_Id; + Actual_2 : Node_Id; + Base_Typ : Entity_Id; + Dim_Value : Rational; + List_Of_Dims : List_Id; + New_Aspect : Node_Id; + New_Aspects : List_Id; + New_E : Entity_Id; + New_N : Node_Id; + New_Typ_L : Node_Id; + Sys : Dim_Sys_Id; + + begin + -- If Rat.Denominator = 1 that means the exponent is an Integer so + -- nothing has to be changed. + -- Note that the node must come from source + + if Comes_From_Source (N) + and then Rat.Denominator /= 1 + then + Base_Typ := Base_Type (Etyp); + + -- Case when the operand is not dimensionless + + if Present (Dims) then + + -- Get the corresponding Dim_Sys_Id to know the exact number of + -- dimensions in the system. + + Sys := Get_Dimension_System_Id (Base_Typ); + + -- Step 1: Generation of a new subtype with the proper dimensions + + -- In order to rewrite the operator as a function call, a new + -- subtype with an aspect dimension using the dimensions of the + -- node has to be created. + + -- Generate: + + -- Base_Typ : constant Entity_Id := Base_Type (Etyp); + -- Sys : constant Dim_Sys_Id := + -- Get_Dimension_System_Id (Base_Typ); + -- N_Dims : constant N_Of_Dimensions := + -- Dim_Systems.Table (Sys).N_Of_Dims; + -- Dim_Value : Rational; + + -- Aspect_Dim_Expr : List; + + -- Append ("", Aspect_Dim_Expr); + + -- for Dim in Dims'First .. N_Dims loop + -- Dim_Value := Dims (Dim); + -- if Dim_Value.Denominator /= 1 then + -- Append (Dim_Value.Numerator / Dim_Value.Denominator, + -- Aspect_Dim_Expr); + -- else + -- Append (Dim_Value.Numerator, Aspect_Dim_Expr); + -- end if; + -- end loop; + + -- subtype T is Base_Typ with Dimension => Aspect_Dim_Expr; + + -- Step 1a: Generate the aggregate for the new Aspect_dimension + + New_Aspects := Empty_List; + List_Of_Dims := New_List; + + Append (Make_String_Literal (Loc, No_String), List_Of_Dims); + + for Dim in Dims'First .. Dim_Systems.Table (Sys).N_Of_Dims loop + Dim_Value := Dims (Dim); + if Dim_Value.Denominator /= 1 then + Append ( + Make_Op_Divide (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Int (Dim_Value.Numerator)), + Right_Opnd => + Make_Integer_Literal (Loc, + Int (Dim_Value.Denominator))), + List_Of_Dims); + else + Append ( + Make_Integer_Literal (Loc, + Int (Dim_Value.Numerator)), + List_Of_Dims); + end if; + end loop; + + -- Step 1b: Create the new Aspect_Dimension + + New_Aspect := + Make_Aspect_Specification (Loc, + Identifier => + Make_Identifier (Loc, Name_Dimension), + Expression => + Make_Aggregate (Loc, + Expressions => List_Of_Dims)); + + -- Step 1c: New identifier for the subtype + + New_E := Make_Temporary (Loc, 'T'); + Set_Is_Internal (New_E); + + -- Step 1d: Declaration of the new subtype + + New_Typ_L := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_E, + Subtype_Indication => + New_Occurrence_Of (Base_Typ, Loc)); + + Append (New_Aspect, New_Aspects); + Set_Parent (New_Aspects, New_Typ_L); + Set_Aspect_Specifications (New_Typ_L, New_Aspects); + + Analyze (New_Typ_L); + + -- Case where the operand is dimensionless + + else + New_E := Base_Typ; + end if; + + -- Step 2: Generation of the function call + + -- Generate: + + -- Actual_1 := Long_Long_Float (L), + + -- Actual_2 := Long_Long_Float (Rat.Numerator) / + -- Long_Long_Float (Rat.Denominator); + + -- (T (Expon_LLF (Actual_1, Actual_2))); + + -- -- where T is the subtype declared in step 1 + + -- -- The node is rewritten as a type conversion + + -- Step 2a: Creation of the two parameters for function Expon_LLF + + Actual_1 := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc), + Expression => Relocate_Node (L)); + + Actual_2 := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Real_Literal (Loc, + UR_From_Uint (UI_From_Int (Int (Rat.Numerator)))), + Right_Opnd => + Make_Real_Literal (Loc, + UR_From_Uint (UI_From_Int (Int (Rat.Denominator))))); + + -- Step 2b: New Node N + + New_N := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (New_E, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Expon_LLF), Loc), + Parameter_Associations => New_List ( + Actual_1, Actual_2))); + + -- Step 3: Rewitten of N + + Rewrite (N, New_N); + Set_Etype (N, New_E); + Analyze_And_Resolve (N, New_E); + end if; + end Eval_Op_Expon_With_Rational_Exponent; + + ------------------------------------------- + -- Expand_Put_Call_With_Dimension_String -- + ------------------------------------------- + + -- For procedure Put defined in System.Dim_Float_IO and + -- System.Dim_Integer_IO, the default string parameter must be rewritten to + -- include the dimension symbols in the output of a dimensioned object. + + -- There are two different cases: + + -- 1) If the parameter is a variable, the default string parameter is + -- replaced by the string defined in the aspect Dimension of the subtype. + -- For instance if the user wants to output a speed: + + -- subtype Speed is Mks_Type with Dimension => + -- ("speed", Meter => 1, Second => -1, others => 0); + -- v : Speed := 2.1 * m * s**(-1); + + -- Put (v) returns: + -- > 2.1 speed + + -- 2) If the parameter is an expression, the procedure + -- Expand_Put_Call_With_Dimension_String creates the string (for instance + -- "m.s**(-1)") and rewrites the default string parameter of Put with the + -- corresponding the String_Id. + + procedure Expand_Put_Call_With_Dimension_String (N : Node_Id) is + Actuals : constant List_Id := Parameter_Associations (N); + Loc : constant Source_Ptr := Sloc (N); + Name_Call : constant Node_Id := Name (N); + Actual : Node_Id; + Base_Typ : Node_Id; + Char_Pack : Name_Id; + Dims : Dimensions; + Etyp : Entity_Id; + First_Actual : Node_Id; + New_Par_Ass : List_Id; + New_Str_Lit : Node_Id; + Sys : Dim_Sys_Id; + + function Is_Procedure_Put_Call (N : Node_Id) return Boolean; + -- Return True if the current call is a call of an instantiation of a + -- procedure Put defined in the package System.Dim_Float_IO and + -- System.Dim_Integer_IO. + + function Is_Procedure_Put_Call (N : Node_Id) return Boolean is + Name_Call : constant Node_Id := Name (N); + Ent : Entity_Id; + + begin + -- There are three different Put routine in each generic package + -- Check that the current procedure call is one of them + + if Is_Entity_Name (Name_Call) then + Ent := Entity (Name_Call); + + -- Check that the name of the procedure is Put + + if Chars (Name_Call) /= Name_Put then + return False; + end if; + + -- Check the procedure is defined in an instantiation of a + -- generic package. + + if Is_Generic_Instance (Scope (Ent)) then + Ent := Cunit_Entity (Get_Source_Unit (Ent)); + + -- Verify that the generic package is System.Dim_Float_IO or + -- System.Dim_Integer_IO. + + if Is_Library_Level_Entity (Ent) then + Char_Pack := Chars (Ent); + + if Char_Pack = Name_Dim_Float_IO + or else Char_Pack = Name_Dim_Integer_IO + then + return True; + end if; + end if; + end if; + end if; + + return False; + end Is_Procedure_Put_Call; + + -- Start of processing for Expand_Put_Call_With_Dimension_String + + begin + if Is_Procedure_Put_Call (N) then + + -- Get the first parameter + + First_Actual := First (Actuals); + + -- Case when the Put routine has four (integer case) or five (float + -- case) parameters. + + if List_Length (Actuals) = 5 + or else List_Length (Actuals) = 4 + then + Actual := Next (First_Actual); + + if Nkind (Actual) = N_Parameter_Association then + + -- Get the dimensions and the corresponding dimension system + -- from the first actual. + + Actual := First_Actual; + end if; + + -- Case when the Put routine has six parameters + + else + Actual := Next (First_Actual); + end if; + + Base_Typ := Base_Type (Etype (Actual)); + Sys := Get_Dimension_System_Id (Base_Typ); + + if Sys /= No_Dim_Sys then + Dims := Get_Dimensions (Actual); + Etyp := Etype (Actual); + + -- Add the string as a suffix of the value if the subtype has a + -- string of dimensions or if the parameter is not dimensionless. + + if Present (Dims) + or else Get_Dimensions_String_Id (Etyp) /= No_String + then + New_Par_Ass := New_List; + + -- Add to the list First_Actual and Actual if they differ + + if Actual /= First_Actual then + Append (New_Copy (First_Actual), New_Par_Ass); + end if; + + Append (New_Copy (Actual), New_Par_Ass); + + -- Look to the next parameter + + Next (Actual); + + -- Check if the type of N is a subtype that has a string of + -- dimensions in Aspect_Dimension_String_Id_Hash_Table. + + if Get_Dimensions_String_Id (Etyp) /= No_String then + Start_String; + + -- Put a space between the value and the dimension + + Store_String_Char (' '); + Store_String_Chars (Get_Dimensions_String_Id (Etyp)); + New_Str_Lit := + Make_String_Literal (Loc, End_String); + + -- Rewrite the String_Literal of the second actual with the + -- new String_Id created by the routine + -- From_Dimension_To_String. + + else + New_Str_Lit := + Make_String_Literal (Loc, + From_Dimension_To_String_Id (Dims, Sys)); + end if; + + Append (New_Str_Lit, New_Par_Ass); + + -- Rewrite the procedure call with the new list of parameters + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Copy (Name_Call), + Parameter_Associations => New_Par_Ass)); + + Analyze (N); + end if; + end if; + end if; + end Expand_Put_Call_With_Dimension_String; + + --------------------------------- + -- From_Dimension_To_String_Id -- + --------------------------------- + + -- Given a dimension vector and the corresponding dimension system, create + -- a String_Id to output the dimension symbols corresponding to the + -- dimensions Dims. + + function From_Dimension_To_String_Id + (Dims : Dimensions; + Sys : Dim_Sys_Id) return String_Id + is + Dim_Rat : Rational; + First_Dim_In_Str : Boolean := True; + + begin + -- Initialization of the new String_Id + + Start_String; + + -- Put a space between the value and the dimensions + + Store_String_Char (' '); + + for Dim in Dimensions'Range loop + + Dim_Rat := Dims (Dim); + if Dim_Rat /= Zero_Rational then + + if First_Dim_In_Str then + First_Dim_In_Str := False; + else + Store_String_Char ('.'); + end if; + + -- Positive dimension case + + if Dim_Rat.Numerator > 0 then + + if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then + Store_String_Chars + (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); + else + Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); + end if; + + -- Integer case + + if Dim_Rat.Denominator = 1 then + + if Dim_Rat.Numerator /= 1 then + Store_String_Chars ("**"); + Store_String_Int (Int (Dim_Rat.Numerator)); + end if; + + -- Rational case when denominator /= 1 + + else + Store_String_Chars ("**"); + Store_String_Char ('('); + Store_String_Int (Int (Dim_Rat.Numerator)); + Store_String_Char ('/'); + Store_String_Int (Int (Dim_Rat.Denominator)); + Store_String_Char (')'); + end if; + + -- Negative dimension case + + else + if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then + Store_String_Chars + (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); + else + Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); + end if; + + Store_String_Chars ("**"); + Store_String_Char ('('); + Store_String_Char ('-'); + Store_String_Int (Int (-Dim_Rat.Numerator)); + + -- Integer case + + if Dim_Rat.Denominator = 1 then + Store_String_Char (')'); + + -- Rational case when denominator /= 1 + + else + Store_String_Char ('/'); + Store_String_Int (Int (Dim_Rat.Denominator)); + Store_String_Char (')'); + end if; + end if; + end if; + end loop; + + return End_String; + end From_Dimension_To_String_Id; + + -------------------- + -- Get_Dimensions -- + -------------------- + + function Get_Dimensions (N : Node_Id) return Dimensions is + begin + return Aspect_Dimension_Hash_Table.Get (N); + end Get_Dimensions; + + ------------------------------ + -- Get_Dimensions_String_Id -- + ------------------------------ + + function Get_Dimensions_String_Id (E : Entity_Id) return String_Id is + begin + return Aspect_Dimension_String_Id_Hash_Table.Get (E); + end Get_Dimensions_String_Id; + + ----------------------------- + -- Get_Dimension_System_Id -- + ----------------------------- + + function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id is + D_Sys : Dim_Sys_Id := No_Dim_Sys; + + begin + -- Scan the Table in order to find N + + for Dim_Sys in 1 .. Dim_Systems.Last loop + if Parent (E) = Dim_Systems.Table (Dim_Sys).Base_Type then + D_Sys := Dim_Sys; + end if; + end loop; + + return D_Sys; + end Get_Dimension_System_Id; + + -------------------------- + -- Is_Dimensioned_Type -- + -------------------------- + + function Is_Dimensioned_Type (E : Entity_Id) return Boolean + is + begin + if Get_Dimension_System_Id (E) /= No_Dim_Sys then + return True; + end if; + + return False; + end Is_Dimensioned_Type; + + --------------------- + -- Move_Dimensions -- + --------------------- + + procedure Move_Dimensions (From, To : Node_Id) is + Dims : constant Dimensions := Get_Dimensions (From); + + begin + -- Copy the dimension of 'From to 'To' and remove the dimension of + -- 'From'. + + if Present (Dims) then + Set_Dimensions (To, Dims); + Remove_Dimensions (From); + end if; + end Move_Dimensions; + + ------------------------ + -- Permits_Dimensions -- + ------------------------ + + -- Here is the list of node that permits a dimension + + Dimensions_Permission : constant array (Node_Kind) of Boolean := + (N_Attribute_Reference => True, + N_Defining_Identifier => True, + N_Function_Call => True, + N_Identifier => True, + N_Indexed_Component => True, + N_Integer_Literal => True, + + N_Op_Abs => True, + N_Op_Add => True, + N_Op_Divide => True, + N_Op_Expon => True, + N_Op_Minus => True, + N_Op_Mod => True, + N_Op_Multiply => True, + N_Op_Plus => True, + N_Op_Rem => True, + N_Op_Subtract => True, + + N_Qualified_Expression => True, + N_Real_Literal => True, + N_Selected_Component => True, + N_Slice => True, + N_Type_Conversion => True, + N_Unchecked_Type_Conversion => True, + + others => False); + + function Permits_Dimensions (N : Node_Id) return Boolean is + begin + return Dimensions_Permission (Nkind (N)); + end Permits_Dimensions; + + ------------- + -- Present -- + ------------- + + function Present (Dim : Dimensions) return Boolean is + begin + return Dim /= Zero_Dimensions; + end Present; + + ----------------------- + -- Remove_Dimensions -- + ----------------------- + + procedure Remove_Dimensions (N : Node_Id) is + Dims : constant Dimensions := Get_Dimensions (N); + + begin + if Present (Dims) then + Aspect_Dimension_Hash_Table.Remove (N); + end if; + end Remove_Dimensions; + + ------------------------------ + -- Remove_Dimension_In_Call -- + ------------------------------ + + procedure Remove_Dimension_In_Call (N : Node_Id) is + Actual : Node_Id; + Par_Ass : constant List_Id := Parameter_Associations (N); + + begin + if Ada_Version < Ada_2012 then + return; + end if; + + if Present (Par_Ass) then + Actual := First (Par_Ass); + + while Present (Actual) loop + Remove_Dimensions (Actual); + Next (Actual); + end loop; + end if; + end Remove_Dimension_In_Call; + + ------------------------------------- + -- Remove_Dimension_In_Declaration -- + ------------------------------------- + + -- Removal of dimension in expressions of N_Object_Declaration and + -- N_Component_Declaration as part of the Analyze_Declarations routine + -- (see package Sem_Ch3). + + procedure Remove_Dimension_In_Declaration (D : Node_Id) is + begin + if Ada_Version < Ada_2012 then + return; + end if; + + if Nkind_In (D, N_Object_Declaration, N_Component_Declaration) then + if Present (Expression (D)) then + Remove_Dimensions (Expression (D)); + end if; + end if; + end Remove_Dimension_In_Declaration; + + ----------------------------------- + -- Remove_Dimension_In_Statement -- + ----------------------------------- + + -- Removal of dimension in statement as part of the Analyze_Statements + -- routine (see package Sem_Ch5). + + procedure Remove_Dimension_In_Statement (S : Node_Id) is + S_Kind : constant Node_Kind := Nkind (S); + + begin + if Ada_Version < Ada_2012 then + return; + end if; + + -- Remove dimension in parameter specifications for accept statement + + if S_Kind = N_Accept_Statement then + declare + Param : Node_Id := First (Parameter_Specifications (S)); + + begin + while Present (Param) loop + Remove_Dimensions (Param); + Next (Param); + end loop; + end; + + -- Remove dimension of name and expression in assignments + + elsif S_Kind = N_Assignment_Statement then + Remove_Dimensions (Expression (S)); + Remove_Dimensions (Name (S)); + end if; + end Remove_Dimension_In_Statement; + + -------------------- + -- Set_Dimensions -- + -------------------- + + procedure Set_Dimensions (N : Node_Id; Dims : Dimensions) is + begin + pragma Assert (Permits_Dimensions (N)); + pragma Assert (Present (Dims)); + Aspect_Dimension_Hash_Table.Set (N, Dims); + end Set_Dimensions; + + ------------------------------ + -- Set_Dimensions_String_Id -- + ------------------------------ + + procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id) is + begin + Aspect_Dimension_String_Id_Hash_Table.Set (E, Str); + end Set_Dimensions_String_Id; + +end Sem_Dim; diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads new file mode 100644 index 00000000000..8089f432160 --- /dev/null +++ b/gcc/ada/sem_dim.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2011, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This new package of the GNAT compiler has been created in order to enable +-- any user of the GNAT compiler to deal with physical issues. + +-- Indeed, the user is now able to create his own dimension system and to +-- assign a dimension, defined from the MKS system (package System.Dim_Mks) +-- or his own dimension systems, with any item and to run operations with +-- dimensionned entities. +-- In that case, a dimensionnality checking will be performed at compile time. +-- If no dimension has been assigned, the compiler assumes that the item is +-- dimensionless. + +----------------------------- +-- Aspect_Dimension_System -- +----------------------------- + +-- In order to enable the user to create his own dimension system, a new +-- aspect: Aspect_Dimension_System has been created. +-- Note that this aspect applies for type declaration of type derived from any +-- numeric type. + +-- It defines the names of each dimension. + +---------------------- +-- Aspect_Dimension -- +---------------------- + +-- This new aspect applies for subtype and object declarations in order to +-- define new dimensions. +-- Using this aspect, the user is able to create new subtype/object with any +-- dimension needed. +-- Note that the base type of the subtype/object must be the type that defines +-- the corresponding dimension system. + +-- The expression of this aspect is an aggregate of rational values for each +-- dimension in the corresponding dimension system. + +------------------------------------------- +-- Dimensionality checking & propagation -- +------------------------------------------- + +-- For each node (when needed), a dimension analysis (Analyze_Dimension) is +-- performed as part of the Resolution routine or the Analysis routine if no +-- Resolution. + +-- The dimension analysis is divided into two phases: + +-- Phase 1: dimension checking + +-- Phase 2: propagation of dimensions + +-- Depending on the node kind, either none, one phase or two phases are +-- executed. +-- Phase 2 is called only when the node allows a dimension (see body of +-- Sem_Dim to get the list of nodes that permit dimensions). + +------------------ +-- Dimension_IO -- +------------------ + +-- This section contains the routine used for IO purposes. + +with Types; use Types; + +package Sem_Dim is + + ----------------------------- + -- Aspect_Dimension_System -- + ----------------------------- + + procedure Analyze_Aspect_Dimension_System + (N : Node_Id; + Id : Node_Id; + Expr : Node_Id); + -- Analyzes the aggregate of Aspect_Dimension_System + + ---------------------- + -- Aspect_Dimension -- + ---------------------- + + procedure Analyze_Aspect_Dimension + (N : Node_Id; + Id : Node_Id; + Expr : Node_Id); + -- Analyzes the aggregate of Aspect_Dimension and attaches the + -- corresponding dimension to N. + + ------------------------------------------- + -- Dimensionality checking & propagation -- + ------------------------------------------- + + procedure Analyze_Dimension (N : Node_Id); + -- Performs a dimension analysis and propagates dimension between nodes + -- when needed. + + procedure Eval_Op_Expon_For_Dimensioned_Type + (N : Node_Id; + B_Typ : Entity_Id); + -- Eval the Expon operator for dimensioned type with rational exponent + + function Is_Dimensioned_Type (E : Entity_Id) return Boolean; + -- Return True if the type is a dimensioned type (i.e: a type which has an + -- aspect Dimension_System) + + procedure Remove_Dimension_In_Call (N : Node_Id); + -- At the end of the Expand_Call routine, remove the dimensions of every + -- parameters in the call N. + + procedure Remove_Dimension_In_Declaration (D : Node_Id); + -- At the end of Analyze_Declarations routine (see Sem_Ch3), removes the + -- dimension of the expression for each declaration. + + procedure Remove_Dimension_In_Statement (S : Node_Id); + -- At the end of the Analyze_Statements routine (see Sem_Ch5), removes the + -- dimension for every statements. + + ------------------ + -- Dimension_IO -- + ------------------ + + procedure Expand_Put_Call_With_Dimension_String (N : Node_Id); + -- Expansion of Put call (from package System.Dim_Float_IO and + -- System.Dim_Integer_IO) for a dimensioned object in order to add the + -- dimension symbols as a suffix of the numeric value. + +end Sem_Dim; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ad989d2784a..49460d00b96 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8062,24 +8062,6 @@ package body Sem_Prag is Default_Pool := Expression (Arg1); - --------------- - -- Dimension -- - --------------- - - when Pragma_Dimension => - GNAT_Pragma; - Check_Arg_Count (4); - Check_No_Identifiers; - Check_Arg_Is_Local_Name (Arg1); - - if not Is_Type (Arg1) then - Error_Pragma ("first argument for pragma% must be subtype"); - end if; - - Check_Arg_Is_Static_Expression (Arg2, Standard_Integer); - Check_Arg_Is_Static_Expression (Arg3, Standard_Integer); - Check_Arg_Is_Static_Expression (Arg4, Standard_Integer); - ------------------------------------ -- Disable_Atomic_Synchronization -- ------------------------------------ @@ -14956,7 +14938,6 @@ package body Sem_Prag is Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, Pragma_Default_Storage_Pool => -1, - Pragma_Dimension => -1, Pragma_Disable_Atomic_Synchronization => -1, Pragma_Discard_Names => 0, Pragma_Dispatching_Domain => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 663e0e8203a..55a5e365904 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -57,6 +57,7 @@ with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; @@ -2010,6 +2011,7 @@ package body Sem_Res is if Analyzed (N) then Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); + Analyze_Dimension (N); return; -- Return if type = Any_Type (previous error encountered) @@ -4878,6 +4880,7 @@ package body Sem_Res is end if; Generate_Operator_Reference (N, Typ); + Analyze_Dimension (N); Eval_Arithmetic_Op (N); -- In SPARK, a multiplication or division with operands of fixed point @@ -5808,6 +5811,10 @@ package body Sem_Res is end; end if; + -- dimension analysis + + Analyze_Dimension (N); + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); @@ -6004,6 +6011,7 @@ package body Sem_Res is -- Evaluate the relation (note we do this after the above check since -- this Eval call may change N to True/False. + Analyze_Dimension (N); Eval_Relational_Op (N); end Resolve_Comparison_Op; @@ -6889,6 +6897,7 @@ package body Sem_Res is or else Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N))) then + Analyze_Dimension (N); Eval_Relational_Op (N); elsif Nkind (N) = N_Op_Ne @@ -7143,6 +7152,8 @@ package body Sem_Res is end loop; end if; + Analyze_Dimension (N); + -- Do not generate the warning on suspicious index if we are analyzing -- package Ada.Tags; otherwise we will report the warning with the -- Prims_Ptr field of the dispatch table. @@ -7998,6 +8009,24 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); + + Analyze_Dimension (N); + + -- Evaluate the Expon operator for dimensioned type with rational + -- exponent. + + if Ada_Version >= Ada_2012 + and then Is_Dimensioned_Type (B_Typ) + then + Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); + + -- Skip the Eval_Op_Expon if the node has already been evaluated + + if Nkind (N) = N_Type_Conversion then + return; + end if; + end if; + Eval_Op_Expon (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -8196,6 +8225,7 @@ package body Sem_Res is Set_Etype (N, Etype (Expr)); end if; + Analyze_Dimension (N); Eval_Qualified_Expression (N); end Resolve_Qualified_Expression; @@ -8629,6 +8659,7 @@ package body Sem_Res is Error_Msg_N ("?\may cause unexpected accesses to atomic object", Prefix (N)); end if; + Analyze_Dimension (N); end Resolve_Selected_Component; ------------------- @@ -8940,6 +8971,7 @@ package body Sem_Res is Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; + Analyze_Dimension (N); Eval_Slice (N); end Resolve_Slice; @@ -9346,6 +9378,8 @@ package body Sem_Res is Check_SPARK_Restriction ("object required", Operand); end if; + Analyze_Dimension (N); + -- Note: we do the Eval_Type_Conversion call before applying the -- required checks for a subtype conversion. This is important, since -- both are prepared under certain circumstances to change the type @@ -9629,6 +9663,7 @@ package body Sem_Res is Check_Unset_Reference (R); Generate_Operator_Reference (N, B_Typ); + Analyze_Dimension (N); Eval_Unary_Op (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -9795,6 +9830,7 @@ package body Sem_Res is -- Resolve operand using its own type Resolve (Operand, Opnd_Type); + Analyze_Dimension (N); Eval_Unchecked_Conversion (N); end Resolve_Unchecked_Type_Conversion; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index d15892a5f02..dd2e5948d3c 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -139,6 +139,8 @@ package Snames is Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; + Name_Dimension : constant Name_Id := N + $; + Name_Dimension_System : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; Name_Post : constant Name_Id := N + $; Name_Pre : constant Name_Id := N + $; @@ -219,6 +221,14 @@ package Snames is subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; + -- Names used by the analyzer and expander for aspect Dimension and + -- Dimension_System to deal with Sqrt and IO routines. + + Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12 + Name_Dim_Integer_IO : constant Name_Id := N + $; -- Ada 12 + Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12 + Name_Sqrt : constant Name_Id := N + $; -- Ada 12 + -- Some miscellaneous names used for error detection/recovery Name_Const : constant Name_Id := N + $; @@ -447,7 +457,6 @@ package Snames is Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT Name_CPU : constant Name_Id := N + $; -- Ada 12 Name_Debug : constant Name_Id := N + $; -- GNAT - Name_Dimension : constant Name_Id := N + $; -- GNAT Name_Elaborate : constant Name_Id := N + $; -- Ada 83 Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; @@ -1610,7 +1619,6 @@ package Snames is Pragma_CPP_Vtable, Pragma_CPU, Pragma_Debug, - Pragma_Dimension, Pragma_Elaborate, Pragma_Elaborate_All, Pragma_Elaborate_Body, |
