summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog88
-rw-r--r--gcc/ada/Make-generated.in62
-rw-r--r--gcc/ada/checks.adb7
-rw-r--r--gcc/ada/exp_ch4.adb3
-rw-r--r--gcc/ada/exp_ch6.adb4
-rw-r--r--gcc/ada/exp_disp.adb26
-rw-r--r--gcc/ada/g-socket.ads7
-rw-r--r--gcc/ada/gnat_ugn.texi8
-rw-r--r--gcc/ada/s-dimmks.ads184
-rw-r--r--gcc/ada/s-dmotpr.ads4
-rw-r--r--gcc/ada/s-oscons-tmplt.c5
-rw-r--r--gcc/ada/sem_aggr.adb23
-rw-r--r--gcc/ada/sem_ch6.adb4
-rw-r--r--gcc/ada/sem_ch8.adb4
-rw-r--r--gcc/ada/sem_dim.adb804
-rw-r--r--gcc/ada/sem_dim.ads39
-rw-r--r--gcc/ada/sem_prag.adb22
-rw-r--r--gcc/ada/sem_res.adb5
18 files changed, 989 insertions, 310 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 98c2ec35d09..6b2c9dfef1b 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,91 @@
+2012-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Process_Convention, Process_Import_Or_Interface):
+ Adjust test so that when the pragma comes from an aspect
+ specification it only applies to the entity in the original
+ declaration.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * gnat_ugn.texi: Document new command line switch -fada-spec-parent.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * s-oscons-tmplt.c, g-socket.ads: Minor code improvement: use gcc
+ builtin __alignof__ to get the alignment of struct fd_set.
+
+2012-10-01 Vincent Pucci <pucci@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Remove call to
+ Remove_Dimension_In_Call.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Analyze dimension of
+ components in array aggregate.
+ (Resolve_Aggr_Expr): Propagate dimensions from the original expression
+ Expr to the new created expression New_Expr when resolving the
+ expression of a component in record aggregates.
+ (Resolve_Record_Aggregate): Analyze
+ dimension of components in record (or extension) aggregate.
+ * sem_ch6.adb (Analyze_Subprogram_Specification): Analyze
+ dimension of formals with default expressions in subprogram
+ specification.
+ * sem_ch8.adb (Analyze_Expanded_Name): Analyze dimension of
+ expanded names.
+ (Find_Selected_Component): Analyze dimension of selected component.
+ * sem_dim.adb: Several dimension error messages reformatting.
+ (Dimensions_Msg_Of): New flag Description_Needed in order to
+ differentiate two different sort of dimension error messages.
+ (Dim_Warning_For_Numeric_Literal): New routine.
+ (Exists): New routine.
+ (Move_Dimensions): Routine spec moved to spec file.
+ * sem_dim.ads (String_From_Numeric_Literal): New routine.
+ (Analyze_Dimension): Analyze dimension only when the
+ node comes from source. Dimension analysis for expanded names added.
+ (Analyze_Dimension_Array_Aggregate): New routine.
+ (Analyze_Dimension_Call): New routine.
+ (Analyze_Dimension_Component_Declaration): Warning if default
+ expression is a numeric literal.
+ (Analyze_Dimension_Extension_Or_Record_Aggregate): New routine.
+ (Analyze_Dimension_Formals): New routine.
+ (Analyze_Dimension_Object_Declaration): Warning if default
+ expression is a numeric literal.
+ (Symbol_Of): Return either the dimension subtype symbol or the
+ dimension symbol built by From_Dim_To_Str_Of_Unit_Symbols.
+ * sem_dim.ads (Analyze_Dimension_Array_Aggregate): New routine.
+ (Analyze_Dimension_Call): New routine.
+ (Analyze_Dimension_Extension_Or_Record_Aggregate): New routine.
+ (Analyze_Dimension_Formals): New routine.
+ (Move_Dimensions): Moved from sem_dim.adb.
+ * s-dimmks.ads: Turn off the warnings for dimensioned object
+ declaration. Dimensioned subtypes sorted in alphabetical
+ order. New subtypes Area, Speed, Volume.
+ * s-dmotpr.ads: Turn off the warnings for dimensioned object
+ declaration.
+ * sem_res.adb (Resolve_Call): Analyze dimension for calls.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * Make-generated.in: Minor cleanup of all targets: use
+ MOVE_IF_CHANGE to put generated files in place, to avoid useless
+ recompilations.
+
+2012-10-01 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Expand_Dispatching_Call): For functions returning
+ interface types add an implicit conversion to the returned object
+ to force the displacement of the pointer to the returned object
+ to reference the corresponding secondary dispatch table. This
+ is needed to handle well combined calls involving secondary
+ dispatch tables (for example Obj.Prim1.Prim2).
+ * exp_ch4.adb (Expand_Allocator_Expression): Declare internal
+ access type as access to constant or access to variable depending
+ on the context. Found working in this ticket.
+
+2012-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * checks.adb (Apply_Predicate_Check): Do not apply check to
+ actual of predicate checking procedure, to prevent infinite
+ recursion.
+
2012-10-01 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies.
diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in
index 833d47f2582..57159342ff7 100644
--- a/gcc/ada/Make-generated.in
+++ b/gcc/ada/Make-generated.in
@@ -18,6 +18,7 @@ ifeq ($(origin MOVE_IF_CHANGE), undefined)
MOVE_IF_CHANGE=mv -f
endif
+.PHONY: ada_extra_files
ada_extra_files : $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/nmake.adb \
$(ADA_GEN_SUBDIR)/nmake.ads $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb $(ADA_GEN_SUBDIR)/snames.h
@@ -27,19 +28,22 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs
- (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs ../../treeprs.ads )
+ (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads )
+ $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads
$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo
- (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo ../../einfo.h )
+ (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo einfo.h )
+ $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h
$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo
- (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo ../../sinfo.h )
+ (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h )
+ $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h
$(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true
$(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUBDIR)/snames.adb-tmpl $(ADA_GEN_SUBDIR)/snames.h-tmpl $(ADA_GEN_SUBDIR)/xsnamest.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
@@ -52,17 +56,47 @@ $(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUB
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h
touch $(ADA_GEN_SUBDIR)/stamp-snames
-$(ADA_GEN_SUBDIR)/nmake.adb : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake_b
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake_b/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake_b
- (cd $(ADA_GEN_SUBDIR)/bldtools/nmake_b; gnatmake -q xnmake ; ./xnmake -b ../../nmake.adb )
-
-$(ADA_GEN_SUBDIR)/nmake.ads : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake_s
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake_s/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake_s
- (cd $(ADA_GEN_SUBDIR)/bldtools/nmake_s; gnatmake -q xnmake ; ./xnmake -s ../../nmake.ads )
+$(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/nmake.ads: $(ADA_GEN_SUBDIR)/stamp-nmake ; @true
+$(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
+ -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake
+ $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^))
+ $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake
+ (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads)
+ $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads
+ $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb
+ touch $(ADA_GEN_SUBDIR)/stamp-nmake
+
+ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(subst -, ,$(host)))),)
+OSCONS_CPP=../../../$(DECC) -E /comment=as_is -DNATIVE \
+ -DTARGET='""$(target)""' s-oscons-tmplt.c
+
+OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \
+ -DTARGET='""$(target)""' s-oscons-tmplt.c ; \
+ ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \
+ ./s-oscons-tmplt.exe > s-oscons-tmplt.s
+
+else
+# GCC_FOR_TARGET has paths relative to the gcc directory, so we need to adjust
+# for running it from $(ADA_GEN_SUBDIR)/bldtools/oscons
+OSCONS_CC=`echo "$(GCC_FOR_TARGET)" \
+ | sed -e 's^\./xgcc^../../../xgcc^' -e 's^-B./^-B../../../^'`
+OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) -E -C \
+ -DTARGET=\"$(target)\" s-oscons-tmplt.c > s-oscons-tmplt.i
+OSCONS_EXTRACT=$(OSCONS_CC) -S s-oscons-tmplt.i
+endif
+
+$(ADA_GEN_SUBDIR)/s-oscons.ads : $(ADA_GEN_SUBDIR)/s-oscons-tmplt.c $(ADA_GEN_SUBDIR)/gsocket.h $(ADA_GEN_SUBDIR)/xoscons.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
+ -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/oscons
+ $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/oscons/,$(notdir $^))
+ $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/oscons
+ (cd $(ADA_GEN_SUBDIR)/bldtools/oscons ; gnatmake -q xoscons ; \
+ $(RM) s-oscons-tmplt.i s-oscons-tmplt.s ; \
+ $(OSCONS_CPP) ; \
+ $(OSCONS_EXTRACT) ; \
+ ./xoscons ; \
+ $(RM) ../../s-oscons.ads ; \
+ $(MOVE_IF_CHANGE) s-oscons.ads $(ADA_GEN_SUBDIR)/s-oscons.ads ; \
+ $(MOVE_IF_CHANGE) s-oscons.h $(ADA_GEN_SUBDIR)/s-oscons.h)
$(ADA_GEN_SUBDIR)/sdefault.adb: $(ADA_GEN_SUBDIR)/stamp-sdefault ; @true
$(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 697599db7dc..c331c339ec7 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2055,6 +2055,13 @@ package body Checks is
if Present (S) and then Get_TSS_Name (S) /= TSS_Null then
return;
+
+ -- Check certainly does not apply within the predicate function
+ -- itself, else we have a infinite recursion.
+
+ elsif S = Predicate_Function (Typ) then
+ return;
+
else
Insert_Action (N,
Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 9cc8865b64d..1f30582d07b 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1089,7 +1089,8 @@ package body Exp_Ch4 is
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
- Constant_Present => False,
+ Constant_Present =>
+ Is_Access_Constant (Etype (N)),
Subtype_Indication =>
New_Reference_To (Etype (Exp), Loc)));
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 930f82befc0..fe01e34331d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -2392,10 +2392,6 @@ package body Exp_Ch6 is
Expand_Put_Call_With_Symbol (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/exp_disp.adb b/gcc/ada/exp_disp.adb
index f2482826356..d5861b47807 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1068,6 +1068,32 @@ package body Exp_Disp is
-- to avoid the generation of spurious warnings under ZFP run-time.
Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
+
+ -- For functions returning interface types add implicit conversion to
+ -- force the displacement of the pointer to the object to reference
+ -- the corresponding secondary dispatch table. This is needed to
+ -- handle well nested calls through secondary dispatch tables
+ -- (for example Obj.Prim1.Prim2).
+
+ if Is_Interface (Res_Typ) then
+ Rewrite (Call_Node,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Res_Typ, Loc),
+ Expression => Relocate_Node (Call_Node)));
+ Set_Etype (Call_Node, Res_Typ);
+ Expand_Interface_Conversion (Call_Node, Is_Static => False);
+ Force_Evaluation (Call_Node);
+
+ pragma Assert (Nkind (Call_Node) = N_Explicit_Dereference
+ and then Nkind (Prefix (Call_Node)) = N_Identifier
+ and then Nkind (Parent (Entity (Prefix (Call_Node))))
+ = N_Object_Declaration);
+ Set_Assignment_OK (Parent (Entity (Prefix (Call_Node))));
+
+ if Nkind (Parent (Call_Node)) = N_Object_Declaration then
+ Set_Assignment_OK (Parent (Call_Node));
+ end if;
+ end if;
end Expand_Dispatching_Call;
---------------------------------
diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads
index 462556265a6..8ee2d0ad9a2 100644
--- a/gcc/ada/g-socket.ads
+++ b/gcc/ada/g-socket.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2011, AdaCore --
+-- Copyright (C) 2001-2012, AdaCore --
-- --
-- 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- --
@@ -1155,10 +1155,7 @@ private
type Fd_Set is
new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set);
- for Fd_Set'Alignment use Interfaces.C.long'Alignment;
- -- Set conservative alignment so that our Fd_Sets are always adequately
- -- aligned for the underlying data type (which is implementation defined
- -- and may be an array of C long integers).
+ for Fd_Set'Alignment use SOSC.ALIGNOF_fd_set;
type Fd_Set_Access is access all Fd_Set;
pragma Convention (C, Fd_Set_Access);
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index e440ed517ed..2ee17554d56 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -18876,6 +18876,9 @@ and will attempt to generate corresponding Ada comments.
If you want to generate a single Ada file and not the transitive closure, you
can use instead the @option{-fdump-ada-spec-slim} switch.
+You can optionally specify a parent unit, of which all generated units will
+be children, using @code{-fada-spec-parent=}@var{unit}.
+
Note that we recommend when possible to use the @command{g++} driver to
generate bindings, even for most C headers, since this will in general
generate better Ada specs. For generating bindings for C++ headers, it is
@@ -19059,6 +19062,11 @@ all header files that these headers depend upon).
Generate Ada spec files for the header files specified on the command line
only.
+@item -fada-spec-parent=@var{unit}
+@cindex -fada-spec-parent (@command{gcc})
+Specifies that all files generated by @option{-fdump-ada-spec-slim} are
+to be child units of the specified parent unit.
+
@item -C
@cindex @option{-C} (@command{gcc})
Extract comments from headers and generate Ada comments in the Ada spec files.
diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads
index fd0fc0060eb..fa0c6e0356d 100644
--- a/gcc/ada/s-dimmks.ads
+++ b/gcc/ada/s-dimmks.ads
@@ -103,6 +103,9 @@ package System.Dim.Mks is
-- SI Base units
+ pragma Warnings (Off);
+ -- Turn off the all the dimension warnings
+
m : constant Length := 1.0;
kg : constant Mass := 1.0;
s : constant Time := 1.0;
@@ -111,98 +114,134 @@ package System.Dim.Mks is
mol : constant Amount_Of_Substance := 1.0;
cd : constant Luminous_Intensity := 1.0;
+ pragma Warnings (On);
+
-- SI Derived dimensioned subtypes
+ subtype Absorbed_Dose is Mks_Type
+ with
+ Dimension => (Symbol => "Gy",
+ Meter => 2,
+ Second => -2,
+ others => 0);
+
subtype Angle is Mks_Type
with
Dimension => (Symbol => "rad",
others => 0);
- subtype Solid_Angle is Mks_Type
+ subtype Area is Mks_Type
with
- Dimension => (Symbol => "sr",
+ Dimension => (
+ Meter => 2,
others => 0);
- subtype Frequency is Mks_Type
+ subtype Catalytic_Activity is Mks_Type
with
- Dimension => (Symbol => "Hz",
+ Dimension => (Symbol => "kat",
Second => -1,
+ Mole => 1,
others => 0);
- subtype Force is Mks_Type
+ subtype Celsius_Temperature is Mks_Type
with
- Dimension => (Symbol => 'N',
- Meter => 1,
- Kilogram => 1,
- Second => -2,
+ Dimension => (Symbol => "°C",
+ Kelvin => 1,
+ others => 0);
+
+ subtype Electric_Capacitance is Mks_Type
+ with
+ Dimension => (Symbol => 'F',
+ Meter => -2,
+ Kilogram => -1,
+ Second => 4,
+ Ampere => 2,
others => 0);
- subtype Pressure is Mks_Type
+ subtype Electric_Charge is Mks_Type
with
- Dimension => (Symbol => "Pa",
- Meter => -1,
- Kilogram => 1,
- Second => -2,
+ Dimension => (Symbol => 'C',
+ Second => 1,
+ Ampere => 1,
+ others => 0);
+
+ subtype Electric_Conductance is Mks_Type
+ with
+ Dimension => (Symbol => 'S',
+ Meter => -2,
+ Kilogram => -1,
+ Second => 3,
+ Ampere => 2,
others => 0);
- subtype Energy is Mks_Type
+ subtype Electric_Potential_Difference is Mks_Type
with
- Dimension => (Symbol => 'J',
+ Dimension => (Symbol => 'V',
Meter => 2,
Kilogram => 1,
- Second => -2,
+ Second => -3,
+ Ampere => -1,
others => 0);
- subtype Power is Mks_Type
+ subtype Electric_Resistance is Mks_Type
with
- Dimension => (Symbol => 'W',
+ Dimension => (Symbol => "Ω",
Meter => 2,
Kilogram => 1,
Second => -3,
+ Ampere => -2,
others => 0);
- subtype Electric_Charge is Mks_Type
+ subtype Energy is Mks_Type
with
- Dimension => (Symbol => 'C',
- Second => 1,
- Ampere => 1,
+ Dimension => (Symbol => 'J',
+ Meter => 2,
+ Kilogram => 1,
+ Second => -2,
+ others => 0);
+
+ subtype Equivalent_Dose is Mks_Type
+ with
+ Dimension => (Symbol => "Sv",
+ Meter => 2,
+ Second => -2,
others => 0);
- subtype Electric_Potential_Difference is Mks_Type
+ subtype Force is Mks_Type
with
- Dimension => (Symbol => 'V',
- Meter => 2,
+ Dimension => (Symbol => 'N',
+ Meter => 1,
Kilogram => 1,
- Second => -3,
- Ampere => -1,
+ Second => -2,
others => 0);
- subtype Electric_Capacitance is Mks_Type
+ subtype Frequency is Mks_Type
with
- Dimension => (Symbol => 'F',
- Meter => -2,
- Kilogram => -1,
- Second => 4,
- Ampere => 2,
- others => 0);
+ Dimension => (Symbol => "Hz",
+ Second => -1,
+ others => 0);
- subtype Electric_Resistance is Mks_Type
+ subtype Illuminance is Mks_Type
with
- Dimension => (Symbol => "Ω",
+ Dimension => (Symbol => "lx",
+ Meter => -2,
+ Candela => 1,
+ others => 0);
+
+ subtype Inductance is Mks_Type
+ with
+ Dimension => (Symbol => 'H',
Meter => 2,
Kilogram => 1,
- Second => -3,
+ Second => -2,
Ampere => -2,
others => 0);
- subtype Electric_Conductance is Mks_Type
+ subtype Luminous_Flux is Mks_Type
with
- Dimension => (Symbol => 'S',
- Meter => -2,
- Kilogram => -1,
- Second => 3,
- Ampere => 2,
- others => 0);
+ Dimension => (Symbol => "lm",
+ Candela => 1,
+ others => 0);
subtype Magnetic_Flux is Mks_Type
with
@@ -221,33 +260,21 @@ package System.Dim.Mks is
Ampere => -1,
others => 0);
- subtype Inductance is Mks_Type
+ subtype Power is Mks_Type
with
- Dimension => (Symbol => 'H',
+ Dimension => (Symbol => 'W',
Meter => 2,
Kilogram => 1,
- Second => -2,
- Ampere => -2,
+ Second => -3,
others => 0);
- subtype Celsius_Temperature is Mks_Type
- with
- Dimension => (Symbol => "°C",
- Kelvin => 1,
- others => 0);
-
- subtype Luminous_Flux is Mks_Type
- with
- Dimension => (Symbol => "lm",
- Candela => 1,
- others => 0);
-
- subtype Illuminance is Mks_Type
+ subtype Pressure is Mks_Type
with
- Dimension => (Symbol => "lx",
- Meter => -2,
- Candela => 1,
- others => 0);
+ Dimension => (Symbol => "Pa",
+ Meter => -1,
+ Kilogram => 1,
+ Second => -2,
+ others => 0);
subtype Radioactivity is Mks_Type
with
@@ -255,27 +282,27 @@ package System.Dim.Mks is
Second => -1,
others => 0);
- subtype Absorbed_Dose is Mks_Type
+ subtype Solid_Angle is Mks_Type
with
- Dimension => (Symbol => "Gy",
- Meter => 2,
- Second => -2,
+ Dimension => (Symbol => "sr",
others => 0);
- subtype Equivalent_Dose is Mks_Type
+ subtype Speed is Mks_Type
with
- Dimension => (Symbol => "Sv",
- Meter => 2,
- Second => -2,
+ Dimension => (
+ Meter => 1,
+ Second => -1,
others => 0);
- subtype Catalytic_Activity is Mks_Type
+ subtype Volume is Mks_Type
with
- Dimension => (Symbol => "kat",
- Second => -1,
- Mole => 1,
+ Dimension => (
+ Meter => 3,
others => 0);
+ pragma Warnings (Off);
+ -- Turn off the all the dimension warnings
+
rad : constant Angle := 1.0;
sr : constant Solid_Angle := 1.0;
Hz : constant Frequency := 1.0;
@@ -349,4 +376,5 @@ package System.Dim.Mks is
kA : constant Electric_Current := 1.0E+03; -- kilo
MeA : constant Electric_Current := 1.0E+06; -- mega
+ pragma Warnings (On);
end System.Dim.Mks;
diff --git a/gcc/ada/s-dmotpr.ads b/gcc/ada/s-dmotpr.ads
index 78bc57ee331..902341c5936 100644
--- a/gcc/ada/s-dmotpr.ads
+++ b/gcc/ada/s-dmotpr.ads
@@ -38,6 +38,9 @@ package System.Dim.Mks.Other_Prefixes is
-- SI prefixes for Meter
+ pragma Warnings (Off);
+ -- Turn off the all the dimension warnings
+
ym : constant Length := 1.0E-24; -- yocto
zm : constant Length := 1.0E-21; -- zepto
am : constant Length := 1.0E-18; -- atto
@@ -165,4 +168,5 @@ package System.Dim.Mks.Other_Prefixes is
Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta
Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta
+ pragma Warnings (On);
end System.Dim.Mks.Other_Prefixes;
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index 50a55e43d23..332c5132269 100644
--- a/gcc/ada/s-oscons-tmplt.c
+++ b/gcc/ada/s-oscons-tmplt.c
@@ -1292,7 +1292,7 @@ CNS(MAX_tv_sec, "")
}
/*
- -- Sizes of various data types
+ -- Sizes and alignments of various data types
*/
#define SIZEOF_sockaddr_in (sizeof (struct sockaddr_in))
@@ -1306,6 +1306,9 @@ CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6")
#define SIZEOF_fd_set (sizeof (fd_set))
CND(SIZEOF_fd_set, "fd_set");
+#define ALIGNOF_fd_set (__alignof__ (fd_set))
+CND(ALIGNOF_fd_set, "");
+
CND(FD_SETSIZE, "Max fd value");
#define SIZEOF_struct_hostent (sizeof (struct hostent))
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index e4c27d015ea..f0e90ee19e3 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -47,6 +47,7 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@@ -2549,6 +2550,10 @@ package body Sem_Aggr is
Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
end if;
+ -- Check the dimensions of each component in the array aggregate.
+
+ Analyze_Dimension_Array_Aggregate (N, Component_Typ);
+
return Success;
end Resolve_Array_Aggregate;
@@ -3225,8 +3230,9 @@ package body Sem_Aggr is
-----------------------
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
- New_C : Entity_Id := Component;
Expr_Type : Entity_Id := Empty;
+ New_C : Entity_Id := Component;
+ New_Expr : Node_Id;
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
@@ -3380,10 +3386,17 @@ package body Sem_Aggr is
end if;
if Relocate then
- Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List);
+ New_Expr := Relocate_Node (Expr);
+
+ -- Since New_Expr is not gonna be analyzed later on, we need to
+ -- propagate here the dimensions form Expr to New_Expr.
+
+ Move_Dimensions (Expr, New_Expr);
else
- Add_Association (New_C, Expr, New_Assoc_List);
+ New_Expr := Expr;
end if;
+
+ Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
-- Start of processing for Resolve_Record_Aggregate
@@ -4490,6 +4503,10 @@ package body Sem_Aggr is
Rewrite (N, New_Aggregate);
end Step_8;
+
+ -- Check the dimensions of the components in the record aggregate.
+
+ Analyze_Dimension_Extension_Or_Record_Aggregate (N);
end Resolve_Record_Aggregate;
-----------------------------
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 8c88d8f9acb..cdb39fb35be 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -3450,6 +3450,10 @@ package body Sem_Ch6 is
Push_Scope (Designator);
Process_Formals (Formals, N);
+ -- Check dimensions in N for formals with default expression
+
+ Analyze_Dimension_Formals (N, Formals);
+
-- Ada 2005 (AI-345): If this is an overriding operation of an
-- inherited interface operation, and the controlling type is
-- a synchronized type, replace the type with its corresponding
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 51772dba296..53ff3274e8b 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -577,6 +577,8 @@ package body Sem_Ch8 is
else
Find_Expanded_Name (N);
end if;
+
+ Analyze_Dimension (N);
end Analyze_Expanded_Name;
---------------------------------------
@@ -6153,6 +6155,8 @@ package body Sem_Ch8 is
Analyze_Selected_Component (N);
end if;
+
+ Analyze_Dimension (N);
end Find_Selected_Component;
---------------
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index a2dd53c4087..8a8b1957f29 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -36,7 +36,9 @@ 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 Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -190,6 +192,7 @@ package body Sem_Dim is
OK_For_Dimension : constant array (Node_Kind) of Boolean :=
(N_Attribute_Reference => True,
+ N_Expanded_Name => True,
N_Defining_Identifier => True,
N_Function_Call => True,
N_Identifier => True,
@@ -236,14 +239,6 @@ package body Sem_Dim is
-- that the dimensions of the returned type and of the returned object
-- match.
- procedure Analyze_Dimension_Function_Call (N : Node_Id);
- -- Subroutine of Analyze_Dimension for function call. General case:
- -- propagate the dimensions from the returned type to N. Elementary
- -- function case (Ada.Numerics.Generic_Elementary_Functions): If N
- -- is a Sqrt call, then evaluate the resulting dimensions as half the
- -- dimensions of the parameter. Otherwise, verify that each parameters
- -- are dimensionless.
-
procedure Analyze_Dimension_Has_Etype (N : Node_Id);
-- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
-- the list below:
@@ -292,9 +287,17 @@ package body Sem_Dim is
function Dimensions_Of (N : Node_Id) return Dimension_Type;
-- Return the dimension vector of node N
- function Dimensions_Msg_Of (N : Node_Id) return String;
- -- Given a node, return "has dimension" followed by the dimension symbols
- -- of N or "is dimensionless" if N is dimensionless.
+ function Dimensions_Msg_Of
+ (N : Node_Id;
+ Description_Needed : Boolean := False) return String;
+ -- Given a node N, return the dimension symbols of N, preceded by "has
+ -- dimension" if Description_Needed. if N is dimensionless, return "[]", or
+ -- "is dimensionless" if Description_Needed.
+
+ procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
+ -- Issue a warning on the given numeric literal N to indicate the
+ -- compilateur made the assumption that the literal is not dimensionless
+ -- but has the dimension of Typ.
procedure Eval_Op_Expon_With_Rational_Exponent
(N : Node_Id;
@@ -304,6 +307,9 @@ package body Sem_Dim is
function Exists (Dim : Dimension_Type) return Boolean;
-- Returns True iff Dim does not denote the null dimension
+ function Exists (Str : String_Id) return Boolean;
+ -- Returns True iff Str does not denote No_String
+
function Exists (Sys : System_Type) return Boolean;
-- Returns True iff Sys does not denote the null system
@@ -330,9 +336,6 @@ package body Sem_Dim is
function Is_Invalid (Position : Dimension_Position) return Boolean;
-- Return True if Pos denotes the invalid position
- procedure Move_Dimensions (From : Node_Id; To : Node_Id);
- -- Copy dimension vector of From to To, delete dimension vector of From
-
procedure Remove_Dimensions (N : Node_Id);
-- Remove the dimension vector of node N
@@ -342,6 +345,10 @@ package body Sem_Dim is
procedure Set_Symbol (E : Entity_Id; Val : String_Id);
-- Associate a symbol representation of a dimension vector with a subtype
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id;
+ -- Return the string that corresponds to the numeric litteral N as it
+ -- appears in the source.
+
function Symbol_Of (E : Entity_Id) return String_Id;
-- E denotes a subtype with a dimension. Return the symbol representation
-- of the dimension vector.
@@ -1122,14 +1129,16 @@ package body Sem_Dim is
procedure Analyze_Dimension (N : Node_Id) is
begin
- -- Aspect is an Ada 2012 feature
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for nodes that don't come from source.
- if Ada_Version < Ada_2012 then
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (N)
+ then
return;
end if;
case Nkind (N) is
-
when N_Assignment_Statement =>
Analyze_Dimension_Assignment_Statement (N);
@@ -1142,10 +1151,8 @@ package body Sem_Dim is
when N_Extended_Return_Statement =>
Analyze_Dimension_Extended_Return_Statement (N);
- when N_Function_Call =>
- Analyze_Dimension_Function_Call (N);
-
when N_Attribute_Reference |
+ N_Expanded_Name |
N_Identifier |
N_Indexed_Component |
N_Qualified_Expression |
@@ -1177,6 +1184,95 @@ package body Sem_Dim is
end case;
end Analyze_Dimension;
+ ---------------------------------------
+ -- Analyze_Dimension_Array_Aggregate --
+ ---------------------------------------
+
+ procedure Analyze_Dimension_Array_Aggregate
+ (N : Node_Id;
+ Comp_Typ : Entity_Id)
+ is
+ Comp_Ass : constant List_Id := Component_Associations (N);
+ Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
+ Exps : constant List_Id := Expressions (N);
+
+ Comp : Node_Id;
+ Expr : Node_Id;
+
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
+
+ begin
+ -- Aspect is an Ada 2012 feature. Nothing to do here if the component
+ -- base type is not a dimensioned type.
+
+ -- Note that here the original node must come from source since the
+ -- original array aggregate may not have been entirely decorated.
+
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (Original_Node (N))
+ or else not Has_Dimension_System (Base_Type (Comp_Typ))
+ then
+ return;
+ end if;
+
+ -- Check whether there is any positional component association
+
+ if Is_Empty_List (Exps) then
+ Comp := First (Comp_Ass);
+ else
+ Comp := First (Exps);
+ end if;
+
+ while Present (Comp) loop
+ -- Get the expression from the component
+
+ if Nkind (Comp) = N_Component_Association then
+ Expr := Expression (Comp);
+ else
+ Expr := Comp;
+ end if;
+
+ -- Issue an error if the dimensions of the component type and the
+ -- dimensions of the component mismatch.
+
+ -- Note that we must ensure the expression has been fully analyzed
+ -- since it may not be decorated at this point. We also don't want to
+ -- issue the same error message multiple times on the same expression
+ -- (may happen when an aggregate is converted into a positional
+ -- aggregate).
+
+ if Comes_From_Source (Original_Node (Expr))
+ and then Present (Etype (Expr))
+ and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
+ and then Sloc (Comp) /= Sloc (Prev (Comp))
+ then
+ -- Check if an error has already been encountered so far
+
+ if not Error_Detected then
+ Error_Msg_N ("dimensions mismatch in array aggregate", N);
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Comp_Typ) & ", found " &
+ Dimensions_Msg_Of (Expr),
+ Expr);
+ end if;
+
+ -- Look at the named components right after the positional components
+
+ if not Present (Next (Comp))
+ and then List_Containing (Comp) = Exps
+ then
+ Comp := First (Comp_Ass);
+ else
+ Next (Comp);
+ end if;
+ end loop;
+ end Analyze_Dimension_Array_Aggregate;
+
--------------------------------------------
-- Analyze_Dimension_Assignment_Statement --
--------------------------------------------
@@ -1205,8 +1301,8 @@ package body Sem_Dim is
is
begin
Error_Msg_N ("dimensions mismatch in assignment", N);
- Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N);
- Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N);
+ Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
+ Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
end Error_Dim_Msg_For_Assignment_Statement;
-- Start of processing for Analyze_Dimension_Assignment
@@ -1241,8 +1337,8 @@ package body Sem_Dim is
"dimensions",
N,
Entity (N));
- Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N);
- Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N);
+ Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
+ Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
end Error_Dim_Msg_For_Binary_Op;
-- Start of processing for Analyze_Dimension_Binary_Op
@@ -1390,6 +1486,174 @@ package body Sem_Dim is
end if;
end Analyze_Dimension_Binary_Op;
+ ----------------------------
+ -- Analyze_Dimension_Call --
+ ----------------------------
+
+ procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ Dims_Of_Formal : Dimension_Type;
+ Formal : Node_Id;
+ Formal_Typ : Entity_Id;
+
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
+
+ begin
+ -- Aspect is an Ada 2012 feature. Nothing to do here if the list of
+ -- actuals is empty.Note that there is no need to check dimensions for
+ -- calls that don't come from source.
+
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (N)
+ or else Is_Empty_List (Actuals)
+ then
+ return;
+ end if;
+
+ -- Special processing for elementary functions
+
+ -- For Sqrt call, the resulting dimensions equal to half the dimensions
+ -- of the actual. For all other elementary calls, this routine check
+ -- that every actual is dimensionless.
+
+ if Nkind (N) = N_Function_Call then
+ Elementary_Function_Calls : declare
+ Dims_Of_Call : Dimension_Type;
+ Ent : Entity_Id := Nam;
+
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean;
+ -- Given Sub_Id, the original subprogram entity, return True if
+ -- call is to an elementary function
+ -- (see Ada.Numerics.Generic_Elementary_Functions).
+
+ -----------------------------------
+ -- Is_Elementary_Function_Entity --
+ -----------------------------------
+
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (Sub_Id);
+
+ begin
+ -- Is function entity in
+ -- Ada.Numerics.Generic_Elementary_Functions?
+
+ return
+ Loc > No_Location
+ and then
+ Is_RTU
+ (Cunit_Entity (Get_Source_Unit (Loc)),
+ Ada_Numerics_Generic_Elementary_Functions);
+ end Is_Elementary_Function_Entity;
+
+ begin
+ -- Get the original subprogram entity following the renaming chain
+
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
+
+ -- Check the call is an Elementary function call
+
+ if Is_Elementary_Function_Entity (Ent) then
+ -- Sqrt function call case
+
+ if Chars (Ent) = Name_Sqrt then
+ Dims_Of_Call := Dimensions_Of (First_Actual (N));
+
+ -- Eavluates the resulting dimensions (i.e. half the
+ -- dimensions of the actual).
+
+ if Exists (Dims_Of_Call) then
+ for Position in Dims_Of_Call'Range loop
+ Dims_Of_Call (Position) :=
+ Dims_Of_Call (Position) *
+ Rational'(Numerator => 1,
+ Denominator => 2);
+ end loop;
+
+ Set_Dimensions (N, Dims_Of_Call);
+ end if;
+
+ -- All other elementary functions case. Note that every actual
+ -- here should be dimensionless.
+
+ else
+ Actual := First_Actual (N);
+
+ while Present (Actual) loop
+ if Exists (Dimensions_Of (Actual)) then
+ -- Check if an error has already been encountered so
+ -- far.
+
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in call of&",
+ N, Name (N));
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N ("\expected dimension [], found " &
+ Dimensions_Msg_Of (Actual),
+ Actual);
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+ end if;
+
+ -- Nothing more to do for elementary functions
+
+ return;
+ end if;
+ end Elementary_Function_Calls;
+ end if;
+
+ -- General case. Check, for each parameter, the dimensions of the actual
+ -- and its corresponding formal match. Otherwise, complain.
+
+ Actual := First_Actual (N);
+ Formal := First_Formal (Nam);
+
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+ Dims_Of_Formal := Dimensions_Of (Formal_Typ);
+
+ -- If the formal is not dimensionless, check dimensions of formal and
+ -- actual match. Otherwise, complain.
+
+ if Exists (Dims_Of_Formal)
+ and then Dimensions_Of (Actual) /= Dims_Of_Formal
+ then
+ -- Check if an error has already been encountered so far
+
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Formal_Typ) & ", found " &
+ Dimensions_Msg_Of (Actual),
+ Actual);
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+
+ -- For function calls, propagate the dimensions from the returned type
+ -- to the function call.
+
+ if Nkind (N) = N_Function_Call then
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+ end Analyze_Dimension_Call;
+
---------------------------------------------
-- Analyze_Dimension_Component_Declaration --
---------------------------------------------
@@ -1418,21 +1682,38 @@ package body Sem_Dim is
Expr : Node_Id) is
begin
Error_Msg_N ("dimensions mismatch in component declaration", N);
- Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N);
- Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Etyp) & ", found " &
+ Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Component_Declaration;
-- Start of processing for Analyze_Dimension_Component_Declaration
begin
+ -- Expression is present
+
if Present (Expr) then
Dims_Of_Expr := Dimensions_Of (Expr);
- -- Return an error if the dimension of the expression and the
- -- dimension of the type mismatch.
+ -- Check dimensions match
if Dims_Of_Etyp /= Dims_Of_Expr then
- Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
+ -- Numeric literal case. Issue a warning if the object type is not
+ -- dimensionless to indicate the literal is treated as if its
+ -- dimension matches the type dimension.
+
+ if Nkind_In (Original_Node (Expr),
+ N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etyp);
+
+ -- Issue a dimension mismatch error for all other cases
+
+ else
+ Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
+ end if;
end if;
-- Removal of dimensions in expression
@@ -1446,38 +1727,36 @@ package body Sem_Dim is
-------------------------------------------------
procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
- Return_Ent : constant Entity_Id :=
- Return_Statement_Entity (N);
- Return_Etyp : constant Entity_Id :=
- Etype (Return_Applies_To (Return_Ent));
- Dims_Of_Return_Etyp : constant Dimension_Type :=
- Dimensions_Of (Return_Etyp);
- Return_Obj_Decls : constant List_Id :=
- Return_Object_Declarations (N);
- Dims_Of_Return_Obj_Id : Dimension_Type;
- Return_Obj_Decl : Node_Id;
- Return_Obj_Id : Entity_Id;
+ Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
+ Return_Etyp : constant Entity_Id :=
+ Etype (Return_Applies_To (Return_Ent));
+ Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
+ Return_Obj_Decl : Node_Id;
+ Return_Obj_Id : Entity_Id;
+ Return_Obj_Typ : Entity_Id;
procedure Error_Dim_Msg_For_Extended_Return_Statement
- (N : Node_Id;
- Return_Etyp : Entity_Id;
- Return_Obj_Id : Entity_Id);
+ (N : Node_Id;
+ Return_Etyp : Entity_Id;
+ Return_Obj_Typ : Entity_Id);
-- Error using Error_Msg_N at node N. Output the dimensions of the
- -- returned type Return_Etyp and the returned object Return_Obj_Id of N.
+ -- returned type Return_Etyp and the returned object type Return_Obj_Typ
+ -- of N.
-------------------------------------------------
-- Error_Dim_Msg_For_Extended_Return_Statement --
-------------------------------------------------
procedure Error_Dim_Msg_For_Extended_Return_Statement
- (N : Node_Id;
- Return_Etyp : Entity_Id;
- Return_Obj_Id : Entity_Id)
+ (N : Node_Id;
+ Return_Etyp : Entity_Id;
+ Return_Obj_Typ : Entity_Id)
is
begin
Error_Msg_N ("dimensions mismatch in extended return statement", N);
- Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
- Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id),
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Return_Etyp) & ", found " &
+ Dimensions_Msg_Of (Return_Obj_Typ),
N);
end Error_Dim_Msg_For_Extended_Return_Statement;
@@ -1486,16 +1765,21 @@ package body Sem_Dim is
begin
if Present (Return_Obj_Decls) then
Return_Obj_Decl := First (Return_Obj_Decls);
+
while Present (Return_Obj_Decl) loop
if Nkind (Return_Obj_Decl) = N_Object_Declaration then
- Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
+ Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
if Is_Return_Object (Return_Obj_Id) then
- Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
+ Return_Obj_Typ := Etype (Return_Obj_Id);
+
+ -- Issue an error message if dimensions mismatch
- if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
+ if Dimensions_Of (Return_Etyp) /=
+ Dimensions_Of (Return_Obj_Typ)
+ then
Error_Dim_Msg_For_Extended_Return_Statement
- (N, Return_Etyp, Return_Obj_Id);
+ (N, Return_Etyp, Return_Obj_Typ);
return;
end if;
end if;
@@ -1506,106 +1790,121 @@ package body Sem_Dim is
end if;
end Analyze_Dimension_Extended_Return_Statement;
- -------------------------------------
- -- Analyze_Dimension_Function_Call --
- -------------------------------------
+ -----------------------------------------------------
+ -- Analyze_Dimension_Extension_Or_Record_Aggregate --
+ -----------------------------------------------------
- -- Propagate the dimensions from the returned type to the call node. Note
- -- that there is a special treatment for elementary function calls. Indeed
- -- for Sqrt call, the resulting dimensions equal to half the dimensions of
- -- the actual, and for other elementary calls, this routine check that
- -- every actuals are dimensionless.
+ procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
+ Comp : Node_Id := First (Component_Associations (N));
+ Comp_Id : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Expr : Node_Id;
- procedure Analyze_Dimension_Function_Call (N : Node_Id) is
- Actuals : constant List_Id := Parameter_Associations (N);
- Name_Call : constant Node_Id := Name (N);
- Actual : Node_Id;
- Dims_Of_Actual : Dimension_Type;
- Dims_Of_Call : Dimension_Type;
- Ent : Entity_Id;
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
+
+ begin
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for aggregates that don't come from source.
- function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
- -- Given E, the original subprogram entity, return True if call is to an
- -- elementary function (see Ada.Numerics.Generic_Elementary_Functions).
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (N)
+ then
+ return;
+ end if;
- -----------------------------------
- -- Is_Elementary_Function_Entity --
- -----------------------------------
+ while Present (Comp) loop
+ Comp_Id := Entity (First (Choices (Comp)));
+ Comp_Typ := Etype (Comp_Id);
- function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
- Loc : constant Source_Ptr := Sloc (E);
+ -- Check the component type is either a dimensioned type or a
+ -- dimensioned subtype.
- begin
- -- Is function entity in Ada.Numerics.Generic_Elementary_Functions?
+ if Has_Dimension_System (Base_Type (Comp_Typ)) then
+ Expr := Expression (Comp);
- return
- Loc > No_Location
- and then
- Is_RTU
- (Cunit_Entity (Get_Source_Unit (Loc)),
- Ada_Numerics_Generic_Elementary_Functions);
- end Is_Elementary_Function_Entity;
+ -- Issue an error if the dimensions of the component type and the
+ -- dimensions of the component mismatch.
- -- Start of processing for Analyze_Dimension_Function_Call
+ if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
+ -- Check if an error has already been encountered so far
- begin
- -- Look for elementary function call
+ if not Error_Detected then
+ -- Extension aggregate case
- if Is_Entity_Name (Name_Call) then
- Ent := Entity (Name_Call);
+ if Nkind (N) = N_Extension_Aggregate then
+ Error_Msg_N ("dimensions mismatch in extension aggregate",
+ N);
- -- Get the original subprogram entity following the renaming chain
+ -- Record aggregate case
- if Present (Alias (Ent)) then
- Ent := Alias (Ent);
- end if;
+ else
+ Error_Msg_N ("dimensions mismatch in record aggregate",
+ N);
+ end if;
- -- Elementary function case
+ Error_Detected := True;
+ end if;
- if Is_Elementary_Function_Entity (Ent) then
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Comp_Typ) & ", found " &
+ Dimensions_Msg_Of (Expr),
+ Comp);
+ end if;
+ end if;
- -- Sqrt function call case
+ Next (Comp);
+ end loop;
+ end Analyze_Dimension_Extension_Or_Record_Aggregate;
- if Chars (Ent) = Name_Sqrt then
- Dims_Of_Call := Dimensions_Of (First (Actuals));
+ -------------------------------
+ -- Analyze_Dimension_Formals --
+ -------------------------------
- if Exists (Dims_Of_Call) then
- for Position in Dims_Of_Call'Range loop
- Dims_Of_Call (Position) :=
- Dims_Of_Call (Position) * Rational'(Numerator => 1,
- Denominator => 2);
- end loop;
+ procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
+ Dims_Of_Typ : Dimension_Type;
+ Formal : Node_Id;
+ Typ : Entity_Id;
- Set_Dimensions (N, Dims_Of_Call);
- end if;
+ begin
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for sub specs that don't come from source.
- -- All other elementary functions case. Note that every actual
- -- here should be dimensionless.
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (N)
+ then
+ return;
+ end if;
- else
- Actual := First (Actuals);
- while Present (Actual) loop
- Dims_Of_Actual := Dimensions_Of (Actual);
-
- if Exists (Dims_Of_Actual) then
- Error_Msg_NE ("parameter of& must be dimensionless",
- Actual, Name_Call);
- Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ Formal := First (Formals);
- Next (Actual);
- end loop;
- end if;
+ while Present (Formal) loop
+ Typ := Parameter_Type (Formal);
+ Dims_Of_Typ := Dimensions_Of (Typ);
- return;
- end if;
- end if;
+ if Exists (Dims_Of_Typ) then
+ declare
+ Expr : constant Node_Id := Expression (Formal);
- -- Other cases
+ begin
+ -- Issue a warning if Expr is a numeric literal and if its
+ -- dimensions differ with the dimensions of the formal type.
+
+ if Present (Expr)
+ and then Dims_Of_Typ /= Dimensions_Of (Expr)
+ and then Nkind_In (Original_Node (Expr),
+ N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
+ end if;
+ end;
+ end if;
- Analyze_Dimension_Has_Etype (N);
- end Analyze_Dimension_Function_Call;
+ Next (Formal);
+ end loop;
+ end Analyze_Dimension_Formals;
---------------------------------
-- Analyze_Dimension_Has_Etype --
@@ -1691,8 +1990,10 @@ package body Sem_Dim is
Expr : Node_Id) is
begin
Error_Msg_N ("dimensions mismatch in object declaration", N);
- Error_Msg_N ("\object type " & Dimensions_Msg_Of (Etyp), N);
- Error_Msg_N ("\object expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Etyp) & ", found " &
+ Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Object_Declaration;
-- Start of processing for Analyze_Dimension_Object_Declaration
@@ -1703,22 +2004,29 @@ package body Sem_Dim is
if Present (Expr) then
Dim_Of_Expr := Dimensions_Of (Expr);
- -- Case when expression is not a literal and when dimensions of the
- -- expression and of the type mismatch
+ -- Check dimensions match
- if not Nkind_In (Original_Node (Expr),
+ if Dim_Of_Expr /= Dim_Of_Etyp then
+ -- Numeric literal case. Issue a warning if the object type is not
+ -- dimensionless to indicate the literal is treated as if its
+ -- dimension matches the type dimension.
+
+ if Nkind_In (Original_Node (Expr),
N_Real_Literal,
N_Integer_Literal)
- and then Dim_Of_Expr /= Dim_Of_Etyp
- then
- -- Propagate the dimension from the expression to the object
- -- entity when the object is a constant whose type is a
- -- dimensioned type.
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etyp);
+
+ -- Case where the object is a constant whose type is a dimensioned
+ -- type.
+
+ elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
+ -- Propagate the dimension from the expression to the object
+ -- entity
- if Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
Set_Dimensions (Id, Dim_Of_Expr);
- -- Otherwise, issue an error message
+ -- For all other cases, issue an error message
else
Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
@@ -1755,11 +2063,11 @@ package body Sem_Dim is
Sub_Mark : Node_Id;
Renamed_Name : Node_Id) is
begin
- Error_Msg_N ("dimensions mismatch in object renaming declaration",
- N);
- Error_Msg_N ("\type " & Dimensions_Msg_Of (Sub_Mark), N);
- Error_Msg_N ("\renamed object " & Dimensions_Msg_Of (Renamed_Name),
- N);
+ Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Sub_Mark) & ", found " &
+ Dimensions_Msg_Of (Renamed_Name),
+ Renamed_Name);
end Error_Dim_Msg_For_Object_Renaming_Declaration;
-- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
@@ -1802,8 +2110,10 @@ package body Sem_Dim is
is
begin
Error_Msg_N ("dimensions mismatch in return statement", N);
- Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
- Error_Msg_N ("\returned expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Return_Etyp) & ", found " &
+ Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Simple_Return_Statement;
-- Start of processing for Analyze_Dimension_Simple_Return_Statement
@@ -1838,7 +2148,8 @@ package body Sem_Dim is
-- it cannot inherit a dimension from its subtype.
if Exists (Dims_Of_Id) then
- Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id), N);
+ Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id, True),
+ N);
else
Set_Dimensions (Id, Dims_Of_Etyp);
Set_Symbol (Id, Symbol_Of (Etyp));
@@ -2011,7 +2322,10 @@ package body Sem_Dim is
-- Dimensions_Msg_Of --
-----------------------
- function Dimensions_Msg_Of (N : Node_Id) return String is
+ function Dimensions_Msg_Of
+ (N : Node_Id;
+ Description_Needed : Boolean := False) return String
+ is
Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
Dimensions_Msg : Name_Id;
System : System_Type;
@@ -2021,13 +2335,32 @@ package body Sem_Dim is
Name_Len := 0;
+ -- N is not dimensionless
+
if Exists (Dims_Of_N) then
System := System_Of (Base_Type (Etype (N)));
- Add_Str_To_Name_Buffer ("has dimension ");
+
+ -- When Description_Needed, add to string "has dimension " before the
+ -- actual dimension.
+
+ if Description_Needed then
+ Add_Str_To_Name_Buffer ("has dimension ");
+ end if;
+
Add_String_To_Name_Buffer
(From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
- else
+
+ -- N is dimensionless
+
+ -- When Description_Needed, return "is dimensionless"
+
+ elsif Description_Needed then
Add_Str_To_Name_Buffer ("is dimensionless");
+
+ -- Otherwise, return "[]"
+
+ else
+ Add_Str_To_Name_Buffer ("[]");
end if;
Dimensions_Msg := Name_Find;
@@ -2045,6 +2378,27 @@ package body Sem_Dim is
return Dimension_Table_Range (Key mod 511);
end Dimension_Table_Hash;
+ -------------------------------------
+ -- Dim_Warning_For_Numeric_Literal --
+ -------------------------------------
+
+ procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
+ begin
+ -- Initialize name buffer
+
+ Name_Len := 0;
+
+ Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
+
+ -- Insert a blank between the literal and the symbol
+ Add_Str_To_Name_Buffer (" ");
+
+ Add_String_To_Name_Buffer (Symbol_Of (Typ));
+
+ Error_Msg_Name_1 := Name_Find;
+ Error_Msg_N ("?assumed to be%%", N);
+ end Dim_Warning_For_Numeric_Literal;
+
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------
@@ -2243,6 +2597,11 @@ package body Sem_Dim is
return Dim /= Null_Dimension;
end Exists;
+ function Exists (Str : String_Id) return Boolean is
+ begin
+ return Str /= No_String;
+ end Exists;
+
function Exists (Sys : System_Type) return Boolean is
begin
return Sys /= Null_System;
@@ -2311,7 +2670,7 @@ package body Sem_Dim is
Dims_Of_Actual : Dimension_Type;
Etyp : Entity_Id;
New_Str_Lit : Node_Id := Empty;
- System : System_Type;
+ Symbols : String_Id;
Is_Put_Dim_Of : Boolean := False;
-- This flag is used in order to differentiate routines Put and
@@ -2463,10 +2822,10 @@ package body Sem_Dim is
-- by the routine From_Dim_To_Str_Of_Dim_Symbols.
if Exists (Dims_Of_Actual) then
- System := System_Of (Base_Type (Etyp));
New_Str_Lit :=
Make_String_Literal (Loc,
- From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_Actual, System));
+ From_Dim_To_Str_Of_Dim_Symbols
+ (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
-- If dimensionless, the output is []
@@ -2481,25 +2840,24 @@ package body Sem_Dim is
-- Add the symbol as a suffix of the value if the subtype has a
-- unit symbol or if the parameter is not dimensionless.
- if Symbol_Of (Etyp) /= No_String then
+ if Exists (Symbol_Of (Etyp)) then
+ Symbols := Symbol_Of (Etyp);
+
+ else
+ Symbols := From_Dim_To_Str_Of_Unit_Symbols
+ (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
+ end if;
+
+ -- Check Symbols exists
+
+ if Exists (Symbols) then
Start_String;
-- Put a space between the value and the dimension
Store_String_Char (' ');
- Store_String_Chars (Symbol_Of (Etyp));
+ Store_String_Chars (Symbols);
New_Str_Lit := Make_String_Literal (Loc, End_String);
-
- -- Check that the item is not dimensionless
-
- -- Create the new String_Literal with the new String_Id generated
- -- by the routine From_Dim_To_Str_Of_Unit_Symbols.
-
- elsif Exists (Dims_Of_Actual) then
- System := System_Of (Base_Type (Etyp));
- New_Str_Lit :=
- Make_String_Literal (Loc,
- From_Dim_To_Str_Of_Unit_Symbols (Dims_Of_Actual, System));
end if;
end if;
@@ -2672,13 +3030,15 @@ package body Sem_Dim is
First_Dim : Boolean := True;
begin
- -- Initialization of the new String_Id
+ -- Return No_String if dimensionless
- Start_String;
+ if not Exists (Dims) then
+ return No_String;
+ end if;
- -- Put a space between the value and the symbols
+ -- Initialization of the new String_Id
- Store_String_Char (' ');
+ Start_String;
for Position in Dimension_Type'Range loop
Dim_Power := Dims (Position);
@@ -2823,6 +3183,10 @@ package body Sem_Dim is
Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
-- Copy the dimension of 'From to 'To' and remove dimension of 'From'
if Exists (Dims_Of_From) then
@@ -2861,26 +3225,6 @@ package body Sem_Dim is
end if;
end Remove_Dimensions;
- ------------------------------
- -- Remove_Dimension_In_Call --
- ------------------------------
-
- procedure Remove_Dimension_In_Call (Call : Node_Id) is
- Actual : Node_Id;
-
- begin
- if Ada_Version < Ada_2012 then
- return;
- end if;
-
- Actual := First (Parameter_Associations (Call));
-
- while Present (Actual) loop
- Remove_Dimensions (Actual);
- Next (Actual);
- end loop;
- end Remove_Dimension_In_Call;
-
-----------------------------------
-- Remove_Dimension_In_Statement --
-----------------------------------
@@ -2935,13 +3279,86 @@ package body Sem_Dim is
Symbol_Table.Set (E, Val);
end Set_Symbol;
+ ---------------------------------
+ -- String_From_Numeric_Literal --
+ ---------------------------------
+
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sbuffer : constant Source_Buffer_Ptr :=
+ Source_Text (Get_Source_File_Index (Loc));
+ Src_Ptr : Source_Ptr := Loc;
+ C : Character := Sbuffer (Src_Ptr);
+ -- Current source program character
+
+ function Belong_To_Numeric_Literal (C : Character) return Boolean;
+ -- Return True if C belongs to a numeric literal
+
+ -------------------------------
+ -- Belong_To_Numeric_Literal --
+ -------------------------------
+
+ function Belong_To_Numeric_Literal (C : Character) return Boolean is
+ begin
+ case C is
+ when '0' .. '9' |
+ '_' |
+ '.' |
+ 'e' |
+ '#' |
+ 'A' |
+ 'B' |
+ 'C' |
+ 'D' |
+ 'E' |
+ 'F' =>
+ return True;
+
+ -- Make sure '+' or '-' is part of an exponent.
+
+ when '+' | '-' =>
+ declare
+ Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
+ begin
+ return Prev_C = 'e' or else Prev_C = 'E';
+ end;
+
+ -- All other character doesn't belong to a numeric literal
+
+ when others =>
+ return False;
+ end case;
+ end Belong_To_Numeric_Literal;
+
+ -- Start of processing for String_From_Numeric_Literal
+
+ begin
+ Start_String;
+
+ while Belong_To_Numeric_Literal (C) loop
+ Store_String_Char (C);
+ Src_Ptr := Src_Ptr + 1;
+ C := Sbuffer (Src_Ptr);
+ end loop;
+
+ return End_String;
+ end String_From_Numeric_Literal;
+
---------------
-- Symbol_Of --
---------------
function Symbol_Of (E : Entity_Id) return String_Id is
+ Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
+
begin
- return Symbol_Table.Get (E);
+ if Subtype_Symbol /= No_String then
+ return Subtype_Symbol;
+
+ else
+ return From_Dim_To_Str_Of_Unit_Symbols
+ (Dimensions_Of (E), System_Of (Base_Type (E)));
+ end if;
end Symbol_Of;
-----------------------
@@ -2971,5 +3388,4 @@ package body Sem_Dim is
return Null_System;
end System_Of;
-
end Sem_Dim;
diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads
index 3799651a072..86ada35f367 100644
--- a/gcc/ada/sem_dim.ads
+++ b/gcc/ada/sem_dim.ads
@@ -108,16 +108,19 @@ package Sem_Dim is
procedure Analyze_Dimension (N : Node_Id);
-- N may denote any of the following contexts:
+ -- * aggregate
-- * assignment statement
-- * attribute reference
-- * binary operator
+ -- * call
-- * compontent declaration
-- * extended return statement
- -- * function call
+ -- * expanded name
-- * identifier
-- * indexed component
-- * object declaration
-- * object renaming declaration
+ -- * procedure call statement
-- * qualified expression
-- * selected component
-- * simple return statement
@@ -129,6 +132,36 @@ package Sem_Dim is
-- Depending on the context, ensure that all expressions and entities
-- involved do not violate the rules of a system.
+ procedure Analyze_Dimension_Array_Aggregate
+ (N : Node_Id;
+ Comp_Typ : Entity_Id);
+ -- Check, for each component of the array aggregate denoted by N, the
+ -- dimensions of the component expression match the dimensions of the
+ -- component type Comp_Typ.
+
+ procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id);
+ -- This routine is split in two steps. Note the second step applies only to
+ -- function calls.
+ -- Step 1. Dimension checking:
+ -- * General case: check the dimensions of each actual parameter match
+ -- the dimensions of the corresponding formal parameter.
+ -- * Elementary function case: check each actual is dimensionless except
+ -- for Sqrt call.
+ -- Step 2. Dimension propagation (only for functions):
+ -- * General case: propagate the dimensions from the returned type to the
+ -- function call.
+ -- * Sqrt case: the resulting dimensions equal to half the dimensions of
+ -- the actual
+
+ procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id);
+ -- Check, for each component of the extension or record aggregate denoted
+ -- by N, the dimensions of the component expression match the dimensions of
+ -- the component type.
+
+ procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id);
+ -- For sub spec N, issue a warning for each dimensioned formal with a
+ -- literal default value in the list of formals Formals.
+
procedure Eval_Op_Expon_For_Dimensioned_Type
(N : Node_Id;
Btyp : Entity_Id);
@@ -150,8 +183,8 @@ package Sem_Dim is
-- Return True if N is a package instantiation of System.Dim.Integer_IO or
-- of System.Dim.Float_IO.
- procedure Remove_Dimension_In_Call (Call : Node_Id);
- -- Remove the dimensions from all formal parameters of Call
+ procedure Move_Dimensions (From : Node_Id; To : Node_Id);
+ -- Copy dimension vector of From to To, delete dimension vector of From
procedure Remove_Dimension_In_Statement (Stmt : Node_Id);
-- Remove the dimensions associated with Stmt
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 38f916f3942..6f9789e0ccb 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -3629,9 +3629,18 @@ package body Sem_Prag is
Generate_Reference (E, Id, 'i');
end if;
- -- Loop through the homonyms of the pragma argument's entity
+ -- If the pragma comes from from an aspect, it only applies
+ -- to the given entity, not its homonyms.
+
+ if From_Aspect_Specification (N) then
+ return;
+ end if;
+
+ -- Otherwise Loop through the homonyms of the pragma argument's
+ -- entity, an apply convention to those in the current scope.
E1 := Ent;
+
loop
E1 := Homonym (E1);
exit when No (E1) or else Scope (E1) /= Current_Scope;
@@ -3659,10 +3668,6 @@ package body Sem_Prag is
Generate_Reference (E1, Id, 'b');
end if;
end if;
-
- -- For aspect case, do NOT apply to homonyms
-
- exit when From_Aspect_Specification (N);
end loop;
end if;
end Process_Convention;
@@ -4528,10 +4533,12 @@ package body Sem_Prag is
or else Is_Generic_Subprogram (Def_Id)
then
-- If the name is overloaded, pragma applies to all of the denoted
- -- entities in the same declarative part.
+ -- entities in the same declarative part, unless the pragma comes
+ -- from an aspect specification.
Hom_Id := Def_Id;
while Present (Hom_Id) loop
+
Def_Id := Get_Base_Subprogram (Hom_Id);
-- Ignore inherited subprograms because the pragma will apply
@@ -4642,6 +4649,9 @@ package body Sem_Prag is
exit;
+ elsif From_Aspect_Specification (N) then
+ exit;
+
else
Hom_Id := Homonym (Hom_Id);
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c528047e634..90b069da8b2 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5888,7 +5888,10 @@ package body Sem_Res is
end;
end if;
- Analyze_Dimension (N);
+ -- Check the dimensions of the actuals in the call. For function calls,
+ -- propagate the dimensions from the returned type to N.
+
+ Analyze_Dimension_Call (N, Nam);
-- All done, evaluate call and deal with elaboration issues
View Lorry Controller Status