OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2012-04-26  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb (Check_Unreachable_Code): Skip past pragmas.

2012-04-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* s-finroo.ads: Remove with clause for
	Ada.Streams. Type Root_Controlled is now abstract tagged null
	record. Remove internal package Stream_Attributes. Root_Controlled
	doesn't need stream attribute redeclaration and avoids the
	dependency on streams.

2012-04-26  Tristan Gingold  <gingold@adacore.com>

	* adaint.c (to_host_path_spec): Removed (unused).
	Minor reformatting.

2012-04-26  Steve Baird  <baird@adacore.com>

	* gnat_rm.texi Improve description of Valid_Scalars attribute.

2012-04-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Can_Override_Operator): If the formal is a
	generic type the operator cannot be overriding.

2012-04-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Spec_Reloaded_For_Body): Check whether the type
	is declared in a package specification, and current unit is the
	corresponding package body. The use clauses themselves may be
	within a nested package.

2012-04-26  Bob Duff  <duff@adacore.com>

	* exp_ch2.adb (Param_Entity): Take into account the case where
	the type of the entry parameter has a representation clause.

From-SVN: r186870
This commit is contained in:
Arnaud Charlet 2012-04-26 11:59:24 +02:00
parent 7a6de2e28f
commit f146302c25
8 changed files with 211 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/ada/ChangeLog
View File

@ -1,3 +1,41 @@
2012-04-26 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb (Check_Unreachable_Code): Skip past pragmas.
2012-04-26 Hristian Kirtchev <kirtchev@adacore.com>
* s-finroo.ads: Remove with clause for
Ada.Streams. Type Root_Controlled is now abstract tagged null
record. Remove internal package Stream_Attributes. Root_Controlled
doesn't need stream attribute redeclaration and avoids the
dependency on streams.
2012-04-26 Tristan Gingold <gingold@adacore.com>
* adaint.c (to_host_path_spec): Removed (unused).
Minor reformatting.
2012-04-26 Steve Baird <baird@adacore.com>
* gnat_rm.texi Improve description of Valid_Scalars attribute.
2012-04-26 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Can_Override_Operator): If the formal is a
generic type the operator cannot be overriding.
2012-04-26 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Spec_Reloaded_For_Body): Check whether the type
is declared in a package specification, and current unit is the
corresponding package body. The use clauses themselves may be
within a nested package.
2012-04-26 Bob Duff <duff@adacore.com>
* exp_ch2.adb (Param_Entity): Take into account the case where
the type of the entry parameter has a representation clause.
2012-04-26 Ed Schonberg <schonberg@adacore.com>
* gnat_ugn.texi: Tweak dimensionality doc.

241
gcc/ada/adaint.c
View File

