summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2012-10-04 18:42:50 +0000
committerbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2012-10-04 18:42:50 +0000
commitdb7c8f2a08c7cd93e83d22de940e2b87a99704e2 (patch)
tree41404f9e1d751c449ad09ce30f02579a291e5e01 /gcc/ada
parentb7ba1683bd64a4f9a3eb34525a390d79e2dbb7a5 (diff)
downloadgcc-db7c8f2a08c7cd93e83d22de940e2b87a99704e2.tar.gz
2012-10-04 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 192095 using svnmerge.py git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@192098 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog129
-rw-r--r--gcc/ada/bindgen.adb18
-rw-r--r--gcc/ada/checks.adb92
-rw-r--r--gcc/ada/exp_ch4.adb22
-rw-r--r--gcc/ada/exp_ch6.adb12
-rw-r--r--gcc/ada/exp_disp.adb525
-rw-r--r--gcc/ada/exp_util.adb5
-rw-r--r--gcc/ada/g-comlin.adb127
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in173
-rw-r--r--gcc/ada/gprep.adb8
-rw-r--r--gcc/ada/init.c4
-rw-r--r--gcc/ada/opt.ads6
-rw-r--r--gcc/ada/prep.adb8
-rw-r--r--gcc/ada/prepcomp.adb18
-rw-r--r--gcc/ada/prj-proc.adb4
-rw-r--r--gcc/ada/projects.texi74
-rw-r--r--gcc/ada/s-bignum.adb11
-rw-r--r--gcc/ada/s-exnllf.adb5
-rw-r--r--gcc/ada/s-exnllf.ads5
-rw-r--r--gcc/ada/sem_ch10.adb53
-rw-r--r--gcc/ada/sem_ch3.adb42
-rw-r--r--gcc/ada/sem_ch4.adb26
-rw-r--r--gcc/ada/sem_ch9.adb8
-rw-r--r--gcc/ada/sem_eval.adb134
-rw-r--r--gcc/ada/sem_prag.adb9
-rw-r--r--gcc/ada/sem_res.adb47
-rw-r--r--gcc/ada/sem_util.adb39
-rw-r--r--gcc/ada/sem_util.ads6
-rw-r--r--gcc/ada/sinfo.ads11
-rw-r--r--gcc/ada/types.ads4
30 files changed, 968 insertions, 657 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d11055f81db..8196e94e8ad 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,132 @@
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * sem_res.adb (Resolve_Set_Membership): Warn on duplicates.
+
+2012-10-04 Emmanuel Briot <briot@adacore.com>
+
+ * g-comlin.adb (Getopt): Fix value of Full_Switch returned in case of
+ invalid switch.
+
+2012-10-04 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Make-lang.in: Update dependencies.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * sem_eval.adb (Fold_Str, Fold_Uint, Fold_Ureal): Reset static
+ expression state after Resolve call.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma. case Warnngs): Don't make entry
+ in the table for Warnings Off pragmas if within an instance.
+
+2012-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch9.adb (Analyze_Entry_Body): Transfer
+ Has_Pragma_Unreferenced flag from entry formal to corresponding
+ entity in body, to prevent spurious warnings when pragma is
+ present.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * s-bignum.adb (Big_Exp): Raise Storage_Error for ludicrously
+ large results.
+
+2012-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Check_Duplicate_Aspects): Diagnose properly
+ aspects that appear in the partial and the full view of a type.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * sinfo.ads (N_Return_Statement): Removed.
+
+2012-10-04 Tristan Gingold <gingold@adacore.com>
+
+ * init.c (__gl_zero_cost_exceptions): Comment it as not used
+ anymore.
+ * bindgen.adb (Gen_Adainit): Do not emit Zero_Cost_Exceptions
+ anymore.
+
+2012-10-04 Thomas Quinot <quinot@adacore.com>
+
+ * prep.adb, prepcomp.adb, gprep.adb, opt.ads: New preprocessor switch
+ -a (all source text preserved).
+
+2012-10-04 Vincent Celier <celier@adacore.com>
+
+ * prj-proc.adb (Recursive_Process): Use project directory
+ display path name as the value of 'Project_Dir.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow):
+ Deal with case where we get a bignum operand and cannot do a
+ range analysis.
+ * sem_eval.adb (Why_Not_Static): Deal with bignum operands
+
+2012-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Find_Unary_Types): Within an instance, an
+ interpretation that involves a predefied arithmetic operator is
+ not a candidate if the corresponding generic formal type is not
+ a numeric type.
+ * sem_util.ads, sem_util.adb (Corresonding_Generic_Type): If a
+ type is a generic actual type within an instance, return the
+ corresponding formal in the generic unit, otherwise return
+ Any_Type.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * checks.adb (Minimize_Eliminate_Overflow_Checks): Dont reanalyze
+ if/case expression if nothing has changed (just reexpand). Stops
+ case expression from generating incorrect temporary.
+ * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow):
+ Fix cut and paste typo for range analysis in NE (not equal) case.
+ * sem_eval.adb (Compile_Time_Compare): Small optimization to
+ catch some more cases.
+ * types.ads (Suppressed_Or_Checked): New subtype of
+ Overflow_Check_Type.
+
+2012-10-04 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Set_CPP_Constructors_Old): Removed.
+ (Set_CPP_Constructors): Code cleanup.
+
+2012-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Is_Ancestor_Unit): Make global, for use elsewhere.
+ (Install_Private_with_Clauses): if clause is private and limited,
+ do not install the limited view if the library unit is an ancestor
+ of the unit being compiled. This unusual configuration occurs
+ when compiling a unit DDP, when an ancestor P of DDP has a
+ private limited with clause on a descendant of P that is itself
+ an ancestor of DDP.
+
+2012-10-04 Vincent Celier <celier@adacore.com>
+
+ * prj-proc.adb (Process_Package_Declaration): Use project
+ directory display path name as the value of 'Project_Dir.
+
+2012-10-04 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): The subpool can be
+ given by an arbitrary name, so copy the tree to make the call's actual.
+
+2012-10-04 Robert Dewar <dewar@adacore.com>
+
+ * s-exnllf.adb, s-exnllf.ads: Minor reformatting.
+
+2012-10-04 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch6.adb: Minor reformatting.
+
+2012-10-04 Pascal Obry <obry@adacore.com>
+
+ * projects.texi: Use consistently @command{} when referencing
+ commands. Fix typos.
+
2012-10-03 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (New_Overloaded_Entity): call
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index 094b25da42e..bb5a0aac906 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -137,7 +137,6 @@ package body Bindgen is
-- Num_Interrupt_States : Integer;
-- Unreserve_All_Interrupts : Integer;
-- Exception_Tracebacks : Integer;
- -- Zero_Cost_Exceptions : Integer;
-- Detect_Blocking : Integer;
-- Default_Stack_Size : Integer;
-- Leap_Seconds_Support : Integer;
@@ -216,9 +215,6 @@ package body Bindgen is
-- tracebacks are provided by default, so a value of zero for this
-- parameter does not necessarily mean no trace backs are available.
- -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
- -- this partition, and to zero if longjmp/setjmp exceptions are used.
-
-- Detect_Blocking indicates whether pragma Detect_Blocking is active or
-- not. A value of zero indicates that the pragma is not present, while a
-- value of 1 signals its presence in the partition.
@@ -607,9 +603,6 @@ package body Bindgen is
"""__gl_exception_tracebacks"");");
end if;
- WBI (" Zero_Cost_Exceptions : Integer;");
- WBI (" pragma Import (C, Zero_Cost_Exceptions, " &
- """__gl_zero_cost_exceptions"");");
WBI (" Detect_Blocking : Integer;");
WBI (" pragma Import (C, Detect_Blocking, " &
"""__gl_detect_blocking"");");
@@ -803,17 +796,6 @@ package body Bindgen is
WBI (" Exception_Tracebacks := 1;");
end if;
- Set_String (" Zero_Cost_Exceptions := ");
-
- if Zero_Cost_Exceptions_Specified then
- Set_String ("1");
- else
- Set_String ("0");
- end if;
-
- Set_String (";");
- Write_Statement_Buffer;
-
Set_String (" Detect_Blocking := ");
if Detect_Blocking then
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index d74a05c11fe..075eb14caeb 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -34,6 +34,7 @@ with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
+with Expander; use Expander;
with Eval_Fat; use Eval_Fat;
with Freeze; use Freeze;
with Lib; use Lib;
@@ -1272,8 +1273,7 @@ package body Checks is
Apply_Range_Check (N, Typ);
end if;
- elsif (Is_Record_Type (Typ)
- or else Is_Private_Type (Typ))
+ elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
and then Has_Discriminants (Base_Type (Typ))
and then Is_Constrained (Typ)
then
@@ -6709,10 +6709,12 @@ package body Checks is
-- to be done in bignum mode), and the determined ranges of the operands.
-- After possible rewriting of a constituent subexpression node, a call is
- -- made to reanalyze the node after setting Analyzed to False. To avoid a
- -- recursive call into the whole overflow apparatus, and important rule for
- -- this reanalysis call is that either Do_Overflow_Check must be False, or
- -- if it is set, then the overflow checking mode must be temporarily set
+ -- made to either reexpand the node (if nothing has changed) or reanalyze
+ -- the node (if it has been modified by the overflow check processing).
+ -- The Analyzed_flag is set False before the reexpand/reanalyze. To avoid
+ -- a recursive call into the whole overflow apparatus, and important rule
+ -- for this call is that either Do_Overflow_Check must be False, or if
+ -- it is set, then the overflow checking mode must be temporarily set
-- to Checked/Suppressed. Either step will avoid the unwanted recursion.
procedure Minimize_Eliminate_Overflow_Checks
@@ -6761,6 +6763,17 @@ package body Checks is
-- range, then we must convert such operands back to the result type.
-- This switch is properly set only when Bignum_Operands is False.
+ procedure Reexpand (C : Suppressed_Or_Checked);
+ -- This is called when we have not modifed the node, so we do not need
+ -- to reanalyze it. But we do want to reexpand it in either CHECKED
+ -- or SUPPRESSED mode (as indicated by the argument C) to get proper
+ -- expansion. It is important that we reset the mode to SUPPRESSED or
+ -- CHECKED, since if we leave it in MINIMIZED or ELIMINATED mode we
+ -- would reenter this routine recursively which would not be good!
+ -- Note that this is not just an optimization, testing has showed up
+ -- several complex cases in which renalyzing an already analyzed node
+ -- causes incorrect behavior.
+
function In_Result_Range return Boolean;
-- Returns True iff Lo .. Hi are within range of the result type
@@ -6813,6 +6826,24 @@ package body Checks is
end if;
end Min;
+ --------------
+ -- Reexpand --
+ --------------
+
+ procedure Reexpand (C : Suppressed_Or_Checked) is
+ Svg : constant Overflow_Check_Type :=
+ Scope_Suppress.Overflow_Checks_General;
+ Sva : constant Overflow_Check_Type :=
+ Scope_Suppress.Overflow_Checks_Assertions;
+ begin
+ Scope_Suppress.Overflow_Checks_General := C;
+ Scope_Suppress.Overflow_Checks_Assertions := C;
+ Set_Analyzed (N, False);
+ Expand (N);
+ Scope_Suppress.Overflow_Checks_General := Svg;
+ Scope_Suppress.Overflow_Checks_Assertions := Sva;
+ end Reexpand;
+
-- Start of processing for Minimize_Eliminate_Overflow_Checks
begin
@@ -6890,13 +6921,13 @@ package body Checks is
-- If we have no Long_Long_Integer operands, then we are in result
-- range, since it means that none of our operands felt the need
-- to worry about overflow (otherwise it would have already been
- -- converted to long long integer or bignum). We reanalyze to
- -- complete the expansion of the if expression
+ -- converted to long long integer or bignum). We reexpand to
+ -- complete the expansion of the if expression (but we do not
+ -- need to reanalyze).
elsif not Long_Long_Integer_Operands then
Set_Do_Overflow_Check (N, False);
- Set_Analyzed (N, False);
- Analyze_And_Resolve (N, Suppress => Overflow_Check);
+ Reexpand (Suppressed);
-- Otherwise convert us to long long integer mode. Note that we
-- don't need any further overflow checking at this level.
@@ -6953,14 +6984,13 @@ package body Checks is
-- that none of our dependent expressions could raise overflow.
-- In this case, we simply return with no changes except for
-- resetting the overflow flag, since we are done with overflow
- -- checks for this node. We will reset the Analyzed flag so that
- -- we will properly reexpand and get the needed expansion for
- -- the case expression.
+ -- checks for this node. We will reexpand to get the needed
+ -- expansion for the case expression, but we do not need to
+ -- renalyze, since nothing has changed.
if not (Bignum_Operands or Long_Long_Integer_Operands) then
Set_Do_Overflow_Check (N, False);
- Set_Analyzed (N, False);
- Analyze_And_Resolve (N, Suppress => Overflow_Check);
+ Reexpand (Suppressed);
-- Otherwise we are going to rebuild the case expression using
-- either bignum or long long integer operands throughout.
@@ -7381,18 +7411,20 @@ package body Checks is
end case;
end if;
- -- If we know we are in the result range, and we do not have Bignum
- -- operands or Long_Long_Integer operands, we can just renalyze with
- -- overflow checks turned off (since we know we cannot have overflow).
- -- As always the reanalysis is required to complete expansion of the
- -- operator, and we prevent recursion by suppressing the check.
+ -- Here for the case where we have not rewritten anything (no bignum
+ -- operands or long long integer operands), and we know the result If we
+ -- know we are in the result range, and we do not have Bignum operands
+ -- or Long_Long_Integer operands, we can just reexpand with overflow
+ -- checks turned off (since we know we cannot have overflow). As always
+ -- the reexpansion is required to complete expansion of the operator,
+ -- but we do not need to reanalyze, and we prevent recursion by
+ -- suppressing the check,
if not (Bignum_Operands or Long_Long_Integer_Operands)
and then In_Result_Range
then
Set_Do_Overflow_Check (N, False);
- Set_Analyzed (N, False);
- Analyze_And_Resolve (N, Suppress => Overflow_Check);
+ Reexpand (Suppressed);
return;
-- Here we know that we are not in the result range, and in the general
@@ -7427,20 +7459,10 @@ package body Checks is
-- eliminated overflow processing which is not what we want. Here
-- we are at the top level, and we need a check against the result
-- mode (i.e. we want to use Checked mode). So do exactly that!
+ -- Also, we have not modified the node, so this is a case where
+ -- we need to reexpand, but not reanalyze.
- declare
- Svg : constant Overflow_Check_Type :=
- Scope_Suppress.Overflow_Checks_General;
- Sva : constant Overflow_Check_Type :=
- Scope_Suppress.Overflow_Checks_Assertions;
- begin
- Scope_Suppress.Overflow_Checks_General := Checked;
- Scope_Suppress.Overflow_Checks_Assertions := Checked;
- Analyze_And_Resolve (N);
- Scope_Suppress.Overflow_Checks_General := Svg;
- Scope_Suppress.Overflow_Checks_Assertions := Sva;
- end;
-
+ Reexpand (Checked);
return;
-- Cases where we do the operation in Bignum mode. This happens either
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 9357be68b57..f47bae4b918 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2325,13 +2325,16 @@ package body Exp_Ch4 is
Minimize_Eliminate_Overflow_Checks
(Right_Opnd (N), Rlo, Rhi, Top_Level => False);
- -- See if the range information decides the result of the comparison
+ -- See if the range information decides the result of the comparison.
+ -- We can only do this if we in fact have full range information (which
+ -- won't be the case if either operand is bignum at this stage).
- case N_Op_Compare (Nkind (N)) is
+ if Llo /= No_Uint and then Rlo /= No_Uint then
+ case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
Set_True;
- elsif Llo > Rhi or else Rlo > Lhi then
+ elsif Llo > Rhi or else Lhi < Rlo then
Set_False;
end if;
@@ -2365,16 +2368,17 @@ package body Exp_Ch4 is
when N_Op_Ne =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
- Set_True;
- elsif Llo > Rhi or else Rlo > Lhi then
Set_False;
+ elsif Llo > Rhi or else Lhi < Rlo then
+ Set_True;
end if;
- end case;
+ end case;
- -- All done if we did the rewrite
+ -- All done if we did the rewrite
- if Nkind (N) not in N_Op_Compare then
- return;
+ if Nkind (N) not in N_Op_Compare then
+ return;
+ end if;
end if;
-- Otherwise, time to do the comparison
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2fac2a3bffc..8d9ef9b38dd 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1217,8 +1217,8 @@ package body Exp_Ch6 is
and then
Present (Effective_Extra_Accessibility (Entity (Lhs)))
then
- -- Copyback target is an Ada 2012 stand-alone object
- -- of an anonymous access type
+ -- Copyback target is an Ada 2012 stand-alone object of an
+ -- anonymous access type.
pragma Assert (Ada_Version >= Ada_2012);
@@ -3046,7 +3046,7 @@ package body Exp_Ch6 is
Set_Last_Assignment (Ent, Sav);
Set_Is_Known_Valid (Ent, False);
- -- For all other cases, just kill the current values
+ -- For all other cases, just kill the current values
else
Kill_Current_Values (Ent);
@@ -3201,7 +3201,7 @@ package body Exp_Ch6 is
end;
end if;
- -- If we are expanding a rhs of an assignment we need to check if tag
+ -- If we are expanding the RHS of an assignment we need to check if tag
-- propagation is needed. You might expect this processing to be in
-- Analyze_Assignment but has to be done earlier (bottom-up) because the
-- assignment might be transformed to a declaration for an unconstrained
@@ -4219,9 +4219,7 @@ package body Exp_Ch6 is
Ret : Node_Id;
begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- then
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
E := Entity (N);
if Is_Formal (E)
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 6db86e14ef0..9b5cb5716ea 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -8447,152 +8447,49 @@ package body Exp_Disp is
procedure Set_CPP_Constructors (Typ : Entity_Id) is
- procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
- -- For backward compatibility this routine handles CPP constructors
- -- of non-tagged types.
-
- procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
- Loc : Source_Ptr;
- Init : Entity_Id;
- E : Entity_Id;
- Found : Boolean := False;
- P : Node_Id;
- Parms : List_Id;
+ function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
+ -- Duplicate the parameters profile of the imported C++ constructor
+ -- adding an access to the object as an additional parameter.
- Covers_Default_Constructor : Entity_Id := Empty;
+ function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (E);
+ Parms : List_Id;
+ P : Node_Id;
begin
- -- Look for the constructor entities
-
- E := Next_Entity (Typ);
- while Present (E) loop
- if Ekind (E) = E_Function
- and then Is_Constructor (E)
- then
- -- Create the init procedure
-
- Found := True;
- Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc,
- Make_Init_Proc_Name (Typ));
- Parms :=
- New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type =>
- New_Reference_To (Typ, Loc)));
-
- if Present (Parameter_Specifications (Parent (E))) then
- P := First (Parameter_Specifications (Parent (E)));
- while Present (P) loop
- Append_To (Parms,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars (Defining_Identifier (P))),
- Parameter_Type =>
- New_Copy_Tree (Parameter_Type (P)),
- Expression => New_Copy_Tree (Expression (P))));
- Next (P);
- end loop;
- end if;
-
- Discard_Node (
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Init,
- Parameter_Specifications => Parms)));
-
- Set_Init_Proc (Typ, Init);
- Set_Is_Imported (Init);
- Set_Is_Constructor (Init);
- Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_CPP);
- Set_Is_Public (Init);
- Set_Has_Completion (Init);
-
- -- If this constructor has parameters and all its parameters
- -- have defaults then it covers the default constructor. The
- -- semantic analyzer ensures that only one constructor with
- -- defaults covers the default constructor.
-
- if Present (Parameter_Specifications (Parent (E)))
- and then Needs_No_Actuals (E)
- then
- Covers_Default_Constructor := Init;
- end if;
- end if;
-
- Next_Entity (E);
- end loop;
-
- -- If there are no constructors, mark the type as abstract since we
- -- won't be able to declare objects of that type.
-
- if not Found then
- Set_Is_Abstract_Type (Typ);
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uInit),
+ Parameter_Type => New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (P))),
+ Parameter_Type => New_Copy_Tree (Parameter_Type (P)),
+ Expression => New_Copy_Tree (Expression (P))));
+ Next (P);
+ end loop;
end if;
- -- Handle constructor that has all its parameters with defaults and
- -- hence it covers the default constructor. We generate a wrapper IP
- -- which calls the covering constructor.
-
- if Present (Covers_Default_Constructor) then
- declare
- Body_Stmts : List_Id;
- Wrapper_Id : Entity_Id;
- Wrapper_Body_Node : Node_Id;
- begin
- Loc := Sloc (Covers_Default_Constructor);
-
- Body_Stmts := New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Covers_Default_Constructor, Loc),
- Parameter_Associations => New_List (
- Make_Identifier (Loc, Name_uInit))));
-
- Wrapper_Id := Make_Defining_Identifier (Loc,
- Make_Init_Proc_Name (Typ));
-
- Wrapper_Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Wrapper_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uInit),
- Parameter_Type =>
- New_Reference_To (Typ, Loc)))),
- Declarations => No_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts,
- Exception_Handlers => No_List));
-
- Discard_Node (Wrapper_Body_Node);
- Set_Init_Proc (Typ, Wrapper_Id);
- end;
- end if;
- end Set_CPP_Constructors_Old;
+ return Parms;
+ end Gen_Parameters_Profile;
-- Local variables
- Loc : Source_Ptr;
- E : Entity_Id;
- Found : Boolean := False;
- P : Node_Id;
- Parms : List_Id;
-
- Constructor_Decl_Node : Node_Id;
- Constructor_Id : Entity_Id;
- Wrapper_Id : Entity_Id;
- Wrapper_Body_Node : Node_Id;
- Actuals : List_Id;
- Body_Stmts : List_Id;
- Init_Tags_List : List_Id;
+ Loc : Source_Ptr;
+ E : Entity_Id;
+ Found : Boolean := False;
+ IP : Entity_Id;
+ IP_Body : Node_Id;
+ P : Node_Id;
+ Parms : List_Id;
Covers_Default_Constructor : Entity_Id := Empty;
@@ -8601,22 +8498,6 @@ package body Exp_Disp is
begin
pragma Assert (Is_CPP_Class (Typ));
- -- For backward compatibility the compiler accepts C++ classes
- -- imported through non-tagged record types. In such case the
- -- wrapper of the C++ constructor is useless because the _tag
- -- component is not available.
-
- -- Example:
- -- type Root is limited record ...
- -- pragma Import (CPP, Root);
- -- function New_Root return Root;
- -- pragma CPP_Constructor (New_Root, ... );
-
- if not Is_Tagged_Type (Typ) then
- Set_CPP_Constructors_Old (Typ);
- return;
- end if;
-
-- Look for the constructor entities
E := Next_Entity (Typ);
@@ -8626,156 +8507,167 @@ package body Exp_Disp is
then
Found := True;
Loc := Sloc (E);
+ Parms := Gen_Parameters_Profile (E);
+ IP :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_Init_Proc_Name (Typ));
+
+ -- Case 1: Constructor of non-tagged type
+
+ -- If the C++ class has no virtual methods then the matching Ada
+ -- type is a non-tagged record type. In such case there is no need
+ -- to generate a wrapper of the C++ constructor because the _tag
+ -- component is not available.
+
+ if not Is_Tagged_Type (Typ) then
+ Discard_Node
+ (Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => IP,
+ Parameter_Specifications => Parms)));
+
+ Set_Init_Proc (Typ, IP);
+ Set_Is_Imported (IP);
+ Set_Is_Constructor (IP);
+ Set_Interface_Name (IP, Interface_Name (E));
+ Set_Convention (IP, Convention_CPP);
+ Set_Is_Public (IP);
+ Set_Has_Completion (IP);
+
+ -- Case 2: Constructor of a tagged type
+
+ -- In this case we generate the IP as a wrapper of the the
+ -- C++ constructor because IP must also save copy of the _tag
+ -- generated in the C++ side. The copy of the _tag is used by
+ -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
- -- Generate the declaration of the imported C++ constructor
-
- Parms :=
- New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uInit),
- Parameter_Type =>
- New_Reference_To (Typ, Loc)));
-
- if Present (Parameter_Specifications (Parent (E))) then
- P := First (Parameter_Specifications (Parent (E)));
- while Present (P) loop
- Append_To (Parms,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars (Defining_Identifier (P))),
- Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
- Next (P);
- end loop;
- end if;
-
- Constructor_Id := Make_Temporary (Loc, 'P');
+ -- Generate:
+ -- procedure IP (_init : Typ; ...) is
+ -- procedure ConstructorP (_init : Typ; ...);
+ -- pragma Import (ConstructorP);
+ -- begin
+ -- ConstructorP (_init, ...);
+ -- if Typ._tag = null then
+ -- Typ._tag := _init._tag;
+ -- end if;
+ -- end IP;
- Constructor_Decl_Node :=
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Constructor_Id,
- Parameter_Specifications => Parms));
+ else
+ declare
+ Body_Stmts : constant List_Id := New_List;
+ Constructor_Id : Entity_Id;
+ Constructor_Decl_Node : Node_Id;
+ Init_Tags_List : List_Id;
- Set_Is_Imported (Constructor_Id);
- Set_Is_Constructor (Constructor_Id);
- Set_Interface_Name (Constructor_Id, Interface_Name (E));
- Set_Convention (Constructor_Id, Convention_CPP);
- Set_Is_Public (Constructor_Id);
- Set_Has_Completion (Constructor_Id);
+ begin
+ Constructor_Id := Make_Temporary (Loc, 'P');
- -- Build the wrapper of this constructor
+ Constructor_Decl_Node :=
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Constructor_Id,
+ Parameter_Specifications => Parms));
- Parms :=
- New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uInit),
- Parameter_Type =>
- New_Reference_To (Typ, Loc)));
-
- if Present (Parameter_Specifications (Parent (E))) then
- P := First (Parameter_Specifications (Parent (E)));
- while Present (P) loop
- Append_To (Parms,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars (Defining_Identifier (P))),
- Parameter_Type =>
- New_Copy_Tree (Parameter_Type (P)),
- Expression => New_Copy_Tree (Expression (P))));
- Next (P);
- end loop;
- end if;
+ Set_Is_Imported (Constructor_Id);
+ Set_Is_Constructor (Constructor_Id);
+ Set_Interface_Name (Constructor_Id, Interface_Name (E));
+ Set_Convention (Constructor_Id, Convention_CPP);
+ Set_Is_Public (Constructor_Id);
+ Set_Has_Completion (Constructor_Id);
- Body_Stmts := New_List;
+ -- Build the init procedure as a wrapper of this constructor
- -- Invoke the C++ constructor
+ Parms := Gen_Parameters_Profile (E);
- Actuals := New_List;
+ -- Invoke the C++ constructor
- P := First (Parms);
- while Present (P) loop
- Append_To (Actuals,
- New_Reference_To (Defining_Identifier (P), Loc));
- Next (P);
- end loop;
+ declare
+ Actuals : constant List_Id := New_List;
- Append_To (Body_Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Constructor_Id, Loc),
- Parameter_Associations => Actuals));
-
- -- Initialize copies of C++ primary and secondary tags
-
- Init_Tags_List := New_List;
-
- declare
- Tag_Elmt : Elmt_Id;
- Tag_Comp : Node_Id;
-
- begin
- Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
- Tag_Comp := First_Tag_Component (Typ);
+ begin
+ P := First (Parms);
+ while Present (P) loop
+ Append_To (Actuals,
+ New_Reference_To (Defining_Identifier (P), Loc));
+ Next (P);
+ end loop;
- while Present (Tag_Elmt)
- and then Is_Tag (Node (Tag_Elmt))
- loop
- -- Skip the following assertion with primary tags because
- -- Related_Type is not set on primary tag components
+ Append_To (Body_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Constructor_Id, Loc),
+ Parameter_Associations => Actuals));
+ end;
- pragma Assert (Tag_Comp = First_Tag_Component (Typ)
- or else Related_Type (Node (Tag_Elmt))
- = Related_Type (Tag_Comp));
+ -- Initialize copies of C++ primary and secondary tags
- Append_To (Init_Tags_List,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Node (Tag_Elmt), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Reference_To (Tag_Comp, Loc))));
+ Init_Tags_List := New_List;
- Tag_Comp := Next_Tag_Component (Tag_Comp);
- Next_Elmt (Tag_Elmt);
- end loop;
- end;
+ declare
+ Tag_Elmt : Elmt_Id;
+ Tag_Comp : Node_Id;
- Append_To (Body_Stmts,
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Typ))),
- Loc),
- Right_Opnd =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (RTE (RE_Null_Address), Loc))),
- Then_Statements => Init_Tags_List));
+ begin
+ Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
+ Tag_Comp := First_Tag_Component (Typ);
- Wrapper_Id := Make_Defining_Identifier (Loc,
- Make_Init_Proc_Name (Typ));
+ while Present (Tag_Elmt)
+ and then Is_Tag (Node (Tag_Elmt))
+ loop
+ -- Skip the following assertion with primary tags
+ -- because Related_Type is not set on primary tag
+ -- components
+
+ pragma Assert
+ (Tag_Comp = First_Tag_Component (Typ)
+ or else Related_Type (Node (Tag_Elmt))
+ = Related_Type (Tag_Comp));
+
+ Append_To (Init_Tags_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Node (Tag_Elmt), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc))));
- Wrapper_Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Wrapper_Id,
- Parameter_Specifications => Parms),
- Declarations => New_List (Constructor_Decl_Node),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts,
- Exception_Handlers => No_List));
+ Tag_Comp := Next_Tag_Component (Tag_Comp);
+ Next_Elmt (Tag_Elmt);
+ end loop;
+ end;
- Discard_Node (Wrapper_Body_Node);
- Set_Init_Proc (Typ, Wrapper_Id);
+ Append_To (Body_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))),
+ Loc),
+ Right_Opnd =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))),
+ Then_Statements => Init_Tags_List));
+
+ IP_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => IP,
+ Parameter_Specifications => Parms),
+ Declarations => New_List (Constructor_Decl_Node),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts,
+ Exception_Handlers => No_List));
+
+ Discard_Node (IP_Body);
+ Set_Init_Proc (Typ, IP);
+ end;
+ end if;
-- If this constructor has parameters and all its parameters
-- have defaults then it covers the default constructor. The
@@ -8785,7 +8677,7 @@ package body Exp_Disp is
if Present (Parameter_Specifications (Parent (E)))
and then Needs_No_Actuals (E)
then
- Covers_Default_Constructor := Wrapper_Id;
+ Covers_Default_Constructor := IP;
end if;
end if;
@@ -8804,39 +8696,42 @@ package body Exp_Disp is
-- which calls the covering constructor.
if Present (Covers_Default_Constructor) then
- Loc := Sloc (Covers_Default_Constructor);
+ declare
+ Body_Stmts : List_Id;
- Body_Stmts := New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Covers_Default_Constructor, Loc),
- Parameter_Associations => New_List (
- Make_Identifier (Loc, Name_uInit))));
+ begin
+ Loc := Sloc (Covers_Default_Constructor);
- Wrapper_Id :=
- Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+ Body_Stmts := New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Covers_Default_Constructor, Loc),
+ Parameter_Associations => New_List (
+ Make_Identifier (Loc, Name_uInit))));
- Wrapper_Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Wrapper_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uInit),
- Parameter_Type =>
- New_Reference_To (Typ, Loc)))),
-
- Declarations => No_List,
+ IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts,
- Exception_Handlers => No_List));
+ IP_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => IP,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uInit),
+ Parameter_Type => New_Reference_To (Typ, Loc)))),
- Discard_Node (Wrapper_Body_Node);
- Set_Init_Proc (Typ, Wrapper_Id);
+ Declarations => No_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts,
+ Exception_Handlers => No_List));
+
+ Discard_Node (IP_Body);
+ Set_Init_Proc (Typ, IP);
+ end;
end if;
-- If the CPP type has constructors then it must import also the default
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index cb397a24d71..82b054adfce 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -710,8 +710,11 @@ package body Exp_Util is
Subpool := Subpool_Handle_Name (Expr);
end if;
+ -- If a subpool is present it can be an arbitrary name, so make
+ -- the actual by copying the tree.
+
if Present (Subpool) then
- Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
+ Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 723ff120ff6..f11846fbb79 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -39,6 +39,10 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Command_Line is
+ -- General note: this entire body could use much more commenting. There
+ -- are large sections of uncommented code throughout, and many formal
+ -- parameters of local subprograms are not documented at all ???
+
package CL renames Ada.Command_Line;
type Switch_Parameter_Type is
@@ -56,6 +60,12 @@ package body GNAT.Command_Line is
Extra : Character := ASCII.NUL);
pragma Inline (Set_Parameter);
-- Set the parameter that will be returned by Parameter below
+ --
+ -- Extra is a character that needs to be added when reporting Full_Switch.
+ -- (it will in general be the switch character, for instance '-').
+ -- Otherwise, Full_Switch will report 'f' instead of '-f'. In particular,
+ -- it needs to be set when reporting an invalid switch or handling '*'.
+ --
-- Parameters need to be defined ???
function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean;
@@ -95,9 +105,9 @@ package body GNAT.Command_Line is
Index_In_Switches : out Integer;
Switch_Length : out Integer;
Param : out Switch_Parameter_Type);
- -- Return the Longest switch from Switches that at least partially
- -- partially Arg. Index_In_Switches is set to 0 if none matches.
- -- What are other parameters??? in particular Param is not always set???
+ -- Return the Longest switch from Switches that at least partially matches
+ -- Arg. Index_In_Switches is set to 0 if none matches. What are other
+ -- parameters??? in particular Param is not always set???
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Argument_List, Argument_List_Access);
@@ -663,17 +673,45 @@ package body GNAT.Command_Line is
if Index_Switches = 0 then
- -- Depending on the value of Concatenate, the full switch is
- -- a single character or the rest of the argument.
+ -- Find the current switch that we did not recognize. This is in
+ -- fact difficult because Getopt does not know explicitly about
+ -- short and long switches. Ideally, we would want the following
+ -- behavior:
+
+ -- * for short switches, with Concatenate:
+ -- if -a is not recognized, and the command line has -daf
+ -- we should report the invalid switch as "-a".
+
+ -- * for short switches, wihtout Concatenate:
+ -- we should report the invalid switch as "-daf".
+
+ -- * for long switches:
+ -- if the commadn line is "--long" we should report --long
+ -- as unrecongized.
+
+ -- Unfortunately, the fact that long switches start with a
+ -- duplicate switch character is just a convention (so we could
+ -- have a long switch "-long" for instance). We'll still rely on
+ -- this convention here to try and get as helpful an error message
+ -- as possible.
+
+ -- Long switch case (starting with double switch character)
- End_Index :=
- (if Concatenate then Parser.Current_Index else Arg'Last);
+ if Arg (Arg'First + 1) = Parser.Switch_Character then
+ End_Index := Arg'Last;
+
+ -- Short switch case
+
+ else
+ End_Index :=
+ (if Concatenate then Parser.Current_Index else Arg'Last);
+ end if;
if Switches (Switches'First) = '*' then
- -- Always prepend the switch character, so that users know that
- -- this comes from a switch on the command line. This is
- -- especially important when Concatenate is False, since
+ -- Always prepend the switch character, so that users know
+ -- that this comes from a switch on the command line. This
+ -- is especially important when Concatenate is False, since
-- otherwise the current argument first character is lost.
if Parser.Section (Parser.Current_Argument) = 0 then
@@ -696,11 +734,21 @@ package body GNAT.Command_Line is
end if;
end if;
- Set_Parameter
- (Parser.The_Switch,
- Arg_Num => Parser.Current_Argument,
- First => Parser.Current_Index,
- Last => End_Index);
+ if Parser.Current_Index = Arg'First then
+ Set_Parameter
+ (Parser.The_Switch,
+ Arg_Num => Parser.Current_Argument,
+ First => Parser.Current_Index,
+ Last => End_Index);
+ else
+ Set_Parameter
+ (Parser.The_Switch,
+ Arg_Num => Parser.Current_Argument,
+ First => Parser.Current_Index,
+ Last => End_Index,
+ Extra => Parser.Switch_Character);
+ end if;
+
Parser.Current_Index := End_Index + 1;
raise Invalid_Switch;
@@ -762,7 +810,7 @@ package body GNAT.Command_Line is
raise Invalid_Parameter;
end if;
- -- If the switch is of the form <switch> xxx
+ -- Case of switch of the form <switch> xxx
elsif Parser.Current_Argument < Parser.Arg_Count
and then Parser.Section (Parser.Current_Argument + 1) /= 0
@@ -830,7 +878,8 @@ package body GNAT.Command_Line is
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
- Last => Arg'Last);
+ Last => Arg'Last,
+ Extra => Parser.Switch_Character);
Parser.Current_Index := Arg'Last + 1;
raise Invalid_Switch;
end if;
@@ -1170,9 +1219,7 @@ package body GNAT.Command_Line is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser);
begin
- if Parser /= null
- and then Parser /= Command_Line_Parser
- then
+ if Parser /= null and then Parser /= Command_Line_Parser then
Free (Parser.Arguments);
Unchecked_Free (Parser);
end if;
@@ -1189,6 +1236,7 @@ package body GNAT.Command_Line is
Section : String := "")
is
Def : Alias_Definition;
+
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
@@ -1255,8 +1303,9 @@ package body GNAT.Command_Line is
-- Add --
---------
- procedure Add (Def : in out Alias_Definitions_List;
- Alias : Alias_Definition)
+ procedure Add
+ (Def : in out Alias_Definitions_List;
+ Alias : Alias_Definition)
is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation
@@ -1511,7 +1560,7 @@ package body GNAT.Command_Line is
Foreach (Config, Section => Section);
- -- Adding relevant aliases
+ -- Add relevant aliases
if Config.Aliases /= null then
for A in Config.Aliases'Range loop
@@ -1585,8 +1634,8 @@ package body GNAT.Command_Line is
function Real_Full_Switch
(S : Character;
Parser : Opt_Parser) return String;
- -- Ensure that the returned switch value contains the
- -- Switch_Char prefix if needed.
+ -- Ensure that the returned switch value contains the Switch_Char prefix
+ -- if needed.
----------------------
-- Real_Full_Switch --
@@ -2465,13 +2514,12 @@ package body GNAT.Command_Line is
((Cmd.Params (C) = null and then Param = "")
or else
(Cmd.Params (C) /= null
- and then
- -- Ignore the separator stored in Parameter
+ -- Ignore the separator stored in Parameter
+ and then
Cmd.Params (C) (Cmd.Params (C)'First + 1
- .. Cmd.Params (C)'Last) =
- Param))
+ .. Cmd.Params (C)'Last) = Param))
then
Remove (Cmd.Expanded, C);
Remove (Cmd.Params, C);
@@ -2550,9 +2598,7 @@ package body GNAT.Command_Line is
-- Start of processing for Group_Switches
begin
- if Cmd.Config = null
- or else Cmd.Config.Prefixes = null
- then
+ if Cmd.Config = null or else Cmd.Config.Prefixes = null then
return;
end if;
@@ -2638,10 +2684,9 @@ package body GNAT.Command_Line is
First : Natural;
procedure Check_Cb (Switch, Separator, Param : String; Index : Integer);
- -- Checks whether the command line contains [Switch].
- -- Sets the global variable [Found] appropriately.
- -- This will be called for each simple switch that make up an alias, to
- -- know whether the alias should be applied.
+ -- Checks whether the command line contains [Switch]. Sets the global
+ -- variable [Found] appropriately. This is called for each simple switch
+ -- that make up an alias, to know whether the alias should be applied.
procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer);
-- Remove the simple switch [Switch] from the command line, since it is
@@ -2708,9 +2753,7 @@ package body GNAT.Command_Line is
-- Start of processing for Alias_Switches
begin
- if Cmd.Config = null
- or else Cmd.Config.Aliases = null
- then
+ if Cmd.Config = null or else Cmd.Config.Aliases = null then
return;
end if;
@@ -3079,7 +3122,7 @@ package body GNAT.Command_Line is
procedure Display_Help (Config : Command_Line_Configuration) is
function Switch_Name
- (Def : Switch_Definition;
+ (Def : Switch_Definition;
Section : String) return String;
-- Return the "-short, --long=ARG" string for Def.
-- Returns "" if the switch is not in the section.
@@ -3194,7 +3237,7 @@ package body GNAT.Command_Line is
-----------------
function Switch_Name
- (Def : Switch_Definition;
+ (Def : Switch_Definition;
Section : String) return String
is
use Ada.Strings.Unbounded;
@@ -3488,7 +3531,7 @@ package body GNAT.Command_Line is
Put_Line (Standard_Error,
Base_Name (Ada.Command_Line.Command_Name)
& ": unrecognized option '"
- & Parser.Switch_Character & Full_Switch (Parser)
+ & Full_Switch (Parser)
& "'");
Put_Line (Standard_Error,
"Try `"
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 5dcb935aabf..60637c9bb1d 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -1259,31 +1259,31 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \
ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \
ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
- ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
- ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \
- ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
- ada/opt.adb ada/output.ads ada/put_alfa.ads ada/restrict.ads \
- ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
- ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \
- ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
- ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
- ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \
- ada/widechar.ads
+ ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \
+ ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
+ ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/opt.adb ada/output.ads ada/put_alfa.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+ ada/rtsfind.adb ada/scans.ads ada/sem.ads ada/sem_attr.ads \
+ ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
+ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \
+ ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
+ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
+ ada/validsw.ads ada/widechar.ads
ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
@@ -1642,28 +1642,28 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \
ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads \
ada/exp_pakd.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \
- ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
- ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
- ada/layout.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \
- ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
- ada/rtsfind.ads ada/rtsfind.adb ada/scil_ll.ads ada/sem.ads \
- ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \
- ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \
- ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads \
- ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
- ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
- ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
- ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads
+ ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/expander.ads \
+ ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \
+ ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-load.ads \
+ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
+ ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scil_ll.ads \
+ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \
+ ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \
+ ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
@@ -1674,10 +1674,10 @@ ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb \
ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \
ada/exp_fixd.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \
- ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \
- ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/expander.ads \
+ ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \
+ ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \
ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
ada/output.ads ada/par_sco.ads ada/put_alfa.ads ada/restrict.ads \
@@ -1708,28 +1708,28 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \
ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \
ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
- ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \
- ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/put_alfa.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
- ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_attr.ads \
- ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \
- ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
+ ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \
+ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \
+ ada/output.ads ada/put_alfa.ads ada/restrict.ads ada/restrict.adb \
+ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \
+ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \
+ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
+ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
+ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
@@ -2044,10 +2044,10 @@ ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \
ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_pakd.ads \
ada/exp_pakd.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
- ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/layout.ads \
- ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/expander.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \
+ ada/layout.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
+ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \
ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
@@ -4179,15 +4179,16 @@ ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
- ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/output.ads ada/stylesw.ads ada/switch.ads ada/switch-c.ads \
- ada/switch-c.adb ada/system.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/validsw.ads ada/warnsw.ads
+ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/get_targ.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/stylesw.ads ada/switch.ads \
+ ada/switch-c.ads ada/switch-c.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads \
+ ada/warnsw.ads
ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \
diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb
index f6ce3acf02e..0fad22bf7a7 100644
--- a/gcc/ada/gprep.adb
+++ b/gcc/ada/gprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -720,7 +720,7 @@ package body GPrep is
loop
begin
- Switch := GNAT.Command_Line.Getopt ("D: b c C r s T u v");
+ Switch := GNAT.Command_Line.Getopt ("D: a b c C r s T u v");
case Switch is
@@ -731,6 +731,10 @@ package body GPrep is
Process_Command_Line_Symbol_Definition
(S => GNAT.Command_Line.Parameter);
+ when 'a' =>
+ Opt.No_Deletion := True;
+ Opt.Undefined_Symbols_Are_False := True;
+
when 'b' =>
Opt.Blank_Deleted_Lines := True;
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 8a27a601617..ad00e148fcc 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -103,12 +103,14 @@ char *__gl_interrupt_states = 0;
int __gl_num_interrupt_states = 0;
int __gl_unreserve_all_interrupts = 0;
int __gl_exception_tracebacks = 0;
-int __gl_zero_cost_exceptions = 0;
int __gl_detect_blocking = 0;
int __gl_default_stack_size = -1;
int __gl_leap_seconds_support = 0;
int __gl_canonical_streams = 0;
+/* This value is not used anymore, but kept for bootstrapping purpose. */
+int __gl_zero_cost_exceptions = 0;
+
/* Indication of whether synchronous signal handler has already been
installed by a previous call to adainit. */
int __gnat_handler_installed = 0;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 184b09758a3..88194b3023b 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -968,6 +968,12 @@ package Opt is
-- in this variable (e.g. 2 = select second unit in file). A value of
-- zero indicates that we are in normal (one unit per file) mode.
+ No_Deletion : Boolean := False;
+ -- GNATPREP
+ -- Set by preprocessor switch -a. Do not eliminate any source text. Implies
+ -- Undefined_Symbols_Are_False. Useful to perform a syntax check on all
+ -- branches of #if constructs.
+
No_Main_Subprogram : Boolean := False;
-- GNATMAKE, GNATBIND
-- Set to True if compilation/binding of a program without main
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
index 2b0e1378bce..3ec2087926a 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -292,8 +292,8 @@ package body Prep is
Result.Value := End_String;
end if;
- -- Now, check the syntax of the symbol (we don't allow accented and
- -- wide characters)
+ -- Now, check the syntax of the symbol (we don't allow accented or
+ -- wide characters).
if Name_Buffer (1) not in 'a' .. 'z'
and then Name_Buffer (1) not in 'A' .. 'Z'
@@ -356,7 +356,7 @@ package body Prep is
begin
-- Always return False when not inside an #if statement
- if Pp_States.Last = Ground then
+ if Opt.No_Deletion or else Pp_States.Last = Ground then
return False;
else
return Pp_States.Table (Pp_States.Last).Deleting;
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index 2da21df3c42..dd64bcb714b 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
@@ -60,6 +60,7 @@ package body Prepcomp is
Undef_False : Boolean := False;
Always_Blank : Boolean := False;
Comments : Boolean := False;
+ No_Deletion : Boolean := False;
List_Symbols : Boolean := False;
Processed : Boolean := False;
end record;
@@ -73,6 +74,7 @@ package body Prepcomp is
Undef_False => False,
Always_Blank => False,
Comments => False,
+ No_Deletion => False,
List_Symbols => False,
Processed => False);
@@ -330,6 +332,16 @@ package body Prepcomp is
-- significant.
case Sinput.Source (Token_Ptr) is
+ when 'a' =>
+
+ -- All source text preserved (also implies -u)
+
+ if Name_Len = 1 then
+ Current_Data.No_Deletion := True;
+ Current_Data.Undef_False := True;
+ OK := True;
+ end if;
+
when 'u' =>
-- Undefined symbol are False
@@ -581,15 +593,15 @@ package body Prepcomp is
-- Set the preprocessing flags according to the preprocessing data
- if Current_Data.Comments and then not Current_Data.Always_Blank then
+ if Current_Data.Comments and not Current_Data.Always_Blank then
Comment_Deleted_Lines := True;
Blank_Deleted_Lines := False;
-
else
Comment_Deleted_Lines := False;
Blank_Deleted_Lines := True;
end if;
+ No_Deletion := Current_Data.No_Deletion;
Undefined_Symbols_Are_False := Current_Data.Undef_False;
List_Preprocessing_Symbols := Current_Data.List_Symbols;
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
index 1d5c7738e52..cb9d533c765 100644
--- a/gcc/ada/prj-proc.adb
+++ b/gcc/ada/prj-proc.adb
@@ -1588,7 +1588,7 @@ package body Prj.Proc is
Add_Attributes
(Project,
Project.Name,
- Name_Id (Project.Directory.Name),
+ Name_Id (Project.Directory.Display_Name),
Shared,
Shared.Packages.Table (New_Pkg).Decl,
First_Attribute_Of
@@ -2850,7 +2850,7 @@ package body Prj.Proc is
Add_Attributes
(Project,
Name,
- Name_Id (Project.Directory.Name),
+ Name_Id (Project.Directory.Display_Name),
In_Tree.Shared,
Project.Decl,
Prj.Attr.Attribute_First,
diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi
index 2fff4eb1fab..fafb1d125de 100644
--- a/gcc/ada/projects.texi
+++ b/gcc/ada/projects.texi
@@ -1033,7 +1033,7 @@ names in lower case)
After building an application or a library it is often required to
install it into the development environment. This installation is
required if the library is to be used by another application for
-example. The @code{gprinstall} tool provide an easy way to install
+example. The @command{gprinstall} tool provide an easy way to install
libraries, executable or object code generated durting the build. The
@b{Install} package can be used to change the default locations.
@@ -1963,11 +1963,10 @@ included in the library.
@c ---------------------------------------------
@noindent
-When using project files, library installation is part of the library build
-process. Thus no further action is needed in order to make use of the
-libraries that are built as part of the general application build. A usable
-version of the library is installed in the directory specified by the
-@code{Library_Dir} attribute of the library project file.
+When using project files, a usable version of the library is created in the
+directory specified by the @code{Library_Dir} attribute of the library
+project file. Thus no further action is needed in order to make use of
+the libraries that are built as part of the general application build.
You may want to install a library in a context different from where the library
is built. This situation arises with third party suppliers, who may want
@@ -1976,6 +1975,12 @@ able to recompile the library. The simplest option in this case is to provide
a project file slightly different from the one used to build the library, by
using the @code{externally_built} attribute. @ref{Using Library Projects}
+Another option is to use @command{gprinstall} to install the library in a
+different context than the build location. A project to use this library is
+generated automatically by @command{gprinstall} which also copy, in the install
+location, the minimum set of sources needed to use the library.
+@ref{Installation}
+
@c ---------------------------------------------
@node Project Extension
@section Project Extension
@@ -2243,8 +2248,8 @@ Very often, modules will build their own executables (for testing
purposes for instance), or libraries (for easier reuse in various
contexts).
-However, if you build your project through gnatmake or gprbuild, using
-a syntax similar to
+However, if you build your project through @command{gnatmake} or
+@command{gprbuild}, using a syntax similar to
@smallexample
gprbuild -PA.gpr
@@ -2252,9 +2257,9 @@ a syntax similar to
this will only rebuild the main programs of project A, not those of the
imported projects B and C. Therefore you have to spawn several
-gnatmake commands, one per project, to build all executables.
+@command{gnatmake} commands, one per project, to build all executables.
This is a little inconvenient, but more importantly is inefficient
-because gnatmake needs to do duplicate work to ensure that sources are
+because @command{gnatmake} needs to do duplicate work to ensure that sources are
up-to-date, and cannot easily compile things in parallel when using
the -j switch.
@@ -2295,14 +2300,14 @@ that are built independently from each other (but can be built in
parallel). For instance, you have a project tree rooted at A, and
another one (which might share some subprojects) rooted at B.
-Using only gprbuild, you could do
+Using only @command{gprbuild}, you could do
@smallexample
gprbuild -PA.gpr
gprbuild -PB.gpr
@end smallexample
-to build both. But again, gprbuild has to do some duplicate work for
+to build both. But again, @command{gprbuild} has to do some duplicate work for
those files that are shared between the two, and cannot truly build
things in parallel efficiently.
@@ -2316,7 +2321,7 @@ sources.
This scenario is particularly useful in environments like VxWorks 653
where the applications running in the multiple partitions can be built
-in parallel through a single gprbuild command. This also works nicely
+in parallel through a single @command{gprbuild} command. This also works nicely
with Annex E.
@c ---------------------------------------------
@@ -2324,9 +2329,9 @@ with Annex E.
@subsection Define a build environment
@c ---------------------------------------------
-The environment variables at the time you launch gprbuild or gprbuild
-will influence the view these tools have of the project (PATH to find
-the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
+The environment variables at the time you launch @command{gprbuild} or
+@command{gnatmake} will influence the view these tools have of the project
+(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
projects, environment variables that are referenced in project files
through the "external" statement,...). Several command line switches
can be used to override those (-X or -aP), but on some systems and
@@ -2382,19 +2387,19 @@ end MyProject;
@subsection Performance improvements in builder
@c --------------------------------------------
-The loading of aggregate projects is optimized in gprbuild and
-gnatmake, so that all files are searched for only once on the disk
+The loading of aggregate projects is optimized in @command{gprbuild} and
+@command{gnatmake}, so that all files are searched for only once on the disk
(thus reducing the number of system calls and contributing to faster
compilation times especially on systems with sources on remote
-servers). As part of the loading, gprbuild and gnatmake compute how
-and where a source file should be compiled, and even if it is found
+servers). As part of the loading, @command{gprbuild} and @command{gnatmake}
+compute how and where a source file should be compiled, and even if it is found
several times in the aggregated projects it will be compiled only
once.
Since there is no ambiguity as to which switches should be used, files
can be compiled in parallel (through the usual -j switch) and this can
be done while maximizing the use of CPUs (compared to launching
-multiple gprbuild and gnatmake commands in parallel).
+multiple @command{gprbuild} and @command{gnatmake} commands in parallel).
@c -------------------------------------
@node Syntax of aggregate projects
@@ -2577,15 +2582,15 @@ These override the value given by the attribute, so that
users can override the value set in the (presumably shared
with others in his team) aggregate project.
-@item The -X command line switch to gprbuild and gnatmake
+@item The -X command line switch to @command{gprbuild} and @command{gnatmake}
This always takes precedence.
@end itemize
This attribute is only taken into account in the main aggregate
-project (i.e. the one specified on the command line to gprbuild or
-natmake), and ignored in other aggregate projects. It is invalid
+project (i.e. the one specified on the command line to @command{gprbuild} or
+@command{gnatmake}), and ignored in other aggregate projects. It is invalid
in standard projects.
The goal is to have a consistent value in all
projects that are built through the aggregate, which would not
@@ -2610,8 +2615,8 @@ are valid:
@item @b{Switches}:
@cindex @code{Switches}
This attribute gives the list of switches to use for the builder
-(gprbuild or gnatmake), depending on the language of the main file.
-For instance,
+(@command{gprbuild} or @command{gnatmake}), depending on the language of the
+main file. For instance,
@smallexample @c projectfile
for Switches ("Ada") use ("-d", "-p");
@@ -2995,7 +3000,7 @@ from other project or library project files.
@item @b{library}: a library project must declare both attributes
@code{Library_Name} and @code{Library_Dir}.
@item @b{configuration}: a configuration project cannot be in a project tree.
- It describes compilers and other tools to @code{gprbuild}.
+ It describes compilers and other tools to @command{gprbuild}.
@end table
@c ---------------------------------------------
@@ -3263,7 +3268,7 @@ Here are some specific examples:
@noindent
An external value is an expression whose value is obtained from the command
that invoked the processing of the current project file (typically a
-gnatmake or gprbuild command).
+@command{gnatmake} or @command{gprbuild} command).
There are two kinds of external values, one that returns a single string, and
one that returns a string list.
@@ -3878,11 +3883,12 @@ Follow all symbolic links when processing project files.
@item ^--subdirs^/SUBDIRS^=<subdir>
@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean)
-This switch is recognized by gnatmake and gnatclean. It indicate that the real
-directories (except the source directories) are the subdirectories <subdir>
-of the directories specified in the project files. This applies in particular
-to object directories, library directories and exec directories. If the
-subdirectories do not exist, they are created automatically.
+This switch is recognized by @command{gnatmake} and @command{gnatclean}. It
+indicate that the real directories (except the source directories) are the
+subdirectories <subdir> of the directories specified in the project files.
+This applies in particular to object directories, library directories and
+exec directories. If the subdirectories do not exist, they are created
+automatically.
@end table
@@ -4592,7 +4598,7 @@ e.g.@: @code{"wtx"} or @code{"vxworks"}.
This is an associative array attribute, whose domain is a language name. Its
value is string that denotes the command to be used to invoke the compiler.
The value of @code{Compiler_Command ("Ada")} is expected to be compatible with
-gnatmake, in particular in the handling of switches.
+@command{gnatmake}, in particular in the handling of switches.
@item Debugger_Command
This is simple attribute, Its value is a string that specifies the name of
diff --git a/gcc/ada/s-bignum.adb b/gcc/ada/s-bignum.adb
index 69772772f55..b3af4796136 100644
--- a/gcc/ada/s-bignum.adb
+++ b/gcc/ada/s-bignum.adb
@@ -341,6 +341,17 @@ package body System.Bignums is
begin
Free_Bignum (XY2);
+ -- Raise storage error if intermediate value is getting too
+ -- large, which we arbitrarily define as 200 words for now!
+
+ if XY2S.Len > 200 then
+ Free_Bignum (XY2S);
+ raise Storage_Error with
+ "exponentiation result is too large";
+ end if;
+
+ -- Otherwise take care of even/odd cases
+
if (Y and 1) = 0 then
return XY2S;
diff --git a/gcc/ada/s-exnllf.adb b/gcc/ada/s-exnllf.adb
index a1e59c179e0..c6765e8fe9a 100644
--- a/gcc/ada/s-exnllf.adb
+++ b/gcc/ada/s-exnllf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009 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- --
@@ -37,8 +37,7 @@ package body System.Exn_LLF is
function Exn_Long_Long_Float
(Left : Long_Long_Float;
- Right : Integer)
- return Long_Long_Float
+ Right : Integer) return Long_Long_Float
is
Result : Long_Long_Float := 1.0;
Factor : Long_Long_Float := Left;
diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads
index 59575b0e088..ba2828277b7 100644
--- a/gcc/ada/s-exnllf.ads
+++ b/gcc/ada/s-exnllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009 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- --
@@ -36,7 +36,6 @@ package System.Exn_LLF is
function Exn_Long_Long_Float
(Left : Long_Long_Float;
- Right : Integer)
- return Long_Long_Float;
+ Right : Integer) return Long_Long_Float;
end System.Exn_LLF;
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index ded081fc3e1..0a90eb2e80a 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -164,6 +164,11 @@ package body Sem_Ch10 is
-- an enclosing scope. Iterate over context to find child units of U_Name
-- or of some ancestor of it.
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
+ -- When compiling a unit Q descended from some parent unit P, a limited
+ -- with_clause in the context of P that names some other ancestor of Q
+ -- must not be installed because the ancestor is immediately visible.
+
function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
-- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
-- returns True if Lib_Unit is a library spec which is a child spec, i.e.
@@ -3521,11 +3526,6 @@ package body Sem_Ch10 is
-- units. The shadow entities are created when the inserted clause is
-- analyzed. Implements Ada 2005 (AI-50217).
- function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
- -- When compiling a unit Q descended from some parent unit P, a limited
- -- with_clause in the context of P that names some other ancestor of Q
- -- must not be installed because the ancestor is immediately visible.
-
---------------------
-- Check_Renamings --
---------------------
@@ -3794,22 +3794,6 @@ package body Sem_Ch10 is
end if;
end Expand_Limited_With_Clause;
- ----------------------
- -- Is_Ancestor_Unit --
- ----------------------
-
- function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
- E1 : constant Entity_Id := Defining_Entity (Unit (U1));
- E2 : Entity_Id;
- begin
- if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
- E2 := Defining_Entity (Unit (Library_Unit (U2)));
- return Is_Ancestor_Package (E1, E2);
- else
- return False;
- end if;
- end Is_Ancestor_Unit;
-
-- Start of processing for Install_Limited_Context_Clauses
begin
@@ -4061,8 +4045,17 @@ package body Sem_Ch10 is
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
+ -- If the unit is an ancestor of the current one, it is the
+ -- case of a private limited with clause on a child unit, and
+ -- the compilation of one of its descendants, In that case the
+ -- limited view is errelevant.
+
if Limited_Present (Item) then
- if not Limited_View_Installed (Item) then
+ if not Limited_View_Installed (Item)
+ and then
+ not Is_Ancestor_Unit (Library_Unit (Item),
+ Cunit (Current_Sem_Unit))
+ then
Install_Limited_Withed_Unit (Item);
end if;
else
@@ -5269,6 +5262,22 @@ package body Sem_Ch10 is
(C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
end Is_Legal_Shadow_Entity_In_Body;
+ ----------------------
+ -- Is_Ancestor_Unit --
+ ----------------------
+
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
+ E1 : constant Entity_Id := Defining_Entity (Unit (U1));
+ E2 : Entity_Id;
+ begin
+ if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+ E2 := Defining_Entity (Unit (Library_Unit (U2)));
+ return Is_Ancestor_Package (E1, E2);
+ else
+ return False;
+ end if;
+ end Is_Ancestor_Unit;
+
-----------------------
-- Load_Needed_Body --
-----------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index cb54be10215..7dd808c0d0d 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -14805,6 +14806,11 @@ package body Sem_Ch3 is
New_Id : Entity_Id;
Prev_Par : Node_Id;
+ procedure Check_Duplicate_Aspects;
+ -- Check that aspects specified in a completion have not been specified
+ -- already in the partial view. Type_Invariant and others can be
+ -- specified on either view but never on both.
+
procedure Tag_Mismatch;
-- Diagnose a tagged partial view whose full view is untagged.
-- We post the message on the full view, with a reference to
@@ -14813,6 +14819,38 @@ package body Sem_Ch3 is
-- so we determine the position of the error message from the
-- respective slocs of both.
+ -----------------------------
+ -- Check_Duplicate_Aspects --
+ -----------------------------
+ procedure Check_Duplicate_Aspects is
+ Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
+ Full_Aspects : constant List_Id := Aspect_Specifications (N);
+ F_Spec, P_Spec : Node_Id;
+
+ begin
+ if Present (Prev_Aspects) and then Present (Full_Aspects) then
+ F_Spec := First (Full_Aspects);
+ while Present (F_Spec) loop
+ P_Spec := First (Prev_Aspects);
+ while Present (P_Spec) loop
+ if
+ Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
+ then
+ Error_Msg_N
+ ("aspect already specified in private declaration",
+ F_Spec);
+ Remove (F_Spec);
+ return;
+ end if;
+
+ Next (P_Spec);
+ end loop;
+
+ Next (F_Spec);
+ end loop;
+ end if;
+ end Check_Duplicate_Aspects;
+
------------------
-- Tag_Mismatch --
------------------
@@ -15022,6 +15060,10 @@ package body Sem_Ch3 is
("declaration of full view must appear in private part", N);
end if;
+ if Ada_Version >= Ada_2012 then
+ Check_Duplicate_Aspects;
+ end if;
+
Copy_And_Swap (Prev, Id);
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 64b40e6a397..9d63e886aaf 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -5888,14 +5888,36 @@ package body Sem_Ch4 is
begin
if not Is_Overloaded (R) then
if Is_Numeric_Type (Etype (R)) then
- Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
+
+ -- In an instance a generic actual may be a numeric type even if
+ -- the formal in the generic unit was not. In that case, the
+ -- predefined operator was not a possible interpretation in the
+ -- generic, and cannot be one in the instance.
+
+ if In_Instance
+ and then
+ not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R)))
+ then
+ null;
+ else
+ Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
+ end if;
end if;
else
Get_First_Interp (R, Index, It);
while Present (It.Typ) loop
if Is_Numeric_Type (It.Typ) then
- Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
+ if In_Instance
+ and then
+ not Is_Numeric_Type
+ (Corresponding_Generic_Type (Etype (It.Typ)))
+ then
+ null;
+
+ else
+ Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
+ end if;
end if;
Get_Next_Interp (Index, It);
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index d40647ed7ad..a81ea5c6148 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -1345,9 +1345,10 @@ package body Sem_Ch9 is
-- Check for unreferenced variables etc. Before the Check_References
-- call, we transfer Never_Set_In_Source and Referenced flags from
-- parameters in the spec to the corresponding entities in the body,
- -- since we want the warnings on the body entities. Note that we do
- -- not have to transfer Referenced_As_LHS, since that flag can only
- -- be set for simple variables.
+ -- since we want the warnings on the body entities. Note that we do not
+ -- have to transfer Referenced_As_LHS, since that flag can only be set
+ -- for simple variables, but we include Has_Pragma_Unreferenced,
+ -- which may have been specified for a formal in the body.
-- At the same time, we set the flags on the spec entities to suppress
-- any warnings on the spec formals, since we also scan the spec.
@@ -1382,6 +1383,7 @@ package body Sem_Ch9 is
Set_Referenced (E2, Referenced (E1));
Set_Referenced (E1);
+ Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1));
Set_Entry_Component (E2, Entry_Component (E1));
<<Continue>>
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 116864aa2a9..f7e774308fb 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -37,6 +37,7 @@ with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
@@ -198,7 +199,7 @@ package body Sem_Eval is
-- Tests to see if expression N whose single operand is Op1 is foldable,
-- i.e. the operand value is known at compile time. If the operation is
-- foldable, then Fold is True on return, and Stat indicates whether
- -- the result is static (i.e. both operands were static). Note that it
+ -- the result is static (i.e. the operand was static). Note that it
-- is quite possible for Fold to be True, and Stat to be False, since
-- there are cases in which we know the value of an operand even though
-- it is not technically static (e.g. the static lower bound of a range
@@ -232,7 +233,7 @@ package body Sem_Eval is
Stat : out Boolean;
Fold : out Boolean);
-- Same processing, except applies to an expression N with two operands
- -- Op1 and Op2.
+ -- Op1 and Op2. The result is static only if both operands are static.
function Test_In_Range
(N : Node_Id;
@@ -240,11 +241,11 @@ package body Sem_Eval is
Assume_Valid : Boolean;
Fixed_Int : Boolean;
Int_Real : Boolean) return Range_Membership;
- -- Common processing for Is_In_Range and Is_Out_Of_Range:
- -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time
- -- that expression N is known to be in or out of range of the subtype Typ.
- -- If not compile time known, Unknown is returned.
- -- See documentation of Is_In_Range for complete description of parameters.
+ -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
+ -- or Out_Of_Range if it can be guaranteed at compile time that expression
+ -- N is known to be in or out of range of the subtype Typ. If not compile
+ -- time known, Unknown is returned. See documentation of Is_In_Range for
+ -- complete description of parameters.
procedure To_Bits (U : Uint; B : out Bits);
-- Converts a Uint value to a bit string of length B'Length
@@ -942,7 +943,49 @@ package body Sem_Eval is
end if;
end if;
- -- Try range analysis on variables and see if ranges are disjoint
+ -- First attempt is to decompose the expressions to extract a
+ -- constant offset resulting from the use of any of the forms:
+
+ -- expr + literal
+ -- expr - literal
+ -- typ'Succ (expr)
+ -- typ'Pred (expr)
+
+ -- Then we see if the two expressions are the same value, and if so
+ -- the result is obtained by comparing the offsets.
+
+ -- Note: the reason we do this test first is that it returns only
+ -- decisive results (with diff set), where other tests, like the
+ -- range test, may not be as so decisive. Consider for example
+ -- J .. J + 1. This code can conclude LT with a difference of 1,
+ -- even if the range of J is not known.
+
+ declare
+ Lnode : Node_Id;
+ Loffs : Uint;
+ Rnode : Node_Id;
+ Roffs : Uint;
+
+ begin
+ Compare_Decompose (L, Lnode, Loffs);
+ Compare_Decompose (R, Rnode, Roffs);
+
+ if Is_Same_Value (Lnode, Rnode) then
+ if Loffs = Roffs then
+ return EQ;
+
+ elsif Loffs < Roffs then
+ Diff.all := Roffs - Loffs;
+ return LT;
+
+ else
+ Diff.all := Loffs - Roffs;
+ return GT;
+ end if;
+ end if;
+ end;
+
+ -- Next, try range analysis and see if operand ranges are disjoint
declare
LOK, ROK : Boolean;
@@ -1074,42 +1117,6 @@ package body Sem_Eval is
end if;
end if;
- -- Next attempt is to decompose the expressions to extract
- -- a constant offset resulting from the use of any of the forms:
-
- -- expr + literal
- -- expr - literal
- -- typ'Succ (expr)
- -- typ'Pred (expr)
-
- -- Then we see if the two expressions are the same value, and if so
- -- the result is obtained by comparing the offsets.
-
- declare
- Lnode : Node_Id;
- Loffs : Uint;
- Rnode : Node_Id;
- Roffs : Uint;
-
- begin
- Compare_Decompose (L, Lnode, Loffs);
- Compare_Decompose (R, Rnode, Roffs);
-
- if Is_Same_Value (Lnode, Rnode) then
- if Loffs = Roffs then
- return EQ;
-
- elsif Loffs < Roffs then
- Diff.all := Roffs - Loffs;
- return LT;
-
- else
- Diff.all := Loffs - Roffs;
- return GT;
- end if;
- end if;
- end;
-
-- Next attempt is to see if we have an entity compared with a
-- compile time known value, where there is a current value
-- conditional for the entity which can tell us the result.
@@ -4039,12 +4046,18 @@ package body Sem_Eval is
-- We now have the literal with the right value, both the actual type
-- and the expected type of this literal are taken from the expression
- -- that was evaluated.
+ -- that was evaluated. So now we do the Analyze and Resolve.
+
+ -- Note that we have to reset Is_Static_Expression both after the
+ -- analyze step (because Resolve will evaluate the literal, which
+ -- will cause semantic errors if it is marked as static), and after
+ -- the Resolve step (since Resolve in some cases sets this flag).
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
+ Set_Is_Static_Expression (N, Static);
end Fold_Str;
---------------
@@ -4093,12 +4106,18 @@ package body Sem_Eval is
-- We now have the literal with the right value, both the actual type
-- and the expected type of this literal are taken from the expression
- -- that was evaluated.
+ -- that was evaluated. So now we do the Analyze and Resolve.
+
+ -- Note that we have to reset Is_Static_Expression both after the
+ -- analyze step (because Resolve will evaluate the literal, which
+ -- will cause semantic errors if it is marked as static), and after
+ -- the Resolve step (since Resolve in some cases sets this flag).
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
+ Set_Is_Static_Expression (N, Static);
end Fold_Uint;
----------------
@@ -4128,12 +4147,20 @@ package body Sem_Eval is
Set_Original_Entity (N, Ent);
- -- Both the actual and expected type comes from the original expression
+ -- We now have the literal with the right value, both the actual type
+ -- and the expected type of this literal are taken from the expression
+ -- that was evaluated. So now we do the Analyze and Resolve.
+
+ -- Note that we have to reset Is_Static_Expression both after the
+ -- analyze step (because Resolve will evaluate the literal, which
+ -- will cause semantic errors if it is marked as static), and after
+ -- the Resolve step (since Resolve in some cases sets this flag).
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
+ Set_Is_Static_Expression (N, Static);
end Fold_Ureal;
---------------
@@ -5413,10 +5440,12 @@ package body Sem_Eval is
return;
end if;
- -- Type must be scalar or string type
+ -- Type must be scalar or string type (but allow Bignum, since this
+ -- is really a scalar type from our point of view in this diagnosis).
if not Is_Scalar_Type (Typ)
and then not Is_String_Type (Typ)
+ and then not Is_RTE (Typ, RE_Bignum)
then
Error_Msg_N
("static expression must have scalar or string type " &
@@ -5533,7 +5562,14 @@ package body Sem_Eval is
when N_Function_Call =>
Why_Not_Static_List (Parameter_Associations (N));
- Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
+
+ -- Complain about non-static function call unless we have Bignum
+ -- which means that the underlying expression is really some
+ -- scalar arithmetic operation.
+
+ if not Is_RTE (Typ, RE_Bignum) then
+ Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
+ end if;
when N_Parameter_Association =>
Why_Not_Static (Explicit_Actual_Parameter (N));
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 029b94b124d..258ec5b1685 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -14802,10 +14802,17 @@ package body Sem_Prag is
loop
Set_Warnings_Off
(E, (Chars (Get_Pragma_Arg (Arg1)) =
- Name_Off));
+ Name_Off));
+
+ -- For OFF case, make entry in warnings off
+ -- pragma table for later processing. But we do
+ -- not do that within an instance, since these
+ -- warnings are about what is needed in the
+ -- template, not an instance of it.
if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
and then Warn_On_Warnings_Off
+ and then not In_Instance
then
Warnings_Off_Pragmas.Append ((N, E));
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 81c4e142cab..4383754fa31 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7685,10 +7685,11 @@ package body Sem_Res is
----------------------------
procedure Resolve_Set_Membership is
- Alt : Node_Id;
+ Alt : Node_Id;
+ Ltyp : constant Entity_Id := Etype (L);
begin
- Resolve (L, Etype (L));
+ Resolve (L, Ltyp);
Alt := First (Alternatives (N));
while Present (Alt) loop
@@ -7699,11 +7700,51 @@ package body Sem_Res is
if not Is_Entity_Name (Alt)
or else not Is_Type (Entity (Alt))
then
- Resolve (Alt, Etype (L));
+ Resolve (Alt, Ltyp);
end if;
Next (Alt);
end loop;
+
+ -- Check for duplicates for discrete case
+
+ if Is_Discrete_Type (Ltyp) then
+ declare
+ type Ent is record
+ Alt : Node_Id;
+ Val : Uint;
+ end record;
+
+ Alts : array (0 .. List_Length (Alternatives (N))) of Ent;
+ Nalts : Nat;
+
+ begin
+ -- Loop checking duplicates. This is quadratic, but giant sets
+ -- are unlikely in this context so it's a reasonable choice.
+
+ Nalts := 0;
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ if Is_Static_Expression (Alt)
+ and then (Nkind_In (Alt, N_Integer_Literal,
+ N_Character_Literal)
+ or else Nkind (Alt) in N_Has_Entity)
+ then
+ Nalts := Nalts + 1;
+ Alts (Nalts) := (Alt, Expr_Value (Alt));
+
+ for J in 1 .. Nalts - 1 loop
+ if Alts (J).Val = Alts (Nalts).Val then
+ Error_Msg_Sloc := Sloc (Alts (J).Alt);
+ Error_Msg_N ("duplicate of value given#?", Alt);
+ end if;
+ end loop;
+ end if;
+
+ Alt := Next (Alt);
+ end loop;
+ end;
+ end if;
end Resolve_Set_Membership;
-- Start of processing for Resolve_Membership_Op
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 2e68039262f..2202c886766 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2489,6 +2489,45 @@ package body Sem_Util is
return Plist;
end Copy_Parameter_List;
+ --------------------------------
+ -- Corresponding_Generic_Type --
+ --------------------------------
+
+ function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
+ Inst : Entity_Id;
+ Gen : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if not Is_Generic_Actual_Type (T) then
+ return Any_Type;
+
+ else
+ Inst := Scope (T);
+
+ if Is_Wrapper_Package (Inst) then
+ Inst := Related_Instance (Inst);
+ end if;
+
+ Gen :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Inst)));
+
+ -- Generic actual has the same name as the corresponding formal
+
+ Typ := First_Entity (Gen);
+ while Present (Typ) loop
+ if Chars (Typ) = Chars (T) then
+ return Typ;
+ end if;
+
+ Next_Entity (Typ);
+ end loop;
+
+ return Any_Type;
+ end if;
+ end Corresponding_Generic_Type;
+
--------------------
-- Current_Entity --
--------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 57c4880b425..1b089b85ee7 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -299,6 +299,12 @@ package Sem_Util is
-- create a new compatible record type. Loc is the source location assigned
-- to the created nodes.
+ function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id;
+ -- If a type is a generic actual type, return the corresponding formal in
+ -- the generic parent unit. There is no direct link in the tree for this
+ -- attribute, except in the case of formal private and derived types.
+ -- Possible optimization???
+
function Current_Entity (N : Node_Id) return Entity_Id;
pragma Inline (Current_Entity);
-- Find the currently visible definition for a given identifier, that is to
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 41998908b75..39e9acba824 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -12419,15 +12419,4 @@ package Sinfo is
pragma Inline (Set_Was_Originally_Stub);
pragma Inline (Set_Withed_Body);
- --------------
- -- Synonyms --
- --------------
-
- -- These synonyms are to aid in transition, they should eventually be
- -- removed when all remaining references to the obsolete name are gone.
-
- N_Return_Statement : constant Node_Kind := N_Simple_Return_Statement;
- -- Rename N_Simple_Return_Statement to be N_Return_Statement. Clients
- -- should refer to N_Simple_Return_Statement.
-
end Sinfo;
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 73b11ac2d69..277bfd55146 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -737,7 +737,9 @@ package Types is
subtype Minimized_Or_Eliminated is
Overflow_Check_Type range Minimized .. Eliminated;
- -- Definte subtypes so that clients don't need to know ordering. Note that
+ subtype Suppressed_Or_Checked is
+ Overflow_Check_Type range Suppressed .. Checked;
+ -- Define subtypes so that clients don't need to know ordering. Note that
-- Overflow_Check_Type is not marked as an ordered enumeration type.
-- The following structure captures the state of check suppression or
View Lorry Controller Status