summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog27
-rw-r--r--gcc/ada/atree.ads2
-rw-r--r--gcc/ada/get_scos.adb68
-rw-r--r--gcc/ada/par_sco.adb265
-rw-r--r--gcc/ada/put_scos.adb89
-rw-r--r--gcc/ada/put_scos.ads8
-rw-r--r--gcc/ada/scos.ads52
-rw-r--r--gcc/ada/sem_attr.adb3
-rw-r--r--gcc/ada/sem_prag.adb9
-rw-r--r--gcc/ada/tracebak.c21
10 files changed, 375 insertions, 169 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c0e6d1aa15e..c323d7cf4aa 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2012-12-05 Thomas Quinot <quinot@adacore.com>
+
+ * par_sco.adb, scos.ads, put_scos.adb, put_scos.ads,
+ get_scos.adb: Generation of SCOs for aspects.
+
+2012-12-05 Thomas Quinot <quinot@adacore.com>
+
+ * sem_prag.adb (Check_Precondition_Postcondition): Remove
+ redundant call to Set_SCO_Pragma_Enabled (the pragma will be
+ rewritten into a pragma Check later on, and the call will be
+ made when processing the rewritten pragma).
+ (Analyze_Pragma, case Pragma_Check): Omit call to
+ Set_SCO_Pragma_Enabled if Split_PPC is set.
+
+2012-12-05 Olivier Hainque <hainque@adacore.com>
+
+ * tracebak.c: Add partial support for Lynx178.
+
+2012-12-05 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Improve
+ the error message related to loop assertions.
+
+2012-12-05 Gary Dismukes <dismukes@adacore.com>
+
+ * atree.ads: Minor reformatting.
+
2012-12-05 Robert Dewar <dewar@adacore.com>
* atree.ads, par-ch4.adb, sem_attr.adb, sem_ch13.adb: Minor
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index e685ead0049..d503dc2a660 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -107,7 +107,7 @@ package Atree is
-- Note: the required parentheses surrounding conditional
-- and quantified expressions count as a level of parens
- -- for this purposes, so e.g. in X := (if A then B else C);
+ -- for this purpose, so e.g. in X := (if A then B else C);
-- Paren_Count for the right side will be 1.
-- Comes_From_Source
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index 4fb00102929..0020bea0868 100644
--- a/gcc/ada/get_scos.adb
+++ b/gcc/ada/get_scos.adb
@@ -28,8 +28,8 @@ pragma Ada_2005;
-- read SCO information from ALI files (Xcov and sco_test). Ada 2005
-- constructs may therefore be used freely (and are indeed).
+with Namet; use Namet;
with SCOs; use SCOs;
-with Snames; use Snames;
with Types; use Types;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
@@ -203,6 +203,8 @@ procedure Get_SCOs is
N : Natural;
-- Scratch buffer, and index into it
+ Nam : Name_Id;
+
-- Start of processing for Get_Scos
begin
@@ -308,7 +310,6 @@ begin
declare
Typ : Character;
Key : Character;
- Pid : Pragma_Id;
begin
Key := 'S';
@@ -327,7 +328,7 @@ begin
-- Loop through items on one line
loop
- Pid := Unknown_Pragma;
+ Nam := No_Name;
Typ := Nextc;
case Typ is
@@ -348,25 +349,16 @@ begin
Skipc;
if Typ = 'P' or else Typ = 'p' then
if Nextc not in '1' .. '9' then
- N := 1;
+ Name_Len := 0;
loop
- Buf (N) := Getc;
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
exit when Nextc = ':';
- N := N + 1;
end loop;
- Skipc;
-
- begin
- Pid :=
- Pragma_Id'Value ("pragma_" & Buf (1 .. N));
- exception
- when Constraint_Error =>
+ Skipc; -- Past ':'
- -- Pid remains set to Unknown_Pragma
-
- null;
- end;
+ Nam := Name_Find;
end if;
end if;
end case;
@@ -379,13 +371,13 @@ begin
end if;
SCO_Table.Append
- ((C1 => Key,
- C2 => Typ,
- From => Loc1,
- To => Loc2,
- Last => At_EOL,
- Pragma_Sloc => No_Location,
- Pragma_Name => Pid));
+ ((C1 => Key,
+ C2 => Typ,
+ From => Loc1,
+ To => Loc2,
+ Last => At_EOL,
+ Pragma_Sloc => No_Location,
+ Pragma_Aspect_Name => Nam));
if Key = '>' then
Key := 'S';
@@ -397,8 +389,21 @@ begin
-- Decision entry
- when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' =>
+ when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
Dtyp := C;
+
+ if C = 'A' then
+ Name_Len := 0;
+ while Nextc /= ' ' loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
+ Nam := Name_Find;
+
+ else
+ Nam := No_Name;
+ end if;
+
Skip_Spaces;
-- Output header
@@ -416,12 +421,13 @@ begin
end if;
SCO_Table.Append
- ((C1 => Dtyp,
- C2 => ' ',
- From => Loc,
- To => No_Source_Location,
- Last => False,
- others => <>));
+ ((C1 => Dtyp,
+ C2 => ' ',
+ From => Loc,
+ To => No_Source_Location,
+ Last => False,
+ Pragma_Aspect_Name => Nam,
+ others => <>));
end;
-- Loop through terms in complex expression
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index 2fdd6c5e8e9..4ce6951a755 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Errout; use Errout;
@@ -125,13 +126,13 @@ package body Par_SCO is
-- Calls above procedure for each element of the list L
procedure Set_Table_Entry
- (C1 : Character;
- C2 : Character;
- From : Source_Ptr;
- To : Source_Ptr;
- Last : Boolean;
- Pragma_Sloc : Source_Ptr := No_Location;
- Pragma_Name : Pragma_Id := Unknown_Pragma);
+ (C1 : Character;
+ C2 : Character;
+ From : Source_Ptr;
+ To : Source_Ptr;
+ Last : Boolean;
+ Pragma_Sloc : Source_Ptr := No_Location;
+ Pragma_Aspect_Name : Name_Id := No_Name);
-- Append an entry to SCO_Table with fields set as per arguments
type Dominant_Info is record
@@ -487,15 +488,22 @@ package body Par_SCO is
Loc : Source_Ptr := No_Location;
-- Node whose Sloc is used for the decision
+ Nam : Name_Id := No_Name;
+ -- For the case of an aspect, aspect name
+
begin
case T is
- when 'I' | 'E' | 'W' =>
+ when 'I' | 'E' | 'W' | 'a' =>
- -- For IF, EXIT, WHILE, the token SLOC can be found from
- -- the SLOC of the parent of the expression.
+ -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
+ -- the parent of the expression.
Loc := Sloc (Parent (N));
+ if T = 'a' then
+ Nam := Chars (Identifier (Parent (N)));
+ end if;
+
when 'G' | 'P' =>
-- For entry guard, the token sloc is from the N_Entry_Body.
@@ -533,12 +541,20 @@ package body Par_SCO is
end case;
Set_Table_Entry
- (C1 => T,
- C2 => ' ',
- From => Loc,
- To => No_Location,
- Last => False,
- Pragma_Sloc => Pragma_Sloc);
+ (C1 => T,
+ C2 => ' ',
+ From => Loc,
+ To => No_Location,
+ Last => False,
+ Pragma_Sloc => Pragma_Sloc,
+ Pragma_Aspect_Name => Nam);
+
+ -- For an aspect specification, which will be rewritten into a
+ -- pragma, enter a hash table entry now.
+
+ if T = 'a' then
+ Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
+ end if;
end Output_Header;
------------------------------
@@ -731,6 +747,8 @@ package body Par_SCO is
procedure Populate_SCO_Instance_Table is
new Sinput.Iterate_On_Instances (Record_Instance);
+ SCO_Index : Nat;
+
begin
if Debug_Flag_Dot_OO then
dsco;
@@ -796,6 +814,24 @@ package body Par_SCO is
end;
end loop;
+ -- Stamp out SCO entries for decisions in disabled constructs (pragmas
+ -- or aspects).
+
+ SCO_Index := 1;
+ while SCO_Index <= SCO_Table.Last loop
+ if Is_Decision (SCO_Table.Table (SCO_Index).C1)
+ and then SCO_Pragma_Disabled
+ (SCO_Table.Table (SCO_Index).Pragma_Sloc)
+ then
+ loop
+ SCO_Table.Table (SCO_Index).C1 := ASCII.NUL;
+ exit when SCO_Table.Table (SCO_Index).Last;
+ SCO_Index := SCO_Index + 1;
+ end loop;
+ end if;
+ SCO_Index := SCO_Index + 1;
+ end loop;
+
-- Now the tables are all setup for output to the ALI file
Write_SCOs_To_ALI_File;
@@ -824,8 +860,30 @@ package body Par_SCO is
declare
T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin
- pragma Assert (T.C1 = 'S');
- return T.C2 = 'p';
+ case T.C1 is
+ when 'S' =>
+ -- Pragma statement
+
+ return T.C2 = 'p';
+
+ when 'A' =>
+ -- Aspect decision (enabled)
+
+ return False;
+
+ when 'a' =>
+ -- Aspect decision (not enabled)
+
+ return True;
+
+ when ASCII.NUL =>
+ -- Nullified disabled SCO
+
+ return True;
+
+ when others =>
+ raise Program_Error;
+ end case;
end;
else
@@ -976,13 +1034,28 @@ package body Par_SCO is
T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin
- -- Called multiple times for the same sloc (need to allow for
- -- C2 = 'P') ???
+ -- Note: may be called multiple times for the same sloc, so
+ -- account for the fact that the entry may already have been
+ -- marked enabled.
+
+ case T.C1 is
+ -- Aspect (decision SCO)
+
+ when 'a' =>
+ T.C1 := 'A';
- pragma Assert (T.C1 = 'S'
- and then
- (T.C2 = 'p' or else T.C2 = 'P'));
- T.C2 := 'P';
+ when 'A' =>
+ null;
+
+ -- Pragma (statement SCO)
+
+ when 'S' =>
+ pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
+ T.C2 := 'P';
+
+ when others =>
+ raise Program_Error;
+ end case;
end;
end if;
end Set_SCO_Pragma_Enabled;
@@ -992,23 +1065,23 @@ package body Par_SCO is
---------------------
procedure Set_Table_Entry
- (C1 : Character;
- C2 : Character;
- From : Source_Ptr;
- To : Source_Ptr;
- Last : Boolean;
- Pragma_Sloc : Source_Ptr := No_Location;
- Pragma_Name : Pragma_Id := Unknown_Pragma)
+ (C1 : Character;
+ C2 : Character;
+ From : Source_Ptr;
+ To : Source_Ptr;
+ Last : Boolean;
+ Pragma_Sloc : Source_Ptr := No_Location;
+ Pragma_Aspect_Name : Name_Id := No_Name)
is
begin
SCO_Table.Append
- ((C1 => C1,
- C2 => C2,
- From => To_Source_Location (From),
- To => To_Source_Location (To),
- Last => Last,
- Pragma_Sloc => Pragma_Sloc,
- Pragma_Name => Pragma_Name));
+ ((C1 => C1,
+ C2 => C2,
+ From => To_Source_Location (From),
+ To => To_Source_Location (To),
+ Last => Last,
+ Pragma_Sloc => Pragma_Sloc,
+ Pragma_Aspect_Name => Pragma_Aspect_Name));
end Set_Table_Entry;
------------------------
@@ -1133,6 +1206,9 @@ package body Par_SCO is
procedure Traverse_One (N : Node_Id);
-- Traverse one declaration or statement
+ procedure Traverse_Aspects (N : Node_Id);
+ -- Helper for Traverse_One: traverse N's aspect specifications
+
-------------------------
-- Set_Statement_Entry --
-------------------------
@@ -1156,21 +1232,21 @@ package body Par_SCO is
To := No_Location;
end if;
Set_Table_Entry
- (C1 => '>',
- C2 => Current_Dominant.K,
- From => From,
- To => To,
- Last => False,
- Pragma_Sloc => No_Location,
- Pragma_Name => Unknown_Pragma);
+ (C1 => '>',
+ C2 => Current_Dominant.K,
+ From => From,
+ To => To,
+ Last => False,
+ Pragma_Sloc => No_Location,
+ Pragma_Aspect_Name => No_Name);
end;
end if;
end if;
declare
- SCE : SC_Entry renames SC.Table (J);
- Pragma_Sloc : Source_Ptr := No_Location;
- Pragma_Name : Pragma_Id := Unknown_Pragma;
+ SCE : SC_Entry renames SC.Table (J);
+ Pragma_Sloc : Source_Ptr := No_Location;
+ Pragma_Aspect_Name : Name_Id := No_Name;
begin
-- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
@@ -1181,20 +1257,22 @@ package body Par_SCO is
Pragma_Sloc := SCE.From;
Condition_Pragma_Hash_Table.Set
(Pragma_Sloc, SCO_Table.Last + 1);
- Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N));
+ Pragma_Aspect_Name := Pragma_Name (SCE.N);
+ pragma Assert (Pragma_Aspect_Name /= No_Name);
elsif SCE.Typ = 'P' then
- Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N));
+ Pragma_Aspect_Name := Pragma_Name (SCE.N);
+ pragma Assert (Pragma_Aspect_Name /= No_Name);
end if;
Set_Table_Entry
- (C1 => 'S',
- C2 => SCE.Typ,
- From => SCE.From,
- To => SCE.To,
- Last => (J = SC_Last),
- Pragma_Sloc => Pragma_Sloc,
- Pragma_Name => Pragma_Name);
+ (C1 => 'S',
+ C2 => SCE.Typ,
+ From => SCE.From,
+ To => SCE.To,
+ Last => (J = SC_Last),
+ Pragma_Sloc => Pragma_Sloc,
+ Pragma_Aspect_Name => Pragma_Aspect_Name);
end;
end loop;
@@ -1293,6 +1371,76 @@ package body Par_SCO is
SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
+ ----------------------
+ -- Traverse_Aspects --
+ ----------------------
+
+ procedure Traverse_Aspects (N : Node_Id) is
+ AN : Node_Id;
+ AE : Node_Id;
+
+ begin
+ AN := First (Aspect_Specifications (N));
+ while Present (AN) loop
+ AE := Expression (AN);
+
+ case Get_Aspect_Id (Chars (Identifier (AN))) is
+
+ -- Aspects rewritten into pragmas controlled by a Check_Policy:
+ -- Current_Pragma_Sloc must be set to the sloc of the aspect
+ -- specification. The corresponding pragma will have the same
+ -- sloc.
+
+ when Aspect_Pre |
+ Aspect_Precondition |
+ Aspect_Post |
+ Aspect_Postcondition =>
+
+ -- SCOs are generated before semantic analysis/expansion:
+ -- PPCs are not split yet.
+
+ pragma Assert (not Split_PPC (AN));
+
+ -- A Pre/Post aspect will be rewritten into a pragma
+ -- Precondition/Postcondition with the same sloc.
+
+ pragma Assert (Current_Pragma_Sloc = No_Location);
+
+ Current_Pragma_Sloc := Sloc (AN);
+
+ -- Create the decision as potentially disabled aspect ('a').
+ -- Set_SCO_Pragma_Enabled will subsequently switch to 'A'.
+
+ Process_Decisions_Defer (AE, 'a');
+ Current_Pragma_Sloc := No_Location;
+
+ -- Aspects whose checks are generated in client units,
+ -- regardless of whether or not the check is activated in the
+ -- unit which contains the declaration.
+
+ when Aspect_Predicate |
+ Aspect_Static_Predicate |
+ Aspect_Dynamic_Predicate |
+ Aspect_Invariant |
+ Aspect_Type_Invariant =>
+
+ Process_Decisions_Defer (AE, 'A');
+
+ -- Other aspects: just process any decision nested in the
+ -- aspect expression.
+
+ when others =>
+
+ if Has_Decision (AE) then
+ Process_Decisions_Defer (AE, 'X');
+ end if;
+
+ end case;
+
+ Next (AN);
+ end loop;
+ end Traverse_Aspects;
+
------------------
-- Traverse_One --
------------------
@@ -1825,6 +1973,9 @@ package body Par_SCO is
end if;
end case;
+ -- Process aspects if present
+
+ Traverse_Aspects (N);
end Traverse_One;
-- Start of processing for Traverse_Declarations_Or_Statements
diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb
index 05184d7a985..e9b03fc8294 100644
--- a/gcc/ada/put_scos.adb
+++ b/gcc/ada/put_scos.adb
@@ -23,10 +23,9 @@
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Opt; use Opt;
-with Par_SCO; use Par_SCO;
with SCOs; use SCOs;
-with Snames; use Snames;
procedure Put_SCOs is
Current_SCO_Unit : SCO_Unit_Index := 0;
@@ -195,18 +194,10 @@ begin
if Sent.C1 = 'S'
and then (Sent.C2 = 'P' or else Sent.C2 = 'p')
- and then Sent.Pragma_Name /= Unknown_Pragma
+ and then Sent.Pragma_Aspect_Name /= No_Name
then
- -- Strip leading "PRAGMA_"
-
- declare
- Pnam : constant String :=
- Sent.Pragma_Name'Img;
- begin
- Output_String
- (Pnam (Pnam'First + 7 .. Pnam'Last));
- Write_Info_Char (':');
- end;
+ Write_Info_Name (Sent.Pragma_Aspect_Name);
+ Write_Info_Char (':');
end if;
end if;
@@ -240,57 +231,55 @@ begin
-- Decision
- when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' =>
+ when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
Start := Start + 1;
- -- For disabled pragma, or nested decision therein, skip
- -- decision output.
+ Write_SCO_Initiate (U);
+ Write_Info_Char (T.C1);
- if SCO_Pragma_Disabled (T.Pragma_Sloc) then
- while not SCO_Table.Table (Start).Last loop
- Start := Start + 1;
- end loop;
+ if T.C1 = 'A' then
+ Write_Info_Name (T.Pragma_Aspect_Name);
+ end if;
+
+ if T.C1 /= 'X' then
+ Write_Info_Char (' ');
+ Output_Source_Location (T.From);
+ end if;
- -- For all other cases output decision line
+ -- Loop through table entries for this decision
- else
- Write_SCO_Initiate (U);
- Write_Info_Char (T.C1);
+ loop
+ declare
+ T : SCO_Table_Entry
+ renames SCO_Table.Table (Start);
- if T.C1 /= 'X' then
+ begin
Write_Info_Char (' ');
- Output_Source_Location (T.From);
- end if;
- -- Loop through table entries for this decision
+ if T.C1 = '!' or else
+ T.C1 = '&' or else
+ T.C1 = '|'
+ then
+ Write_Info_Char (T.C1);
+ Output_Source_Location (T.From);
- loop
- declare
- T : SCO_Table_Entry
- renames SCO_Table.Table (Start);
+ else
+ Write_Info_Char (T.C2);
+ Output_Range (T);
+ end if;
- begin
- Write_Info_Char (' ');
+ exit when T.Last;
+ Start := Start + 1;
+ end;
+ end loop;
- if T.C1 = '!' or else
- T.C1 = '&' or else
- T.C1 = '|'
- then
- Write_Info_Char (T.C1);
- Output_Source_Location (T.From);
+ Write_Info_Terminate;
- else
- Write_Info_Char (T.C2);
- Output_Range (T);
- end if;
+ when ASCII.NUL =>
- exit when T.Last;
- Start := Start + 1;
- end;
- end loop;
+ -- Nullified entry: skip
- Write_Info_Terminate;
- end if;
+ null;
when others =>
raise Program_Error;
diff --git a/gcc/ada/put_scos.ads b/gcc/ada/put_scos.ads
index d8d77202b7d..323e6528458 100644
--- a/gcc/ada/put_scos.ads
+++ b/gcc/ada/put_scos.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- P U T _ S C O S --
+-- P U T _ S C O S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-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- --
@@ -28,6 +28,7 @@
-- the ALI file. The interface allows control over the destination of the
-- output, so that this routine can also be used for debugging purposes.
+with Namet; use Namet;
with Types; use Types;
generic
@@ -43,6 +44,9 @@ generic
-- Initiates write of new line to output file, the parameter is the
-- keyword character for the line.
+ with procedure Write_Info_Name (Nam : Name_Id) is <>;
+ -- Outputs one name
+
with procedure Write_Info_Nat (N : Nat) is <>;
-- Writes image of N to output file with no leading or trailing blanks
diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads
index 076a66ef3c9..0082099afb4 100644
--- a/gcc/ada/scos.ads
+++ b/gcc/ada/scos.ads
@@ -28,11 +28,8 @@
-- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that
-- is used in the ALI file.
-with Snames; use Snames;
--- Note: used for Pragma_Id only, no other feature from Snames should be used,
--- as a simplified version is maintained in Xcov.
-
-with Types; use Types;
+with Namet; use Namet;
+with Types; use Types;
with GNAT.Table;
@@ -248,18 +245,21 @@ package SCOs is
-- C* sloc expression
- -- Here * is one of the following characters:
+ -- Here * is one of the following:
- -- E decision in EXIT WHEN statement
- -- G decision in entry guard
- -- I decision in IF statement or if expression
- -- P decision in pragma Assert/Check/Pre_Condition/Post_Condition
- -- W decision in WHILE iteration scheme
- -- X decision appearing in some other expression context
+ -- E decision in EXIT WHEN statement
+ -- G decision in entry guard
+ -- I decision in IF statement or if expression
+ -- P decision in pragma Assert / Check / Pre/Post_Condition
+ -- A[name] decision in aspect Pre/Post (aspect name optional)
+ -- W decision in WHILE iteration scheme
+ -- X decision in some other expression context
-- For E, G, I, P, W, sloc is the source location of the EXIT, ENTRY, IF,
-- PRAGMA or WHILE token, respectively
+ -- For A sloc is the source location of the aspect identifier
+
-- For X, sloc is omitted
-- The expression is a prefix polish form indicating the structure of
@@ -369,10 +369,12 @@ package SCOs is
Pragma_Sloc : Source_Ptr := No_Location;
-- For the statement SCO for a pragma, or for any expression SCO nested
-- in a pragma Debug/Assert/PPC, location of PRAGMA token (used for
- -- control of SCO output, value not recorded in ALI file).
+ -- control of SCO output, value not recorded in ALI file). For the
+ -- decision SCO for an aspect, or for any expression SCO nested in an
+ -- aspect, location of aspect identifier token (likewise).
- Pragma_Name : Pragma_Id := Unknown_Pragma;
- -- For the statement SCO for a pragma, gives the pragma name
+ Pragma_Aspect_Name : Name_Id := No_Name;
+ -- For the SCO for a pragma/aspect, gives the pragma/apsect name
end record;
package SCO_Table is new GNAT.Table (
@@ -382,6 +384,11 @@ package SCOs is
Table_Initial => 500,
Table_Increment => 300);
+ Is_Decision : constant array (Character) of Boolean :=
+ ('E' | 'G' | 'I' | 'P' | 'A' | 'W' | 'X' => True,
+ others => False);
+ -- Indicates which C1 values correspond to decisions
+
-- The SCO_Table_Entry values appear as follows:
-- Statements
@@ -432,7 +439,20 @@ package SCOs is
-- SCO contexts, the only pragmas with decisions are Assert, Check,
-- dyadic Debug, Precondition and Postcondition). These entries will
-- be omitted in output if the pragma is disabled (see comments for
- -- statement entries).
+ -- statement entries). This is achieved by setting C1 to NUL for all
+ -- SCO entries of the decision.
+
+ -- Decision (ASPECT)
+ -- C1 = 'A'
+ -- C2 = ' '
+ -- From = aspect identifier
+ -- To = No_Source_Location
+ -- Last = unused
+
+ -- Note: when the parse tree is first scanned, we unconditionally build a
+ -- pragma decision entry for any decision in an aspect (Pre/Post/
+ -- [Type_]Invariant/[Static_|Dynamic_]Predicate). Entries for disabled
+ -- Pre/Post aspects will be omitted from output.
-- Decision (Expression)
-- C1 = 'X'
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 836c278621e..94cbd9e730a 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3847,7 +3847,8 @@ package body Sem_Attr is
if not In_Loop_Assertion then
Error_Attr
- ("attribute % must appear within pragma Loop_Assertion", N);
+ ("attribute % must appear within pragma Loop_Variant or " &
+ "Loop_Invariant", N);
end if;
-- A Loop_Entry that applies to a given loop statement shall not
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index ec7f3b95d97..ddd84822ce1 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -2181,13 +2181,6 @@ package body Sem_Prag is
(Get_Pragma_Arg (Arg2), Standard_String);
end if;
- -- For a pragma in the extended main source unit, record enabled
- -- status in SCO (note: there is never any SCO for an instance).
-
- if Check_Enabled (Pname) then
- Set_SCO_Pragma_Enabled (Loc);
- end if;
-
-- If we are within an inlined body, the legality of the pragma
-- has been checked already.
@@ -7407,7 +7400,7 @@ package body Sem_Prag is
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
- if Check_On then
+ if Check_On and then not Split_PPC (N) then
Set_SCO_Pragma_Enabled (Loc);
end if;
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index 2c8335de68b..01b96548baf 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -287,9 +287,10 @@ __gnat_backtrace (void **array,
#error Unhandled darwin architecture.
#endif
-/*------------------------ PPC AIX/Older Darwin -------------------------*/
+/*---------------------- PPC AIX/PPC Lynx 178/Older Darwin ------------------*/
#elif ((defined (_POWER) && defined (_AIX)) || \
-(defined (__ppc__) && defined (__APPLE__)))
+ (defined (__powerpc__) && defined (__Lynx__) && !defined(__ELF__)) || \
+ (defined (__ppc__) && defined (__APPLE__)))
#define USE_GENERIC_UNWINDER
@@ -307,9 +308,23 @@ struct layout
should to feature a null backchain, AIX might expose a null return
address instead. */
+/* Then LynxOS-178 features yet another variation, with return_address
+ == &__start, which we only add conditionally as this symbol is not
+ necessarily present elsewhere. Beware that &bla returns the
+ address of a descriptor when "bla" is a function. Getting the code
+ address requires an extra dereference. */
+
+#if defined (__Lynx__)
+extern void __start();
+#define EXTRA_STOP_CONDITION(CURRENT) ((CURRENT)->return_address == *(void**)&__start)
+#else
+#define EXTRA_STOP_CONDITION(CURRENT) (0)
+#endif
+
#define STOP_FRAME(CURRENT, TOP_STACK) \
(((void *) (CURRENT) < (TOP_STACK)) \
- || (CURRENT)->return_address == NULL)
+ || (CURRENT)->return_address == NULL \
+ || EXTRA_STOP_CONDITION(CURRENT))
/* The PPC ABI has an interesting specificity: the return address saved by a
function is located in it's caller's frame, and the save operation only
View Lorry Controller Status