OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r194211
This commit is contained in:
Arnaud Charlet 2012-12-05 12:15:35 +01:00
parent af31bd5750
commit 06ad40d3ec
10 changed files with 385 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/ada/ChangeLog
View File

@ -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> 2012-12-05 Robert Dewar <dewar@adacore.com>
* atree.ads, par-ch4.adb, sem_attr.adb, sem_ch13.adb: Minor * atree.ads, par-ch4.adb, sem_attr.adb, sem_ch13.adb: Minor

2
gcc/ada/atree.ads
View File

@ -107,7 +107,7 @@ package Atree is
-- Note: the required parentheses surrounding conditional -- Note: the required parentheses surrounding conditional
-- and quantified expressions count as a level of parens -- 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. -- Paren_Count for the right side will be 1.
-- Comes_From_Source -- Comes_From_Source

68
gcc/ada/get_scos.adb
View File

@ -28,8 +28,8 @@ pragma Ada_2005;
-- read SCO information from ALI files (Xcov and sco_test). Ada 2005 -- read SCO information from ALI files (Xcov and sco_test). Ada 2005
-- constructs may therefore be used freely (and are indeed). -- constructs may therefore be used freely (and are indeed).
with Namet; use Namet;
with SCOs; use SCOs; with SCOs; use SCOs;
with Snames; use Snames;
with Types; use Types; with Types; use Types;
with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.IO_Exceptions; use Ada.IO_Exceptions;
@ -203,6 +203,8 @@ procedure Get_SCOs is
N : Natural; N : Natural;
-- Scratch buffer, and index into it -- Scratch buffer, and index into it
Nam : Name_Id;
-- Start of processing for Get_Scos -- Start of processing for Get_Scos
begin begin
@ -308,7 +310,6 @@ begin
declare declare
Typ : Character; Typ : Character;
Key : Character; Key : Character;
Pid : Pragma_Id;
begin begin
Key := 'S'; Key := 'S';
@ -327,7 +328,7 @@ begin
-- Loop through items on one line -- Loop through items on one line
loop loop
Pid := Unknown_Pragma; Nam := No_Name;
Typ := Nextc; Typ := Nextc;
case Typ is case Typ is
@ -348,25 +349,16 @@ begin
Skipc; Skipc;
if Typ = 'P' or else Typ = 'p' then if Typ = 'P' or else Typ = 'p' then
if Nextc not in '1' .. '9' then if Nextc not in '1' .. '9' then
N := 1; Name_Len := 0;
loop loop
Buf (N) := Getc; Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
exit when Nextc = ':'; exit when Nextc = ':';
N := N + 1;
end loop; end loop;
Skipc; Skipc; -- Past ':'
begin Nam := Name_Find;
Pid :=
Pragma_Id'Value ("pragma_" & Buf (1 .. N));
exception
when Constraint_Error =>
-- Pid remains set to Unknown_Pragma
null;
end;
end if; end if;
end if; end if;
end case; end case;
@ -379,13 +371,13 @@ begin
end if; end if;
SCO_Table.Append SCO_Table.Append
((C1 => Key, ((C1 => Key,
C2 => Typ, C2 => Typ,
From => Loc1, From => Loc1,
To => Loc2, To => Loc2,
Last => At_EOL, Last => At_EOL,
Pragma_Sloc => No_Location, Pragma_Sloc => No_Location,
Pragma_Name => Pid)); Pragma_Aspect_Name => Nam));
if Key = '>' then if Key = '>' then
Key := 'S'; Key := 'S';
@ -397,8 +389,21 @@ begin
-- Decision entry -- Decision entry
when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' => when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
Dtyp := C; 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; Skip_Spaces;
-- Output header -- Output header
@ -416,12 +421,13 @@ begin
end if; end if;
SCO_Table.Append SCO_Table.Append
((C1 => Dtyp, ((C1 => Dtyp,
C2 => ' ', C2 => ' ',
From => Loc, From => Loc,
To => No_Source_Location, To => No_Source_Location,
Last => False, Last => False,
others => <>)); Pragma_Aspect_Name => Nam,
others => <>));
end; end;
-- Loop through terms in complex expression -- Loop through terms in complex expression