@ -3086,11 +3086,12 @@ __gnat_to_canonical_file_list_free ()
char *
__gnat_translate_vms (char *src)
{
static char retbuf [NAM$C_MAXRSS+1];
static char retbuf [NAM$C_MAXRSS + 1];
char *srcendpos, *pos1, *pos2, *retpos;
int disp, path_present = 0;
if (!src) return NULL;
if (!src)
return NULL;
srcendpos = strchr (src, '\0');
retpos = retbuf;
@ -3099,112 +3100,132 @@ __gnat_translate_vms (char *src)
pos1 = src;
pos2 = strchr (pos1, ':');
if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
/* There is a node name. "node_name::" becomes "node_name!" */
disp = pos2 - pos1;
strncpy (retbuf, pos1, disp);
retpos [disp] = '!';
retpos = retpos + disp + 1;
pos1 = pos2 + 2;
pos2 = strchr (pos1, ':');
}
if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':'))
{
/* There is a node name. "node_name::" becomes "node_name!" */
disp = pos2 - pos1;
strncpy (retbuf, pos1, disp);
retpos [disp] = '!';
retpos = retpos + disp + 1;
pos1 = pos2 + 2;
pos2 = strchr (pos1, ':');
}
if (pos2) {
/* There is a device name. "dev_name:" becomes "/dev_name/" */
*(retpos++) = '/';
disp = pos2 - pos1;
strncpy (retpos, pos1, disp);
retpos = retpos + disp;
pos1 = pos2 + 1;
*(retpos++) = '/';
}
if (pos2)
{
/* There is a device name. "dev_name:" becomes "/dev_name/" */
*(retpos++) = '/';
disp = pos2 - pos1;
strncpy (retpos, pos1, disp);
retpos = retpos + disp;
pos1 = pos2 + 1;
*(retpos++) = '/';
}
else
/* No explicit device; we must look ahead and prepend /sys$disk/ if
the path is absolute */
if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
&& !strchr (".-]>", *(pos1 + 1))) {
strncpy (retpos, "/sys$disk/", 10);
retpos += 10;
}
&& !strchr (".-]>", *(pos1 + 1)))
{
strncpy (retpos, "/sys$disk/", 10);
retpos += 10;
}
/* Process the path part */
while (*pos1 == '[' || *pos1 == '<') {
path_present++;
pos1++;
if (*pos1 == ']' || *pos1 == '>') {
/* Special case, [] translates to '.' */
*(retpos++) = '.';
while (*pos1 == '[' || *pos1 == '<')
{
path_present++;
pos1++;
}
else {
/* '[000000' means root dir. It can be present in the middle of
the path due to expansion of logical devices, in which case
we skip it */
if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
(*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
pos1 += 6;
if (*pos1 == '.') pos1++;
if (*pos1 == ']' || *pos1 == '>')
{
/* Special case, [] translates to '.' */
*(retpos++) = '.';
pos1++;
}
else if (*pos1 == '.') {
/* Relative path */
*(retpos++) = '.';
}
else
{
/* '[000000' means root dir. It can be present in the middle of
the path due to expansion of logical devices, in which case
we skip it */
if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
(*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.'))
{
pos1 += 6;
if (*pos1 == '.') pos1++;
}
else if (*pos1 == '.')
{
/* Relative path */
*(retpos++) = '.';
}
/* There is a qualified path */
while (*pos1 && *pos1 != ']' && *pos1 != '>') {
switch (*pos1) {
case '.':
/* '.' is used to separate directories. Replace it with '/' but
only if there isn't already '/' just before */
if (*(retpos - 1) != '/') *(retpos++) = '/';
pos1++;
if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
/* ellipsis refers to entire subtree; replace with '**' */
*(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
pos1 += 2;
/* There is a qualified path */
while (*pos1 && *pos1 != ']' && *pos1 != '>')
{
switch (*pos1)
{
case '.':
/* '.' is used to separate directories. Replace it with '/' but
only if there isn't already '/' just before */
if (*(retpos - 1) != '/')
*(retpos++) = '/';
pos1++;
if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.')
{
/* ellipsis refers to entire subtree; replace with '**' */
*(retpos++) = '*';
*(retpos++) = '*';
*(retpos++) = '/';
pos1 += 2;
}
break;
case '-' :
/* When after '.' '[' '<' is equivalent to Unix ".." but there
may be several in a row */
if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
*(pos1 - 1) == '<')
{
while (*pos1 == '-')
{
pos1++;
*(retpos++) = '.';
*(retpos++) = '.';
*(retpos++) = '/';
}
retpos--;
break;
}
/* otherwise fall through to default */
default:
*(retpos++) = *(pos1++);
}
}
break;
case '-' :
/* When after '.' '[' '<' is equivalent to Unix ".." but there
may be several in a row */
if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
*(pos1 - 1) == '<') {
while (*pos1 == '-') {
pos1++;
*(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
}
retpos--;
break;
}
/* otherwise fall through to default */
default:
*(retpos++) = *(pos1++);
pos1++;
}
}
pos1++;
}
}
if (pos1 < srcendpos) {
/* Now add the actual file name, until the version suffix if any */
if (path_present) *(retpos++) = '/';
pos2 = strchr (pos1, ';');
disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
strncpy (retpos, pos1, disp);
retpos += disp;
if (pos2 && pos2 < srcendpos) {
/* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
*retpos++ = '.';
disp = srcendpos - pos2 - 1;
strncpy (retpos, pos2 + 1, disp);
if (pos1 < srcendpos)
{
/* Now add the actual file name, until the version suffix if any */
if (path_present)
*(retpos++) = '/';
pos2 = strchr (pos1, ';');
disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
strncpy (retpos, pos1, disp);
retpos += disp;
if (pos2 && pos2 < srcendpos)
{
/* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
*retpos++ = '.';
disp = srcendpos - pos2 - 1;
strncpy (retpos, pos2 + 1, disp);
retpos += disp;
}
}
}
*retpos = '\0';
return retbuf;
}
/* Translate a VMS syntax directory specification in to Unix syntax. If
@ -3355,52 +3376,13 @@ __gnat_to_canonical_path_spec (char *pathspec)
static char filename_buff [MAXPATH];
static int
translate_unix (char *name, int type)
translate_unix (char *name, int type ATTRIBUTE_UNUSED)
{
strncpy (filename_buff, name, MAXPATH);
filename_buff [MAXPATH - 1] = (char) 0;
return 0;
}
/* Translate a Unix syntax path spec into a VMS style (comma separated list of
directories. */
static char *
to_host_path_spec (char *pathspec)
{
char *curr, *next, buff [MAXPATH];
if (pathspec == 0)
return pathspec;
/* Can't very well test for colons, since that's the Unix separator! */
if (strchr (pathspec, ']') || strchr (pathspec, ','))
return pathspec;
new_host_pathspec[0] = 0;
curr = pathspec;
for (;;)
{
next = strchr (curr, ':');
if (next == 0)
next = strchr (curr, 0);
strncpy (buff, curr, next - curr);
buff[next - curr] = 0;
strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
if (*next == 0)
break;
strncat (new_host_pathspec, ",", MAXPATH);
curr = next + 1;
}
new_host_pathspec [MAXPATH - 1] = (char) 0;
return new_host_pathspec;
}
/* Translate a Unix syntax directory specification into VMS syntax. The
PREFIXFLAG has no effect, but is kept for symmetry with
to_canonical_dir_spec. If indicators of VMS syntax found, return input
@ -3592,7 +3574,8 @@ char __gnat_environment_char = '$';
Returns 0 if operation was successful and -1 in case of error. */
int
__gnat_copy_attribs (char *from, char *to, int mode)
__gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED,
int mode ATTRIBUTE_UNUSED)
{
#if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
defined (__nucleus__)

28
gcc/ada/exp_ch2.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -723,6 +723,8 @@ package body Exp_Ch2 is
-- typ!(recobj).rec.all'Constrained
-- where rec is a selector whose Entry_Formal link points to the formal
-- If the type of the entry parameter has a representation clause, then an
-- extra temp is involved (see below).
-- For a formal of a task entity, the formal is rewritten as a local
-- renaming.
@ -760,10 +762,30 @@ package body Exp_Ch2 is
else
if Nkind (N) = N_Explicit_Dereference then
declare
P : constant Node_Id := Prefix (N);
S : Node_Id;
P : Node_Id := Prefix (N);
S : Node_Id;
E : Entity_Id;
Decl : Node_Id;
begin
-- If the type of an entry parameter has a representation
-- clause, then the prefix is not a selected component, but
-- instead a reference to a temp pointing at the selected
-- component. In this case, set P to be the initial value of
-- that temp.
if Nkind (P) = N_Identifier then
E := Entity (P);
if Ekind (E) = E_Constant then
Decl := Parent (E);
if Nkind (Decl) = N_Object_Declaration then
P := Expression (Decl);
end if;
end if;
end if;
if Nkind (P) = N_Selected_Component then
S := Selector_Name (P);

28
gcc/ada/gnat_rm.texi
View File

@ -6998,18 +6998,22 @@ caller.
@findex Valid_Scalars
@noindent
The @code{'Valid_Scalars} attribute is intended to make it easier to
check the validity of scalar subcomponents of composite objects. It
is defined for any prefix @code{X} that denotes a scalar or composite
object (after any implicit dereference), that is not of classwide type
or of a formal generic type with an unknown discriminant.
@code{X'Valid_Scalars} yields True if and only if @code{X'Valid}
yields True, if @code{X} is a scalar object, or @code{Y'Valid} yields
True for every scalar subcomponent @code{Y} of @code{X}, if @code{X}
is a composite object. If computing the value of
@code{X'Valid_Scalars} involves evaluations of subtype predicates, it
is unspecified in which order these evaluations take place, or if they
take place at all in case the result is False. The value of this
attribute is of the predefined type Boolean.
check the validity of scalar subcomponents of composite objects. It
is defined for any prefix @code{X} that denotes an object.
The value of this attribute is of the predefined type Boolean.
@code{X'Valid_Scalars} yields True if and only if evaluation of
@code{P'Valid} yields True for every scalar part P of X or if X has
no scalar parts. It is not specified in what order the scalar parts
are checked, nor whether any more are checked after any one of them
is determined to be invalid. If the prefix @code{X} is of a class-wide
type @code{T'Class} (where @code{T} is the associated specific type),
or if the prefix @code{X} is of a specific tagged type @code{T}, then
only the scalar parts of components of @code{T} are traversed; in other
words, components of extensions of @code{T} are not traversed even if
@code{T'Class (X)'Tag /= T'Tag} . The compiler will issue a warning if it can
be determined at compile time that the prefix of the attribute has no
scalar parts (e.g., if the prefix is of an access type, an interface type,
an undiscriminated task type, or an undiscriminated protected type).
@node VADS_Size
@unnumberedsec VADS_Size

18
gcc/ada/s-finroo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -31,30 +31,16 @@
-- This unit provides the basic support for controlled (finalizable) types
with Ada.Streams;
package System.Finalization_Root is
pragma Preelaborate;
-- The base for types Controlled and Limited_Controlled declared in Ada.
-- Finalization.
type Root_Controlled is tagged null record;
type Root_Controlled is abstract tagged null record;
procedure Adjust (Object : in out Root_Controlled);
procedure Finalize (Object : in out Root_Controlled);
procedure Initialize (Object : in out Root_Controlled);
package Stream_Attributes is
procedure Read
(Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Item : out Root_Controlled) is null;
procedure Write
(Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Item : Root_Controlled) is null;
end Stream_Attributes;
for Root_Controlled'Read use Stream_Attributes.Read;
for Root_Controlled'Write use Stream_Attributes.Write;
end System.Finalization_Root;

6
gcc/ada/sem_ch5.adb
View File

@ -2767,6 +2767,12 @@ package body Sem_Ch5 is
begin
Nxt := Original_Node (Next (N));
-- Skip past pragmas
while Nkind (Nxt) = N_Pragma loop
Nxt := Original_Node (Next (Nxt));
end loop;
-- If a label follows us, then we never have dead code, since
-- someone could branch to the label, so we just ignore it, unless
-- we are in formal mode where goto statements are not allowed.

4
gcc/ada/sem_ch6.adb
View File

@ -7383,6 +7383,7 @@ package body Sem_Ch6 is
function Can_Override_Operator (Subp : Entity_Id) return Boolean is
Typ : Entity_Id;
begin
if Nkind (Subp) /= N_Defining_Operator_Symbol then
return False;
@ -7390,7 +7391,10 @@ package body Sem_Ch6 is
else
Typ := Base_Type (Etype (First_Formal (Subp)));
-- Check explicitly that the operation is a primitive of the type
return Operator_Matches_Spec (Subp, Subp)
and then not Is_Generic_Type (Typ)
and then Scope (Subp) = Scope (Typ)
and then not Is_Class_Wide_Type (Typ);
end if;

10
gcc/ada/sem_ch8.adb
View File

@ -7963,10 +7963,16 @@ package body Sem_Ch8 is
Spec : constant Node_Id :=
Parent (List_Containing (Parent (Id)));
begin
-- Check whether type is declared in a package specification,
-- and current unit is the corresponding package body. The
-- use clauses themselves may be within a nested package.
return
Nkind (Spec) = N_Package_Specification
and then Corresponding_Body (Parent (Spec)) =
Cunit_Entity (Current_Sem_Unit);
and then
In_Same_Source_Unit (Corresponding_Body (Parent (Spec)),
Cunit_Entity (Current_Sem_Unit));
end;
end if;