+2012-10-05 Thomas Quinot <quinot@adacore.com>
+
+ * sem_dim.adb, errout.adb, errout.ads (Analyze_Dimension_Call): Add
+ guard against abnormal tree resulting from a previously diagnosed
+ illegality.
+
+2012-10-05 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_Expression): Rename local variable Cspc to Spec
+ and update all refs to it. Do not freeze an entity outside a subprogram
+ body when the original context is an expression function.
+
+2012-10-05 Robert Dewar <dewar@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Default for overflow checking
+ is suppressed, even if backend overflow/divide checks are enabled.
+
+2012-10-05 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.adb (Set_Invariant_Procedure, Set_Predicate_Function):
+ chain properly subprograms on Subprograms_For_Type list.
+ * sem_ch13.ads; (Build_Invariant_Procedure_Declaration): new
+ procedure, to create declaration for invariant procedure
+ independently of the construction of the body, so that it can
+ be called within expression functions.
+ * sem_ch13.adb (Build_Invariant_Procedure): code cleanup. The
+ declaration may already have been generated at the point an
+ explicit invariant aspect is encountered.
+ * sem_prag.adb; (Analyze_Pragma, case Invariant): create declaration
+ for invariant procedure.
+ * sem_ch7.adb (Analyze_Package_Specification): clean up call to
+ build invariant procedure.
+ (Preserve_Full_Attributes): propagate information about invariants
+ if they appear on a completion,
+
+2012-10-05 Pascal Obry <obry@adacore.com>
+
+ * gnat_ugn.texi: Update documentation to lift Microsoft C
+ restriction.
+
2012-10-05 Robert Dewar <dewar@adacore.com>
* sem_util.adb (Has_One_Matching_Field): Handle case of lone
S := Subprograms_For_Type (Id);
Set_Subprograms_For_Type (Id, V);
+ Set_Subprograms_For_Type (V, S);
while Present (S) loop
if Has_Invariants (S) then
S := Subprograms_For_Type (S);
end if;
end loop;
-
- Set_Subprograms_For_Type (Id, V);
end Set_Invariant_Procedure;
----------------------------
S := Subprograms_For_Type (Id);
Set_Subprograms_For_Type (Id, V);
+ Set_Subprograms_For_Type (V, S);
while Present (S) loop
if Has_Predicates (S) then
S := Subprograms_For_Type (S);
end if;
end loop;
-
- Set_Subprograms_For_Type (Id, V);
end Set_Predicate_Function;
-----------------
-- spec for precise definition of the conversion that is performed by this
-- routine in OpenVMS mode.
+ --------------------
+ -- Cascaded_Error --
+ --------------------
+
+ procedure Cascaded_Error is
+ begin
+ -- An anomaly has been detected which is assumed to be a consequence of
+ -- a previous error. Raise an exception if no serious error has been
+ -- found so far.
+
+ if Serious_Errors_Detected = 0 then
+ raise Program_Error;
+ end if;
+ end Cascaded_Error;
+
-----------------------
-- Change_Error_Text --
-----------------------
-- This routine can only be called during semantic analysis. It may not
-- be called during parsing.
+ procedure Cascaded_Error;
+ -- When an anomaly is detected, many semantic routines silently bail out,
+ -- assuming that the anomaly was caused by a previously detected error.
+ -- This routine should be called in these cases, and will raise an
+ -- exception if no serious error has been detected. This ensure that the
+ -- anomaly is never allowed to go unnoticed.
+
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String);
-- The error message text of the message identified by Id is replaced by
-- the given text. This text may contain insertion characters in the
-- subprogram body that we are inside.
if In_Exp_Body (Parent_P) then
-
- -- However, we *do* want to freeze at this point if we have
- -- an entity to freeze, and that entity is declared *inside*
- -- the body of the expander generated procedure. This case
- -- is recognized by the scope of the type, which is either
- -- the spec for some enclosing body, or (in the case of
- -- init_procs, for which there are no separate specs) the
- -- current scope.
-
declare
Subp : constant Node_Id := Parent (Parent_P);
- Cspc : Entity_Id;
+ Spec : Entity_Id;
begin
+ -- Freeze the entity only when it is declared inside the
+ -- body of the expander generated procedure. This case
+ -- is recognized by the scope of the entity or its type,
+ -- which is either the spec for some enclosing body, or
+ -- (in the case of init_procs, for which there are no
+ -- separate specs) the current scope.
+
if Nkind (Subp) = N_Subprogram_Body then
- Cspc := Corresponding_Spec (Subp);
+ Spec := Corresponding_Spec (Subp);
- if (Present (Typ) and then Scope (Typ) = Cspc)
+ if (Present (Typ) and then Scope (Typ) = Spec)
or else
- (Present (Nam) and then Scope (Nam) = Cspc)
+ (Present (Nam) and then Scope (Nam) = Spec)
then
exit;
elsif Present (Typ)
and then Scope (Typ) = Current_Scope
- and then Current_Scope = Defining_Entity (Subp)
+ and then Defining_Entity (Subp) = Current_Scope
then
exit;
end if;
end if;
- end;
- -- If not that exception to the exception, then this is
- -- where we delay the freeze till outside the body.
+ -- An expression function may act as a completion of
+ -- a function declaration. As such, it can reference
+ -- entities declared between the two views:
- Parent_P := Parent (Parent_P);
- Freeze_Outside := True;
+ -- Hidden []; -- 1
+ -- function F return ...;
+ -- private
+ -- function Hidden return ...;
+ -- function F return ... is (Hidden); -- 2
+
+ -- Refering to the example above, freezing the expression
+ -- of F (2) would place Hidden's freeze node (1) in the
+ -- wrong place. Avoid explicit freezing and let the usual
+ -- scenarios do the job - for example, reaching the end
+ -- of the private declarations.
+
+ if Nkind (Original_Node (Subp)) =
+ N_Expression_Function
+ then
+ null;
+
+ -- Freeze outside the body
+
+ else
+ Parent_P := Parent (Parent_P);
+ Freeze_Outside := True;
+ end if;
+ end;
-- Here if normal case where we are in handled statement
-- sequence and want to do the insertion right there.
Exception_Mechanism := Back_End_Exceptions;
end if;
- -- Set proper status for overflow checks. If already set (by -gnato or
- -- -gnatp) then we have nothing to do.
+ -- Set proper status for overflow checks
+
+ -- If already set (by - gnato or -gnatp) then we have nothing to do
if Opt.Suppress_Options.Overflow_Checks_General /= Not_Set then
null;
+ -- Otherwise set appropriate default mode. Note: at present we set
+ -- SUPPRESSED in all three of the following cases. They are separated
+ -- because in the future we may make different choices.
+
-- By default suppress overflow checks in -gnatg mode
elsif GNAT_Mode then
Suppress_Options.Overflow_Checks_Assertions := Suppressed;
-- If we have backend divide and overflow checks, then by default
- -- overflow checks are minimized, which is a reasonable setting.
+ -- overflow checks are suppressed. Historically this code used to
+ -- activate overflow checks, although no target currently has these
+ -- flags set, so this was dead code anyway.
elsif Targparm.Backend_Divide_Checks_On_Target
and
Targparm.Backend_Overflow_Checks_On_Target
then
- Suppress_Options.Overflow_Checks_General := Minimized;
- Suppress_Options.Overflow_Checks_Assertions := Minimized;
+ Suppress_Options.Overflow_Checks_General := Suppressed;
+ Suppress_Options.Overflow_Checks_Assertions := Suppressed;
- -- Otherwise for now, default is checks are suppressed. This is likely
+ -- Otherwise for now, default is checks are suppressed. This is subject
-- to change in the future, but for now this is the compatible behavior
-- with previous versions of GNAT.
features are not used, but it is not guaranteed to work.
@item
-It is not possible to link against Microsoft libraries except for
+It is not possible to link against Microsoft C++ libraries except for
import libraries. Interfacing must be done by the mean of DLLs.
+@item
+It is possible to link against Microsoft C libraries. Yet the preferred
+solution is to use C/C++ compiler that comes with @value{EDITION}, since it
+doesn't require having two different development environments and makes the
+inter-language debugging experience smoother.
+
@item
When the compilation environment is located on FAT32 drives, users may
experience recompilations of the source files that have not changed if
Windows C/C++ development environment conditions your overall
interoperability strategy.
-If you use @command{gcc} to compile the non-Ada part of your application,
-there are no Windows-specific restrictions that affect the overall
-interoperability with your Ada code. If you do want to use the
-Microsoft tools for your non-Ada code, you have two choices:
+If you use @command{gcc} or Microsoft C to compile the non-Ada part of
+your application, there are no Windows-specific restrictions that
+affect the overall interoperability with your Ada code. If you do want
+to use the Microsoft tools for your C++ code, you have two choices:
@enumerate
@item
-Encapsulate your non-Ada code in a DLL to be linked with your Ada
+Encapsulate your C++ code in a DLL to be linked with your Ada
application. In this case, use the Microsoft or whatever environment to
build the DLL and use GNAT to build your executable
(@pxref{Using DLLs with GNAT}).
end if;
end Analyze_Record_Representation_Clause;
+ -------------------------------------------
+ -- Build_Invariant_Procedure_Declaration --
+ -------------------------------------------
+
+ function Build_Invariant_Procedure_Declaration
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ Spec : Node_Id;
+ SId : Entity_Id;
+
+ begin
+ Set_Etype (Object_Entity, Typ);
+
+ -- Check for duplicate definiations.
+
+ if Has_Invariants (Typ)
+ and then Present (Invariant_Procedure (Typ))
+ then
+ return Empty;
+ end if;
+
+ SId := Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Invariant"));
+ Set_Has_Invariants (SId);
+ Set_Has_Invariants (Typ);
+ Set_Ekind (SId, E_Procedure);
+ Set_Invariant_Procedure (Typ, SId);
+
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
+
+ return Make_Subprogram_Declaration (Loc, Specification => Spec);
+ end Build_Invariant_Procedure_Declaration;
+
-------------------------------
-- Build_Invariant_Procedure --
-------------------------------
-- "inherited" to the exception message and generating an informational
-- message about the inheritance of an invariant.
- Object_Name : constant Name_Id := New_Internal_Name ('I');
+ Object_Name : Name_Id;
-- Name for argument of invariant procedure
- Object_Entity : constant Node_Id :=
- Make_Defining_Identifier (Loc, Object_Name);
- -- The procedure declaration entity for the argument
+ Object_Entity : Node_Id;
+ -- The entity of the formal for the procedure
--------------------
-- Add_Invariants --
Stmts := No_List;
PDecl := Empty;
PBody := Empty;
- Set_Etype (Object_Entity, Typ);
+ SId := Empty;
+
+ -- If the aspect specification exists for some view of the type, the
+ -- declaration for the procedure has been created.
+
+ if Has_Invariants (Typ) then
+ SId := Invariant_Procedure (Typ);
+ end if;
+
+ if Present (SId) then
+ PDecl := Unit_Declaration_Node (SId);
+
+ else
+ PDecl := Build_Invariant_Procedure_Declaration (Typ);
+ end if;
+
+ -- Recover formal of procedure, for use in the calls to invariant
+ -- functions (including inherited ones).
+
+ Object_Entity :=
+ Defining_Identifier
+ (First (Parameter_Specifications (Specification (PDecl))));
+ Object_Name := Chars (Object_Entity);
-- Add invariants for the current type
if Stmts /= No_List then
- -- Build procedure declaration
-
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Invariant"));
- Set_Has_Invariants (SId);
- Set_Invariant_Procedure (Typ, SId);
-
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))));
-
- PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-
- -- Build procedure body
-
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Invariant"));
-
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Object_Name),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))));
+ Spec := Copy_Separate_Tree (Specification (PDecl));
PBody :=
Make_Subprogram_Body (Loc,
Statements => Stmts));
-- Insert procedure declaration and spec at the appropriate points.
+ -- If declaration is already analyzed, it was processed by the
+ -- generated pragma.
if Present (Private_Decls) then
-- The spec goes at the end of visible declarations, but they have
-- already been analyzed, so we need to explicitly do the analyze.
- Append_To (Visible_Decls, PDecl);
- Analyze (PDecl);
+ if not Analyzed (PDecl) then
+ Append_To (Visible_Decls, PDecl);
+ Analyze (PDecl);
+ end if;
-- The body goes at the end of the private declarations, which we
-- have not analyzed yet, so we do not need to perform an explicit
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
Set_Has_Predicates (SId);
+ Set_Ekind (SId, E_Function);
Set_Predicate_Function (Typ, SId);
-- The predicate function is shared between views of a type.
-- order is specified and there is at least one component clause. Adjusts
-- component positions according to either Ada 95 or Ada 2005 (AI-133).
+ function Build_Invariant_Procedure_Declaration
+ (Typ : Entity_Id) return Node_Id;
+ -- If a type declaration has a specified invariant aspect, build the
+ -- declaration for the procedure at once, so that calls to it can be
+ -- generated before the body of the invariant procedure is built. This
+ -- is needed in the presence of public expression functions that return
+ -- the type in question.
+
procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id);
-- Typ is a private type with invariants (indicated by Has_Invariants being
-- set for Typ, indicating the presence of pragma Invariant entries on the
-- handling of private and full declarations, and the construction of dispatch
-- tables for tagged types.
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
and then Nkind (Parent (E)) = N_Full_Type_Declaration
and then Has_Aspects (Parent (E))
then
- Build_Invariant_Procedure (E, N);
+ declare
+ ASN : Node_Id;
+ begin
+ ASN := First (Aspect_Specifications (Parent (E)));
+ while Present (ASN) loop
+ if Chars (Identifier (ASN)) = Name_Invariant
+ or else Chars (Identifier (ASN)) = Name_Type_Invariant
+ then
+ Build_Invariant_Procedure (E, N);
+ exit;
+ end if;
+
+ Next (ASN);
+ end loop;
+ end;
end if;
Next_Entity (E);
Set_Freeze_Node (Priv, Freeze_Node (Full));
+ -- Propagate information of type invariants, which may be specified
+ -- for the full view.
+
+ if Has_Invariants (Full) and not Has_Invariants (Priv) then
+ Set_Has_Invariants (Priv);
+ Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full));
+ end if;
+
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
and then not Error_Posted (Full)
Formal := First_Formal (Nam);
while Present (Formal) loop
+
+ -- A missing corresponding actual indicates that the analysis of
+ -- the call was aborted due to a previous error.
+
+ if No (Actual) then
+ Cascaded_Error;
+ return;
+ end if;
+
Formal_Typ := Etype (Formal);
Dims_Of_Formal := Dimensions_Of (Formal_Typ);
when Pragma_Invariant => Invariant : declare
Type_Id : Node_Id;
Typ : Entity_Id;
+ PDecl : Node_Id;
Discard : Boolean;
pragma Unreferenced (Discard);
-- Note that the type has at least one invariant, and also that
-- it has inheritable invariants if we have Invariant'Class.
+ -- Build the corresponding invariant procedure declaration, so
+ -- that calls to it can be generated before the body is built
+ -- (for example wihin an expression function).
- Set_Has_Invariants (Typ);
+ PDecl := Build_Invariant_Procedure_Declaration (Typ);
+ Insert_After (N, PDecl);
+ Analyze (PDecl);
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
projects / thirdparty / gcc.git / commitdiff