265
gcc/ada/par_sco.adb
View File

@ -23,6 +23,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree; with Atree; use Atree;
with Debug; use Debug; with Debug; use Debug;
with Errout; use Errout; with Errout; use Errout;
@ -125,13 +126,13 @@ package body Par_SCO is
-- Calls above procedure for each element of the list L -- Calls above procedure for each element of the list L
procedure Set_Table_Entry procedure Set_Table_Entry
(C1 : Character; (C1 : Character;
C2 : Character; C2 : Character;
From : Source_Ptr; From : Source_Ptr;
To : Source_Ptr; To : Source_Ptr;
Last : Boolean; Last : Boolean;
Pragma_Sloc : Source_Ptr := No_Location; Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Name : Pragma_Id := Unknown_Pragma); Pragma_Aspect_Name : Name_Id := No_Name);
-- Append an entry to SCO_Table with fields set as per arguments -- Append an entry to SCO_Table with fields set as per arguments
type Dominant_Info is record type Dominant_Info is record
@ -487,15 +488,22 @@ package body Par_SCO is
Loc : Source_Ptr := No_Location; Loc : Source_Ptr := No_Location;
-- Node whose Sloc is used for the decision -- Node whose Sloc is used for the decision
Nam : Name_Id := No_Name;
-- For the case of an aspect, aspect name
begin begin
case T is case T is
when 'I' | 'E' | 'W' => when 'I' | 'E' | 'W' | 'a' =>
-- For IF, EXIT, WHILE, the token SLOC can be found from -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
-- the SLOC of the parent of the expression. -- the parent of the expression.
Loc := Sloc (Parent (N)); Loc := Sloc (Parent (N));
if T = 'a' then
Nam := Chars (Identifier (Parent (N)));
end if;
when 'G' | 'P' => when 'G' | 'P' =>
-- For entry guard, the token sloc is from the N_Entry_Body. -- For entry guard, the token sloc is from the N_Entry_Body.
@ -533,12 +541,20 @@ package body Par_SCO is
end case; end case;
Set_Table_Entry Set_Table_Entry
(C1 => T, (C1 => T,
C2 => ' ', C2 => ' ',
From => Loc, From => Loc,
To => No_Location, To => No_Location,
Last => False, Last => False,
Pragma_Sloc => Pragma_Sloc); 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; end Output_Header;
------------------------------ ------------------------------
@ -731,6 +747,8 @@ package body Par_SCO is
procedure Populate_SCO_Instance_Table is procedure Populate_SCO_Instance_Table is
new Sinput.Iterate_On_Instances (Record_Instance); new Sinput.Iterate_On_Instances (Record_Instance);
SCO_Index : Nat;
begin begin
if Debug_Flag_Dot_OO then if Debug_Flag_Dot_OO then
dsco; dsco;
@ -796,6 +814,24 @@ package body Par_SCO is
end; end;
end loop; 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 -- Now the tables are all setup for output to the ALI file
Write_SCOs_To_ALI_File; Write_SCOs_To_ALI_File;
@ -824,8 +860,30 @@ package body Par_SCO is
declare declare
T : SCO_Table_Entry renames SCO_Table.Table (Index); T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin begin
pragma Assert (T.C1 = 'S'); case T.C1 is
return T.C2 = 'p'; 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; end;
else else
@ -976,13 +1034,28 @@ package body Par_SCO is
T : SCO_Table_Entry renames SCO_Table.Table (Index); T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin begin
-- Called multiple times for the same sloc (need to allow for -- Note: may be called multiple times for the same sloc, so
-- C2 = 'P') ??? -- account for the fact that the entry may already have been
-- marked enabled.
pragma Assert (T.C1 = 'S' case T.C1 is
and then -- Aspect (decision SCO)
(T.C2 = 'p' or else T.C2 = 'P'));
T.C2 := 'P'; when 'a' =>
T.C1 := 'A';
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;
end if; end if;
end Set_SCO_Pragma_Enabled; end Set_SCO_Pragma_Enabled;
@ -992,23 +1065,23 @@ package body Par_SCO is
--------------------- ---------------------
procedure Set_Table_Entry procedure Set_Table_Entry
(C1 : Character; (C1 : Character;
C2 : Character; C2 : Character;
From : Source_Ptr; From : Source_Ptr;
To : Source_Ptr; To : Source_Ptr;
Last : Boolean; Last : Boolean;
Pragma_Sloc : Source_Ptr := No_Location; Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Name : Pragma_Id := Unknown_Pragma) Pragma_Aspect_Name : Name_Id := No_Name)
is is
begin begin
SCO_Table.Append SCO_Table.Append
((C1 => C1, ((C1 => C1,
C2 => C2, C2 => C2,
From => To_Source_Location (From), From => To_Source_Location (From),
To => To_Source_Location (To), To => To_Source_Location (To),
Last => Last, Last => Last,
Pragma_Sloc => Pragma_Sloc, Pragma_Sloc => Pragma_Sloc,
Pragma_Name => Pragma_Name)); Pragma_Aspect_Name => Pragma_Aspect_Name));
end Set_Table_Entry; end Set_Table_Entry;
------------------------ ------------------------
@ -1133,6 +1206,9 @@ package body Par_SCO is
procedure Traverse_One (N : Node_Id); procedure Traverse_One (N : Node_Id);
-- Traverse one declaration or statement -- Traverse one declaration or statement
procedure Traverse_Aspects (N : Node_Id);
-- Helper for Traverse_One: traverse N's aspect specifications
------------------------- -------------------------
-- Set_Statement_Entry -- -- Set_Statement_Entry --
------------------------- -------------------------
@ -1156,21 +1232,21 @@ package body Par_SCO is
To := No_Location; To := No_Location;
end if; end if;
Set_Table_Entry Set_Table_Entry
(C1 => '>', (C1 => '>',
C2 => Current_Dominant.K, C2 => Current_Dominant.K,
From => From, From => From,
To => To, To => To,
Last => False, Last => False,
Pragma_Sloc => No_Location, Pragma_Sloc => No_Location,
Pragma_Name => Unknown_Pragma); Pragma_Aspect_Name => No_Name);
end; end;
end if; end if;
end if; end if;
declare declare
SCE : SC_Entry renames SC.Table (J); SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location; Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Name : Pragma_Id := Unknown_Pragma; Pragma_Aspect_Name : Name_Id := No_Name;
begin begin
-- For the case of a statement SCO for a pragma controlled by -- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and -- 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; Pragma_Sloc := SCE.From;
Condition_Pragma_Hash_Table.Set Condition_Pragma_Hash_Table.Set
(Pragma_Sloc, SCO_Table.Last + 1); (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 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; end if;
Set_Table_Entry Set_Table_Entry
(C1 => 'S', (C1 => 'S',
C2 => SCE.Typ, C2 => SCE.Typ,
From => SCE.From, From => SCE.From,
To => SCE.To, To => SCE.To,
Last => (J = SC_Last), Last => (J = SC_Last),
Pragma_Sloc => Pragma_Sloc, Pragma_Sloc => Pragma_Sloc,
Pragma_Name => Pragma_Name); Pragma_Aspect_Name => Pragma_Aspect_Name);
end; end;
end loop; end loop;
@ -1293,6 +1371,76 @@ package body Par_SCO is
SD.Append ((Empty, L, T, Current_Pragma_Sloc)); SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer; 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 -- -- Traverse_One --
------------------ ------------------
@ -1825,6 +1973,9 @@ package body Par_SCO is
end if; end if;
end case; end case;
-- Process aspects if present
Traverse_Aspects (N);
end Traverse_One; end Traverse_One;
-- Start of processing for Traverse_Declarations_Or_Statements -- Start of processing for Traverse_Declarations_Or_Statements

109
gcc/ada/put_scos.adb
View File

@ -23,10 +23,9 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Par_SCO; use Par_SCO;
with SCOs; use SCOs; with SCOs; use SCOs;
with Snames; use Snames;
procedure Put_SCOs is procedure Put_SCOs is
Current_SCO_Unit : SCO_Unit_Index := 0; Current_SCO_Unit : SCO_Unit_Index := 0;
@ -195,18 +194,10 @@ begin
if Sent.C1 = 'S' if Sent.C1 = 'S'
and then (Sent.C2 = 'P' or else Sent.C2 = 'p') 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 then
-- Strip leading "PRAGMA_" Write_Info_Name (Sent.Pragma_Aspect_Name);
Write_Info_Char (':');
declare
Pnam : constant String :=
Sent.Pragma_Name'Img;
begin
Output_String
(Pnam (Pnam'First + 7 .. Pnam'Last));
Write_Info_Char (':');
end;
end if; end if;
end if; end if;
@ -240,58 +231,56 @@ begin
-- Decision -- Decision
when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' => when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
Start := Start + 1; Start := Start + 1;
-- For disabled pragma, or nested decision therein, skip Write_SCO_Initiate (U);
-- decision output. Write_Info_Char (T.C1);
if SCO_Pragma_Disabled (T.Pragma_Sloc) then if T.C1 = 'A' then
while not SCO_Table.Table (Start).Last loop Write_Info_Name (T.Pragma_Aspect_Name);
Start := Start + 1;
end loop;
-- For all other cases output decision line
else
Write_SCO_Initiate (U);
Write_Info_Char (T.C1);
if T.C1 /= 'X' then
Write_Info_Char (' ');
Output_Source_Location (T.From);
end if;
-- Loop through table entries for this decision
loop
declare
T : SCO_Table_Entry
renames SCO_Table.Table (Start);
begin
Write_Info_Char (' ');
if T.C1 = '!' or else
T.C1 = '&' or else
T.C1 = '|'
then
Write_Info_Char (T.C1);
Output_Source_Location (T.From);
else
Write_Info_Char (T.C2);
Output_Range (T);
end if;
exit when T.Last;
Start := Start + 1;
end;
end loop;
Write_Info_Terminate;
end if; end if;
if T.C1 /= 'X' then
Write_Info_Char (' ');
Output_Source_Location (T.From);
end if;
-- Loop through table entries for this decision
loop
declare
T : SCO_Table_Entry
renames SCO_Table.Table (Start);
begin
Write_Info_Char (' ');
if T.C1 = '!' or else
T.C1 = '&' or else
T.C1 = '|'
then
Write_Info_Char (T.C1);
Output_Source_Location (T.From);
else
Write_Info_Char (T.C2);
Output_Range (T);
end if;
exit when T.Last;
Start := Start + 1;
end;
end loop;
Write_Info_Terminate;
when ASCII.NUL =>
-- Nullified entry: skip
null;
when others => when others =>
raise Program_Error; raise Program_Error;
end case; end case;

8
gcc/ada/put_scos.ads
View File

@ -2,11 +2,11 @@
-- -- -- --
-- GNAT COMPILER COMPONENTS -- -- GNAT COMPILER COMPONENTS --
-- -- -- --
-- P U T _ S C O S -- -- P U T _ S C O S --
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- 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 -- the ALI file. The interface allows control over the destination of the
-- output, so that this routine can also be used for debugging purposes. -- output, so that this routine can also be used for debugging purposes.
with Namet; use Namet;
with Types; use Types; with Types; use Types;
generic generic
@ -43,6 +44,9 @@ generic
-- Initiates write of new line to output file, the parameter is the -- Initiates write of new line to output file, the parameter is the
-- keyword character for the line. -- 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 <>; with procedure Write_Info_Nat (N : Nat) is <>;
-- Writes image of N to output file with no leading or trailing blanks -- Writes image of N to output file with no leading or trailing blanks

52
gcc/ada/scos.ads
View File

@ -28,11 +28,8 @@
-- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that -- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that
-- is used in the ALI file. -- is used in the ALI file.
with Snames; use Snames; with Namet; use Namet;
-- Note: used for Pragma_Id only, no other feature from Snames should be used, with Types; use Types;
-- as a simplified version is maintained in Xcov.
with Types; use Types;
with GNAT.Table; with GNAT.Table;
@ -248,18 +245,21 @@ package SCOs is
-- C* sloc expression -- C* sloc expression
-- Here * is one of the following characters: -- Here * is one of the following:
-- E decision in EXIT WHEN statement -- E decision in EXIT WHEN statement
-- G decision in entry guard -- G decision in entry guard
-- I decision in IF statement or if expression -- I decision in IF statement or if expression
-- P decision in pragma Assert/Check/Pre_Condition/Post_Condition -- P decision in pragma Assert / Check / Pre/Post_Condition
-- W decision in WHILE iteration scheme -- A[name] decision in aspect Pre/Post (aspect name optional)
-- X decision appearing in some other expression context -- 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, -- For E, G, I, P, W, sloc is the source location of the EXIT, ENTRY, IF,
-- PRAGMA or WHILE token, respectively -- PRAGMA or WHILE token, respectively
-- For A sloc is the source location of the aspect identifier
-- For X, sloc is omitted -- For X, sloc is omitted
-- The expression is a prefix polish form indicating the structure of -- The expression is a prefix polish form indicating the structure of
@ -369,10 +369,12 @@ package SCOs is
Pragma_Sloc : Source_Ptr := No_Location; Pragma_Sloc : Source_Ptr := No_Location;
-- For the statement SCO for a pragma, or for any expression SCO nested -- 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 -- 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; Pragma_Aspect_Name : Name_Id := No_Name;
-- For the statement SCO for a pragma, gives the pragma name -- For the SCO for a pragma/aspect, gives the pragma/apsect name
end record; end record;
package SCO_Table is new GNAT.Table ( package SCO_Table is new GNAT.Table (
@ -382,6 +384,11 @@ package SCOs is
Table_Initial => 500, Table_Initial => 500,
Table_Increment => 300); 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: -- The SCO_Table_Entry values appear as follows:
-- Statements -- Statements
@ -432,7 +439,20 @@ package SCOs is
-- SCO contexts, the only pragmas with decisions are Assert, Check, -- SCO contexts, the only pragmas with decisions are Assert, Check,
-- dyadic Debug, Precondition and Postcondition). These entries will -- dyadic Debug, Precondition and Postcondition). These entries will
-- be omitted in output if the pragma is disabled (see comments for -- 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) -- Decision (Expression)
-- C1 = 'X' -- C1 = 'X'

3
gcc/ada/sem_attr.adb
View File

@ -3847,7 +3847,8 @@ package body Sem_Attr is
if not In_Loop_Assertion then if not In_Loop_Assertion then
Error_Attr Error_Attr
("attribute % must appear within pragma Loop_Assertion", N); ("attribute % must appear within pragma Loop_Variant or " &
"Loop_Invariant", N);
end if; end if;
-- A Loop_Entry that applies to a given loop statement shall not -- A Loop_Entry that applies to a given loop statement shall not

9
gcc/ada/sem_prag.adb
View File

@ -2181,13 +2181,6 @@ package body Sem_Prag is
(Get_Pragma_Arg (Arg2), Standard_String); (Get_Pragma_Arg (Arg2), Standard_String);
end if; 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 -- If we are within an inlined body, the legality of the pragma
-- has been checked already. -- has been checked already.
@ -7407,7 +7400,7 @@ package body Sem_Prag is
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); 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); Set_SCO_Pragma_Enabled (Loc);
end if; end if;

21
gcc/ada/tracebak.c
View File

@ -287,9 +287,10 @@ __gnat_backtrace (void **array,
#error Unhandled darwin architecture. #error Unhandled darwin architecture.
#endif #endif
/*------------------------ PPC AIX/Older Darwin -------------------------*/ /*---------------------- PPC AIX/PPC Lynx 178/Older Darwin ------------------*/
#elif ((defined (_POWER) && defined (_AIX)) || \ #elif ((defined (_POWER) && defined (_AIX)) || \
(defined (__ppc__) && defined (__APPLE__))) (defined (__powerpc__) && defined (__Lynx__) && !defined(__ELF__)) || \
(defined (__ppc__) && defined (__APPLE__)))
#define USE_GENERIC_UNWINDER #define USE_GENERIC_UNWINDER
@ -307,9 +308,23 @@ struct layout
should to feature a null backchain, AIX might expose a null return should to feature a null backchain, AIX might expose a null return
address instead. */ 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) \ #define STOP_FRAME(CURRENT, TOP_STACK) \
(((void *) (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 /* 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 function is located in it's caller's frame, and the save operation only