+2009-04-10 Sergey Rybin <rybin@adacore.com>
+
+ * vms_data.ads:
+ Add qualifier for new gnatstub option '--no-exception'
+
+ * gnat_ugn.texi:
+ Add the description of the new gnatstub option '--no-exception'
+
+2009-04-10 Robert Dewar <dewar@adacore.com>
+
+ * rtsfind.adb: Minor reformatting
+
+2009-04-10 Thomas Quinot <quinot@adacore.com>
+
+ * sem_disp.adb: Minor reformatting.
+ Add comment pointing to RM clause for the case of warning against a
+ (failed) attempt at declaring a primitive operation elsewhere than in a
+ package spec.
+
+2009-04-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Denotes_Formal_Package): Check whether the package is
+ an actual for a previous formal package of the current instance.
+
2009-04-10 Bob Duff <duff@adacore.com>
* rtsfind.adb (RTE): Put implicit with_clauses on whatever unit needs
the source search path when calling @command{gnatstub}, see the description
of @command{gnatstub} switches below.
+By default, all the program unit body stubs generated by @code{gnatstub}
+raise the predefined @code{Program_Error} exception, which will catch
+accidental calls of generated stubs. This behavior can be changed with
+option @option{^--no-exception^/NO_EXCEPTION^} (see below).
+
@menu
* Running gnatstub::
* Switches for gnatstub::
@cindex @option{^-l^/LINE_LENGTH^} (@command{gnatstub})
Same as @option{^-gnatyM^/MAX_LINE_LENGTH=^@var{n}}
-@item ^-o^/BODY=^@var{body-name}
+@item ^--no-exception^/NO_EXCEPTION^
+@cindex @option{^--no-exception^/NO_EXCEPTION^} (@command{gnatstub})
+Avoind raising PROGRAM_ERROR in the generated bodies of program unit stubs.
+This is not always possible for function stubs.
+
+@item ^-o ^/BODY=^@var{body-name}
@cindex @option{^-o^/BODY^} (@command{gnatstub})
Body file name. This should be set if the argument file name does not
follow
-- for a call issued from RTE_Available.
<<Found>>
- if (not U.Withed) and then not RTE_Available_Call then
+ if not U.Withed and then not RTE_Available_Call then
U.Withed := True;
declare
-- illegal circular instantiation.
function Denotes_Formal_Package
- (Pack : Entity_Id;
- On_Exit : Boolean := False) return Boolean;
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False;
+ Instance : Entity_Id := Empty) return Boolean;
-- Returns True if E is a formal package of an enclosing generic, or
-- the actual for such a formal in an enclosing instantiation. If such
-- a package is used as a formal in an nested generic, or as an actual
-- in a nested instantiation, the visibility of ITS formals should not
-- be modified. When called from within Restore_Private_Views, the flag
-- On_Exit is true, to indicate that the search for a possible enclosing
- -- instance should ignore the current one.
+ -- instance should ignore the current one. In that case Instance denotes
+ -- the declaration for which this is an actual. This declaration may be
+ -- an instantiation in the source, or the internal instantiation that
+ -- corresponds to the actual for a formal package.
function Find_Actual_Type
(Typ : Entity_Id;
----------------------------
function Denotes_Formal_Package
- (Pack : Entity_Id;
- On_Exit : Boolean := False) return Boolean
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False;
+ Instance : Entity_Id := Empty) return Boolean
is
Par : Entity_Id;
Scop : constant Entity_Id := Scope (Pack);
E : Entity_Id;
+ function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
+ -- The package in question may be an actual for a previous formal
+ -- package P of the current instance, so examine its actuals as well.
+
+ ----------------------------------
+ -- Is_Actual_Of_Previous_Formal --
+ ----------------------------------
+
+ function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
+ E1 : Entity_Id;
+
+ begin
+ E1 := First_Entity (E);
+ while Present (E1) and then E1 /= Instance loop
+ if Ekind (E1) = E_Package
+ and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
+ and then Renamed_Object (E1) = Pack
+ then
+ return True;
+
+ elsif Renamed_Object (E1) = P then
+ return False;
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+
+ return False;
+ end Is_Actual_Of_Previous_Formal;
+
+ -- Start processing of Denotes_Formal_Package
+
begin
if On_Exit then
Par :=
elsif Renamed_Object (E) = Pack then
return True;
+
+ elsif Is_Actual_Of_Previous_Formal (E) then
+ return True;
+
end if;
Next_Entity (E);
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
- elsif Denotes_Formal_Package (Renamed_Object (E), True) then
+ elsif
+ Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
+ then
Set_Is_Hidden (E, False);
else
-- be delayed until after the spec is seen, but that's
-- a tricky change to the delicate freezing code.
- -- Look at each declaration following the type up
- -- until the new subprogram body. If any of the
- -- declarations is a body then the type has been
- -- frozen already so the overriding primitive is
- -- illegal.
+ -- Look at each declaration following the type up until the
+ -- new subprogram body. If any of the declarations is a body
+ -- then the type has been frozen already so the overriding
+ -- primitive is illegal.
while Present (Decl_Item)
and then (Decl_Item /= Subp_Body)
end loop;
-- If the subprogram doesn't follow in the list of
- -- declarations including the type then the type
- -- has definitely been frozen already and the body
- -- is illegal.
+ -- declarations including the type then the type has
+ -- definitely been frozen already and the body is illegal.
if No (Decl_Item) then
Error_Msg_N ("overriding of& is too late!", Subp);
-- If the type is not frozen yet and we are not in the overriding
-- case it looks suspiciously like an attempt to define a primitive
- -- operation.
+ -- operation, which requires the declaration to be in a package spec
+ -- (3.2.3(6)).
elsif not Is_Frozen (Tagged_Type) then
Error_Msg_N
-- HIGH A great number of messages are output, most of them not
-- being useful for the user.
+ S_Stub_No_Exc : aliased constant S := "/NO_EXCEPTION " &
+ "--no-exception";
+ -- /NONO_EXCEPTION (D)
+ -- /NO_EXCEPTION
+ --
+ -- Avoid raising PROGRAM_ERROR in the generated program unit stubs.
+
S_Stub_Output : aliased constant S := "/OUTPUT=@" &
"-o@";
-- /OUTPUT=filespec
S_Stub_Mess 'Access,
S_Stub_Output 'Access,
S_Stub_Project 'Access,
+ S_Stub_No_Exc 'Access,
S_Stub_Quiet 'Access,
S_Stub_Search 'Access,
S_Stub_Subdirs 'Access,
projects / thirdparty / gcc.git / commitdiff
