From: Arnaud Charlet Date: Thu, 26 Apr 2012 09:59:24 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f146302c2594902c5584bdf9ea25c57979e4cb1c;p=gcc.git [multiple changes] 2012-04-26 Robert Dewar * sem_ch5.adb (Check_Unreachable_Code): Skip past pragmas. 2012-04-26 Hristian Kirtchev * 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 * adaint.c (to_host_path_spec): Removed (unused). Minor reformatting. 2012-04-26 Steve Baird * gnat_rm.texi Improve description of Valid_Scalars attribute. 2012-04-26 Ed Schonberg * sem_ch6.adb (Can_Override_Operator): If the formal is a generic type the operator cannot be overriding. 2012-04-26 Ed Schonberg * 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 * exp_ch2.adb (Param_Entity): Take into account the case where the type of the entry parameter has a representation clause. From-SVN: r186870 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2b65223d7d8..db2dc69e674 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2012-04-26 Robert Dewar + + * sem_ch5.adb (Check_Unreachable_Code): Skip past pragmas. + +2012-04-26 Hristian Kirtchev + + * 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 + + * adaint.c (to_host_path_spec): Removed (unused). + Minor reformatting. + +2012-04-26 Steve Baird + + * gnat_rm.texi Improve description of Valid_Scalars attribute. + +2012-04-26 Ed Schonberg + + * sem_ch6.adb (Can_Override_Operator): If the formal is a + generic type the operator cannot be overriding. + +2012-04-26 Ed Schonberg + + * 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 + + * 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 * gnat_ugn.texi: Tweak dimensionality doc. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index e13b01cdb6e..34136ff914d 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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++) = '.'; - } - - /* 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; + 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++; } - 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; + 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; + } + 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++); + } } - /* 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. ";" becomes "." */ - *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. ";" becomes "." */ + *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__) diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 80f381b82a1..2f19d20996b 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -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); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 96e3ab150f2..88a30f9fe5d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads index 4de2b7c0375..0e1a16f933e 100644 --- a/gcc/ada/s-finroo.ads +++ b/gcc/ada/s-finroo.ads @@ -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; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6feb84cdefa..3d96591967a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 920cb0cd0ac..e8aa81c307c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index dda30af7e1c..f31110b088a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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;