aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2012-10-01 12:07:24 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2012-10-01 12:07:24 +0200
commit0929eaeb0128f2bcb9707ffd78bf0bca1a6b7aea (patch)
tree91820ae56088b235e14ebd8b3e430343693d843a /gcc
parent5f6e1c559b08a262977b1cbcfe16f75116fef4f7 (diff)
downloadgcc-0929eaeb0128f2bcb9707ffd78bf0bca1a6b7aea.zip
gcc-0929eaeb0128f2bcb9707ffd78bf0bca1a6b7aea.tar.gz
gcc-0929eaeb0128f2bcb9707ffd78bf0bca1a6b7aea.tar.bz2
[multiple changes]
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. From-SVN: r191910
Diffstat (limited to 'gcc')
-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 98c2ec3..6b2c9df 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 833d47f2..5715934 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 697599d..c331c33 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 9cc8865..1f30582 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 930f82b..fe01e34 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 f248282..d5861b4 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 4625562..8ee2d0a 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 e440ed5..2ee1755 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 fd0fc00..fa0c6e0 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 78bc57e..902341c 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 50a55e4..332c513 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 e4c27d0..f0e90ee 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 8c88d8f..cdb39fb 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 51772db..53ff327 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 a2dd53c..8a8b195 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 3799651..86ada35 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 38f916f..6f9789e 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 c528047..90b069d 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