25ebc08558
2011-08-29 Tristan Gingold <gingold@adacore.com> * a-exstat.adb (String_To_EO): Do no set Cleanup_Flag. * a-exexda.adb (Set_Exception_C_Msg): Ditto. (Set_Exception_Msg): Ditto. * a-exexpr-gcc.adb (Setup_Current_Excep): Ditto. Do not set Private_Data. * a-except.adb, a-except-2005.adb (Save_Occurrence_No_Private): Remove. Use Save_Occurrence instead of Save_Occurrence_No_Private. (Raise_With_Msg): Remove Cleanup_Flag. * a-except.ads, a-except-2005.ads (Exception_Occurrence): Remove Clean_Flag and Private_Data components. 2011-08-29 Yannick Moy <moy@adacore.com> * freeze.adb (Freeze_Record_Type): Ignore packing in Alfa mode, like in CodePeer mode. * sem_ch3.adb (Signed_Integer_Type_Declaration): Correct the generation of an explicitly declared type, so that the base types of the original type and this generated type are the same, and a "type" (not a subtype like previously). * errout.adb (Special_Msg_Delete): Do not issue messages "Size too small" in Alfa mode, like in CodePeer mode. * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ignore rep clauses in Alfa mode. 2011-08-29 Javier Miranda <miranda@adacore.com> * exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this function to the package spec. * sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For internally generated bodies of null procedures locate the internally generated spec enforcing mode conformance. (Is_Interface_Conformant): Ensure that the controlling formal of the primitives match. 2011-08-29 Ed Schonberg <schonberg@adacore.com> * sem_prag.adb (Analyze_Pragma, case Inline): In an instance, do not reject the pragma if it appears to apply to a formal subprogram. 2011-08-29 Ed Schonberg <schonberg@adacore.com> * exp_ch4.adb (Expand_Allocator_Expression): Use consistent name for inner expression, to prevent double evaluation. From-SVN: r178216
259 lines
8.3 KiB
Ada
259 lines
8.3 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2011, 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- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
-- --
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
|
-- --
|
|
-- You should have received a copy of the GNU General Public License and --
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
pragma Warnings (Off);
|
|
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
|
|
-- package will be categorized as Preelaborate. See AI-362 for details.
|
|
-- It is safe in the context of the run-time to violate the rules!
|
|
|
|
with System.Exception_Table; use System.Exception_Table;
|
|
with System.Storage_Elements; use System.Storage_Elements;
|
|
|
|
pragma Warnings (On);
|
|
|
|
separate (Ada.Exceptions)
|
|
package body Stream_Attributes is
|
|
|
|
-------------------
|
|
-- EId_To_String --
|
|
-------------------
|
|
|
|
function EId_To_String (X : Exception_Id) return String is
|
|
begin
|
|
if X = Null_Id then
|
|
return "";
|
|
else
|
|
return Exception_Name (X);
|
|
end if;
|
|
end EId_To_String;
|
|
|
|
------------------
|
|
-- EO_To_String --
|
|
------------------
|
|
|
|
-- We use the null string to represent the null occurrence, otherwise
|
|
-- we output the Exception_Information string for the occurrence.
|
|
|
|
function EO_To_String (X : Exception_Occurrence) return String is
|
|
begin
|
|
if X.Id = Null_Id then
|
|
return "";
|
|
else
|
|
return Exception_Information (X);
|
|
end if;
|
|
end EO_To_String;
|
|
|
|
-------------------
|
|
-- String_To_EId --
|
|
-------------------
|
|
|
|
function String_To_EId (S : String) return Exception_Id is
|
|
begin
|
|
if S = "" then
|
|
return Null_Id;
|
|
else
|
|
return Exception_Id (Internal_Exception (S));
|
|
end if;
|
|
end String_To_EId;
|
|
|
|
------------------
|
|
-- String_To_EO --
|
|
------------------
|
|
|
|
function String_To_EO (S : String) return Exception_Occurrence is
|
|
From : Natural;
|
|
To : Integer;
|
|
|
|
X : aliased Exception_Occurrence;
|
|
-- This is the exception occurrence we will create
|
|
|
|
procedure Bad_EO;
|
|
pragma No_Return (Bad_EO);
|
|
-- Signal bad exception occurrence string
|
|
|
|
procedure Next_String;
|
|
-- On entry, To points to last character of previous line of the
|
|
-- message, terminated by LF. On return, From .. To are set to
|
|
-- specify the next string, or From > To if there are no more lines.
|
|
|
|
procedure Bad_EO is
|
|
begin
|
|
Raise_Exception
|
|
(Program_Error'Identity,
|
|
"bad exception occurrence in stream input");
|
|
|
|
-- The following junk raise of Program_Error is required because
|
|
-- this is a No_Return function, and unfortunately Raise_Exception
|
|
-- can return (this particular call can't, but the back end is not
|
|
-- clever enough to know that).
|
|
|
|
raise Program_Error;
|
|
end Bad_EO;
|
|
|
|
procedure Next_String is
|
|
begin
|
|
From := To + 2;
|
|
|
|
if From < S'Last then
|
|
To := From + 1;
|
|
|
|
while To < S'Last - 1 loop
|
|
if To >= S'Last then
|
|
Bad_EO;
|
|
elsif S (To + 1) = ASCII.LF then
|
|
exit;
|
|
else
|
|
To := To + 1;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end Next_String;
|
|
|
|
-- Start of processing for String_To_EO
|
|
|
|
begin
|
|
if S = "" then
|
|
return Null_Occurrence;
|
|
|
|
else
|
|
To := S'First - 2;
|
|
Next_String;
|
|
|
|
if S (From .. From + 15) /= "Exception name: " then
|
|
Bad_EO;
|
|
end if;
|
|
|
|
X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
|
|
|
|
Next_String;
|
|
|
|
if From <= To and then S (From) = 'M' then
|
|
if S (From .. From + 8) /= "Message: " then
|
|
Bad_EO;
|
|
end if;
|
|
|
|
X.Msg_Length := To - From - 8;
|
|
X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
|
|
Next_String;
|
|
|
|
else
|
|
X.Msg_Length := 0;
|
|
end if;
|
|
|
|
X.Pid := 0;
|
|
|
|
if From <= To and then S (From) = 'P' then
|
|
if S (From .. From + 3) /= "PID:" then
|
|
Bad_EO;
|
|
end if;
|
|
|
|
From := From + 5; -- skip past PID: space
|
|
|
|
while From <= To loop
|
|
X.Pid := X.Pid * 10 +
|
|
(Character'Pos (S (From)) - Character'Pos ('0'));
|
|
From := From + 1;
|
|
end loop;
|
|
|
|
Next_String;
|
|
end if;
|
|
|
|
X.Num_Tracebacks := 0;
|
|
|
|
if From <= To then
|
|
if S (From .. To) /= "Call stack traceback locations:" then
|
|
Bad_EO;
|
|
end if;
|
|
|
|
Next_String;
|
|
loop
|
|
exit when From > To;
|
|
|
|
declare
|
|
Ch : Character;
|
|
C : Integer_Address;
|
|
N : Integer_Address;
|
|
|
|
begin
|
|
if S (From) /= '0'
|
|
or else S (From + 1) /= 'x'
|
|
then
|
|
Bad_EO;
|
|
else
|
|
From := From + 2;
|
|
end if;
|
|
|
|
C := 0;
|
|
while From <= To loop
|
|
Ch := S (From);
|
|
|
|
if Ch in '0' .. '9' then
|
|
N :=
|
|
Character'Pos (S (From)) - Character'Pos ('0');
|
|
|
|
elsif Ch in 'a' .. 'f' then
|
|
N :=
|
|
Character'Pos (S (From)) - Character'Pos ('a') + 10;
|
|
|
|
elsif Ch = ' ' then
|
|
From := From + 1;
|
|
exit;
|
|
|
|
else
|
|
Bad_EO;
|
|
end if;
|
|
|
|
C := C * 16 + N;
|
|
|
|
From := From + 1;
|
|
end loop;
|
|
|
|
if X.Num_Tracebacks = Max_Tracebacks then
|
|
Bad_EO;
|
|
end if;
|
|
|
|
X.Num_Tracebacks := X.Num_Tracebacks + 1;
|
|
X.Tracebacks (X.Num_Tracebacks) :=
|
|
TBE.TB_Entry_For (To_Address (C));
|
|
end;
|
|
end loop;
|
|
end if;
|
|
|
|
-- If an exception was converted to a string, it must have
|
|
-- already been raised, so flag it accordingly and we are done.
|
|
|
|
X.Exception_Raised := True;
|
|
return X;
|
|
end if;
|
|
end String_To_EO;
|
|
|
|
end Stream_Attributes;
|