* gnat_rm.texi: Minor reshuffling to place restriction at
appropriate place.
2012-02-08 Bob Duff <duff@adacore.com>
* warnsw.adb (Set_Warning_Switch): Set Warn_On_Suspicious_Modulus_Value
False for '-gnatwA', to suppress these warnings.
2012-02-08 Vincent Celier <celier@adacore.com>
* sinput-p.adb (Source_File_Is_Subunit): Check for BOM before
starting to scan, so that UTF8 encoding is taken into account.
2012-02-08 Arnaud Charlet <charlet@adacore.com>
* s-tasren.adb, s-tasren.ads (Internal_Complete_Rendezvous): New
function.
(Complete_Rendezvous): Now call Internal_Complete_Rendezvous.
(Exceptional_Complete_Rendezvous): Mark No_Return.
2012-02-08 Eric Botcazou <ebotcazou@adacore.com>
* exp_aggr.adb (Compile_Time_Known_Composite_Value):
New predicate to compute whether a composite value can be
evaluated at compile time.
(Component_Not_OK_For_Backend): Use Compile_Time_Known_Value for all
expressions of elementary type and Compile_Time_Known_Composite_Value
for all other expressions.
(Expand_Record_Aggregate): Convert to assignments in the case
of a type with mutable components if the aggregate cannot be
built statically.
2012-02-08 Gary Dismukes <dismukes@adacore.com>
* aspects.ads (type Aspect_Id): Add Simple_Storage_Pool_Type.
(Impl_Defined_Aspects): Add association for
Aspect_Simple_Storage_Pool_Type.
(Aspect_Names): Add
association for Aspect_Simple_Storage_Pool_Type.
* aspects.adb:
(Canonical_Aspect): Add association for Simple_Storage_Pool_Type.
* exp_attr.adb (Expand_N_Attribute_Reference):
Change name to Name_Simple_Storage_Pool_Type.
* exp_ch4.adb (Expand_N_Allocator): Change
name to Name_Simple_Storage_Pool_Type.
* exp_intr.adb (Expand_Unc_Deallocation): Change name to
Name_Simple_Storage_Pool_Type. * freeze.adb (Freeze_Entity):
Change names to Name_Simple_Storage_Pool_Type. * par-prag.adb:
Change names to Name_Simple_Storage_Pool_Type. * sem_attr.adb:
(Analyze_Attribute): Change name to Name_Simple_Storage_Pool_Type.
* sem_ch13.adb (Analyze_Attribute_Definition_Clause):
Change name to Name_Simple_Storage_Pool_Type.
* sem_prag.adb:
(Analyze_Pragma): Change name to Name_Simple_Storage_Pool_Type.
(Sig_Flags): Change name to Name_Simple_Storage_Pool_Type.
* sem_res.adb (Resolve_Allocator): Change name to
Name_Simple_Storage_Pool_Type. * snames.ads-tmpl:
(Name_Simple_Storage_Pool_Type): New name constant.
(type Pragma_Id): Change name to Name_Simple_Storage_Pool_Type and
move to main pragma section because it no longer matches the
attribute name.
* snames.adb-tmpl (Get_Pragma_Id): Remove test for
Name_Simple_Storage_Pool.
(Is_Pragma_Name): Remove test for Name_Simple_Storage_Pool.
2012-02-08 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Add some clarification to -gnatwA and -gnatws.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@184003
138bc75d-0d04-0410-961f-
82ee72b054a4
+2012-02-08 Yannick Moy <moy@adacore.com>
+
+ * gnat_rm.texi: Minor reshuffling to place restriction at
+ appropriate place.
+
+2012-02-08 Bob Duff <duff@adacore.com>
+
+ * warnsw.adb (Set_Warning_Switch): Set Warn_On_Suspicious_Modulus_Value
+ False for '-gnatwA', to suppress these warnings.
+
+2012-02-08 Vincent Celier <celier@adacore.com>
+
+ * sinput-p.adb (Source_File_Is_Subunit): Check for BOM before
+ starting to scan, so that UTF8 encoding is taken into account.
+
+2012-02-08 Arnaud Charlet <charlet@adacore.com>
+
+ * s-tasren.adb, s-tasren.ads (Internal_Complete_Rendezvous): New
+ function.
+ (Complete_Rendezvous): Now call Internal_Complete_Rendezvous.
+ (Exceptional_Complete_Rendezvous): Mark No_Return.
+
+2012-02-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Compile_Time_Known_Composite_Value):
+ New predicate to compute whether a composite value can be
+ evaluated at compile time.
+ (Component_Not_OK_For_Backend): Use Compile_Time_Known_Value for all
+ expressions of elementary type and Compile_Time_Known_Composite_Value
+ for all other expressions.
+ (Expand_Record_Aggregate): Convert to assignments in the case
+ of a type with mutable components if the aggregate cannot be
+ built statically.
+
+2012-02-08 Gary Dismukes <dismukes@adacore.com>
+
+ * aspects.ads (type Aspect_Id): Add Simple_Storage_Pool_Type.
+ (Impl_Defined_Aspects): Add association for
+ Aspect_Simple_Storage_Pool_Type.
+ (Aspect_Names): Add
+ association for Aspect_Simple_Storage_Pool_Type.
+ * aspects.adb:
+ (Canonical_Aspect): Add association for Simple_Storage_Pool_Type.
+ * exp_attr.adb (Expand_N_Attribute_Reference):
+ Change name to Name_Simple_Storage_Pool_Type.
+ * exp_ch4.adb (Expand_N_Allocator): Change
+ name to Name_Simple_Storage_Pool_Type.
+ * exp_intr.adb (Expand_Unc_Deallocation): Change name to
+ Name_Simple_Storage_Pool_Type. * freeze.adb (Freeze_Entity):
+ Change names to Name_Simple_Storage_Pool_Type. * par-prag.adb:
+ Change names to Name_Simple_Storage_Pool_Type. * sem_attr.adb:
+ (Analyze_Attribute): Change name to Name_Simple_Storage_Pool_Type.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause):
+ Change name to Name_Simple_Storage_Pool_Type.
+ * sem_prag.adb:
+ (Analyze_Pragma): Change name to Name_Simple_Storage_Pool_Type.
+ (Sig_Flags): Change name to Name_Simple_Storage_Pool_Type.
+ * sem_res.adb (Resolve_Allocator): Change name to
+ Name_Simple_Storage_Pool_Type. * snames.ads-tmpl:
+ (Name_Simple_Storage_Pool_Type): New name constant.
+ (type Pragma_Id): Change name to Name_Simple_Storage_Pool_Type and
+ move to main pragma section because it no longer matches the
+ attribute name.
+ * snames.adb-tmpl (Get_Pragma_Id): Remove test for
+ Name_Simple_Storage_Pool.
+ (Is_Pragma_Name): Remove test for Name_Simple_Storage_Pool.
+
+2012-02-08 Robert Dewar <dewar@adacore.com>
+
+ * gnat_ugn.texi: Add some clarification to -gnatwA and -gnatws.
+
2012-02-08 Pascal Obry <obry@adacore.com>
* prj.adb (Compute_All_Imported_Projects): Use new
Aspect_Read => Aspect_Read,
Aspect_Shared => Aspect_Atomic,
Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
+ Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
Aspect_Size => Aspect_Size,
Aspect_Small => Aspect_Small,
Aspect_Static_Predicate => Aspect_Predicate,
Aspect_Pure_Function, -- GNAT
Aspect_Remote_Access_Type, -- GNAT
Aspect_Shared, -- GNAT (equivalent to Atomic)
+ Aspect_Simple_Storage_Pool_Type, -- GNAT
Aspect_Suppress_Debug_Info, -- GNAT
Aspect_Unchecked_Union,
Aspect_Universal_Aliasing, -- GNAT
-- The following array identifies all implementation defined aspects
Impl_Defined_Aspects : constant array (Aspect_Id) of Boolean :=
- (Aspect_Ada_2005 => True,
- Aspect_Ada_2012 => True,
- Aspect_Compiler_Unit => True,
- Aspect_Dimension => True,
- Aspect_Dimension_System => True,
- Aspect_Favor_Top_Level => True,
- Aspect_Inline_Always => True,
- Aspect_Object_Size => True,
- Aspect_Persistent_BSS => True,
- Aspect_Predicate => True,
- Aspect_Preelaborate_05 => True,
- Aspect_Pure_05 => True,
- Aspect_Pure_12 => True,
- Aspect_Pure_Function => True,
- Aspect_Remote_Access_Type => True,
- Aspect_Shared => True,
- Aspect_Simple_Storage_Pool => True,
- Aspect_Suppress_Debug_Info => True,
- Aspect_Test_Case => True,
- Aspect_Universal_Data => True,
- Aspect_Universal_Aliasing => True,
- Aspect_Unmodified => True,
- Aspect_Unreferenced => True,
- Aspect_Unreferenced_Objects => True,
- Aspect_Value_Size => True,
- others => False);
+ (Aspect_Ada_2005 => True,
+ Aspect_Ada_2012 => True,
+ Aspect_Compiler_Unit => True,
+ Aspect_Dimension => True,
+ Aspect_Dimension_System => True,
+ Aspect_Favor_Top_Level => True,
+ Aspect_Inline_Always => True,
+ Aspect_Object_Size => True,
+ Aspect_Persistent_BSS => True,
+ Aspect_Predicate => True,
+ Aspect_Preelaborate_05 => True,
+ Aspect_Pure_05 => True,
+ Aspect_Pure_12 => True,
+ Aspect_Pure_Function => True,
+ Aspect_Remote_Access_Type => True,
+ Aspect_Shared => True,
+ Aspect_Simple_Storage_Pool => True,
+ Aspect_Simple_Storage_Pool_Type => True,
+ Aspect_Suppress_Debug_Info => True,
+ Aspect_Test_Case => True,
+ Aspect_Universal_Data => True,
+ Aspect_Universal_Aliasing => True,
+ Aspect_Unmodified => True,
+ Aspect_Unreferenced => True,
+ Aspect_Unreferenced_Objects => True,
+ Aspect_Value_Size => True,
+ others => False);
-- The following array indicates aspects for which multiple occurrences of
-- the same aspect attached to the same declaration are allowed.
Aspect_Shared => Name_Shared,
Aspect_Shared_Passive => Name_Shared_Passive,
Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool,
+ Aspect_Simple_Storage_Pool_Type => Name_Simple_Storage_Pool_Type,
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_Static_Predicate => Name_Static_Predicate,
-- and the aggregate can be constructed statically and handled by
-- the back-end.
+ function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean;
+ -- Returns true if N is an expression of composite type which can be
+ -- fully evaluated at compile time without raising constraint error.
+ -- Such expressions can be passed as is to Gigi without any expansion.
+ --
+ -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
+ -- set and constants whose expression is such an aggregate, recursively.
+
function Component_Not_OK_For_Backend return Boolean;
-- Check for presence of component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- For nested aggregates return the ultimate enclosing aggregate; for
-- non-nested aggregates return N.
+ ----------------------------------------
+ -- Compile_Time_Known_Composite_Value --
+ ----------------------------------------
+
+ function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean
+ is
+
+ begin
+ -- If we have an entity name, then see if it is the name of a
+ -- constant and if so, test the corresponding constant value.
+
+ if Is_Entity_Name (N) then
+ declare
+ E : constant Entity_Id := Entity (N);
+ V : Node_Id;
+
+ begin
+ if Ekind (E) /= E_Constant then
+ return False;
+ end if;
+
+ V := Constant_Value (E);
+ return Present (V)
+ and then Compile_Time_Known_Composite_Value (V);
+ end;
+
+ -- We have a value, see if it is compile time known
+
+ else
+ if Nkind (N) = N_Aggregate then
+ return Compile_Time_Known_Aggregate (N);
+ end if;
+
+ -- All other types of values are not known at compile time
+
+ return False;
+ end if;
+
+ end Compile_Time_Known_Composite_Value;
+
----------------------------------
-- Component_Not_OK_For_Backend --
----------------------------------
return True;
end if;
- if Is_Scalar_Type (Etype (Expr_Q)) then
+ if Is_Elementary_Type (Etype (Expr_Q)) then
if not Compile_Time_Known_Value (Expr_Q) then
Static_Components := False;
end if;
- elsif Nkind (Expr_Q) /= N_Aggregate
- or else not Compile_Time_Known_Aggregate (Expr_Q)
- then
+ elsif not Compile_Time_Known_Composite_Value (Expr_Q) then
Static_Components := False;
if Is_Private_Type (Etype (Expr_Q))
-- may be distinct from the default size of the type component, so
-- we need to expand to insure that the back-end copies the proper
-- size of the data. However, if the aggregate is the initial value of
- -- a constant, the target is immutable and may be built statically.
+ -- a constant, the target is immutable and might be built statically
+ -- if components are appropriate.
elsif Has_Mutable_Components (Typ)
and then
(Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
- or else not Constant_Present (Parent (Top_Level_Aggr)))
+ or else not Constant_Present (Parent (Top_Level_Aggr))
+ or else not Static_Components)
then
Convert_To_Assignments (N, Typ);
-- then the result will default to zero.
if Present (Get_Rep_Pragma (Root_Type (Ptyp),
- Name_Simple_Storage_Pool))
+ Name_Simple_Storage_Pool_Type))
then
declare
Pool_Type : constant Entity_Id :=
-- and save a reference to the pool type's Allocate routine.
elsif Present (Get_Rep_Pragma
- (Etype (Pool), Name_Simple_Storage_Pool))
+ (Etype (Pool), Name_Simple_Storage_Pool_Type))
then
declare
Alloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Allocate);
-- to null.
elsif Present (Get_Rep_Pragma
- (Etype (Pool), Name_Simple_Storage_Pool))
+ (Etype (Pool), Name_Simple_Storage_Pool_Type))
then
declare
Dealloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Deallocate);
-- two are optional). We also verify that the full type for a
-- private type is allowed to be a simple storage pool type.
- if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool))
+ if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type))
and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
then
-- If the type is marked Has_Private_Declaration, then this is
-- a full type for a private type that was specified with the
- -- pragma Simple_Storage_Pool, and here we ensure that the
+ -- pragma Simple_Storage_Pool_Type, and here we ensure that the
-- pragma is allowed for the full type (for example, it can't
-- be an array type, or a nonlimited record type).
or else not Is_Immutably_Limited_Type (E))
and then not Is_Private_Type (E)
then
- Error_Msg_Name_1 := Name_Simple_Storage_Pool;
+ Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
Error_Msg_N
("pragma% can only apply to full type that is an " &
object or a nested component, either declared on the stack or on the heap. The
deallocation of a controlled object no longer finalizes its contents.
-@item No_Implicit_Aliasing
-@findex No_Implicit_Aliasing
-
-This restriction, which is not required to be partition-wide consistent,
-requires an explicit aliased keyword for an object to which 'Access,
-'Unchecked_Access, or 'Address is applied, and forbids entirely the use of
-the 'Unrestricted_Access attribute for objects. Note: the reason that
-Unrestricted_Access is forbidden is that it would require the prefix
-to be aliased, and in such cases, it can always be replaced by
-the standard attribute Unchecked_Access which is preferable.
-
@item No_Implicit_Conditionals
@findex No_Implicit_Conditionals
This restriction ensures that the generated code does not contain any
are present. With this restriction, the only other restriction identifiers
that can be used are those defined in the Ada Reference Manual.
+@item No_Implicit_Aliasing
+@findex No_Implicit_Aliasing
+This restriction, which is not required to be partition-wide consistent,
+requires an explicit aliased keyword for an object to which 'Access,
+'Unchecked_Access, or 'Address is applied, and forbids entirely the use of
+the 'Unrestricted_Access attribute for objects. Note: the reason that
+Unrestricted_Access is forbidden is that it would require the prefix
+to be aliased, and in such cases, it can always be replaced by
+the standard attribute Unchecked_Access which is preferable.
+
@item No_Wide_Characters
@findex No_Wide_Characters
This restriction ensures at compile time that no uses of the types
@cindex @option{-gnatwA} (@command{gcc})
This switch suppresses all optional warning messages, see remaining list
in this section for details on optional warning messages that can be
-individually controlled.
+individually controlled. Note that unlike switch @option{-gnatws}, the
+use of switch @option{-gnatwA} does not suppress warnings that are
+normally given unconditionally and cannot be individually controlled
+(for example, the warning about a missing exit path in a function).
+Also, again unlike switch @option{-gnatws}, warnings suppressed by
+the use of switch @option{-gnatwA} can be individually turned back
+on. For example the use of switch @option{-gnatwA} followed by
+switch @option{-gnatwd} will suppress all optional warnings except
+the warnings for implicit dereferencing.
@item -gnatw.a
@emph{Activate warnings on failing assertions.}
@emph{Suppress all warnings.}
@cindex @option{-gnatws} (@command{gcc})
This switch completely suppresses the
-output of all warning messages from the GNAT front end.
-Note that it does not suppress warnings from the @command{gcc} back end.
+output of all warning messages from the GNAT front end, including
+both warnings that can be controlled by switches described in this
+section, and those that are normally given unconditionally. The
+effect of this suppress action can only be cancelled by a subsequent
+use of the switch @option{-gnatwn}.
+
+Note that switch @option{-gnatws} does not suppress
+warnings from the @command{gcc} back end.
To suppress these back end warnings as well, use the switch @option{-w}
in addition to @option{-gnatws}. Also this switch has no effect on the
handling of style check messages.
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
- Pragma_Simple_Storage_Pool |
+ Pragma_Simple_Storage_Pool_Type |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- debugging it may be wise to modify the above renamings to the
-- non-nestable forms.
+ procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
+ -- Internal version of Complete_Rendezvous, used to implement
+ -- Complete_Rendezvous and Exceptional_Complete_Rendezvous.
+ -- Should be called holding no locks, generally with abort not yet
+ -- deferred.
+
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
pragma Inline (Boost_Priority);
-- Call this only with abort deferred and holding lock of Acceptor
procedure Complete_Rendezvous is
begin
- Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
+ Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
end Complete_Rendezvous;
-------------------------------------
procedure Exceptional_Complete_Rendezvous
(Ex : Ada.Exceptions.Exception_Id)
is
+ procedure Internal_Reraise;
+ pragma No_Return (Internal_Reraise);
+ pragma Import (C, Internal_Reraise, "__gnat_reraise");
+
+ begin
+ Local_Complete_Rendezvous (Ex);
+ Internal_Reraise;
+
+ -- ??? Do we need to give precedence to Program_Error that might be
+ -- raised due to failure of finalization, over Tasking_Error from
+ -- failure of requeue?
+ end Exceptional_Complete_Rendezvous;
+
+ -------------------------------
+ -- Local_Complete_Rendezvous --
+ -------------------------------
+
+ procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
Caller : Task_Id;
Called_PO : STPE.Protection_Entries_Access;
Acceptor_Prev_Priority : Integer;
- Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
Ceiling_Violation : Boolean;
use type Ada.Exceptions.Exception_Id;
- procedure Internal_Reraise;
- pragma Import (C, Internal_Reraise, "__gnat_reraise");
-
procedure Transfer_Occurrence
(Target : Ada.Exceptions.Exception_Occurrence_Access;
Source : Ada.Exceptions.Exception_Occurrence);
use type STPE.Protection_Entries_Access;
begin
- -- Consider phasing out Complete_Rendezvous in favor of direct call to
- -- this with Ada.Exceptions.Null_ID. See code expansion examples for
- -- Accept_Call and Selective_Wait. Also consider putting an explicit
- -- re-raise after this call, in the generated code. That way we could
- -- eliminate the code here that reraises the exception.
-
-- The deferral level is critical here, since we want to raise an
-- exception or allow abort to take place, if there is an exception or
-- abort pending.
pragma Debug
- (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
+ (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
if Ex = Ada.Exceptions.Null_Id then
if Ceiling_Violation then
pragma Assert (Ex = Ada.Exceptions.Null_Id);
-
- Exception_To_Raise := Program_Error'Identity;
- Entry_Call.Exception_To_Raise := Exception_To_Raise;
+ Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
Lock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
-
- if Exception_To_Raise /= Ada.Exceptions.Null_Id then
- Internal_Reraise;
- end if;
-
- -- ??? Do we need to give precedence to Program_Error that might be
- -- raised due to failure of finalization, over Tasking_Error from
- -- failure of requeue?
-
- end Exceptional_Complete_Rendezvous;
+ end Local_Complete_Rendezvous;
-------------------------------------
-- Requeue_Protected_To_Task_Entry --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
procedure Exceptional_Complete_Rendezvous
(Ex : Ada.Exceptions.Exception_Id);
+ pragma No_Return (Exceptional_Complete_Rendezvous);
-- Called by acceptor to mark the end of the current rendezvous and
-- propagate an exception to the caller.
if Attr_Id = Attribute_Storage_Pool then
if Present (Get_Rep_Pragma (Etype (Entity (N)),
- Name_Simple_Storage_Pool))
+ Name_Simple_Storage_Pool_Type))
then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("cannot use % attribute for type with simple " &
else
if not Present (Get_Rep_Pragma (Etype (Entity (N)),
- Name_Simple_Storage_Pool))
+ Name_Simple_Storage_Pool_Type))
then
Error_Attr_P
("cannot use % attribute for type without simple " &
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
-- In the Simple_Storage_Pool case, we allow a variable of any
- -- Simple_Storage_Pool type, so we Resolve without imposing an
+ -- simple storage pool type, so we Resolve without imposing an
-- expected type.
else
Analyze_And_Resolve (Expr);
if not Present (Get_Rep_Pragma
- (Etype (Expr), Name_Simple_Storage_Pool))
+ (Etype (Expr), Name_Simple_Storage_Pool_Type))
then
Error_Msg_N
("expression must be of a simple storage pool type", Expr);
Check_Valid_Configuration_Pragma;
Short_Descriptors := True;
- -------------------------
- -- Simple_Storage_Pool --
- -------------------------
+ ------------------------------
+ -- Simple_Storage_Pool_Type --
+ ------------------------------
- -- pragma Simple_Storage_Pool (type_LOCAL_NAME);
+ -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
- when Pragma_Simple_Storage_Pool => Simple_Storage_Pool : declare
- Type_Id : Node_Id;
- Typ : Entity_Id;
+ when Pragma_Simple_Storage_Pool_Type =>
+ Simple_Storage_Pool_Type : declare
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
begin
GNAT_Pragma;
end if;
Record_Rep_Item (Typ, N);
- end Simple_Storage_Pool;
+ end Simple_Storage_Pool_Type;
----------------------
-- Source_File_Name --
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
- Pragma_Simple_Storage_Pool => 0,
+ Pragma_Simple_Storage_Pool_Type => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
:= Associated_Storage_Pool (Root_Type (Typ));
begin
if Present (Pool)
- and then Present (Get_Rep_Pragma
- (Etype (Pool), Name_Simple_Storage_Pool))
+ and then
+ Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool_Type))
then
Error_Msg_N
("limited function calls not yet supported in simple " &
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, 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- --
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
+with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
+
+with Opt; use Opt;
+with Output; use Output;
with Prj.Err;
with Sinput.C;
with System;
+with System.WCh_Con; use System.WCh_Con;
package body Sinput.P is
Prj.Err.Scanner.Set_Special_Character ('#');
Prj.Err.Scanner.Set_Special_Character ('$');
+ -- Check for BOM
+
+ declare
+ BOM : BOM_Kind;
+ Len : Natural;
+ Tst : String (1 .. 5);
+
+ begin
+ for J in 1 .. 5 loop
+ Tst (J) := Source (Scan_Ptr + Source_Ptr (J) - 1);
+ end loop;
+
+ Read_BOM (Tst, Len, BOM, False);
+
+ case BOM is
+ when UTF8_All =>
+ Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
+ Wide_Character_Encoding_Method := WCEM_UTF8;
+ Upper_Half_Encoding := True;
+
+ when UTF16_LE | UTF16_BE =>
+ Set_Standard_Error;
+ Write_Line ("UTF-16 encoding format not recognized");
+ Set_Standard_Output;
+ raise Unrecoverable_Error;
+
+ when UTF32_LE | UTF32_BE =>
+ Set_Standard_Error;
+ Write_Line ("UTF-32 encoding format not recognized");
+ Set_Standard_Output;
+ raise Unrecoverable_Error;
+
+ when Unknown =>
+ null;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end;
+
-- We scan past junk to the first interesting compilation unit token, to
-- see if it is SEPARATE. We ignore WITH keywords during this and also
-- PRIVATE. The reason for ignoring PRIVATE is that it handles some
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
return Pragma_Relative_Deadline;
- elsif N = Name_Simple_Storage_Pool then
- return Pragma_Simple_Storage_Pool;
elsif N = Name_Storage_Size then
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
or else N = Name_Interface
or else N = Name_Relative_Deadline
or else N = Name_Priority
- or else N = Name_Simple_Storage_Pool
or else N = Name_Storage_Size
or else N = Name_Storage_Unit;
end Is_Pragma_Name;
Name_Share_Generic : constant Name_Id := N + $; -- GNAT
Name_Shared : constant Name_Id := N + $; -- Ada 83
Name_Shared_Passive : constant Name_Id := N + $;
+ Name_Simple_Storage_Pool_Type : constant Name_Id := N + $; -- GNAT
-- Note: Storage_Size is not in this list because its name matches the name
-- of the corresponding attribute. However, it is included in the
Pragma_Share_Generic,
Pragma_Shared,
Pragma_Shared_Passive,
+ Pragma_Simple_Storage_Pool_Type,
Pragma_Source_Reference,
Pragma_Static_Elaboration_Desired,
Pragma_Stream_Convert,
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Priority,
- Pragma_Simple_Storage_Pool,
Pragma_Storage_Size,
Pragma_Storage_Unit,
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
Warn_On_Redundant_Constructs := False;
Warn_On_Reverse_Bit_Order := False;
Warn_On_Suspicious_Contract := False;
+ Warn_On_Suspicious_Modulus_Value := False;
Warn_On_Unchecked_Conversion := False;
Warn_On_Unordered_Enumeration_Type := False;
Warn_On_Unrecognized_Pragma := False;
OSDN Git Service
