-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
pragma Inline (Check_Wakeup);
function Check_Unlock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Lock);
+ pragma Inline (Check_Unlock);
function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
pragma Inline (Check_Finalize_Lock);
pragma Unreferenced (Code);
pragma Unreferenced (Context);
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
Old_Set : aliased sigset_t;
Result : Interfaces.C.int;
-----------------
function Record_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
is
pragma Unreferenced (Reason);
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
------------------
function Check_Unlock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
use type System.CRTL.size_t;
- -- Substantial rewriting is needed here. These functions are far too
- -- long to be inlined. They should be rewritten to be small helper
- -- functions that are inlined, and then call the real routines.???
+ -- As the functions fread, fwrite and setvbuf are too big to be inlined,
+ -- they are just wrappers to the following implementation functions.
- -- Alternatively, provide a separate spec for VMS, in which case we
- -- could reduce the amount of junk bodies in the other cases by
- -- interfacing directly in the spec.???
+ function fread_impl
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t;
+
+ function fread_impl
+ (buffer : voids;
+ index : size_t;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t;
+
+ function fwrite_impl
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t;
+
+ function setvbuf_impl
+ (stream : FILEs;
+ buffer : chars;
+ mode : int;
+ size : size_t) return int;
------------
-- fread --
------------
- function fread
+ function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
end loop;
return Get_Count;
- end fread;
-
- ------------
- -- fread --
- ------------
+ end fread_impl;
- function fread
+ function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
end loop;
return Get_Count;
+ end fread_impl;
+
+ function fread
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t
+ is
+ begin
+ return fread_impl (buffer, size, count, stream);
+ end fread;
+
+ function fread
+ (buffer : voids;
+ index : size_t;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t
+ is
+ begin
+ return fread_impl (buffer, index, size, count, stream);
end fread;
------------
-- fwrite --
------------
- function fwrite
+ function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
end loop;
return Put_Count;
+ end fwrite_impl;
+
+ function fwrite
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs) return size_t
+ is
+ begin
+ return fwrite_impl (buffer, size, count, stream);
end fwrite;
-------------
-- setvbuf --
-------------
- function setvbuf
+ function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
return System.CRTL.setvbuf
(stream, buffer, mode, System.CRTL.size_t (size));
end if;
+ end setvbuf_impl;
+
+ function setvbuf
+ (stream : FILEs;
+ buffer : chars;
+ mode : int;
+ size : size_t) return int
+ is
+ begin
+ return setvbuf_impl (stream, buffer, mode, size);
end setvbuf;
end Interfaces.C_Streams;
+2004-02-02 Vincent Celier <celier@gnat.com>
+
+ * gprcmd.adb (Check_Args): If condition is false, print the invoked
+ comment before the usage.
+ Gprcmd: Fail when command is not recognized.
+ (Usage): Document command "prefix"
+
+ * g-md5.adb (Digest): Process last block.
+ (Update): Do not process last block. Store remaining characters and
+ length in Context.
+
+ * g-md5.ads (Update): Document that several call to update are
+ equivalent to one call with the concatenated string.
+ (Context): Add fields to allow new Update behaviour.
+
+ * fname-uf.ads/adb (Get_File_Name): New Boolean parameter May_Fail,
+ defaulted to False.
+ When May_Fail is True and no existing file can be found, return No_File.
+
+ * 6vcstrea.adb: Inlined functions are now wrappers to implementation
+ functions.
+
+ * lib-writ.adb (Write_With_Lines): When body file does not exist, use
+ spec file name instead on the W line.
+
+2004-02-02 Robert Dewar <dewar@gnat.com>
+
+ * ali.adb: Read and acquire info from new format restrictions lines
+
+ * bcheck.adb: Add circuits for checking restrictions with parameters
+
+ * bindgen.adb: Output dummy restrictions data
+ To be changed later
+
+ * ali.ads, checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb,
+ exp_ch3.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_util.adb,
+ freeze.adb, gnat1drv.adb, sem_attr.adb, sem_ch10.adb, sem_ch11.adb,
+ sem_ch12.adb, targparm.adb, targparm.ads, tbuild.adb, sem_ch2.adb,
+ sem_elab.adb, sem_res.adb: Minor changes for new restrictions handling.
+
+ * exp_ch9.adb (Build_Master_Entity): Cleanup the code (also suppresses
+ the warning message on access to possibly uninitialized variable S)
+ Minor changes for new restrictions handling.
+
+ * gnatbind.adb: Minor reformatting
+ Minor changes for new restrictions handling
+ Move circuit for -r processing here from bcheck (cleaner)
+
+ * gnatcmd.adb, gnatlink.adb: Minor reformatting
+
+ * lib-writ.adb: Output new format restrictions lines
+
+ * lib-writ.ads: Document new R format lines for new restrictions
+ handling.
+
+ * s-restri.ads/adb: New files
+
+ * Makefile.rtl: Add entry for s-restri.ads/adb
+
+ * par-ch3.adb: Fix bad error messages starting with upper case letter
+ Minor reformatting
+
+ * restrict.adb: Major rewrite throughout for new restrictions handling
+ Major point is to handle restrictions with parameters
+
+ * restrict.ads: Major changes in interface to handle restrictions with
+ parameters. Also generally simplifies setting of restrictions.
+
+ * snames.ads/adb: New entry for proper handling of No_Requeue
+
+ * sem_ch3.adb (Count_Tasks): New circuitry for implementing Max_Tasks
+ restriction counting.
+ Other minor changes for new restrictions handling
+
+ * sem_prag.adb: No_Requeue is a synonym for No_Requeue_Statements.
+ Restriction_Warnings now allows full parameter notation
+ Major rewrite of Restrictions for new restrictions handling
+
+2004-02-02 Javier Miranda <miranda@gnat.com>
+
+ * par-ch3.adb (P_Identifier_Declarations): Give support to the Ada 0Y
+ syntax rule for object renaming declarations.
+ (P_Array_Type_Definition): Give support for the Ada 0Y syntax rule for
+ component definitions.
+
+ * sem_ch3.adb (Analyze_Component_Declaration): Give support to access
+ components.
+ (Array_Type_Declaration): Give support to access components. In addition
+ it was also modified to reflect the name of the object in anonymous
+ array types. The old code did not take into account that it is possible
+ to have an unconstrained anonymous array with an initial value.
+ (Check_Or_Process_Discriminants): Allow access discriminant in
+ non-limited types.
+ (Process_Discriminants): Allow access discriminant in non-limited types
+ Initialize the new Access_Definition field in N_Object_Renaming_Decl
+ node. Change Ada0Y to Ada 0Y in comments
+
+ * sem_ch4.adb (Find_Equality_Types): Allow anonymous access types in
+ equality operators.
+ Change Ada0Y to Ada 0Y in comments
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Give support to access
+ renamings Change Ada0Y to Ada 0Y in comments
+
+ * sem_type.adb (Find_Unique_Type): Give support to the equality
+ operators for universal access types
+ Change Ada0Y to Ada 0Y in comments
+
+ * sinfo.adb (Access_Definition, Set_Access_Definition): New subprograms
+
+ * sinfo.ads (N_Component_Definition): Addition of Access_Definition
+ field.
+ (N_Object_Renaming_Declaration): Addition of Access_Definition field
+ Change Ada0Y to Ada 0Y in comments
+
+ * sprint.adb (Sprint_Node_Actual): Give support to the new syntax for
+ component definition and object renaming nodes
+ Change Ada0Y to Ada 0Y in comments
+
+2004-02-02 Jose Ruiz <ruiz@act-europe.fr>
+
+ * restrict.adb: Use the new restriction identifier
+ No_Requeue_Statements instead of the old No_Requeue for defining the
+ restricted profile.
+
+ * sem_ch9.adb (Analyze_Requeue): Check the new restriction
+ No_Requeue_Statements.
+
+ * s-rident.ads: Adding restriction No_Requeue_Statements (AI-00249)
+ that supersedes the GNAT specific restriction No_Requeue. The later is
+ kept for backward compatibility.
+
+2004-02-02 Ed Schonberg <schonberg@gnat.com>
+
+ * lib.ads, i-cobol.ads, * s-stoele.ads, s-thread.ads, style.ads,
+ 5staprop.adb, atree.adb, atree.ads, g-crc32.ads: Remove redundant
+ pragma and fix incorrect ones.
+
+ * sem_prag.adb For pragma Inline and pragma Pure_Function, emit a
+ warning if the pragma is redundant.
+
+2004-02-02 Thomas Quinot <quinot@act-europe.fr>
+
+ * 5staprop.adb: Add missing 'constant' keywords.
+
+ * Makefile.in: use consistent value for SYMLIB on
+ platforms where libaddr2line is supported.
+
+2004-02-02 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * utils.c (end_subprog_body): Do not call rest_of_compilation if just
+ annotating types.
+
+2004-02-02 Olivier Hainque <hainque@act-europe.fr>
+
+ * init.c (__gnat_install_handler): Setup an alternate stack for signal
+ handlers in the environment thread. This allows proper propagation of
+ an exception on stack overflows in this thread even when the builtin
+ ABI stack-checking scheme is used without support for a stack reserve
+ region.
+
+ * utils.c (create_field_decl): Augment the head comment about bitfield
+ creation, and don't account for DECL_BIT_FIELD in DECL_NONADDRESSABLE_P
+ here, because the former is not accurate enough at this point.
+ Let finish_record_type decide instead.
+ Don't make a bitfield if the field is to be addressable.
+ Always set a size for the field if the record is packed, to ensure the
+ checks for bitfield creation are triggered.
+ (finish_record_type): During last pass over the fields, clear
+ DECL_BIT_FIELD when possible in the !STRICT_ALIGNMENT case, as this is
+ not covered by the calls to layout_decl. Adjust DECL_NONADDRESSABLE_P
+ from DECL_BIT_FIELD.
+
2004-01-30 Kelley Cook <kcook@gcc.gnu.org>
* Make-lang.in (doc/gnat_ug_unx.dvi): Use $(abs_docdir).
GMEM_LIB =
MISCLIB =
SYMLIB =
+ADDR2LINE_SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
SYMDEPS = $(LIBINTL_DEP)
OUTPUT_OPTION = @OUTPUT_OPTION@
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
- SYMLIB = -laddr2line -lbfd $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
s-parame.adb<5lparame.adb \
system.ads<5lsystem.ads
- TOOLS_TARGET_PAIRS = mlib-tgt.adb<5lml-tgt.adb
- SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
+ TOOLS_TARGET_PAIRS = \
+ mlib-tgt.adb<5lml-tgt.adb
+
+ SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5hml-tgt.adb
TGT_LIB = /usr/lib/libcl.a
THREADSLIB = -lpthread
- SYMLIB = -laddr2line -lbfd $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib
soext = .sl
SO_OPTS = -Wl,+h,
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5bml-tgt.adb
GMEM_LIB = gmemlib
- SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
endif
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5aml-tgt.adb
GMEM_LIB=gmemlib
- SYMLIB = -laddr2line -lbfd $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5wml-tgt.adb
MISCLIB = -lwsock32
- SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
EXTRA_GNATTOOLS = ../../gnatdll$(exeext)
system.ads<5nsystem.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb
- SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
+ SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
s-poosiz$(objext) \
s-powtab$(objext) \
s-purexc$(objext) \
+ s-restri$(objext) \
s-rident$(objext) \
- s-rpc$(objext) \
+ s-rpc$(objext) \
s-scaval$(objext) \
s-secsta$(objext) \
s-sequio$(objext) \
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- be ignored by Scan_ALI and skipped, and False if the lines
-- are to be read and processed.
+ Restrictions_Initial : Rident.Restrictions_Info;
+ pragma Warnings (Off, Restrictions_Initial);
+ -- This variable, which should really be a constant (but that's not
+ -- allowed by the language) is used only for initialization, and the
+ -- reason we are declaring it is to get the default initialization
+ -- set for the object.
+
Bad_ALI_Format : exception;
-- Exception raised by Fatal_Error if Err is True
Skip_Space;
V := 0;
-
loop
V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
exit when At_End_Of_Field;
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
Queuing_Policy => ' ',
- Restrictions => (others => ' '),
+ Restrictions => Restrictions_Initial,
Sfile => No_Name,
Task_Dispatching_Policy => ' ',
Time_Slice_Value => -1,
Queuing_Policy_Specified := Getc;
ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
- -- Processing fir flags starting with S
+ -- Processing for flags starting with S
elsif C = 'S' then
C := Getc;
C := Getc;
- -- Acquire restrictions line
+ -- Acquire first restrictions line
if C /= 'R' then
Fatal_Error;
Checkc (' ');
Skip_Space;
- for J in All_Restrictions loop
+ for R in All_Boolean_Restrictions loop
C := Getc;
- ALIs.Table (Id).Restrictions (J) := C;
case C is
when 'v' =>
- Restrictions (J) := 'v';
+ ALIs.Table (Id).Restrictions.Violated (R) := True;
+ Cumulative_Restrictions.Violated (R) := True;
when 'r' =>
- if Restrictions (J) = 'n' then
- Restrictions (J) := 'r';
- end if;
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Set (R) := True;
when 'n' =>
null;
C := Getc;
+ -- See if we have a second R line
+
+ if C /= 'R' then
+
+ -- If not, just ignore, and leave the restrictions variables
+ -- unchanged. This is useful for dealing with old format ALI
+ -- files with only one R line (this can be removed later on,
+ -- but is useful for transitional purposes).
+
+ null;
+
+ -- Here we have a second R line, ignore it if ignore flag set
+
+ elsif Ignore ('R') then
+ Skip_Line;
+ C := Getc;
+
+ -- Otherwise acquire second R line
+
+ else
+ Checkc (' ');
+ Skip_Space;
+
+ for RP in All_Parameter_Restrictions loop
+
+ -- Acquire restrictions pragma information
+
+ case Getc is
+ when 'n' =>
+ null;
+
+ when 'r' =>
+ ALIs.Table (Id).Restrictions.Set (RP) := True;
+
+ declare
+ N : constant Integer := Integer (Get_Nat);
+ begin
+ ALIs.Table (Id).Restrictions.Value (RP) := N;
+
+ if Cumulative_Restrictions.Set (RP) then
+ Cumulative_Restrictions.Value (RP) :=
+ Integer'Min (Cumulative_Restrictions.Value (RP), N);
+ else
+ Cumulative_Restrictions.Set (RP) := True;
+ Cumulative_Restrictions.Value (RP) := N;
+ end if;
+ end;
+
+ when others =>
+ Fatal_Error;
+ end case;
+
+ -- Acquire restrictions violations information
+
+ case Getc is
+ when 'n' =>
+ null;
+
+ when 'v' =>
+ ALIs.Table (Id).Restrictions.Violated (RP) := True;
+ Cumulative_Restrictions.Violated (RP) := True;
+
+ declare
+ N : constant Integer := Integer (Get_Nat);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ ALIs.Table (Id).Restrictions.Count (RP) := N;
+
+ if RP in Checked_Max_Parameter_Restrictions then
+ Cumulative_Restrictions.Count (RP) :=
+ Integer'Max (Cumulative_Restrictions.Count (RP), N);
+ else
+ Cumulative_Restrictions.Count (RP) :=
+ Cumulative_Restrictions.Count (RP) + N;
+ end if;
+
+ exception
+ when Constraint_Error =>
+
+ -- A constraint error comes from the addition in
+ -- the else branch. We reset to the maximum and
+ -- indicate that the real value is now unknown.
+
+ Cumulative_Restrictions.Value (RP) := Integer'Last;
+ Cumulative_Restrictions.Unknown (RP) := True;
+ end;
+
+ if Nextc = '+' then
+ Skipc;
+ ALIs.Table (Id).Restrictions.Unknown (RP) := True;
+ Cumulative_Restrictions.Unknown (RP) := True;
+ end if;
+
+ when others =>
+ Fatal_Error;
+ end case;
+ end loop;
+
+ Skip_Eol;
+ C := Getc;
+ end if;
+
-- Acquire 'I' lines if present
while C = 'I' loop
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
type Main_Program_Type is (None, Proc, Func);
-- Indicator of whether unit can be used as main program
- type Restrictions_String is array (All_Restrictions) of Character;
- -- Type used to hold string from R line
-
type ALIs_Record is record
Afile : File_Name_Type;
-- Set to True if file was compiled with zero cost exceptions.
-- Not set if 'P' appears in Ignore_Lines.
- Restrictions : Restrictions_String;
- -- Copy of restrictions letters from R line.
- -- Not set if 'R' appears in Ignore_Lines.
+ Restrictions : Restrictions_Info;
+ -- Restrictions information reconstructed from R lines
First_Interrupt_State : Interrupt_State_Id;
Last_Interrupt_State : Interrupt_State_Id'Base;
-- Set to blank by Initialize_ALI. Set to the appropriate queuing policy
-- character if an ali file contains a P line setting the queuing policy.
- Restrictions : Restrictions_String := (others => 'n');
- -- This array records the cumulative contributions of R lines in all
- -- ali files. An entry is changed will be set to v if any ali file
- -- indicates that the restriction is violated, and otherwise will be
- -- set to r if the restriction is specified by some unit.
+ Cumulative_Restrictions : Restrictions_Info;
+ -- This variable records the cumulative contributions of R lines in all
+ -- ali files, showing whether a restriction pragma exists anywhere, and
+ -- accumulating the aggregate knowledge of violations.
Static_Elaboration_Model_Used : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if any ALI file for a
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
procedure New_Entity_Debugging_Output;
-- Debugging routine for debug flag N
+ pragma Inline (New_Entity_Debugging_Output);
---------------------------------
-- New_Entity_Debugging_Output --
end if;
end New_Entity_Debugging_Output;
- pragma Inline (New_Entity_Debugging_Output);
-
-- Start of processing for New_Entity
begin
procedure New_Node_Debugging_Output;
-- Debugging routine for debug flag N
+ pragma Inline (New_Node_Debugging_Output);
--------------------------
-- New_Debugging_Output --
end if;
end New_Node_Debugging_Output;
- pragma Inline (New_Node_Debugging_Output);
-
-- Start of processing for New_Node
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
pragma Inline (Flag151);
function Flag152 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag152);
function Flag153 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag153);
function Flag154 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag154);
function Flag155 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag155);
function Flag156 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag156);
function Flag157 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag157);
function Flag158 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
+ pragma Inline (Flag158);
function Flag159 (N : Node_Id) return Boolean;
pragma Inline (Flag159);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars;
- procedure Check_Consistent_Partition_Restrictions;
procedure Check_Consistent_Queuing_Policy;
+ procedure Check_Consistent_Restrictions;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Consistency_Error_Msg (Msg : String);
Check_Consistent_Normalize_Scalars;
Check_Consistent_Dynamic_Elaboration_Checking;
- Check_Consistent_Partition_Restrictions;
+ Check_Consistent_Restrictions;
Check_Consistent_Interrupt_States;
end Check_Configuration_Consistency;
end if;
end Check_Consistent_Normalize_Scalars;
- ---------------------------------------------
- -- Check_Consistent_Partition_Restrictions --
- ---------------------------------------------
-
- -- The rule is that if a restriction is specified in any unit,
- -- then all units must obey the restriction. The check applies
- -- only to restrictions which require partition wide consistency,
- -- and not to internal units.
-
- -- The check is done in two steps. First for every restriction
- -- a unit specifying that restriction is found, if any.
- -- Second, all units are verified against the specified restrictions.
-
- procedure Check_Consistent_Partition_Restrictions is
- No_Restriction_List : constant array (All_Restrictions) of Boolean :=
- (No_Implicit_Conditionals => True,
- -- This could modify and pessimize generated code
-
- No_Implicit_Dynamic_Code => True,
- -- This could modify and pessimize generated code
-
- No_Implicit_Loops => True,
- -- This could modify and pessimize generated code
+ -------------------------------------
+ -- Check_Consistent_Queuing_Policy --
+ -------------------------------------
- No_Recursion => True,
- -- Not checkable at compile time
+ -- The rule is that all files for which the queuing policy is
+ -- significant must be compiled with the same setting.
- No_Reentrancy => True,
- -- Not checkable at compile time
+ procedure Check_Consistent_Queuing_Policy is
+ begin
+ -- First search for a unit specifying a policy and then
+ -- check all remaining units against it.
- others => False);
- -- Define those restrictions that should be output if the gnatbind -r
- -- switch is used. Not all restrictions are output for the reasons given
- -- above in the list, and this array is used to test whether the
- -- corresponding pragma should be listed. True means that it should not
- -- be listed.
+ Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).Queuing_Policy /= ' ' then
+ Check_Policy : declare
+ Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
+ begin
+ for A2 in A1 + 1 .. ALIs.Last loop
+ if ALIs.Table (A2).Queuing_Policy /= ' '
+ and then
+ ALIs.Table (A2).Queuing_Policy /= Policy
+ then
+ Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
- R : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id);
- -- Record the first unit specifying each compilation unit restriction
+ Consistency_Error_Msg
+ ("% and % compiled with different queuing policies");
+ exit Find_Policy;
+ end if;
+ end loop;
+ end Check_Policy;
- V : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id);
- -- Record the last unit violating each partition restriction. Note
- -- that entries in this array that do not correspond to partition
- -- restrictions can never be modified.
+ exit Find_Policy;
+ end if;
+ end loop Find_Policy;
+ end Check_Consistent_Queuing_Policy;
- Additional_Restrictions_Listed : Boolean := False;
- -- Set True if we have listed header for restrictions
+ -----------------------------------
+ -- Check_Consistent_Restrictions --
+ -----------------------------------
- begin
- -- Loop to find restrictions
+ -- The rule is that if a restriction is specified in any unit,
+ -- then all units must obey the restriction. The check applies
+ -- only to restrictions which require partition wide consistency,
+ -- and not to internal units.
- for A in ALIs.First .. ALIs.Last loop
- for J in All_Restrictions loop
- if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then
- R (J) := A;
- end if;
- end loop;
- end loop;
+ procedure Check_Consistent_Restrictions is
+ Restriction_File_Output : Boolean;
+ -- Shows if we have output header messages for restriction violation
- -- Loop to find violations
+ procedure Print_Restriction_File (R : All_Restrictions);
+ -- Print header line for R if not printed yet
- for A in ALIs.First .. ALIs.Last loop
- for J in All_Restrictions loop
- if ALIs.Table (A).Restrictions (J) = 'v'
- and then not Is_Internal_File_Name (ALIs.Table (A).Sfile)
- then
- -- A violation of a restriction was found
+ ----------------------------
+ -- Print_Restriction_File --
+ ----------------------------
- V (J) := A;
+ procedure Print_Restriction_File (R : All_Restrictions) is
+ begin
+ if not Restriction_File_Output then
+ Restriction_File_Output := True;
- -- If this is a paritition restriction, and the restriction
- -- was specified in some unit in the partition, then this
- -- is a violation of the consistency requirement, so we
- -- generate an appropriate error message.
+ -- Find the ali file specifying the restriction
- if R (J) /= No_ALI_Id
- and then J in Partition_Restrictions
+ for A in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A).Restrictions.Set (R)
+ and then (R in All_Boolean_Restrictions
+ or else ALIs.Table (A).Restrictions.Value (R) =
+ Cumulative_Restrictions.Value (R))
then
+ -- We have found that ALI file A specifies the restriction
+ -- that is being violated (the minimum value is specified
+ -- in the case of a parameter restriction).
+
declare
- M1 : constant String := "% has Restriction (";
- S : constant String := Restriction_Id'Image (J);
- M2 : String (1 .. M1'Length + S'Length + 1);
+ M1 : constant String := "% has restriction ";
+ S : constant String := Restriction_Id'Image (R);
+ M2 : String (1 .. 200); -- big enough!
+ P : Integer;
begin
Name_Buffer (1 .. S'Length) := S;
Name_Len := S'Length;
- Set_Casing
- (Units.Table (ALIs.Table (R (J)).First_Unit).Icasing);
+ Set_Casing (Mixed_Case);
M2 (M1'Range) := M1;
- M2 (M1'Length + 1 .. M2'Last - 1) :=
- Name_Buffer (1 .. S'Length);
- M2 (M2'Last) := ')';
+ P := M1'Length + 1;
+ M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length);
+ P := P + S'Length;
+
+ if R in All_Parameter_Restrictions then
+ M2 (P .. P + 4) := " => #";
+ Error_Msg_Nat_1 :=
+ Int (Cumulative_Restrictions.Value (R));
+ P := P + 5;
+ end if;
- Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile;
- Consistency_Error_Msg (M2);
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
+ Consistency_Error_Msg (M2 (1 .. P - 1));
Consistency_Error_Msg
- ("but file % violates this restriction");
+ ("but the following files violate this restriction:");
end;
end if;
- end if;
- end loop;
- end loop;
+ end loop;
+ end if;
+ end Print_Restriction_File;
- -- List applicable restrictions if option set
+ -- Start of processing for Check_Consistent_Restrictions
- if List_Restrictions then
+ begin
+ -- Loop through all restriction violations
- -- List any restrictions which were not violated and not specified
+ for R in All_Restrictions loop
- for J in All_Restrictions loop
- if V (J) = No_ALI_Id
- and then R (J) = No_ALI_Id
- and then not No_Restriction_List (J)
- then
- if not Additional_Restrictions_Listed then
- Write_Eol;
- Write_Line
- ("The following additional restrictions may be" &
- " applied to this partition:");
- Additional_Restrictions_Listed := True;
- end if;
+ -- Check for violation of this restriction
- Write_Str ("pragma Restrictions (");
+ if Cumulative_Restrictions.Set (R)
+ and then Cumulative_Restrictions.Violated (R)
+ and then (R in Partition_Boolean_Restrictions
+ or else (R in All_Parameter_Restrictions
+ and then
+ Cumulative_Restrictions.Count (R) >
+ Cumulative_Restrictions.Value (R)))
+ then
+ Restriction_File_Output := False;
- declare
- S : constant String := Restriction_Id'Image (J);
- begin
- Name_Len := S'Length;
- Name_Buffer (1 .. Name_Len) := S;
- end;
+ -- Loop through files looking for violators
- Set_Casing (Mixed_Case);
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Str (");");
- Write_Eol;
- end if;
- end loop;
- end if;
- end Check_Consistent_Partition_Restrictions;
+ for A2 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A2).Restrictions.Violated (R) then
- -------------------------------------
- -- Check_Consistent_Queuing_Policy --
- -------------------------------------
+ -- We exclude predefined files from the list of
+ -- violators. This should be rethought. It is not
+ -- clear that this is the right thing to do, that
+ -- is particularly the case for restricted runtimes.
- -- The rule is that all files for which the queuing policy is
- -- significant must be compiled with the same setting.
+ if not Is_Internal_File_Name (ALIs.Table (A2).Sfile) then
+ Print_Restriction_File (R);
- procedure Check_Consistent_Queuing_Policy is
- begin
- -- First search for a unit specifying a policy and then
- -- check all remaining units against it.
+ Error_Msg_Name_1 := ALIs.Table (A2).Sfile;
- Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A1).Queuing_Policy /= ' ' then
- Check_Policy : declare
- Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
- begin
- for A2 in A1 + 1 .. ALIs.Last loop
- if ALIs.Table (A2).Queuing_Policy /= ' '
- and then
- ALIs.Table (A2).Queuing_Policy /= Policy
- then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ if R in All_Boolean_Restrictions then
+ Consistency_Error_Msg (" %");
- Consistency_Error_Msg
- ("% and % compiled with different queuing policies");
- exit Find_Policy;
- end if;
- end loop;
- end Check_Policy;
+ elsif R in Checked_Add_Parameter_Restrictions
+ or else ALIs.Table (A2).Restrictions.Count (R) >
+ Cumulative_Restrictions.Value (R)
+ then
+ Error_Msg_Nat_1 :=
+ Int (ALIs.Table (A2).Restrictions.Count (R));
- exit Find_Policy;
+ if ALIs.Table (A2).Restrictions.Unknown (R) then
+ Consistency_Error_Msg
+ (" % (count = at least #)");
+ else
+ Consistency_Error_Msg
+ (" % (count = #)");
+ end if;
+ end if;
+ end if;
+ end if;
+ end loop;
end if;
- end loop Find_Policy;
- end Check_Consistent_Queuing_Policy;
+ end loop;
+ end Check_Consistent_Restrictions;
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
Write_Statement_Buffer;
Set_String (" """);
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
+ for J in All_Restrictions loop
+ null;
end loop;
Set_String (""";");
Set_String (" const char *restrictions = """);
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
+ for J in All_Restrictions loop
+ null;
end loop;
Set_String (""";");
-- If compiling for the JVM, we directly reference Adafinal because
-- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
if Hostparm.Java_VM then
Set_String
(" System.Standard_Library.Adafinal'Code_Address");
WBI (" " & Ada_Init_Name.all & ",");
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Set_String (" system__standard_library__adafinal");
end if;
-- Initialize and Finalize
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" procedure initialize;");
WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
WBI ("");
WBI (" gnat_envp := System.Null_Address;");
end if;
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" Initialize;");
end if;
-- Adafinal call is skipped if no finalization
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
-- If compiling for the JVM, we directly call Adafinal because
-- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
-- Finalize is only called if we have a run time
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" Finalize;");
end if;
-- Call adafinal if finalization active
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" ");
WBI (" system__standard_library__adafinal ();");
end if;
-- then we need to make sure that the binder program is compiled with
-- the same restriction, so that no exception tables are generated.
- if Restrictions_On_Target (No_Exception_Handlers) then
+ if Cumulative_Restrictions.Set (No_Exception_Handlers) then
WBI ("pragma Restrictions (No_Exception_Handlers);");
end if;
-- No need to generate a finalization routine if finalization
-- is restricted, since there is nothing to do in this case.
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI ("");
WBI (" procedure " & Ada_Final_Name.all & ";");
WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
-- Import the finalization procedure only if finalization active
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
-- In the Java case, pragma Import C cannot be used, so the
-- standard Ada constructs will be used instead.
-- No need to generate a finalization routine if no finalization
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Gen_Adafinal_Ada;
end if;
-- Generate the adafinal routine. In no runtime mode, this is
-- not needed, since there is no finalization to do.
- if not Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Gen_Adafinal_C;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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 Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
else
-- Skip generation of this code if we don't want elab code
- if not Restrictions (No_Elaboration_Code) then
+ if not Restriction_Active (No_Elaboration_Code) then
Insert_After_And_Analyze (N,
Make_Raise_Program_Error (Loc,
Condition =>
begin
CompDef_Node := New_Node (N_Component_Definition, Stloc);
Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, Empty);
Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
Set_Component_Definition (Tdef_Node, CompDef_Node);
end;
begin
CompDef_Node := New_Node (N_Component_Definition, Stloc);
Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, Empty);
Set_Subtype_Indication (CompDef_Node,
Identifier_For (S_Wide_Character));
Set_Component_Definition (Tdef_Node, CompDef_Node);
Write_Str (" .. ");
Write_Str (IEEES_Last'Universal_Literal_String);
-
elsif Digs = IEEEL_Digits then
Write_Str (IEEEL_First'Universal_Literal_String);
Write_Str (" .. ");
layout_type (gnu_type);
+ /* If the type we are dealing with is to represent a packed array,
+ we need to have the bits left justified on big-endian targets
+ (see exp_packd.ads). We build a record with a bitfield of the
+ appropriate size to achieve this. */
if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN)
{
tree gnu_field_type = gnu_type;
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM");
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
+
+ /* Don't notify the field as "addressable", since we won't be taking
+ it's address and it would prevent create_field_decl from making a
+ bitfield. */
gnu_field = create_field_decl (get_identifier ("OBJECT"),
- gnu_field_type, gnu_type, 1, 0, 0, 1),
+ gnu_field_type, gnu_type, 1, 0, 0, 0);
+
finish_record_type (gnu_type, gnu_field, 0, 0);
TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1;
SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
with Nmake; use Nmake;
with Nlists; use Nlists;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Ttypes; use Ttypes;
with Sem; use Sem;
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
- -- initialization (<>) in any component (Ada0Y: AI-287)
+ -- initialization (<>) in any component (Ada 0Y: AI-287)
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
--
-- Otherwise we call Build_Code recursively.
--
- -- Ada0Y (AI-287): In case of default initialized component, Expr is
+ -- Ada 0Y (AI-287): In case of default initialized component, Expr is
-- empty and we generate a call to the corresponding IP subprogram.
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
Res : List_Id;
begin
- -- Ada0Y (AI-287): Do nothing else in case of default initialized
- -- component
+ -- Ada 0Y (AI-287): Do nothing else in case of default
+ -- initialized component.
if not Present (Expr) then
return Lis;
Set_Assignment_OK (Indexed_Comp);
- -- Ada0Y (AI-287): In case of default initialized component, Expr
- -- is not present (and therefore we also initialize Expr_Q to empty)
+ -- Ada 0Y (AI-287): In case of default initialized component, Expr
+ -- is not present (and therefore we also initialize Expr_Q to empty).
if not Present (Expr) then
Expr_Q := Empty;
elsif Present (Next (First (New_Indices))) then
- -- Ada0Y (AI-287): Do nothing in case of default initialized
+ -- Ada 0Y (AI-287): Do nothing in case of default initialized
-- component because we have received the component type in
-- the formal parameter Ctype.
- -- ??? I have added some assert pragmas to check if this new
+
+ -- ??? Some assert pragmas have been added to check if this new
-- formal can be used to replace this code in all cases.
if Present (Expr) then
begin
while Present (P) loop
-
if Nkind (P) = N_Aggregate
and then Present (Etype (P))
then
P := Parent (P);
end if;
end loop;
+
pragma Assert (Comp_Type = Ctype); -- AI-287
end;
end if;
end if;
- -- Ada0Y (AI-287): We only analyze the expression in case of non
- -- default initialized components (otherwise Expr_Q is not present)
+ -- Ada 0Y (AI-287): We only analyze the expression in case of non
+ -- default initialized components (otherwise Expr_Q is not present).
if Present (Expr_Q)
and then (Nkind (Expr_Q) = N_Aggregate
-- analyzed yet because the array aggregate code has not
-- been updated to use the Expansion_Delayed flag and
-- avoid analysis altogether to solve the same problem
- -- (see Resolve_Aggr_Expr) so let's do the analysis of
+ -- (see Resolve_Aggr_Expr). So let us do the analysis of
-- non-array aggregates now in order to get the value of
-- Expansion_Delayed flag for the inner aggregate ???
end if;
end if;
- -- Ada0Y (AI-287): In case of default initialized component, call
- -- the initialization subprogram associated with the component type
+ -- Ada 0Y (AI-287): In case of default initialized component, call
+ -- the initialization subprogram associated with the component type.
if not Present (Expr) then
if Empty_Range (L, H) then
Append_To (S, Make_Null_Statement (Loc));
- -- Ada0Y (AI-287): Nothing else need to be done in case of
- -- default initialized component
+ -- Ada 0Y (AI-287): Nothing else need to be done in case of
+ -- default initialized component.
if not Present (Expr) then
null;
if Present (Component_Associations (N)) then
Assoc := Last (Component_Associations (N));
- -- Ada0Y (AI-287)
+ -- Ada 0Y (AI-287)
+
if Box_Present (Assoc) then
Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
Aggr_High,
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- -- Ada0Y (AI-287): Give support to default initialization of limited
- -- types and components
+ -- Ada 0Y (AI-287): Give support to default initialization of limited
+ -- types and components.
if (Nkind (Target) = N_Identifier
- and then Present (Etype (Target))
- and then Is_Limited_Type (Etype (Target)))
- or else (Nkind (Target) = N_Selected_Component
- and then Present (Etype (Selector_Name (Target)))
- and then Is_Limited_Type (Etype (Selector_Name (Target))))
- or else (Nkind (Target) = N_Unchecked_Type_Conversion
- and then Present (Etype (Target))
- and then Is_Limited_Type (Etype (Target)))
- or else (Nkind (Target) = N_Unchecked_Expression
- and then Nkind (Expression (Target)) = N_Indexed_Component
- and then Present (Etype (Prefix (Expression (Target))))
- and then Is_Limited_Type
- (Etype (Prefix (Expression (Target)))))
+ and then Present (Etype (Target))
+ and then Is_Limited_Type (Etype (Target)))
+ or else
+ (Nkind (Target) = N_Selected_Component
+ and then Present (Etype (Selector_Name (Target)))
+ and then Is_Limited_Type (Etype (Selector_Name (Target))))
+ or else
+ (Nkind (Target) = N_Unchecked_Type_Conversion
+ and then Present (Etype (Target))
+ and then Is_Limited_Type (Etype (Target)))
+ or else
+ (Nkind (Target) = N_Unchecked_Expression
+ and then Nkind (Expression (Target)) = N_Indexed_Component
+ and then Present (Etype (Prefix (Expression (Target))))
+ and then Is_Limited_Type (Etype (Prefix (Expression (Target)))))
then
-
if Init_Pr then
Append_List_To (L,
Build_Initialization_Call (Loc,
Check_Ancestor_Discriminants (Entity (A));
end if;
- -- Ada0Y (AI-287): If the ancestor part is a limited type, a
- -- recursive call expands the ancestor.
+ -- Ada 0Y (AI-287): If the ancestor part is a limited type,
+ -- a recursive call expands the ancestor.
elsif Is_Limited_Type (Etype (A)) then
Ancestor_Is_Expression := True;
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
- -- Ada0Y (AI-287): Default initialization of a limited component
+ -- Ada 0Y (AI-287): Default initialization of a limited component
if Box_Present (Comp)
and then Is_Limited_Type (Etype (Selector))
then
- -- Ada0Y (AI-287): If the component type has tasks then generate
+ -- Ada 0Y (AI-287): If the component type has tasks then generate
-- the activation chain and master entities (except in case of an
-- allocator because in that case these entities are generated
- -- by Build_Task_Allocate_Block_With_Init_Stmts)
+ -- by Build_Task_Allocate_Block_With_Init_Stmts).
declare
Ctype : constant Entity_Id := Etype (Selector);
-- because of this limit.
Max_Aggr_Size : constant Nat :=
- 5000 + (2 ** 24 - 5000) * Boolean'Pos
- (Restrictions (No_Elaboration_Code)
- or else
- Restrictions (No_Implicit_Loops));
- begin
+ 5000 + (2 ** 24 - 5000) *
+ Boolean'Pos
+ (Restriction_Active (No_Elaboration_Code)
+ or else
+ Restriction_Active (No_Implicit_Loops));
+ begin
if Nkind (Original_Node (N)) = N_String_Literal then
return True;
end if;
Cunit_Entity (Current_Sem_Unit);
begin
- if Restrictions (No_Elaboration_Code)
- or else Restrictions (No_Implicit_Loops)
+ if Restriction_Active (No_Elaboration_Code)
+ or else Restriction_Active (No_Implicit_Loops)
or else Is_Preelaborated (P)
or else (Ekind (P) = E_Package_Body
and then
Is_Preelaborated (Spec_Entity (P)))
then
null;
+
elsif Rep_Count > Max_Others_Replicate then
return False;
end if;
-- Start of processing for Convert_To_Positional
begin
- -- Ada0Y (AI-287): Do not convert in case of default initialized
+ -- Ada 0Y (AI-287): Do not convert in case of default initialized
-- components because in this case will need to call the corresponding
-- IP procedure.
if Has_Default_Init_Comps (N) then
- -- Ada0Y (AI-287): This case has not been analyzed???
+ -- Ada 0Y (AI-287): This case has not been analyzed???
pragma Assert (False);
null;
then
Convert_To_Assignments (N, Typ);
- -- Ada0Y (AI-287): In case of default initialized components we convert
+ -- Ada 0Y (AI-287): In case of default initialized components we convert
-- the aggregate into assignments.
elsif Has_Default_Init_Comps (N) then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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 Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
if Is_Protected_Type (Conctype) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctype) > 1
then
Name :=
if Is_Protected_Type (Conctyp) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
then
Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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 Opt; use Opt;
with Rtsfind; use Rtsfind;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
return;
end if;
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Register_Exception (except'Unchecked_Access);
- if not Restrictions (No_Exception_Handlers)
- and then not Restrictions (No_Exception_Registration)
+ if not Restriction_Active (No_Exception_Handlers)
+ and then not Restriction_Active (No_Exception_Registration)
then
L := New_List (
Make_Procedure_Call_Statement (Loc,
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
begin
if Present (Exception_Handlers (N))
- and then not Restrictions (No_Exception_Handlers)
+ and then not Restriction_Active (No_Exception_Handlers)
then
Expand_Exception_Handlers (N);
end if;
-- Build a C-compatible string in case of no exception handlers,
-- since this is what the last chance handler is expecting.
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
-- Generate an empty message if configuration pragma
-- Suppress_Exception_Locations is set for this unit.
return;
end if;
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- The same consideration applies for No_Exception_Handlers (which
-- is also set in High_Integrity_Mode).
- if Restrictions (No_Exceptions)
- or Restrictions (No_Exception_Handlers)
+ if Restriction_Active (No_Exceptions)
+ or Restriction_Active (No_Exception_Handlers)
then
return;
end if;
-- Do not generate if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Do not generate if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Nothing to do if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
if Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type)
- or else (not Restrictions (No_Initialize_Scalars)
+ or else (not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (A_Type)
and then Root_Type (A_Type) /= Standard_String
and then Root_Type (A_Type) /= Standard_Wide_String)
begin
-- Nothing to do if there is no task hierarchy.
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
return;
end if;
-- through the outer routines.
if Has_Task (Full_Type) then
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
-- See comments in System.Tasking.Initialization.Init_RTS
-- for the value 3 (should be rtsfindable constant ???)
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- -- Ada0Y (AI-287): In case of default initialized components
+ -- Ada 0Y (AI-287): In case of default initialized components
-- with tasks, we generate a null string actual parameter.
-- This is just a workaround that must be improved later???
end if;
end if;
- -- Ada0Y (AI-287) In case of default initialized components, we
+ -- Ada 0Y (AI-287) In case of default initialized components, we
-- need to generate the corresponding selected component node
-- to access the discriminant value. In other cases this is not
-- required because we are inside the init proc and we use the
begin
-- Nothing to do if there is no task hierarchy.
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
return;
end if;
First_Discr_Param := Next (First (Parameters));
if Has_Task (Rec_Type) then
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
-- See comments in System.Tasking.Initialization.Init_RTS
-- for the value 3.
if Is_CPP_Class (Rec_Id) then
return False;
- elsif not Restrictions (No_Initialize_Scalars)
+ elsif not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (Rec_Id)
then
return True;
----------------------------
-- Generates the following subprogram:
+
-- procedure Assign
-- (Source, Target : Array_Type,
-- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
-- is
-- Li1 : Index;
-- Ri1 : Index;
+
-- begin
-- if Rev then
-- Li1 := Left_Hi;
-- Li1 := Left_Lo;
-- Ri1 := Right_Lo;
-- end if;
- --
+
-- loop
-- Target (Li1) := Source (Ri1);
+
-- if Rev then
-- exit when Li2 = Left_Lo;
-- Li2 := Index'pred (Li2);
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
- Lnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
- Rnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- -- subscripts for left and right sides
+ Lnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ Rnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ -- Subscripts for left and right sides
- Decls : List_Id;
- Loops : Node_Id;
- Stats : List_Id;
+ Decls : List_Id;
+ Loops : Node_Id;
+ Stats : List_Id;
begin
- -- Build declarations for indices.
+ -- Build declarations for indices
Decls := New_List;
Stats := New_List;
- -- Build initializations for indices.
+ -- Build initializations for indices
declare
F_Init : constant List_Id := New_List;
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
- -- Build the increment/decrement statements.
+ -- Build the increment/decrement statements
declare
F_Ass : constant List_Id := New_List;
Append_To (Stats, Loops);
declare
- Spec : Node_Id;
- Formals : List_Id := New_List;
+ Spec : Node_Id;
+ Formals : List_Id := New_List;
begin
Formals := New_List (
------------------------------------
-- Generates:
- --
+
-- function _Equality (X, Y : T) return Boolean is
-- begin
-- -- Compare discriminants
Next_Elmt (Elmt);
end loop;
- -- If the derived type itself is private with a full view,
- -- then associate the full view with the inherited TSS_Elist
- -- as well.
+ -- If the derived type itself is private with a full view, then
+ -- associate the full view with the inherited TSS_Elist as well.
if Ekind (B_Id) in Private_Kind
and then Present (Full_View (B_Id))
-- In normal mode, add the others clause with the test
- if not Restrictions (No_Exception_Handlers) then
+ if not Restriction_Active (No_Exception_Handlers) then
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
- -- An exception is made for types defined in the run-time
- -- because Ada.Tags.Tag itself is such a type and cannot
- -- afford this unnecessary overhead that would generates a
- -- loop in the expansion scheme...
+ -- An exception is made for types defined in the run-time
+ -- because Ada.Tags.Tag itself is such a type and cannot
+ -- afford this unnecessary overhead that would generates a
+ -- loop in the expansion scheme...
- and then not In_Runtime (Def_Id)
+ and then not In_Runtime (Def_Id)
- -- Another exception is if Restrictions (No_Finalization)
- -- is active, since then we know nothing is controlled.
+ -- Another exception is if Restrictions (No_Finalization)
+ -- is active, since then we know nothing is controlled.
- and then not Restrictions (No_Finalization))
+ and then not Restriction_Active (No_Finalization))
-- If the designated type is not frozen yet, its controlled
-- status must be retrieved explicitly.
-- We also skip these if finalization is not available
- elsif Restrictions (No_Finalization) then
+ elsif Restriction_Active (No_Finalization) then
null;
elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
-- We also skip them if dispatching is not available.
if not Is_Limited_Type (Tag_Typ)
- and then not Restrictions (No_Finalization)
+ and then not Restriction_Active (No_Finalization)
then
if No (TSS (Tag_Typ, TSS_Stream_Read)) then
Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
-- Skip this if finalization is not available
- elsif Restrictions (No_Finalization) then
+ elsif Restriction_Active (No_Finalization) then
null;
elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
-- Case of both are false with No_Implicit_Conditionals
- elsif Restrictions (No_Implicit_Conditionals) then
+ elsif Restriction_Active (No_Implicit_Conditionals) then
declare
T : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars => Name_T);
-- This is skipped if we have no finalization
if Expand_Ctrl_Actions
- and then not Restrictions (No_Finalization)
+ and then not Restriction_Active (No_Finalization)
then
L := New_List (
Make_Block_Statement (Loc,
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
-- since we won't be able to generate the code to handle the
-- recursion in any case.
- if Restrictions (No_Implicit_Conditionals) then
+ if Restriction_Active (No_Implicit_Conditionals) then
return;
end if;
-- if we can tell that the first parameter cannot possibly be null.
-- This helps optimization and also generation of warnings.
- if not Restrictions (No_Exception_Handlers)
+ if not Restriction_Active (No_Exception_Handlers)
and then Is_RTE (Subp, RE_Raise_Exception)
then
declare
-- Create new exception handler
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
Excep_Handlers := No_List;
else
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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 Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Targparm; use Targparm;
with Sinfo; use Sinfo;
return (Is_Class_Wide_Type (T)
and then not In_Finalization_Root (T)
- and then not Restrictions (No_Finalization))
+ and then not Restriction_Active (No_Finalization))
or else Is_Controlled (T)
or else Has_Some_Controlled_Component (T)
or else (Is_Concurrent_Type (T)
end if;
elsif Is_Master then
- if Restrictions (No_Task_Hierarchy) = False then
+ if Restriction_Active (No_Task_Hierarchy) = False then
Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
end if;
and then Has_Entries (Pid)
then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Unlock := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6;
elsif Has_Entries (Typ) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
then
Protection_Type := RE_Protection_Entries;
S : Entity_Id;
begin
- -- Ada0Y (AI-287): Do not set/get the has_master_entity reminder in
- -- internal scopes. Required for nested limited aggregates.
-
- if not Extensions_Allowed then
-
- -- Nothing to do if we already built a master entity for this scope
- -- or if there is no task hierarchy.
-
- if Has_Master_Entity (Scope (E))
- or else Restrictions (No_Task_Hierarchy)
- then
- return;
- end if;
+ S := Scope (E);
- else
- -- Ada0Y (AI-287): Similar to the previous case but skipping
- -- internal scopes. If we are not inside an internal scope this
- -- code is equivalent to the previous code.
+ -- Ada 0Y (AI-287): Do not set/get the has_master_entity reminder in
+ -- internal scopes. Required for nested limited aggregates.
- S := Scope (E);
+ if Extensions_Allowed then
while Is_Internal (S) loop
S := Scope (S);
end loop;
+ end if;
- if Has_Master_Entity (S)
- or else Restrictions (No_Task_Hierarchy)
- then
- return;
- end if;
+ -- Nothing to do if we already built a master entity for this scope
+ -- or if there is no task hierarchy.
+
+ if Has_Master_Entity (S)
+ or else Restriction_Active (No_Task_Hierarchy)
+ then
+ return;
end if;
-- Otherwise first build the master entity
Insert_Before (P, Decl);
Analyze (Decl);
- -- Ada0Y (AI-287): Set the has_marter_entity reminder in the
+ -- Ada 0Y (AI-287): Set the has_master_entity reminder in the
-- non-internal scope selected above.
if not Extensions_Allowed then
Add_Object_Pointer (Op_Decls, Pid, Loc);
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access))));
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return
Make_Subprogram_Body (Loc,
Specification => Espec,
Set_All_Others (Ohandle);
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Complete :=
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
then
Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
-- parameters.
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else not Is_Protected_Type (Conctyp)
or else Number_Entries (Conctyp) > 1
then
if Is_Protected_Type (Conctyp) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
then
-- Change the type of the index declaration
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
-
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
(Etype (Discrete_Subtype_Definition
(Parent (Efam))), Loc)))))));
-
end if;
Next_Entity (Efam);
Call : Node_Id;
begin
- if Restrictions (No_Task_Hierarchy) = False then
+ if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
Prepend_To (Declarations (N), Call);
Analyze (Call);
if Has_Entries
and then (Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Num_Entries > 1)
then
New_Op_Body := Build_Find_Body_Index (Pid);
elsif Has_Entries (Prottyp) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Prottyp) > 1
then
Protection_Subtype :=
New_External_Name (Chars (Prottyp), 'A'));
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
then
Body_Arr := Make_Object_Declaration (Loc,
-- no entry queue, 1 entry)
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
then
Sub :=
Append_To (Parms, New_Reference_To (B, Loc));
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Etype (Concval)) > 1
then
Rewrite (Call,
Attribute_Name => Name_Unrestricted_Access));
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
then
-- Find index mapping function (clumsy but ok for now).
end if;
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
then
Append_To (L,
-- See comments in System.Tasking.Initialization.Init_RTS for the
-- value 3.
- if Restrictions (No_Task_Hierarchy) = False then
+ if Restriction_Active (No_Task_Hierarchy) = False then
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
else
Append_To (Args, Make_Integer_Literal (Loc, 3));
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
-- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
-- generate a dummy declaration only.
- if Restrictions (No_Implicit_Heap_Allocations)
+ if Restriction_Active (No_Implicit_Heap_Allocations)
or else Global_Discard_Names
then
T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
function Get_File_Name
(Uname : Unit_Name_Type;
- Subunit : Boolean) return File_Name_Type
+ Subunit : Boolean;
+ May_Fail : Boolean := False) return File_Name_Type
is
Unit_Char : Character;
-- Set to 's' or 'b' for spec or body or to 'u' for a subunit
-- the file does not exist.
if No_File_Check then
- return Fnam;
+ if May_Fail then
+ return No_File;
+
+ else
+ return Fnam;
+ end if;
-- Otherwise we check if the file exists
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
function Get_File_Name
(Uname : Unit_Name_Type;
- Subunit : Boolean) return File_Name_Type;
+ Subunit : Boolean;
+ May_Fail : Boolean := False) return File_Name_Type;
-- This function returns the file name that corresponds to a given unit
-- name, Uname. The Subunit parameter is set True for subunits, and
-- false for all other kinds of units. The caller is responsible for
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2004 Ada Core Technologies, 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- --
procedure Update
(C : in out CRC32;
Value : String);
- pragma Inline (Update);
-- For each character in the Value string call above routine
procedure Wide_Update
(C : in out CRC32;
Value : Wide_Character);
- pragma Inline (Update);
-- Evolve CRC by including the contribution from Wide_Character'Pos (Value)
-- with the bytes being included in the natural memory order.
procedure Wide_Update
(C : in out CRC32;
Value : Wide_String);
- pragma Inline (Update);
-- For each character in the Value string call above routine
procedure Update
(C : in out CRC32;
Value : Ada.Streams.Stream_Element);
- pragma Inline (Update);
-- Evolve CRC by including the contribution from Value
procedure Update
(C : in out CRC32;
Value : Ada.Streams.Stream_Element_Array);
- pragma Inline (Update);
-- For each element in the Value array call above routine
function Get_Value (C : CRC32) return Interfaces.Unsigned_32
-- change the value of C, so it may be used to retrieve intermediate
-- values of the CRC32 value during a sequence of Update calls.
+ pragma Inline (Update);
+ pragma Inline (Wide_Update);
end GNAT.CRC32;
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2004 Ada Core Technologies, 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- --
Cur : Natural := 1;
-- Index in Result where the next character will be placed.
+ Last_Block : String (1 .. 64);
+
+ C1 : Context := C;
+
procedure Convert (X : Unsigned_32);
-- Put the contribution of one of the four words (A, B, C, D) of the
-- Context in Result. Increments Cur.
-- Start of processing for Digest
begin
- Convert (C.A);
- Convert (C.B);
- Convert (C.C);
- Convert (C.D);
+ -- Process characters in the context buffer, if any
+
+ Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last);
+
+ if C.Last > 56 then
+ Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last);
+ Transform (C1, Last_Block);
+ Last_Block := (others => ASCII.NUL);
+
+ else
+ Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last);
+ end if;
+
+ -- Add the input length (as stored in the context) as 8 characters
+
+ Last_Block (57 .. 64) := (others => ASCII.NUL);
+
+ declare
+ L : Unsigned_64 := Unsigned_64 (C.Length) * 8;
+ Idx : Positive := 57;
+
+ begin
+ while L > 0 loop
+ Last_Block (Idx) := Character'Val (L and 16#Ff#);
+ L := Shift_Right (L, 8);
+ Idx := Idx + 1;
+ end loop;
+ end;
+
+ Transform (C1, Last_Block);
+
+ Convert (C1.A);
+ Convert (C1.B);
+ Convert (C1.C);
+ Convert (C1.D);
return Result;
end Digest;
function Digest (S : String) return Message_Digest is
C : Context;
-
begin
Update (C, S);
return Digest (C);
end Digest;
function Digest
- (A : Ada.Streams.Stream_Element_Array)
- return Message_Digest
+ (A : Ada.Streams.Stream_Element_Array) return Message_Digest
is
C : Context;
-
begin
Update (C, A);
return Digest (C);
(C : in out Context;
Input : String)
is
- Cur : Positive := Input'First;
- Last_Block : String (1 .. 64);
+ Inp : constant String := C.Buffer (1 .. C.Last) & Input;
+ Cur : Positive := Inp'First;
begin
- while Cur + 63 <= Input'Last loop
- Transform (C, Input (Cur .. Cur + 63));
+ C.Length := C.Length + Input'Length;
+
+ while Cur + 63 <= Inp'Last loop
+ Transform (C, Inp (Cur .. Cur + 63));
Cur := Cur + 64;
end loop;
- Last_Block (1 .. Input'Last - Cur + 1) := Input (Cur .. Input'Last);
-
- if Input'Last - Cur + 1 > 56 then
- Cur := Input'Last - Cur + 2;
- Last_Block (Cur .. 64) := Padding (1 .. 64 - Cur + 1);
- Transform (C, Last_Block);
- Last_Block := (others => ASCII.NUL);
-
- else
- Cur := Input'Last - Cur + 2;
- Last_Block (Cur .. 56) := Padding (1 .. 56 - Cur + 1);
- end if;
-
- -- Add the input length as 8 characters
-
- Last_Block (57 .. 64) := (others => ASCII.NUL);
-
- declare
- L : Unsigned_64 := Unsigned_64 (Input'Length) * 8;
-
- begin
- Cur := 57;
- while L > 0 loop
- Last_Block (Cur) := Character'Val (L and 16#Ff#);
- L := Shift_Right (L, 8);
- Cur := Cur + 1;
- end loop;
- end;
-
- Transform (C, Last_Block);
+ C.Last := Inp'Last - Cur + 1;
+ C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last);
end Update;
procedure Update
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2004 Ada Core Technologies, 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- --
-- the Message-Digest of Input.
--
-- These procedures may be called successively with the same context and
- -- different inputs. However, several successive calls will not produce
+ -- different inputs, and these several successive calls will produce
-- the same final context as a call with the concatenation of the inputs.
subtype Message_Digest is String (1 .. 32);
B : Interfaces.Unsigned_32 := Initial_B;
C : Interfaces.Unsigned_32 := Initial_C;
D : Interfaces.Unsigned_32 := Initial_D;
+ Buffer : String (1 .. 64) := (others => ASCII.NUL);
+ Last : Natural := 0;
+ Length : Natural := 0;
end record;
Initial_Context : constant Context :=
- (A => Initial_A, B => Initial_B, C => Initial_C, D => Initial_D);
+ (A => Initial_A, B => Initial_B, C => Initial_C, D => Initial_D,
+ Buffer => (others => ASCII.NUL), Last => 0, Length => 0);
end GNAT.MD5;
with Prepcomp;
with Repinfo; use Repinfo;
with Restrict;
-with Rident;
with Sem;
with Sem_Ch8;
with Sem_Ch12;
S : Source_File_Index;
N : Name_Id;
- R : Restrict.Restriction_Id;
- P : Restrict.Restriction_Parameter_Id;
begin
Name_Buffer (1 .. 10) := "system.ads";
-- Acquire configuration pragma information from Targparm
- for J in Rident.Partition_Restrictions loop
- R := Restrict.Partition_Restrictions (J);
-
- if Targparm.Restrictions_On_Target (J) then
- Restrict.Restrictions (R) := True;
- Restrict.Restrictions_Loc (R) := System_Location;
- end if;
- end loop;
-
- for K in Rident.Restriction_Parameter_Id loop
- P := Restrict.Restriction_Parameter_Id (K);
-
- if Targparm.Restriction_Parameters_On_Target (K) /= No_Uint then
- Restrict.Restriction_Parameters (P) :=
- Targparm.Restriction_Parameters_On_Target (K);
- Restrict.Restriction_Parameters_Loc (P) := System_Location;
- end if;
- end loop;
+ Restrict.Restrictions := Targparm.Restrictions_On_Target;
end;
-- Set Configurable_Run_Time mode if system.ads flag set
with Bindgen; use Bindgen;
with Bindusg;
with Butil; use Butil;
+with Casing; use Casing;
with Csets;
with Fmap;
with Gnatvsn; use Gnatvsn;
with Switch.B; use Switch.B;
with Targparm; use Targparm;
with Types; use Types;
-with Uintp; use Uintp;
with System.Case_Util; use System.Case_Util;
Output_File_Name_Seen : Boolean := False;
Output_File_Name : String_Ptr := new String'("");
- L_Switch_Seen : Boolean := False;
+ L_Switch_Seen : Boolean := False;
- Mapping_File : String_Ptr := null;
+ Mapping_File : String_Ptr := null;
+
+ procedure List_Applicable_Restrictions;
+ -- List restrictions that apply to this partition if option taken
procedure Scan_Bind_Arg (Argv : String);
-- Scan and process binder specific arguments. Argv is a single argument.
-- All the one character arguments are still handled by Switch. This
-- routine handles -aO -aI and -I-.
+ ----------------------------------
+ -- List_Applicable_Restrictions --
+ ----------------------------------
+
+ procedure List_Applicable_Restrictions is
+
+ -- Define those restrictions that should be output if the gnatbind
+ -- -r switch is used. Not all restrictions are output for the reasons
+ -- given above in the list, and this array is used to test whether
+ -- the corresponding pragma should be listed. True means that it
+ -- should not be listed.
+
+ No_Restriction_List : constant array (All_Restrictions) of Boolean :=
+ (No_Exceptions => True,
+ -- Has unexpected Suppress (All_Checks) effect
+
+ No_Implicit_Conditionals => True,
+ -- This could modify and pessimize generated code
+
+ No_Implicit_Dynamic_Code => True,
+ -- This could modify and pessimize generated code
+
+ No_Implicit_Loops => True,
+ -- This could modify and pessimize generated code
+
+ No_Recursion => True,
+ -- Not checkable at compile time
+
+ No_Reentrancy => True,
+ -- Not checkable at compile time
+
+ Max_Entry_Queue_Depth => True,
+ -- Not checkable at compile time
+
+ Max_Storage_At_Blocking => True,
+ -- Not checkable at compile time
+
+ others => False);
+
+ Additional_Restrictions_Listed : Boolean := False;
+ -- Set True if we have listed header for restrictions
+
+ begin
+ -- Loop through restrictions
+
+ for R in All_Restrictions loop
+ if not No_Restriction_List (R) then
+
+ -- We list a restriction if it is not violated, or if
+ -- it is violated but the violation count is exactly known.
+
+ if Cumulative_Restrictions.Violated (R) = False
+ or else (R in All_Parameter_Restrictions
+ and then
+ Cumulative_Restrictions.Unknown (R) = False)
+ then
+ if not Additional_Restrictions_Listed then
+ Write_Eol;
+ Write_Line
+ ("The following additional restrictions may be" &
+ " applied to this partition:");
+ Additional_Restrictions_Listed := True;
+ end if;
+
+ Write_Str ("pragma Restrictions (");
+
+ declare
+ S : constant String := Restriction_Id'Image (R);
+ begin
+ Name_Len := S'Length;
+ Name_Buffer (1 .. Name_Len) := S;
+ end;
+
+ Set_Casing (Mixed_Case);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+
+ if R in All_Parameter_Restrictions then
+ Write_Str (" => ");
+ Write_Int (Int (Cumulative_Restrictions.Count (R)));
+ end if;
+
+ Write_Str (");");
+ Write_Eol;
+ end if;
+ end if;
+ end loop;
+ end List_Applicable_Restrictions;
+
-------------------
-- Scan_Bind_Arg --
-------------------
if No_Run_Time_Mode then
- -- Set standard restrictions
-
- Restrictions_On_Target (No_Finalization) := True;
- Restrictions_On_Target (No_Exception_Handlers) := True;
- Restrictions_On_Target (No_Tasking) := True;
- Restriction_Parameters_On_Target (Max_Tasks) := Uint_0;
-
-- Set standard configuration parameters
Suppress_Standard_Library_On_Target := True;
Check_Consistency;
Check_Configuration_Consistency;
- -- Acquire restrictions and add them to target restrictions. After
- -- this loop, Restrictions_On_Target entries will be set True for
- -- all partition-wide restrictions specified in the partition.
+ -- List restrictions that could be applied to this partition
- for J in Partition_Restrictions loop
- if Restrictions (J) = 'r' then
- Restrictions_On_Target (J) := True;
- end if;
- end loop;
+ if List_Restrictions then
+ List_Applicable_Restrictions;
+ end if;
-- Complete bind if no errors
for Arg in Command_Arg + 1 .. Argument_Count loop
declare
The_Arg : constant String := Argument (Arg);
+
begin
-- Check if an argument file is specified
Last : Natural;
begin
- -- Open the file. Fail if the file cannot be found.
+ -- Open the file and fail if the file cannot be found
begin
Open
Fail ("-p and -P cannot be used together");
elsif Argv'Length = 2 then
+
-- There is space between -P and the project file
-- name. -P cannot be the last option.
Data : constant Prj.Project_Data :=
Prj.Projects.Table (Project);
- Pkg : constant Prj.Package_Id :=
- Prj.Util.Value_Of
- (Name => Tool_Package_Name,
- In_Packages => Data.Decl.Packages);
+ Pkg : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Tool_Package_Name,
+ In_Packages => Data.Decl.Packages);
Element : Package_Element;
-- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim)
-- have an attributed Switches, an associative array, indexed
-- by the name of the file.
+
-- They also have an attribute Default_Switches, indexed
-- by the name of the programming language.
else
Set_Exit_Status (My_Exit_Status);
end if;
-
end GNATCmd;
end if;
for J in Objs_Begin .. Objs_End loop
+
-- Opening quote for GNU linker
+
if Using_GNU_Linker then
Status := Write (Tname_FD, Opening'Address, 1);
end if;
Linker_Objects.Table (J);
end loop;
- -- handle GNU linker response file footer.
+ -- Handle GNU linker response file footer
if Using_GNU_Linker then
declare
-- on Unix. On non-Unix systems executables have a suffix, so the warning
-- will not appear. However, do not warn in the case of a cross compiler.
- -- Assume that if the executable name is not gnatlink, this is a cross
- -- tool.
+ -- Assume this is a cross tool if the executable name is not gnatlink
if Base_Name (Command_Name) = "gnatlink"
and then Output_File_Name.all = "test"
-- Perform consistency checks
- -- Transform the .ali file name into the binder output file name.
+ -- Transform the .ali file name into the binder output file name
Make_Binder_File_Names : declare
Fname : constant String := Base_Name (Ali_File_Name.all);
-- If the file cannot be read, exit the process with an error code.
procedure Check_Args (Condition : Boolean);
- -- If Condition is false, print the usage, and exit the process.
+ -- If Condition is false, print command invoked, then the usage,
+ -- and exit the process.
procedure Deps (Objext : String; File : String; GCC : Boolean);
-- Process $(CC) dependency file. If GCC is True, add a rule so that make
procedure Check_Args (Condition : Boolean) is
begin
if not Condition then
+ Put_Line
+ (Standard_Error,
+ "bad call to gprcmd with" & Argument_Count'Img & " arguments.");
+ for J in 0 .. Argument_Count loop
+ Put (Standard_Error, Argument (J) & " ");
+ end loop;
+
+ New_Line (Standard_Error);
+
Usage;
end if;
end Check_Args;
"post process dependency makefiles");
Put_Line (Standard_Error, " stamp " &
"copy file time stamp from file1 to file2");
+ Put_Line (Standard_Error, " prefix " &
+ "get the prefix of the GNAT installation");
OS_Exit (1);
end Usage;
end if;
end if;
end;
+
+ else
+ -- Uknown command
+
+ Check_Args (False);
end if;
end;
end Gprcmd;
-- S p e c --
-- (ASCII Version) --
-- --
--- Copyright (C) 1993-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
pragma Inline (To_Binary);
pragma Inline (To_Decimal);
pragma Inline (To_Display);
- pragma Inline (To_Decimal);
pragma Inline (To_Long_Binary);
pragma Inline (Valid);
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2003 Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2004 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- *
{
struct sigaction act;
+ /* stack-checking on this platform is performed by the back-end and conforms
+ to what the ABI *mandates* (DEC OSF/1 Calling standard for AXP systems,
+ chapter 6: Stack Limits in Multihtreaded Execution Environments). This
+ does not include a "stack reserve" region, so nothing guarantees that
+ enough room remains on the current stack to propagate an exception when
+ a stack-overflow is signaled. We deal with this by requesting the use of
+ an alternate stack region for signal handlers.
+
+ ??? The actual use of this alternate region depends on the act.sa_flags
+ including SA_ONSTACK below. Care should be taken to update s-intman if
+ we want this to happen for tasks also. */
+
+ static char sig_stack [8*1024];
+ /* 8K allocated here because 4K is not enough for the GCC/ZCX scheme. */
+
+ struct sigaltstack ss;
+
+ ss.ss_sp = (void *) & sig_stack;
+ ss.ss_size = sizeof (sig_stack);
+ ss.ss_flags = 0;
+
+ sigaltstack (&ss, 0);
+
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
signal that might cause a scheduling event! */
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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 Osint.C; use Osint.C;
with Par;
with Restrict; use Restrict;
+with Rident; use Rident;
with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
if Is_Spec_Name (Uname) then
Body_Fname :=
- Get_File_Name (Get_Body_Name (Uname), Subunit => False);
+ Get_File_Name
+ (Get_Body_Name (Uname),
+ Subunit => False, May_Fail => True);
+
+ if Body_Fname = No_File then
+ Body_Fname := Get_File_Name (Uname, Subunit => False);
+ end if;
+
else
Body_Fname := Get_File_Name (Uname, Subunit => False);
end if;
or else Unit = Main_Unit
then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
- Violations (No_ELaboration_Code) := True;
+ Main_Restrictions.Violated (No_Elaboration_Code) := True;
+ Main_Restrictions.Count (No_Elaboration_Code) := -1;
end if;
end if;
end loop;
- -- Output restrictions line
+ -- Output first restrictions line
Write_Info_Initiate ('R');
Write_Info_Char (' ');
- for J in All_Restrictions loop
- if Main_Restrictions (J) then
+ for R in All_Boolean_Restrictions loop
+ if Main_Restrictions.Set (R) then
Write_Info_Char ('r');
- elsif Violations (J) then
+ elsif Main_Restrictions.Violated (R) then
Write_Info_Char ('v');
else
Write_Info_Char ('n');
Write_Info_EOL;
+ -- Output second restrictions line
+
+ Write_Info_Initiate ('R');
+ Write_Info_Char (' ');
+
+ for RP in All_Parameter_Restrictions loop
+ if Main_Restrictions.Set (RP) then
+ Write_Info_Char ('r');
+ Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
+ else
+ Write_Info_Char ('n');
+ end if;
+
+ if not Main_Restrictions.Violated (RP)
+ or else RP not in Checked_Parameter_Restrictions
+ then
+ Write_Info_Char ('n');
+ else
+ Write_Info_Char ('v');
+ Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
+
+ if Main_Restrictions.Unknown (RP) then
+ Write_Info_Char ('+');
+ end if;
+ end if;
+ end loop;
+
+ Write_Info_EOL;
+
-- Output interrupt state lines
for J in Interrupt_States.First .. Interrupt_States.Last loop
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- -- R Restrictions --
-- ---------------------
+ -- Two lines are generated to record the status of restrictions that can
+ -- be specified by pragma Restrictions. The first of these lines refers
+ -- to Restriction_Id values:
+
-- R <<restriction-characters>>
- -- This line records information regarding restrictions. The
- -- parameter is a string of characters, one for each entry in
- -- Restrict.Compilation_Unit_Restrictions, in order. There are
- -- three settings possible settings for each restriction:
+ -- This line records information regarding restrictions that do
+ -- not take parameter values. Here "restriction-characters is a
+ -- string of characters, one for each value (in order) defined
+ -- in Restrict.All_Boolean_Restrictions. There are three possible
+ -- settings for each restriction:
-- r Restricted. Unit was compiled under control of a pragma
-- Restrictions for the corresponding restriction. In
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
+ -- The second R line refers to parameter restrictions:
+
+ -- R <<restriction-parameter-id-entries>>
+
+ -- The parameter is a string of entries, one for each value in
+ -- Restrict.All_Parameter_Restrictions. Each entry has two
+ -- components in sequence, the first indicating whether or not
+ -- there is a restriction, and the second indicating whether
+ -- or not the compiler detected violations. In the boolean case
+ -- it is not necessary to separate these, since if a restriction
+ -- is set, and violated, that is an error. But in the parameter
+ -- case, this is not true. For example, we can have a unit with
+ -- a pragma Restrictions (Max_Tasks => 4), where the compiler
+ -- can detect that there are exactly three tasks declared. Both
+ -- of these pieces of information must be passed to the binder.
+ -- The parameter of 4 is important in case the total number of
+ -- tasks in the partition is greater than 4. The parameter of
+ -- 3 is important in case some other unit has a restrictions
+ -- pragma with Max_Tasks=>2.
+
+ -- The component for the presence of restriction has one of two
+ -- possible forms:
+
+ -- n No pragma for this restriction is present in the
+ -- set of units for this ali file.
+
+ -- rN At least one pragma for this restriction is present
+ -- in the set of units for this ali file. The value N
+ -- is the minimum parameter value encountered in any
+ -- such pragma. N is in the range of Integer (a value
+ -- larger than N'Last causes the pragma to be ignored).
+
+ -- The component for the violation detection has one of three
+ -- possible forms:
+
+ -- n No violations were detected by the compiler
+
+ -- vN A violation was detected. N is either the maximum or total
+ -- count of violations (depending on the checking type) in
+ -- all the units represented by the ali file). Note that
+ -- this setting is only allowed for restrictions that are
+ -- in Checked_[Max|Sum]_Parameter_Restrictions. The value
+ -- here is known to be exact by the compiler and is in the
+ -- range of Natural.
+
+ -- vN+ A violation was detected. The compiler cannot determine
+ -- the exact count of violations, but it is at least N.
+
+ -- There are no spaces in the line, so the entry for the example
+ -- in the header of this section for Max_Tasks would appear as
+ -- the string r4v3.
+
-- ------------------------
-- -- I Interrupt States --
-- ------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- same value for each argument.
function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean;
- pragma Inline (In_Same_Source_Unit);
+ pragma Inline (In_Same_Code_Unit);
-- Determines if the two nodes or entities N1 and N2 are in the same
-- code unit, the criterion being that Get_Code_Unit yields the same
-- value for each argument.
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
+with Hostparm; use Hostparm;
with Sinfo.CN; use Sinfo.CN;
separate (Par)
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
-- EXCEPTION_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : exception renames exception_NAME;
Done : out Boolean;
In_Spec : Boolean)
is
+ Acc_Node : Node_Id;
Decl_Node : Node_Id;
Type_Node : Node_Id;
Ident_Sloc : Source_Ptr;
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
+ -- Ada 0Y (AI-230): Access Definition case
+
+ elsif Token = Tok_Access then
+ if not Extensions_Allowed then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 0Y extension");
+
+ if OpenVMS then
+ Error_Msg_SP
+ ("\unit must be compiled with " &
+ "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+ else
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+ end if;
+
+ Acc_Node := P_Access_Definition;
+
+ if Token /= Tok_Renames then
+ Error_Msg_SC ("'RENAMES' expected");
+ raise Error_Resync;
+ end if;
+
+ Scan; -- past renames
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Access_Definition (Decl_Node, Acc_Node);
+ Set_Name (Decl_Node, P_Name);
+
-- Subtype indication case
else
-- DISCRETE_SUBTYPE_DEFINITION ::=
-- DISCRETE_SUBTYPE_INDICATION | RANGE
- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+ -- COMPONENT_DEFINITION ::=
+ -- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- The caller has checked that the initial token is ARRAY
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
- if Token = Tok_Aliased then
- Set_Aliased_Present (CompDef_Node, True);
- Scan; -- past ALIASED
+ -- Ada 0Y (AI-230): Access Definition case
+
+ if Token = Tok_Access then
+ if not Extensions_Allowed then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 0Y extension");
+
+ if OpenVMS then
+ Error_Msg_SP
+ ("\unit must be compiled with " &
+ "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+ else
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, P_Access_Definition);
+ else
+ Set_Access_Definition (CompDef_Node, Empty);
+
+ if Token_Name = Name_Aliased then
+ Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+ end if;
+
+ if Token = Tok_Aliased then
+ Set_Aliased_Present (CompDef_Node, True);
+ Scan; -- past ALIASED
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
end if;
- Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
Set_Component_Definition (Def_Node, CompDef_Node);
return Def_Node;
Scan; -- past the left paren
if Token = Tok_Box then
-
if Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
-- [:= DEFAULT_EXPRESSION];
- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+ -- COMPONENT_DEFINITION ::=
+ -- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Error recovery: cannot raise Error_Resync, if an error occurs,
-- the scan is positioned past the following semicolon.
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
- if Token_Name = Name_Aliased then
- Check_95_Keyword (Tok_Aliased, Tok_Identifier);
- end if;
+ if Token = Tok_Access then
+ if not Extensions_Allowed then
+ Error_Msg_SP
+ ("Generalized use of anonymous access types " &
+ "is an Ada0X extension");
- if Token = Tok_Aliased then
- Scan; -- past ALIASED
- Set_Aliased_Present (CompDef_Node, True);
- end if;
+ if OpenVMS then
+ Error_Msg_SP
+ ("\unit must be compiled with " &
+ "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+ else
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+ end if;
- if Token = Tok_Array then
- Error_Msg_SC ("anonymous arrays not allowed as components");
- raise Error_Resync;
+ Set_Subtype_Indication (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node, P_Access_Definition);
+ else
+
+ Set_Access_Definition (CompDef_Node, Empty);
+
+ if Token_Name = Name_Aliased then
+ Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+ end if;
+
+ if Token = Tok_Aliased then
+ Scan; -- past ALIASED
+ Set_Aliased_Present (CompDef_Node, True);
+ end if;
+
+ if Token = Tok_Array then
+ Error_Msg_SC
+ ("anonymous arrays not allowed as components");
+ raise Error_Resync;
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
end if;
- Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication);
Set_Component_Definition (Decl_Node, CompDef_Node);
Set_Expression (Decl_Node, Init_Expr_Opt);
if Prot_Flag then
Scan; -- past PROTECTED
+
if Token /= Tok_Procedure and then Token /= Tok_Function then
Error_Msg_SC ("FUNCTION or PROCEDURE expected");
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
function Abort_Allowed return Boolean is
begin
- if Restrictions (No_Abort_Statements)
- and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
+ if Restrictions.Set (No_Abort_Statements)
+ and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
+ and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
then
return False;
-
else
return True;
end if;
-- Even in the error case it is a bit dubious, either gigi needs
-- the table locked or it does not! ???
- if Restrictions (No_Elaboration_Code)
+ if Restrictions.Set (No_Elaboration_Code)
and then not Suppress_Restriction_Message (N)
then
Namet.Unlock;
declare
Fnam : constant File_Name_Type :=
Get_File_Name (U, Subunit => False);
- R_Id : Restriction_Id;
begin
if not Is_Predefined_File_Name (Fnam) then
return;
- -- Ada child unit spec, needs checking against list
+ -- Predefined spec, needs checking against list
else
-- Pad name to 8 characters with blanks
if Name_Len = 8
and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
then
- R_Id := Unit_Array (J).Res_Id;
- Violations (R_Id) := True;
-
- if Restrictions (R_Id) then
- declare
- S : constant String := Restriction_Id'Image (R_Id);
-
- begin
- Error_Msg_Unit_1 := U;
-
- Error_Msg_N
- ("|dependence on $ not allowed,", N);
-
- Name_Buffer (1 .. S'Last) := S;
- Name_Len := S'Length;
- Set_Casing (All_Lower_Case);
- Error_Msg_Name_1 := Name_Enter;
- Error_Msg_Sloc := Restrictions_Loc (R_Id);
-
- Error_Msg_N
- ("\|violates pragma Restriction (%) #", N);
- return;
- end;
- end if;
+ Check_Restriction (Unit_Array (J).Res_Id, N);
end if;
end loop;
end if;
-- Check_Restriction --
-----------------------
- -- Case of simple identifier (no parameter)
-
- procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
+ procedure Check_Restriction
+ (R : Restriction_Id;
+ N : Node_Id;
+ V : Uint := Uint_Minus_1)
+ is
Rimage : constant String := Restriction_Id'Image (R);
- begin
- Violations (R) := True;
+ VV : Integer;
+ -- V converted to integer form. If V is greater than Integer'Last,
+ -- it is reset to minus 1 (unknown value).
- if (Restrictions (R) or Restriction_Warnings (R))
- and then not Suppress_Restriction_Message (N)
- then
- -- Output proper message. If this is just a case of
- -- a restriction warning, then we output a warning msg
+ procedure Update_Restrictions (Info : in out Restrictions_Info);
+ -- Update violation information in Info.Violated and Info.Count
- if not Restrictions (R) then
- Restriction_Msg
- ("?violation of restriction %", Rimage, N);
+ -------------------------
+ -- Update_Restrictions --
+ -------------------------
- -- If this is a real restriction violation, then generate
- -- a non-serious message with appropriate location.
+ procedure Update_Restrictions (Info : in out Restrictions_Info) is
+ begin
+ -- If not violated, set as violated now
- else
- Error_Msg_Sloc := Restrictions_Loc (R);
+ if not Info.Violated (R) then
+ Info.Violated (R) := True;
+
+ if R in All_Parameter_Restrictions then
+ if VV < 0 then
+ Info.Unknown (R) := True;
+ Info.Count (R) := 1;
+ else
+ Info.Count (R) := VV;
+ end if;
+ end if;
+
+ -- Otherwise if violated already and a parameter restriction,
+ -- update count by maximizing or summing depending on restriction.
+
+ elsif R in All_Parameter_Restrictions then
+
+ -- If new value is unknown, result is unknown
+
+ if VV < 0 then
+ Info.Unknown (R) := True;
- -- If we have a location for the Restrictions pragma, output it
+ -- If checked by maximization, do maximization
- if Error_Msg_Sloc > No_Location
- or else Error_Msg_Sloc = System_Location
- then
- Restriction_Msg
- ("|violation of restriction %#", Rimage, N);
+ elsif R in Checked_Max_Parameter_Restrictions then
+ Info.Count (R) := Integer'Max (Info.Count (R), VV);
- -- Otherwise restriction was implicit (e.g. set by another pragma)
+ -- If checked by adding, do add, checking for overflow
+
+ elsif R in Checked_Add_Parameter_Restrictions then
+ declare
+ pragma Unsuppress (Overflow_Check);
+ begin
+ Info.Count (R) := Info.Count (R) + VV;
+ exception
+ when Constraint_Error =>
+ Info.Count (R) := Integer'Last;
+ Info.Unknown (R) := True;
+ end;
+
+ -- Should not be able to come here, known counts should only
+ -- occur for restrictions that are Checked_max or Checked_Sum.
else
- Restriction_Msg
- ("|violation of implicit restriction %", Rimage, N);
+ raise Program_Error;
end if;
end if;
- end if;
- end Check_Restriction;
+ end Update_Restrictions;
- -- Case where a parameter is present, with a count
+ -- Start of processing for Check_Restriction
- procedure Check_Restriction
- (R : Restriction_Parameter_Id;
- V : Uint;
- N : Node_Id)
- is
begin
- if Restriction_Parameters (R) /= No_Uint
- and then V > Restriction_Parameters (R)
- and then not Suppress_Restriction_Message (N)
+ if UI_Is_In_Int_Range (V) then
+ VV := Integer (UI_To_Int (V));
+ else
+ VV := -1;
+ end if;
+
+ -- Count can only be specified in the checked val parameter case
+
+ pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
+
+ -- Nothing to do if value of zero specified for parameter restriction
+
+ if VV = 0 then
+ return;
+ end if;
+
+ -- Update current restrictions
+
+ Update_Restrictions (Restrictions);
+
+ -- If in main extended unit, update main restrictions as well
+
+ if Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N)
then
- declare
- S : constant String := Restriction_Parameter_Id'Image (R);
- begin
- Name_Buffer (1 .. S'Last) := S;
- Name_Len := S'Length;
- Set_Casing (All_Lower_Case);
- Error_Msg_Name_1 := Name_Enter;
- Error_Msg_Sloc := Restriction_Parameters_Loc (R);
- Error_Msg_N ("|maximum value exceeded for restriction %#", N);
- end;
+ Update_Restrictions (Main_Restrictions);
end if;
- end Check_Restriction;
- -- Case where a parameter is present, no count given
+ -- Nothing to do if restriction message suppressed
- procedure Check_Restriction
- (R : Restriction_Parameter_Id;
- N : Node_Id)
- is
- begin
- if Restriction_Parameters (R) = Uint_0
- and then not Suppress_Restriction_Message (N)
+ if Suppress_Restriction_Message (N) then
+ null;
+
+ -- If restriction not set, nothing to do
+
+ elsif not Restrictions.Set (R) then
+ null;
+
+ -- Here if restriction set, check for violation (either this is a
+ -- Boolean restriction, or a parameter restriction with a value of
+ -- zero and an unknown count, or a parameter restriction with a
+ -- known value that exceeds the restriction count).
+
+ elsif R in All_Boolean_Restrictions
+ or else (Restrictions.Unknown (R)
+ and then Restrictions.Value (R) = 0)
+ or else Restrictions.Count (R) > Restrictions.Value (R)
then
- declare
- S : constant String := Restriction_Parameter_Id'Image (R);
- begin
- Name_Buffer (1 .. S'Last) := S;
- Name_Len := S'Length;
- Set_Casing (All_Lower_Case);
- Error_Msg_Name_1 := Name_Enter;
- Error_Msg_Sloc := Restriction_Parameters_Loc (R);
- Error_Msg_N ("|maximum value exceeded for restriction %#", N);
- end;
+ Error_Msg_Sloc := Restrictions_Loc (R);
+
+ -- If we have a location for the Restrictions pragma, output it
+
+ if Error_Msg_Sloc > No_Location
+ or else Error_Msg_Sloc = System_Location
+ then
+ if Restriction_Warnings (R) then
+ Restriction_Msg ("|violation of restriction %#?", Rimage, N);
+ else
+ Restriction_Msg ("|violation of restriction %#", Rimage, N);
+ end if;
+
+ -- Otherwise we have the case of an implicit restriction
+ -- (e.g. a restriction implicitly set by another pragma)
+
+ else
+ Restriction_Msg
+ ("|violation of implicit restriction %", Rimage, N);
+ end if;
end if;
end Check_Restriction;
- -------------------------------------------
- -- Compilation_Unit_Restrictions_Restore --
- -------------------------------------------
+ ----------------------------------------
+ -- Cunit_Boolean_Restrictions_Restore --
+ ----------------------------------------
- procedure Compilation_Unit_Restrictions_Restore
- (R : Save_Compilation_Unit_Restrictions)
+ procedure Cunit_Boolean_Restrictions_Restore
+ (R : Save_Cunit_Boolean_Restrictions)
is
begin
- for J in Compilation_Unit_Restrictions loop
- Restrictions (J) := R (J);
+ for J in Cunit_Boolean_Restrictions loop
+ Restrictions.Set (J) := R (J);
end loop;
- end Compilation_Unit_Restrictions_Restore;
+ end Cunit_Boolean_Restrictions_Restore;
- ----------------------------------------
- -- Compilation_Unit_Restrictions_Save --
- ----------------------------------------
+ -------------------------------------
+ -- Cunit_Boolean_Restrictions_Save --
+ -------------------------------------
- function Compilation_Unit_Restrictions_Save
- return Save_Compilation_Unit_Restrictions
+ function Cunit_Boolean_Restrictions_Save
+ return Save_Cunit_Boolean_Restrictions
is
- R : Save_Compilation_Unit_Restrictions;
+ R : Save_Cunit_Boolean_Restrictions;
begin
- for J in Compilation_Unit_Restrictions loop
- R (J) := Restrictions (J);
- Restrictions (J) := False;
+ for J in Cunit_Boolean_Restrictions loop
+ R (J) := Restrictions.Set (J);
+ Restrictions.Set (J) := False;
end loop;
return R;
- end Compilation_Unit_Restrictions_Save;
+ end Cunit_Boolean_Restrictions_Save;
------------------------
-- Get_Restriction_Id --
------------------------
function Get_Restriction_Id
- (N : Name_Id)
- return Restriction_Id
+ (N : Name_Id) return Restriction_Id
is
- J : Restriction_Id;
-
begin
Get_Name_String (N);
Set_Casing (All_Upper_Case);
- J := Restriction_Id'First;
- while J /= Not_A_Restriction_Id loop
+ for J in All_Restrictions loop
declare
S : constant String := Restriction_Id'Image (J);
-
begin
- exit when S = Name_Buffer (1 .. Name_Len);
+ if S = Name_Buffer (1 .. Name_Len) then
+ return J;
+ end if;
end;
-
- J := Restriction_Id'Succ (J);
end loop;
- return J;
+ return Not_A_Restriction_Id;
end Get_Restriction_Id;
- ----------------------------------
- -- Get_Restriction_Parameter_Id --
- ----------------------------------
-
- function Get_Restriction_Parameter_Id
- (N : Name_Id)
- return Restriction_Parameter_Id
- is
- J : Restriction_Parameter_Id;
-
- begin
- Get_Name_String (N);
- Set_Casing (All_Upper_Case);
-
- J := Restriction_Parameter_Id'First;
- while J /= Not_A_Restriction_Parameter_Id loop
- declare
- S : constant String := Restriction_Parameter_Id'Image (J);
-
- begin
- exit when S = Name_Buffer (1 .. Name_Len);
- end;
-
- J := Restriction_Parameter_Id'Succ (J);
- end loop;
-
- return J;
- end Get_Restriction_Parameter_Id;
-
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
function No_Exception_Handlers_Set return Boolean is
begin
- return Restrictions (No_Exception_Handlers);
+ return Restrictions.Set (No_Exception_Handlers);
end No_Exception_Handlers_Set;
------------------------
function Restricted_Profile return Boolean is
begin
- return Restrictions (No_Abort_Statements)
- and then Restrictions (No_Asynchronous_Control)
- and then Restrictions (No_Entry_Queue)
- and then Restrictions (No_Task_Hierarchy)
- and then Restrictions (No_Task_Allocators)
- and then Restrictions (No_Dynamic_Priorities)
- and then Restrictions (No_Terminate_Alternatives)
- and then Restrictions (No_Dynamic_Interrupts)
- and then Restrictions (No_Protected_Type_Allocators)
- and then Restrictions (No_Local_Protected_Objects)
- and then Restrictions (No_Requeue)
- and then Restrictions (No_Task_Attributes)
- and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
- and then Restriction_Parameters (Max_Task_Entries) = 0
- and then Restriction_Parameters (Max_Protected_Entries) <= 1
- and then Restriction_Parameters (Max_Select_Alternatives) = 0;
+ return Restrictions.Set (No_Abort_Statements)
+ and then Restrictions.Set (No_Asynchronous_Control)
+ and then Restrictions.Set (No_Entry_Queue)
+ and then Restrictions.Set (No_Task_Hierarchy)
+ and then Restrictions.Set (No_Task_Allocators)
+ and then Restrictions.Set (No_Dynamic_Priorities)
+ and then Restrictions.Set (No_Terminate_Alternatives)
+ and then Restrictions.Set (No_Dynamic_Interrupts)
+ and then Restrictions.Set (No_Protected_Type_Allocators)
+ and then Restrictions.Set (No_Local_Protected_Objects)
+ and then Restrictions.Set (No_Requeue_Statements)
+ and then Restrictions.Set (No_Task_Attributes)
+ and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
+ and then Restrictions.Set (Max_Task_Entries)
+ and then Restrictions.Set (Max_Protected_Entries)
+ and then Restrictions.Set (Max_Select_Alternatives)
+ and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
+ and then Restrictions.Value (Max_Task_Entries) = 0
+ and then Restrictions.Value (Max_Protected_Entries) <= 1
+ and then Restrictions.Value (Max_Select_Alternatives) = 0;
end Restricted_Profile;
+ ------------------------
+ -- Restriction_Active --
+ ------------------------
+
+ function Restriction_Active (R : All_Restrictions) return Boolean is
+ begin
+ return Restrictions.Set (R);
+ end Restriction_Active;
+
---------------------
-- Restriction_Msg --
---------------------
-------------------
procedure Set_Ravenscar (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
begin
Set_Restricted_Profile (N);
- Restrictions (Boolean_Entry_Barriers) := True;
- Restrictions (No_Select_Statements) := True;
- Restrictions (No_Calendar) := True;
- Restrictions (No_Entry_Queue) := True;
- Restrictions (No_Relative_Delay) := True;
- Restrictions (No_Task_Termination) := True;
- Restrictions (No_Implicit_Heap_Allocations) := True;
-
- Restrictions_Loc (Boolean_Entry_Barriers) := Loc;
- Restrictions_Loc (No_Select_Statements) := Loc;
- Restrictions_Loc (No_Calendar) := Loc;
- Restrictions_Loc (No_Entry_Queue) := Loc;
- Restrictions_Loc (No_Relative_Delay) := Loc;
- Restrictions_Loc (No_Task_Termination) := Loc;
- Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc;
+ Set_Restriction (Boolean_Entry_Barriers, N);
+ Set_Restriction (No_Select_Statements, N);
+ Set_Restriction (No_Calendar, N);
+ Set_Restriction (No_Entry_Queue, N);
+ Set_Restriction (No_Relative_Delay, N);
+ Set_Restriction (No_Task_Termination, N);
+ Set_Restriction (No_Implicit_Heap_Allocations, N);
end Set_Ravenscar;
----------------------------
-- This must be coordinated with Restricted_Profile
procedure Set_Restricted_Profile (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ begin
+ -- Set Boolean restrictions for Restricted Profile
+
+ Set_Restriction (No_Abort_Statements, N);
+ Set_Restriction (No_Asynchronous_Control, N);
+ Set_Restriction (No_Entry_Queue, N);
+ Set_Restriction (No_Task_Hierarchy, N);
+ Set_Restriction (No_Task_Allocators, N);
+ Set_Restriction (No_Dynamic_Priorities, N);
+ Set_Restriction (No_Terminate_Alternatives, N);
+ Set_Restriction (No_Dynamic_Interrupts, N);
+ Set_Restriction (No_Protected_Type_Allocators, N);
+ Set_Restriction (No_Local_Protected_Objects, N);
+ Set_Restriction (No_Requeue_Statements, N);
+ Set_Restriction (No_Task_Attributes, N);
+
+ -- Set parameter restrictions
+
+ Set_Restriction (Max_Asynchronous_Select_Nesting, N, 0);
+ Set_Restriction (Max_Task_Entries, N, 0);
+ Set_Restriction (Max_Select_Alternatives, N, 0);
+ Set_Restriction (Max_Protected_Entries, N, 1);
+ end Set_Restricted_Profile;
+
+ ---------------------
+ -- Set_Restriction --
+ ---------------------
+
+ -- Case of Boolean restriction
+ procedure Set_Restriction
+ (R : All_Boolean_Restrictions;
+ N : Node_Id)
+ is
begin
- Restrictions (No_Abort_Statements) := True;
- Restrictions (No_Asynchronous_Control) := True;
- Restrictions (No_Entry_Queue) := True;
- Restrictions (No_Task_Hierarchy) := True;
- Restrictions (No_Task_Allocators) := True;
- Restrictions (No_Dynamic_Priorities) := True;
- Restrictions (No_Terminate_Alternatives) := True;
- Restrictions (No_Dynamic_Interrupts) := True;
- Restrictions (No_Protected_Type_Allocators) := True;
- Restrictions (No_Local_Protected_Objects) := True;
- Restrictions (No_Requeue) := True;
- Restrictions (No_Task_Attributes) := True;
-
- Restrictions_Loc (No_Abort_Statements) := Loc;
- Restrictions_Loc (No_Asynchronous_Control) := Loc;
- Restrictions_Loc (No_Entry_Queue) := Loc;
- Restrictions_Loc (No_Task_Hierarchy) := Loc;
- Restrictions_Loc (No_Task_Allocators) := Loc;
- Restrictions_Loc (No_Dynamic_Priorities) := Loc;
- Restrictions_Loc (No_Terminate_Alternatives) := Loc;
- Restrictions_Loc (No_Dynamic_Interrupts) := Loc;
- Restrictions_Loc (No_Protected_Type_Allocators) := Loc;
- Restrictions_Loc (No_Local_Protected_Objects) := Loc;
- Restrictions_Loc (No_Requeue) := Loc;
- Restrictions_Loc (No_Task_Attributes) := Loc;
-
- Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
- Restriction_Parameters (Max_Task_Entries) := Uint_0;
- Restriction_Parameters (Max_Select_Alternatives) := Uint_0;
-
- if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
- Restriction_Parameters (Max_Protected_Entries) := Uint_1;
+ Restrictions.Set (R) := True;
+
+ -- Set location, but preserve location of system
+ -- restriction for nice error msg with run time name
+
+ if Restrictions_Loc (R) /= System_Location then
+ Restrictions_Loc (R) := Sloc (N);
end if;
- end Set_Restricted_Profile;
+
+ -- Record the restriction if we are in the main unit,
+ -- or in the extended main unit. The reason that we
+ -- test separately for Main_Unit is that gnat.adc is
+ -- processed with Current_Sem_Unit = Main_Unit, but
+ -- nodes in gnat.adc do not appear to be the extended
+ -- main source unit (they probably should do ???)
+
+ if Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N)
+ then
+ if not Restriction_Warnings (R) then
+ Main_Restrictions.Set (R) := True;
+ end if;
+ end if;
+ end Set_Restriction;
+
+ -- Case of parameter restriction
+
+ procedure Set_Restriction
+ (R : All_Parameter_Restrictions;
+ N : Node_Id;
+ V : Integer)
+ is
+ begin
+ if Restrictions.Set (R) then
+ if V < Restrictions.Value (R) then
+ Restrictions.Value (R) := V;
+ Restrictions_Loc (R) := Sloc (N);
+ end if;
+
+ else
+ Restrictions.Set (R) := True;
+ Restrictions.Value (R) := V;
+ Restrictions_Loc (R) := Sloc (N);
+ end if;
+
+ -- Record the restriction if we are in the main unit,
+ -- or in the extended main unit. The reason that we
+ -- test separately for Main_Unit is that gnat.adc is
+ -- processed with Current_Sem_Unit = Main_Unit, but
+ -- nodes in gnat.adc do not appear to be the extended
+ -- main source unit (they probably should do ???)
+
+ if Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N)
+ then
+ if Main_Restrictions.Set (R) then
+ if V < Main_Restrictions.Value (R) then
+ Main_Restrictions.Value (R) := V;
+ end if;
+
+ elsif not Restriction_Warnings (R) then
+ Main_Restrictions.Set (R) := True;
+ Main_Restrictions.Value (R) := V;
+ end if;
+ end if;
+ end Set_Restriction;
----------------------------------
-- Suppress_Restriction_Message --
function Tasking_Allowed return Boolean is
begin
- return Restriction_Parameters (Max_Tasks) /= 0
- and then not Restrictions (No_Tasking);
+ return not Restrictions.Set (No_Tasking)
+ and then (not Restrictions.Set (Max_Tasks)
+ or else Restrictions.Value (Max_Tasks) > 0);
end Tasking_Allowed;
end Restrict;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- This package deals with the implementation of the Restrictions pragma
-with Rident;
+with Rident; use Rident;
with Types; use Types;
with Uintp; use Uintp;
package Restrict is
- type Restriction_Id is new Rident.Restriction_Id;
- -- The type Restriction_Id defines the set of restriction identifiers,
- -- which take no parameter (i.e. they are either present or not present).
- -- The actual definition is in the separate package Rident, so that
- -- it can easily be accessed by the binder without dragging in lots
- -- of stuff.
-
- subtype All_Restrictions is
- Restriction_Id range
- Restriction_Id (Rident.All_Restrictions'First) ..
- Restriction_Id (Rident.All_Restrictions'Last);
- -- All restriction identifiers
-
- subtype Partition_Restrictions is
- Restriction_Id range
- Restriction_Id (Rident.Partition_Restrictions'First) ..
- Restriction_Id (Rident.Partition_Restrictions'Last);
- -- Range of restriction identifiers that are checked by the binder
-
- subtype Compilation_Unit_Restrictions is
- Restriction_Id range
- Restriction_Id (Rident.Compilation_Unit_Restrictions'First) ..
- Restriction_Id (Rident.Compilation_Unit_Restrictions'Last);
- -- Range of restriction identifiers not checked by binder
-
- type Restriction_Parameter_Id is new Rident.Restriction_Parameter_Id;
- -- The type Restriction_Parameter_Id records cases where a parameter is
- -- present in the corresponding pragma. The actual definition is in the
- -- separate package Rident for consistency.
-
- type Restrictions_Flags is array (Restriction_Id) of Boolean;
- -- Type used for arrays indexed by Restriction_Id.
-
- Restrictions : Restrictions_Flags := (others => False);
- -- Corresponding entry is False if restriction is not active, and
- -- True if the restriction is active, i.e. if a pragma Restrictions
- -- has been seen anywhere. Note that we are happy to pick up any
- -- restrictions pragmas in with'ed units, since we are required to
- -- be consistent at link time, and we might as well find the error
- -- at compile time. Clients must NOT use this array for checking to
- -- see if a restriction is violated, instead it is required that the
- -- Check_Restriction subprograms be used for this purpose. The only
- -- legitimate direct use of this array is when the code is modified
- -- as a result of the restriction in some way.
-
- Restrictions_Loc : array (Restriction_Id) of Source_Ptr :=
+ Restrictions : Restrictions_Info;
+ -- This variable records restrictions found in any units in the main
+ -- extended unit, and in the case of restrictions checked for partition
+ -- consistency, restrictions found in any with'ed units, parent specs
+ -- etc, since we may as well check as much as we can at compile time.
+ -- These variables should not be referenced directly by clients. Instead
+ -- use Check_Restrictions to record a violation of a restriction, and
+ -- Restriction_Active to test if a given restriction is active.
+
+ Restrictions_Loc : array (All_Restrictions) of Source_Ptr :=
(others => No_Location);
-- Locations of Restrictions pragmas for error message purposes.
-- Valid only if corresponding entry in Restrictions is set. A value
-- pragma, and a value of System_Location is used for restrictions
-- set from package Standard by the processing in Targparm.
- Main_Restrictions : Restrictions_Flags := (others => False);
- -- This variable saves the cumulative restrictions in effect compiling
- -- any unit that is part of the extended main unit (i.e. the compiled
- -- unit, its spec if any, and its subunits if any). The reason we keep
- -- track of this is for the information that goes to the binder about
- -- restrictions that are set. The binder will identify a unit that has
- -- a restrictions pragma for error message purposes, and we do not want
- -- to pick up a restrictions pragma in a with'ed unit for this purpose.
-
- Violations : Restrictions_Flags := (others => False);
- -- Corresponding entry is False if the restriction has not been
- -- violated in the current main unit, and True if it has been violated.
+ Main_Restrictions : Restrictions_Info;
+ -- This variable records only restrictions found in any units of the
+ -- main extended unit. These are the variables used for ali file output,
+ -- since we want the binder to be able to accurately diagnose inter-unit
+ -- restriction violations.
- Restriction_Warnings : Restrictions_Flags := (others => False);
+ Restriction_Warnings : Rident.Restriction_Flags;
-- If one of these flags is set, then it means that violation of the
-- corresponding restriction results only in a warning message, not
-- in an error message, and the restriction is not otherwise enforced.
+ -- Note that the flags in Restrictions are set to indicate that the
+ -- restriction is set in this case, but Main_Restrictions is never
+ -- set if Restriction_Warnings is set, so this does not look like a
+ -- restriction to the binder.
- Restriction_Parameters :
- array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
- -- This array indicates the setting of restriction parameter identifier
- -- values. All values are initially set to No_Uint indicating that the
- -- parameter is not set, and are set to the appropriate non-negative
- -- value if a Restrictions pragma specifies the corresponding
- -- restriction parameter identifier with an appropriate value.
+ type Save_Cunit_Boolean_Restrictions is private;
+ -- Type used for saving and restoring compilation unit restrictions.
+ -- See Cunit_Boolean_Restrictions_[Save|Restore] subprograms.
- Restriction_Parameters_Loc :
- array (Restriction_Parameter_Id) of Source_Ptr;
- -- Locations of Restrictions pragmas for error message purposes.
- -- Valid only if corresponding entry in Restriction_Parameters is
- -- set to a value other than No_Uint.
+ -- The following declarations establish a mapping between restriction
+ -- identifiers, and the names of corresponding restriction library units.
type Unit_Entry is record
Res_Id : Restriction_Id;
Filenm : String (1 .. 8);
end record;
- type Unit_Array_Type is array (Positive range <>) of Unit_Entry;
-
- Unit_Array : constant Unit_Array_Type := (
+ Unit_Array : constant array (Positive range <>) of Unit_Entry := (
(No_Asynchronous_Control, "a-astaco"),
(No_Calendar, "a-calend"),
(No_Calendar, "calendar"),
(No_Unchecked_Conversion, "unchconv"),
(No_Unchecked_Deallocation, "a-uncdea"),
(No_Unchecked_Deallocation, "unchdeal"));
- -- This array defines the mapping between restriction identifiers and
- -- predefined language files containing units for which the identifier
- -- forbids semantic dependence.
-
- type Save_Compilation_Unit_Restrictions is private;
- -- Type used for saving and restoring compilation unit restrictions.
- -- See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
-- The following map has True for all GNAT pragmas. It is used to
-- implement pragma Restrictions (No_Implementation_Restrictions)
-- (which is why this restriction itself is excluded from the list).
- Implementation_Restriction : Restrictions_Flags :=
+ Implementation_Restriction : array (All_Restrictions) of Boolean :=
(Boolean_Entry_Barriers => True,
No_Calendar => True,
No_Dynamic_Interrupts => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Relative_Delay => True,
- No_Requeue => True,
+ No_Requeue_Statements => True,
No_Secondary_Stack => True,
No_Select_Statements => True,
No_Standard_Storage_Pools => True,
-- restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO).
-- If a restriction exists post error message at the given node.
- procedure Check_Restriction (R : Restriction_Id; N : Node_Id);
+ procedure Check_Restriction
+ (R : Restriction_Id;
+ N : Node_Id;
+ V : Uint := Uint_Minus_1);
-- Checks that the given restriction is not set, and if it is set, an
-- appropriate message is posted on the given node. Also records the
- -- violation in the violations array. Note that it is mandatory to
- -- always use this routine to check if a restriction is violated. Such
- -- checks must never be done directly by the caller, since otherwise
- -- they are not properly recorded in the violations array.
-
- procedure Check_Restriction
- (R : Restriction_Parameter_Id;
- V : Uint;
- N : Node_Id);
- -- Checks that the count in V does not exceed the maximum value of the
- -- restriction parameter value corresponding to the given restriction
- -- parameter identifier (if it has been set). If the count in V exceeds
- -- the maximum, then post an error message on node N. We use this call
- -- when we can tell the maximum usage at compile time. In other words,
- -- we guarantee that if a call is made to this routine, then the front
- -- end will make all necessary calls for the restriction parameter R
- -- to ensure that we really know the maximum value used anywhere.
-
- procedure Check_Restriction (R : Restriction_Parameter_Id; N : Node_Id);
- -- Check that the maximum value of the restriction parameter corresponding
- -- to the given restriction parameter identifier is not set to zero. If
- -- it has been set to zero, post an error message on node N. We use this
- -- call in cases where we can tell at compile time that the count must be
- -- at least one, but we can't tell anything more.
+ -- violation in the appropriate internal arrays. Note that it is
+ -- mandatory to always use this routine to check if a restriction
+ -- is violated. Such checks must never be done directly by the caller,
+ -- since otherwise violations in the absence of restrictions are not
+ -- properly recorded. The value of V is relevant only for parameter
+ -- restrictions, and in this case indicates the exact count for the
+ -- violation. If the exact count is not known, V is left at its
+ -- default value of -1 which indicates an unknown count.
procedure Check_Elaboration_Code_Allowed (N : Node_Id);
-- Tests to see if elaboration code is allowed by the current restrictions
-- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N).
-- Provided for easy use by back end, which has to check this restriction.
- function Compilation_Unit_Restrictions_Save
- return Save_Compilation_Unit_Restrictions;
+ function Cunit_Boolean_Restrictions_Save
+ return Save_Cunit_Boolean_Restrictions;
-- This function saves the compilation unit restriction settings, and
-- resets them to False. This is used e.g. when compiling a with'ed
-- unit to avoid incorrectly propagating restrictions. Note that it
-- required to be partition wide, because it allows the restriction
-- violation message to be given at compile time instead of link time.
- procedure Compilation_Unit_Restrictions_Restore
- (R : Save_Compilation_Unit_Restrictions);
+ procedure Cunit_Boolean_Restrictions_Restore
+ (R : Save_Cunit_Boolean_Restrictions);
-- This is the corresponding restore procedure to restore restrictions
- -- previously saved by Compilation_Unit_Restrictions_Save.
+ -- previously saved by Cunit_Boolean_Restrictions_Save.
function Get_Restriction_Id
- (N : Name_Id)
- return Restriction_Id;
+ (N : Name_Id) return Restriction_Id;
-- Given an identifier name, determines if it is a valid restriction
-- identifier, and if so returns the corresponding Restriction_Id
-- value, otherwise returns Not_A_Restriction_Id.
- function Get_Restriction_Parameter_Id
- (N : Name_Id)
- return Restriction_Parameter_Id;
- -- Given an identifier name, determines if it is a valid restriction
- -- parameter identifier, and if so returns the corresponding
- -- Restriction_Parameter_Id value, otherwise returns
- -- Not_A_Restriction_Parameter_Id.
-
function No_Exception_Handlers_Set return Boolean;
-- Test to see if current restrictions settings specify that no exception
-- handlers are present. This function is called by Gigi when it needs to
-- expand an AT END clean up identifier with no exception handler.
+ function Restriction_Active (R : All_Restrictions) return Boolean;
+ pragma Inline (Restriction_Active);
+ -- Determines if a given restriction is active. This call should only be
+ -- used where the compiled code depends on whether the restriction is
+ -- active. Always use Check_Restriction to record a violation.
+
function Restricted_Profile return Boolean;
-- Tests to see if tasking operations follow the GNAT restricted run time
-- profile.
-- pragma node, which is used for error messages on any constructs that
-- violate the profile.
+ procedure Set_Restriction
+ (R : All_Boolean_Restrictions;
+ N : Node_Id);
+ -- N is a node (typically a pragma node) that has the effect of setting
+ -- Boolean restriction R. The restriction is set in Restrictions, and
+ -- also in Main_Restrictions if this is the main unit.
+
+ procedure Set_Restriction
+ (R : All_Parameter_Restrictions;
+ N : Node_Id;
+ V : Integer);
+ -- Similar to the above, except that this is used for the case of a
+ -- parameter restriction, and the corresponding value V is given.
+
procedure Set_Restricted_Profile (N : Node_Id);
-- Enables the set of restrictions for pragma Restricted_Run_Time. N is
-- the corresponding pragma node, which is used for error messages on
-- be non-zero.
private
- type Save_Compilation_Unit_Restrictions is
- array (Compilation_Unit_Restrictions) of Boolean;
+ type Save_Cunit_Boolean_Restrictions is
+ array (Cunit_Boolean_Restrictions) of Boolean;
-- Type used for saving and restoring compilation unit restrictions.
-- See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R E S T R I C T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Restrictions is
+ use Rident;
+
+ -------------------
+ -- Abort_Allowed --
+ -------------------
+
+ function Abort_Allowed return Boolean is
+ begin
+ return Restrictions.Violated (No_Abort_Statements)
+ or else
+ Restrictions.Violated (Max_Asynchronous_Select_Nesting);
+ end Abort_Allowed;
+
+ ---------------------
+ -- Tasking_Allowed --
+ ---------------------
+
+ function Tasking_Allowed return Boolean is
+ begin
+ return Restrictions.Violated (Max_Tasks)
+ or else
+ Restrictions.Violated (No_Tasking);
+ end Tasking_Allowed;
+
+begin
+ null;
+end System.Restrictions;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R E S T R I C T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a run-time interface for checking the set of
+-- restrictions that applies to the current partition. The information
+-- comes both from explicit restriction pragmas present, and also from
+-- compile time checking.
+
+-- The package simply contains an instantiation of System.Rident, but
+-- with names discarded, so that we do not have image tables for the
+-- large restriction enumeration types at run time.
+
+with System.Rident;
+
+package System.Restrictions is
+ pragma Discard_Names;
+ package Rident is new System.Rident;
+
+ Restrictions : Rident.Restrictions_Info;
+
+ ------------------
+ -- Subprograms --
+ -----------------
+
+ function Abort_Allowed return Boolean;
+ pragma Inline (Abort_Allowed);
+ -- Tests to see if abort is allowed by the current restrictions settings.
+ -- For abort to be allowed, either No_Abort_Statements must be False,
+ -- or Max_Asynchronous_Select_Nesting must be non-zero.
+
+ function Tasking_Allowed return Boolean;
+ pragma Inline (Tasking_Allowed);
+ -- Tests to see if tasking operations are allowed by the current
+ -- restrictions settings. For tasking to be allowed Max_Tasks must
+
+end System.Restrictions;
+
+
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
package System.Rident is
-- The following enumeration type defines the set of restriction
- -- identifiers not taking a parameter that are implemented in GNAT.
+ -- identifiers that are implemented in GNAT.
+
-- To add a new restriction identifier, add an entry with the name
-- to be used in the pragma, and add appropriate calls to the
-- Restrict.Check_Restriction routine.
- type Restriction_Id is (
+ type Restriction_Id is
-- The following cases are checked for consistency in the binder
- Boolean_Entry_Barriers, -- GNAT (Ravenscar)
+ (Boolean_Entry_Barriers, -- GNAT (Ravenscar)
No_Abort_Statements, -- (RM D.7(5), H.4(3))
No_Access_Subprograms, -- (RM H.4(17))
No_Allocators, -- (RM H.4(7))
No_Recursion, -- (RM H.4(22))
No_Reentrancy, -- (RM H.4(23))
No_Relative_Delay, -- GNAT (Ravenscar)
- No_Requeue, -- GNAT
+ No_Requeue_Statements, -- GNAT
No_Secondary_Stack, -- GNAT
No_Select_Statements, -- GNAT (Ravenscar)
No_Standard_Storage_Pools, -- GNAT
No_Implementation_Restrictions, -- GNAT
No_Elaboration_Code, -- GNAT
+ -- The following cases require a parameter value
+
+ -- The following entries are fully checked at compile/bind time,
+ -- which means that the compiler can in general tell the minimum
+ -- value which could be used with a restrictions pragma. The binder
+ -- can deduce the appropriate minimum value for the partition by
+ -- taking the maximum value required by any unit.
+
+ Max_Protected_Entries, -- (RM D.7(14))
+ Max_Select_Alternatives, -- (RM D.7(12))
+ Max_Task_Entries, -- (RM D.7(13), H.4(3))
+
+ -- The following entries are also fully checked at compile/bind
+ -- time, and the compiler can also at least in some cases tell
+ -- the minimum value which could be used with a restriction pragma.
+ -- The difference is that the contributions are additive, so the
+ -- binder deduces this value by adding the unit contributions.
+
+ Max_Tasks, -- (RM D.7(19), H.4(3))
+
+ -- The following entries are checked at compile time only for
+ -- zero/nonzero entries. This means that the compiler can tell
+ -- at compile time if a restriction value of zero is (would be)
+ -- violated, but that is all. The compiler cannot distinguish
+ -- between different non-zero values.
+
+ Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
+ Max_Entry_Queue_Depth, -- GNAT
+
+ -- The remaining entries are not checked at compile/bind time
+
+ Max_Storage_At_Blocking, -- (RM D.7(17))
+
Not_A_Restriction_Id);
+ -- Synonyms permitted for historical purposes of compatibility
+
+ -- No_Requeue synonym for No_Requeue_Statements
+ -- No_Tasking synonym for Max_Tasks => 0
+
subtype All_Restrictions is Restriction_Id range
- Boolean_Entry_Barriers .. No_Elaboration_Code;
- -- All restrictions except Not_A_Restriction_Id
+ Boolean_Entry_Barriers .. Max_Storage_At_Blocking;
+ -- All restrictions (excluding only Not_A_Restriction_Id)
- -- The following range of Restriction identifiers is checked for
- -- consistency across a partition. The generated ali file is marked
- -- for each entry to show one of three possibilities:
- --
- -- Corresponding restriction is set (so unit does not violate it)
- -- Corresponding restriction is not violated
- -- Corresponding restriction is violated
+ subtype All_Boolean_Restrictions is Restriction_Id range
+ Boolean_Entry_Barriers .. No_Elaboration_Code;
+ -- All restrictions which do not take a parameter
- subtype Partition_Restrictions is Restriction_Id range
+ subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range
Boolean_Entry_Barriers .. Static_Storage_Size;
+ -- Boolean restrictions that are checked for partition consistency.
+ -- Note that all parameter restrictions are checked for partition
+ -- consistency by default, so this distinction is only needed in the
+ -- case of Boolean restrictions.
- -- The following set of Restriction identifiers is not checked for
- -- consistency across a partition. The generated ali file still
- -- contains indications of the above three possibilities for the
- -- purposes of listing applicable restrictions.
-
- subtype Compilation_Unit_Restrictions is Restriction_Id range
+ subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range
Immediate_Reclamation .. No_Elaboration_Code;
+ -- Boolean restrictions that are not checked for partition consistency
+ -- and that thus apply only to the current unit. Note that for these
+ -- restrictions, the compiler does not apply restrictions found in
+ -- with'ed units, parent specs etc to the main unit.
- -- The following enumeration type defines the set of restriction
- -- parameter identifiers taking a parameter that are implemented in
- -- GNAT. To add a new restriction parameter identifier, add an entry
- -- with the name to be used in the pragma, and add appropriate
- -- calls to Restrict.Check_Restriction.
-
- -- Note: the GNAT implementation currently only accomodates restriction
- -- parameter identifiers whose expression value is a non-negative
- -- integer. This is true for all language defined parameters.
-
- type Restriction_Parameter_Id is (
- Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
- Max_Entry_Queue_Depth, -- GNAT
- Max_Protected_Entries, -- (RM D.7(14))
- Max_Select_Alternatives, -- (RM D.7(12))
- Max_Storage_At_Blocking, -- (RM D.7(17))
- Max_Task_Entries, -- (RM D.7(13), H.4(3))
- Max_Tasks, -- (RM D.7(19), H.4(3))
- Not_A_Restriction_Parameter_Id);
+ subtype All_Parameter_Restrictions is
+ Restriction_Id range
+ Max_Protected_Entries .. Max_Storage_At_Blocking;
+ -- All restrictions that are take a parameter
+
+ subtype Checked_Parameter_Restrictions is
+ All_Parameter_Restrictions range
+ Max_Protected_Entries .. Max_Entry_Queue_Depth;
+ -- These are the parameter restrictions that can be at least partially
+ -- checked at compile/binder time. Minimally, the compiler can detect
+ -- violations of a restriction pragma with a value of zero reliably.
+
+ subtype Checked_Max_Parameter_Restrictions is
+ Checked_Parameter_Restrictions range
+ Max_Protected_Entries .. Max_Task_Entries;
+ -- Restrictions with parameters that can be checked in some cases by
+ -- maximizing among statically detected instances where the compiler
+ -- can determine the count.
+
+ subtype Checked_Add_Parameter_Restrictions is
+ Checked_Parameter_Restrictions range
+ Max_Tasks .. Max_Tasks;
+ -- Restrictions with parameters that can be checked in some cases by
+ -- summing the statically detected instances where the compiler can
+ -- determine the count.
+
+ subtype Checked_Val_Parameter_Restrictions is
+ Checked_Parameter_Restrictions range
+ Max_Protected_Entries .. Max_Tasks;
+ -- Restrictions with parameter where the count is known at least in
+ -- some cases by the compiler/binder.
+
+ subtype Checked_Zero_Parameter_Restrictions is
+ Checked_Parameter_Restrictions range
+ Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Depth;
+ -- Restrictions with parameters where the compiler can detect the use of
+ -- the feature, and hence violations of a restriction specifying a value
+ -- of zero, but cannot detect specific values other than zero/nonzero.
+
+ subtype Unchecked_Parameter_Restrictions is
+ All_Parameter_Restrictions range
+ Max_Storage_At_Blocking .. Max_Storage_At_Blocking;
+ -- Restrictions with parameters where the compiler cannot ever detect
+ -- corresponding compile time usage, so the binder and compiler never
+ -- detect violations of any restriction.
+
+ -------------------------------------
+ -- Restriction Status Declarations --
+ -------------------------------------
+
+ -- The following declarations are used to record the current status
+ -- or restrictions (for the current unit, or related units, at compile
+ -- time, and for all units in a partition at bind time or run time).
+
+ type Restriction_Flags is array (All_Restrictions) of Boolean;
+ type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
+ type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean;
+
+ type Restrictions_Info is record
+ Set : Restriction_Flags := (others => False);
+ -- An entry is True in the Set array if a restrictions pragma has
+ -- been encountered for the given restriction. If the value is
+ -- True for a parameter restriction, then the corresponding entry
+ -- in the Value array gives the minimum value encountered for any
+ -- such restriction.
+
+ Value : Restriction_Values;
+ -- If the entry for a parameter restriction in Set is True (i.e. a
+ -- restrictions pragma for the restriction has been encountered), then
+ -- the corresponding entry in the Value array is the minimum value
+ -- specified by any such restrictions pragma. Note that a restrictions
+ -- pragma specifying a value greater than Int'Last is simply ignored.
+
+ Violated : Restriction_Flags := (others => False);
+ -- An entry is True in the violations array if the compiler has
+ -- detected a violation of the restriction. For a parameter
+ -- restriction, the Count and Unknown arrays have additional
+ -- information.
+
+ Count : Restriction_Values := (others => 0);
+ -- If an entry for a parameter restriction is True in Violated,
+ -- the corresponding entry in the Count array may record additional
+ -- information. If the actual minimum count is known (by taking
+ -- maximums, or sums, depending on the restriction), it will be
+ -- recorded in this array. If not, then the value will remain zero.
+
+ Unknown : Parameter_Flags := (others => False);
+ -- If an entry for a parameter restriction is True in Violated,
+ -- the corresponding entry in the Unknown array may record additional
+ -- information. If the actual count is not known by the compiler (but
+ -- is known to be non-zero), then the entry in Unknown will be True.
+ -- This indicates that the value in Count is not known to be exact,
+ -- and the actual violation count may be higher.
+
+ -- Note: If Violated (K) is True, then either Count (K) > 0 or
+ -- Unknown (K) = True. It is possible for both these to be set.
+ -- For example, if Count (K) = 3 and Unknown (K) is True, it means
+ -- that the actual violation count is at least 3 but might be higher.
+ end record;
end System.Rident;
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "-" (Left : Address; Right : Storage_Offset) return Address;
pragma Convention (Intrinsic, "-");
pragma Inline_Always ("-");
- pragma Pure_Function ("+");
+ pragma Pure_Function ("-");
function "-" (Left, Right : Address) return Storage_Offset;
pragma Convention (Intrinsic, "-");
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
pragma Inline (Get_Jmpbuf_Address);
procedure Set_Jmpbuf_Address (Addr : Address);
- pragma Inline (Get_Jmpbuf_Address);
+ pragma Inline (Set_Jmpbuf_Address);
function Get_Sec_Stack_Addr return Address;
pragma Inline (Get_Sec_Stack_Addr);
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sdefault; use Sdefault;
with Sem; use Sem;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
declare
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
if not GNAT_Mode then
Semantics (Parent_Spec (Unit_Node));
Version_Update (N, Parent_Spec (Unit_Node));
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
Un : Unit_Number_Type;
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
Item := First (Context_Items (N));
end loop;
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
-- Set True if the unit currently being compiled is an internal unit
Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
if Limited_Present (N) then
-- Restore style checks and restrictions
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
-- Record the reference, but do NOT set the unit as referenced, we
-- want to consider the unit as unreferenced if this is the only
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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 Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch5; use Sem_Ch5;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Rident; use Rident;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
if K = E_Generic_In_Parameter then
- -- Ada0Y (AI-287): Limited aggregates allowed in generic formals
+ -- Ada 0Y (AI-287): Limited aggregates allowed in generic formals
if not Extensions_Allowed and then Is_Limited_Type (T) then
Error_Msg_N
elsif Ekind (Gen_Unit) /= E_Generic_Package then
- -- Ada0Y (AI-50217): Instance can not be used in limited with_clause
+ -- Ada 0Y (AI-50217): Instance can not be used in limited with_clause
if From_With_Type (Gen_Unit) then
Error_Msg_N
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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 Errout; use Errout;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem_Ch8; use Sem_Ch8;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
- -- Ada0Y (AI-50217): Propagate the attribute that indicates that the
+ -- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-- access type is also imported, and therefore restricted in its use.
-- The access type may already be imported, so keep setting otherwise.
- -- Ada0Y (AI-50217): If the non-limited view of the designated type is
+ -- Ada 0Y (AI-50217): If the non-limited view of the designated type is
-- available, use it as the designated type of the access type, so that
-- the back-end gets a usable entity.
begin
Generate_Definition (Id);
Enter_Name (Id);
- T := Find_Type_Of_Object (Subtype_Indication (Component_Definition (N)),
- N);
+
+ if Present (Subtype_Indication (Component_Definition (N))) then
+ T := Find_Type_Of_Object
+ (Subtype_Indication (Component_Definition (N)), N);
+
+ -- Ada 0Y (AI-230): Access Definition case
+
+ elsif Present (Access_Definition (Component_Definition (N))) then
+ T := Access_Definition
+ (Related_Nod => N,
+ N => Access_Definition (Component_Definition (N)));
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
-- If the subtype is a constrained subtype of the enclosing record,
-- (which must have a partial view) the back-end does not handle
-- the subtype of the object is constrained by the defaults, so it is
-- worthile building the corresponding subtype.
+ function Count_Tasks (T : Entity_Id) return Uint;
+ -- This function is called when a library level object of type T
+ -- is declared. It's function is to count the static number of
+ -- tasks declared within the type (it is only called if Has_Tasks
+ -- is set for T). As a side effect, if an array of tasks with
+ -- non-static bounds or a variant record type is encountered,
+ -- Check_Restrictions is called indicating the count is unknown.
+
---------------------------
-- Build_Default_Subtype --
---------------------------
return Act;
end Build_Default_Subtype;
+ -----------------
+ -- Count_Tasks --
+ -----------------
+
+ function Count_Tasks (T : Entity_Id) return Uint is
+ C : Entity_Id;
+ X : Node_Id;
+ V : Uint;
+
+ begin
+ if Is_Task_Type (T) then
+ return Uint_1;
+
+ elsif Is_Record_Type (T) then
+ if Has_Discriminants (T) then
+ Check_Restriction (Max_Tasks, N);
+ return Uint_0;
+
+ else
+ V := Uint_0;
+ C := First_Component (T);
+ while Present (C) loop
+ V := V + Count_Tasks (Etype (C));
+ Next_Component (C);
+ end loop;
+
+ return V;
+ end if;
+
+ elsif Is_Array_Type (T) then
+ X := First_Index (T);
+ V := Count_Tasks (Component_Type (T));
+ while Present (X) loop
+ C := Etype (X);
+
+ if not Is_Static_Subtype (C) then
+ Check_Restriction (Max_Tasks, N);
+ return Uint_0;
+ else
+ V := V * (UI_Max (Uint_0,
+ Expr_Value (Type_High_Bound (C)) -
+ Expr_Value (Type_Low_Bound (C)) + Uint_1));
+ end if;
+
+ Next_Index (X);
+ end loop;
+
+ return V;
+
+ else
+ return Uint_0;
+ end if;
+ end Count_Tasks;
+
-- Start of processing for Analyze_Object_Declaration
begin
end if;
if Has_Task (Etype (Id)) then
- Check_Restriction (Max_Tasks, N);
+ Check_Restriction (No_Tasking, N);
- if not Is_Library_Level_Entity (Id) then
+ if Is_Library_Level_Entity (Id) then
+ Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
+
+ else
+ Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Hierarchy, N);
Check_Potentially_Blocking_Operation (N);
end if;
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
+ Access_Definition => Empty,
Subtype_Mark => New_Occurrence_Of
(Base_Type (Etype (Id)), Loc),
Name => E));
-- The full view, if present, now points to the current type
- -- Ada0Y (AI-50217): If the type was previously decorated when imported
+ -- Ada 0Y (AI-50217): If the type was previously decorated when imported
-- through a LIMITED WITH clause, it appears as incomplete but has no
-- full view.
begin
if Nkind (Def) = N_Constrained_Array_Definition then
-
Index := First (Discrete_Subtype_Definitions (Def));
+ else
+ Index := First (Subtype_Marks (Def));
+ end if;
- -- Find proper names for the implicit types which may be public.
- -- in case of anonymous arrays we use the name of the first object
- -- of that type as prefix.
-
- if No (T) then
- Related_Id := Defining_Identifier (P);
- else
- Related_Id := T;
- end if;
+ -- Find proper names for the implicit types which may be public.
+ -- in case of anonymous arrays we use the name of the first object
+ -- of that type as prefix.
+ if No (T) then
+ Related_Id := Defining_Identifier (P);
else
- Index := First (Subtype_Marks (Def));
+ Related_Id := T;
end if;
Nb_Index := 1;
Nb_Index := Nb_Index + 1;
end loop;
- Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
- P, Related_Id, 'C');
+ if Present (Subtype_Indication (Component_Def)) then
+ Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
+ P, Related_Id, 'C');
+
+ -- Ada 0Y (AI-230): Access Definition case
+
+ elsif Present (Access_Definition (Component_Def)) then
+ Element_Type := Access_Definition
+ (Related_Nod => Related_Id,
+ N => Access_Definition (Component_Def));
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
-- Constrained array case
Discr : Entity_Id;
Discr_Con_Elist : Elist_Id;
Discr_Con_El : Elmt_Id;
-
- Subt : Entity_Id;
+ Subt : Entity_Id;
begin
-- Set the designated type so it is available in case this is
and then not In_Instance
and then not In_Inlined_Body
then
- -- Ada0Y (AI-287): Relax the strictness of the front-end in case of
+ -- Ada 0Y (AI-287): Relax the strictness of the front-end in case of
-- limited aggregates and extension aggregates.
if Extensions_Allowed
Set_Is_Immediately_Visible (D);
Set_Homonym (D, Prev);
- -- This restriction gets applied to the full type here; it
- -- has already been applied earlier to the partial view
+ -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
+ -- record types
+
+ if not Extensions_Allowed then
- Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ -- This restriction gets applied to the full type here; it
+ -- has already been applied earlier to the partial view
+
+ Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ end if;
Next_Discriminant (D);
end loop;
end if;
if Is_Access_Type (Discr_Type) then
- Check_Access_Discriminant_Requires_Limited
- (Discr, Discriminant_Type (Discr));
+
+ -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
+ -- record types
+
+ if not Extensions_Allowed then
+ Check_Access_Discriminant_Requires_Limited
+ (Discr, Discriminant_Type (Discr));
+ end if;
if Ada_83 and then Comes_From_Source (Discr) then
Error_Msg_N
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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 Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
and then Comes_From_Source (N)
and then not In_Instance_Body
then
- -- Ada0Y (AI-287): Do not post an error if the expression corres-
- -- ponds to a limited aggregate. Limited aggregates are checked in
- -- sem_aggr in a per-component manner (cf. Get_Value subprogram).
+ -- Ada 0Y (AI-287): Do not post an error if the expression
+ -- corresponds to a limited aggregate. Limited aggregates
+ -- are checked in sem_aggr in a per-component manner
+ -- (compare with handling of Get_Value subprogram).
if Extensions_Allowed
and then Nkind (Expression (E)) = N_Aggregate
end if;
if Has_Task (Designated_Type (Acc_Type)) then
+ Check_Restriction (No_Tasking, N);
Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Allocators, N);
end if;
Actual := First_Actual (N);
while Present (Actual) loop
- -- Ada0Y (AI-50217): Post an error in case of premature usage of
+ -- Ada 0Y (AI-50217): Post an error in case of premature usage of
-- an entity from the limited view.
if not Analyzed (Etype (Actual))
return;
end if;
+ -- Ada 0Y (AI-230): Keep restriction imposed by Ada 83 and 95: Do not
+ -- allow anonymous access types in equality operators.
+
+ if not Extensions_Allowed
+ and then Ekind (T1) = E_Anonymous_Access_Type
+ then
+ return;
+ end if;
+
if T1 /= Standard_Void_Type
and then not Is_Limited_Type (T1)
and then not Is_Limited_Composite (T1)
- and then Ekind (T1) /= E_Anonymous_Access_Type
and then Has_Compatible_Type (R, T1)
then
if Found
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
Id : constant Entity_Id := Defining_Identifier (N);
Dec : Node_Id;
Nam : constant Node_Id := Name (N);
- S : constant Entity_Id := Subtype_Mark (N);
T : Entity_Id;
T2 : Entity_Id;
Set_Etype (Nam, T);
end if;
- else
- Find_Type (S);
- T := Entity (S);
+ elsif Present (Subtype_Mark (N)) then
+ Find_Type (Subtype_Mark (N));
+ T := Entity (Subtype_Mark (N));
+ Analyze_And_Resolve (Nam, T);
+
+ -- Ada 0Y (AI-230): Access renaming
+
+ elsif Present (Access_Definition (N)) then
+ Find_Type (Subtype_Mark (Access_Definition (N)));
+ T := Access_Definition
+ (Related_Nod => N,
+ N => Access_Definition (N));
Analyze_And_Resolve (Nam, T);
+
+ else
+ pragma Assert (False);
+ null;
end if;
-- An object renaming requires an exact match of the type;
Error_Msg_N
("expect package name in renaming", Name (N));
- -- Ada0Y (AI-50217): Limited withed packages can not be renamed
+ -- Ada 0Y (AI-50217): Limited withed packages can not be renamed
elsif Ekind (Old_P) = E_Package
and then From_With_Type (Old_P)
Set_Chars (Selector, Chars (Id));
end if;
- -- Ada0Y (AI-50217): Check usage of entities in limited withed units
+ -- Ada 0Y (AI-50217): Check usage of entities in limited withed units
if Ekind (P_Name) = E_Package
and then From_With_Type (P_Name)
Set_In_Use (P);
- -- Ada0Y (AI-50217): Check restriction.
+ -- Ada 0Y (AI-50217): Check restriction.
if From_With_Type (P) then
Error_Msg_N ("limited withed package cannot appear in use clause", N);
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
-- Local Subprograms --
-----------------------
- procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id);
- -- Given either a protected definition or a task definition in Def, check
+ procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
+ -- Given either a protected definition or a task definition in D, check
-- the corresponding restriction parameter identifier R, and if it is set,
-- count the entries (checking the static requirement), and compare with
-- the given maximum.
-- with interrupt handlers. Note that we need to analyze the protected
-- definition to set Has_Entries and such.
- if (Abort_Allowed or else Restrictions (No_Entry_Queue) = False
+ if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (T) > 1)
and then
(Has_Entries (T)
Outer_Ent : Entity_Id;
begin
- Check_Restriction (No_Requeue, N);
+ Check_Restriction (No_Requeue_Statements, N);
Check_Unreachable_Code (N);
Tasking_Used := True;
begin
Check_Restriction (No_Select_Statements, N);
- Check_Restriction (Max_Select_Alternatives, N);
Tasking_Used := True;
Alt := First (Alts);
Next (Alt);
end loop;
- Check_Restriction (Max_Select_Alternatives, Alt_Count, N);
+ Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
Check_Potentially_Blocking_Operation (N);
if Terminate_Present and Delay_Present then
-- expanded twice, with disastrous result.
Analyze_Task_Type (N);
-
end Analyze_Single_Task;
-----------------------
Def_Id : constant Entity_Id := Defining_Identifier (N);
begin
- Tasking_Used := True;
Check_Restriction (No_Tasking, N);
+ Tasking_Used := True;
T := Find_Type_Name (N);
Generate_Definition (T);
-- Check_Max_Entries --
-----------------------
- procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id) is
+ procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
Ecount : Uint;
procedure Count (L : List_Id);
end if;
end;
- -- If entry family with non-static bounds, give error msg
+ -- Entry family with non-static bounds
+
+ else
+ -- If restriction is set, then this is an error
- elsif Restriction_Parameters (R) /= No_Uint then
- Error_Msg_N
- ("static subtype required by Restriction pragma", DSD);
+ if Restrictions.Set (R) then
+ Error_Msg_N
+ ("static subtype required by Restriction pragma",
+ DSD);
+
+ -- Otherwise we record an unknown count restriction
+
+ else
+ Check_Restriction (R, D);
+ end if;
end if;
end;
end if;
begin
Ecount := Uint_0;
- Count (Visible_Declarations (Def));
- Count (Private_Declarations (Def));
+ Count (Visible_Declarations (D));
+ Count (Private_Declarations (D));
if Ecount > 0 then
- Check_Restriction (R, Ecount, Def);
+ Check_Restriction (R, D, Ecount);
end if;
end Check_Max_Entries;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch7; use Sem_Ch7;
if (Nkind (Original_Node (N)) = N_Accept_Statement
or else Nkind (Original_Node (N)) = N_Selective_Accept)
- and then Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
return Abandon;
elsif Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
and then not Cunit_SC
- and then not Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ and then
+ not Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
-- Runtime elaboration check required. generate check of the
-- elaboration Boolean for the unit containing the entity.
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
-- is set to the default from the subprogram name.
procedure Process_Interrupt_Or_Attach_Handler;
- -- Attach the pragmas to the rep item chain.
+ -- Common processing for Interrupt and Attach_Handler pragmas
+
+ procedure Process_Restrictions_Or_Restriction_Warnings;
+ -- Common processing for Restrictions and Restriction_Warnings pragmas
procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
-- Common processing for Suppress and Unsuppress. The boolean parameter
-- for packages, exceptions, and record components.
elsif C = Convention_Java
- and then (Ekind (Def_Id) = E_Package
- or else Ekind (Def_Id) = E_Exception
- or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
+ and then
+ (Ekind (Def_Id) = E_Package
+ or else Ekind (Def_Id) = E_Exception
+ or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
then
Set_Imported (Def_Id);
Set_Is_Public (Def_Id);
--------------------
procedure Process_Inline (Active : Boolean) is
- Assoc : Node_Id;
- Decl : Node_Id;
- Subp_Id : Node_Id;
- Subp : Entity_Id;
- Applies : Boolean;
+ Assoc : Node_Id;
+ Decl : Node_Id;
+ Subp_Id : Node_Id;
+ Subp : Entity_Id;
+ Applies : Boolean;
+ Effective : Boolean := False;
procedure Make_Inline (Subp : Entity_Id);
-- Subp is the defining unit name of the subprogram
Set_Has_Pragma_Inline (Subp);
Set_Next_Rep_Item (N, First_Rep_Item (Subp));
Set_First_Rep_Item (Subp, N);
+ Effective := True;
end if;
end Set_Inline_Flags;
if not Applies then
Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc);
+
+ elsif not Effective
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_NE ("pragma inline on& is redundant?",
+ N, Entity (Subp_Id));
end if;
Next (Assoc);
if Ekind (Proc_Scope) = E_Protected_Type then
if Prag_Id = Pragma_Interrupt_Handler
- or Prag_Id = Pragma_Attach_Handler
+ or else
+ Prag_Id = Pragma_Attach_Handler
then
Record_Rep_Item (Proc_Scope, N);
end if;
end if;
end Process_Interrupt_Or_Attach_Handler;
+ --------------------------------------------------
+ -- Process_Restrictions_Or_Restriction_Warnings --
+ --------------------------------------------------
+
+ procedure Process_Restrictions_Or_Restriction_Warnings is
+ Arg : Node_Id;
+ R_Id : Restriction_Id;
+ Id : Name_Id;
+ Expr : Node_Id;
+ Val : Uint;
+
+ procedure Set_Warning (R : All_Restrictions);
+ -- If this is a Restriction_Warnings pragma, set warning flag
+
+ procedure Set_Warning (R : All_Restrictions) is
+ begin
+ if Prag_Id = Pragma_Restriction_Warnings then
+ Restriction_Warnings (R) := True;
+ end if;
+ end Set_Warning;
+
+ -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
+
+ begin
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (1);
+ Check_Valid_Configuration_Pragma;
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Id := Chars (Arg);
+ Expr := Expression (Arg);
+
+ -- Case of no restriction identifier
+
+ if Id = No_Name then
+ if Nkind (Expr) /= N_Identifier then
+ Error_Pragma_Arg
+ ("invalid form for restriction", Arg);
+
+ else
+ -- No_Requeue is a synonym for No_Requeue_Statements
+
+ if Chars (Expr) = Name_No_Requeue then
+ Check_Restriction
+ (No_Implementation_Restrictions, Arg);
+ Set_Restriction (No_Requeue_Statements, N);
+ Set_Warning (No_Requeue_Statements);
+
+ -- Normal processing for all other cases
+
+ else
+ R_Id := Get_Restriction_Id (Chars (Expr));
+
+ if R_Id not in All_Boolean_Restrictions then
+ Error_Pragma_Arg
+ ("invalid restriction identifier", Arg);
+
+ -- Restriction is active
+
+ else
+ if Implementation_Restriction (R_Id) then
+ Check_Restriction
+ (No_Implementation_Restrictions, Arg);
+ end if;
+
+ Set_Restriction (R_Id, N);
+ Set_Warning (R_Id);
+
+ -- A very special case that must be processed here:
+ -- pragma Restrictions (No_Exceptions) turns off
+ -- all run-time checking. This is a bit dubious in
+ -- terms of the formal language definition, but it
+ -- is what is intended by RM H.4(12).
+
+ if R_Id = No_Exceptions then
+ Scope_Suppress := (others => True);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Case of restriction identifier present
+
+ else
+ R_Id := Get_Restriction_Id (Id);
+ Analyze_And_Resolve (Expr, Any_Integer);
+
+ if R_Id not in All_Parameter_Restrictions then
+ Error_Pragma_Arg
+ ("invalid restriction parameter identifier", Arg);
+
+ elsif not Is_OK_Static_Expression (Expr) then
+ Flag_Non_Static_Expr
+ ("value must be static expression!", Expr);
+ raise Pragma_Exit;
+
+ elsif not Is_Integer_Type (Etype (Expr))
+ or else Expr_Value (Expr) < 0
+ then
+ Error_Pragma_Arg
+ ("value must be non-negative integer", Arg);
+
+ -- Restriction pragma is active
+
+ else
+ Val := Expr_Value (Expr);
+
+ if not UI_Is_In_Int_Range (Val) then
+ Error_Pragma_Arg
+ ("pragma ignored, value too large?", Arg);
+ else
+ Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
+ Set_Warning (R_Id);
+ end if;
+ end if;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Process_Restrictions_Or_Restriction_Warnings;
+
---------------------------------
-- Process_Suppress_Unsuppress --
---------------------------------
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
- if not Restrictions (No_Initialize_Scalars) then
+ if not Restriction_Active (No_Initialize_Scalars) then
Init_Or_Norm_Scalars := True;
Initialize_Scalars := True;
end if;
end if;
end;
- Restrictions (No_Finalization) := True;
- Restrictions (No_Exception_Handlers) := True;
- Restriction_Parameters (Max_Tasks) := Uint_0;
+ Set_Restriction (No_Finalization, N);
+ Set_Restriction (No_Exception_Handlers, N);
+ Set_Restriction (Max_Tasks, N, 0);
+ Set_Restriction (No_Tasking, N);
-----------------------
-- Normalize_Scalars --
-- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
when Pragma_Pure_Function => Pure_Function : declare
- E_Id : Node_Id;
- E : Entity_Id;
- Def_Id : Entity_Id;
+ E_Id : Node_Id;
+ E : Entity_Id;
+ Def_Id : Entity_Id;
+ Effective : Boolean := False;
begin
GNAT_Pragma;
end if;
Set_Is_Pure (Def_Id);
- Set_Has_Pragma_Pure_Function (Def_Id);
+
+ if not Has_Pragma_Pure_Function (Def_Id) then
+ Set_Has_Pragma_Pure_Function (Def_Id);
+ Effective := True;
+ end if;
E := Homonym (E);
exit when No (E) or else Scope (E) /= Current_Scope;
end loop;
+
+ if not Effective
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_NE ("pragma Pure_Function on& is redundant?",
+ N, Entity (E_Id));
+ end if;
end if;
end Pure_Function;
-- restriction_IDENTIFIER
-- | restriction_parameter_IDENTIFIER => EXPRESSION
- when Pragma_Restrictions => Restrictions_Pragma : declare
- Arg : Node_Id;
- R_Id : Restriction_Id;
- RP_Id : Restriction_Parameter_Id;
- Id : Name_Id;
- Expr : Node_Id;
- Val : Uint;
-
- begin
- Check_Ada_83_Warning;
- Check_At_Least_N_Arguments (1);
- Check_Valid_Configuration_Pragma;
-
- Arg := Arg1;
- while Present (Arg) loop
- Id := Chars (Arg);
- Expr := Expression (Arg);
-
- -- Case of no restriction identifier
-
- if Id = No_Name then
- if Nkind (Expr) /= N_Identifier then
- Error_Pragma_Arg
- ("invalid form for restriction", Arg);
-
- else
- R_Id := Get_Restriction_Id (Chars (Expr));
-
- if R_Id = Not_A_Restriction_Id then
- Error_Pragma_Arg
- ("invalid restriction identifier", Arg);
-
- -- Restriction is active
-
- else
- if Implementation_Restriction (R_Id) then
- Check_Restriction
- (No_Implementation_Restrictions, Arg);
- end if;
-
- Restrictions (R_Id) := True;
-
- -- Set location, but preserve location of system
- -- restriction for nice error msg with run time name
-
- if Restrictions_Loc (R_Id) /= System_Location then
- Restrictions_Loc (R_Id) := Sloc (N);
- end if;
-
- -- Record the restriction if we are in the main unit,
- -- or in the extended main unit. The reason that we
- -- test separately for Main_Unit is that gnat.adc is
- -- processed with Current_Sem_Unit = Main_Unit, but
- -- nodes in gnat.adc do not appear to be the extended
- -- main source unit (they probably should do ???)
-
- if Current_Sem_Unit = Main_Unit
- or else In_Extended_Main_Source_Unit (N)
- then
- Main_Restrictions (R_Id) := True;
- end if;
-
- -- A very special case that must be processed here:
- -- pragma Restrictions (No_Exceptions) turns off all
- -- run-time checking. This is a bit dubious in terms
- -- of the formal language definition, but it is what
- -- is intended by the wording of RM H.4(12).
-
- if R_Id = No_Exceptions then
- Scope_Suppress := (others => True);
- end if;
- end if;
- end if;
-
- -- Case of restriction identifier present
-
- else
- RP_Id := Get_Restriction_Parameter_Id (Id);
- Analyze_And_Resolve (Expr, Any_Integer);
-
- if RP_Id = Not_A_Restriction_Parameter_Id then
- Error_Pragma_Arg
- ("invalid restriction parameter identifier", Arg);
-
- elsif not Is_OK_Static_Expression (Expr) then
- Flag_Non_Static_Expr
- ("value must be static expression!", Expr);
- raise Pragma_Exit;
-
- elsif not Is_Integer_Type (Etype (Expr))
- or else Expr_Value (Expr) < 0
- then
- Error_Pragma_Arg
- ("value must be non-negative integer", Arg);
-
- -- Restriction pragma is active
-
- else
- Val := Expr_Value (Expr);
-
- -- Record pragma if most restrictive so far
-
- if Restriction_Parameters (RP_Id) = No_Uint
- or else Val < Restriction_Parameters (RP_Id)
- then
- Restriction_Parameters (RP_Id) := Val;
- Restriction_Parameters_Loc (RP_Id) := Sloc (N);
- end if;
- end if;
- end if;
-
- Next (Arg);
- end loop;
- end Restrictions_Pragma;
+ when Pragma_Restrictions =>
+ Process_Restrictions_Or_Restriction_Warnings;
--------------------------
-- Restriction_Warnings --
-- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
- -- RESTRICTION ::= restriction_IDENTIFIER
-
- when Pragma_Restriction_Warnings => Restriction_Warn : declare
- Arg : Node_Id;
- R_Id : Restriction_Id;
- Expr : Node_Id;
-
- begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
- Check_Valid_Configuration_Pragma;
- Check_No_Identifiers;
-
- Arg := Arg1;
- while Present (Arg) loop
- Expr := Expression (Arg);
-
- if Nkind (Expr) /= N_Identifier then
- Error_Pragma_Arg
- ("invalid form for restriction", Arg);
-
- else
- R_Id := Get_Restriction_Id (Chars (Expr));
-
- if R_Id = Not_A_Restriction_Id then
- Error_Pragma_Arg
- ("invalid restriction identifier", Arg);
-
- -- Restriction is active
-
- else
- if Implementation_Restriction (R_Id) then
- Check_Restriction
- (No_Implementation_Restrictions, Arg);
- end if;
-
- Restriction_Warnings (R_Id) := True;
- end if;
- end if;
+ -- RESTRICTION ::=
+ -- restriction_IDENTIFIER
+ -- | restriction_parameter_IDENTIFIER => EXPRESSION
- Next (Arg);
- end loop;
- end Restriction_Warn;
+ when Pragma_Restriction_Warnings =>
+ Process_Restrictions_Or_Restriction_Warnings;
----------------
-- Reviewable --
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
Scop := Current_Scope;
if Nam = Scop
- and then not Restrictions (No_Recursion)
+ and then not Restriction_Active (No_Recursion)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
then
return True;
- -- Ada0Y (AI-50217): Additional branches to make the shadow entity
+ -- Ada 0Y (AI-50217): Additional branches to make the shadow entity
-- compatible with its real entity.
elsif From_With_Type (T1) then
elsif T = Universal_Fixed then
return Etype (R);
+ -- Ada 0Y (AI-230): Support the following operators:
+
+ -- function "=" (L, R : universal_access) return Boolean;
+ -- function "/=" (L, R : universal_access) return Boolean;
+
+ elsif Extensions_Allowed
+ and then Ekind (Etype (L)) = E_Anonymous_Access_Type
+ and then Is_Access_Type (Etype (R))
+ then
+ return Etype (L);
+
+ elsif Extensions_Allowed
+ and then Ekind (Etype (R)) = E_Anonymous_Access_Type
+ and then Is_Access_Type (Etype (L))
+ then
+ return Etype (R);
+
else
return Specific_Type (T, Etype (R));
end if;
return Node2 (N);
end Accept_Statement;
+ function Access_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Definition
+ or else NT (N).Nkind = N_Object_Renaming_Declaration);
+ return Node3 (N);
+ end Access_Definition;
+
function Access_Types_To_Process
(N : Node_Id) return Elist_Id is
begin
Set_Node2_With_Parent (N, Val);
end Set_Accept_Statement;
+ procedure Set_Access_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Definition
+ or else NT (N).Nkind = N_Object_Renaming_Declaration);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Access_Definition;
+
procedure Set_Access_Types_To_Process
(N : Node_Id; Val : Elist_Id) is
begin
-- 3.6 Component Definition --
-------------------------------
- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+ -- COMPONENT_DEFINITION ::=
+ -- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Note: although the syntax does not permit a component definition to
-- be an anonymous array (and the parser will diagnose such an attempt
-- with an appropriate message), it is possible for anonymous arrays
-- to appear as component definitions. The semantics and back end handle
-- this case properly, and the expander in fact generates such cases.
+ -- Access_Definition is an optional field that gives support to Ada 0Y
+ -- (AI-230). The parser generates nodes that have either the
+ -- Subtype_Indication field or else the Access_Definition field.
-- N_Component_Definition
- -- Sloc points to ALIASED or to first token of subtype mark
+ -- Sloc points to ALIASED, ACCESS or to first token of subtype mark
-- Aliased_Present (Flag4)
- -- Subtype_Indication (Node5)
+ -- Subtype_Indication (Node5) (set to Empty if not present)
+ -- Access_Definition (Node3) (set to Empty if not present)
-----------------------------
-- 3.6.1 Index Constraint --
-- list of selector names in the record aggregate case, or a list of
-- discrete choices in the array aggregate case or an N_Others_Choice
-- node (which appears as a singleton list). Box_Present gives support
- -- to Ada0Y (AI-287).
+ -- to Ada 0Y (AI-287).
------------------------------------
-- 4.3.1 Commponent Choice List --
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
+
+ -- Note: Access_Definition is an optional field that gives support to
+ -- Ada 0Y (AI-230). The parser generates nodes that have either the
+ -- Subtype_Indication field or else the Access_Definition field.
-- N_Object_Renaming_Declaration
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
- -- Subtype_Mark (Node4)
+ -- Subtype_Mark (Node4) (set to Empty if not present)
+ -- Access_Definition (Node3) (set to Empty if not present)
-- Name (Node2)
-- Corresponding_Generic_Association (Node5-Sem)
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Note: Limited_Present and Limited_View_Installed give support to
- -- Ada0Y (AI-50217).
+ -- Ada 0Y (AI-50217).
----------------------
-- With_Type clause --
function Accept_Statement
(N : Node_Id) return Node_Id; -- Node2
+ function Access_Definition
+ (N : Node_Id) return Node_Id; -- Node3
+
function Access_Types_To_Process
(N : Node_Id) return Elist_Id; -- Elist2
procedure Set_Accept_Statement
(N : Node_Id; Val : Node_Id); -- Node2
+ procedure Set_Access_Definition
+ (N : Node_Id; Val : Node_Id); -- Node3
+
procedure Set_Access_Types_To_Process
(N : Node_Id; Val : Elist_Id); -- Elist2
pragma Inline (Abstract_Present);
pragma Inline (Accept_Handler_Records);
pragma Inline (Accept_Statement);
+ pragma Inline (Access_Definition);
pragma Inline (Access_Types_To_Process);
pragma Inline (Actions);
pragma Inline (Activation_Chain_Entity);
pragma Inline (Set_Abstract_Present);
pragma Inline (Set_Accept_Handler_Records);
pragma Inline (Set_Accept_Statement);
+ pragma Inline (Set_Access_Definition);
pragma Inline (Set_Access_Types_To_Process);
pragma Inline (Set_Actions);
pragma Inline (Set_Activation_Chain_Entity);
"on#" &
"parameter_types#" &
"reference#" &
+ "no_requeue#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
Name_DLL : constant Name_Id := N + 241;
Name_Win32 : constant Name_Id := N + 242;
- -- Other special names used in processing pragma arguments
+ -- Other special names used in processing pragmas
Name_As_Is : constant Name_Id := N + 243;
Name_Body_File_Name : constant Name_Id := N + 244;
Name_On : constant Name_Id := N + 274;
Name_Parameter_Types : constant Name_Id := N + 275;
Name_Reference : constant Name_Id := N + 276;
- Name_Restricted : constant Name_Id := N + 277;
- Name_Result_Mechanism : constant Name_Id := N + 278;
- Name_Result_Type : constant Name_Id := N + 279;
- Name_Runtime : constant Name_Id := N + 280;
- Name_SB : constant Name_Id := N + 281;
- Name_Secondary_Stack_Size : constant Name_Id := N + 282;
- Name_Section : constant Name_Id := N + 283;
- Name_Semaphore : constant Name_Id := N + 284;
- Name_Spec_File_Name : constant Name_Id := N + 285;
- Name_Static : constant Name_Id := N + 286;
- Name_Stack_Size : constant Name_Id := N + 287;
- Name_Subunit_File_Name : constant Name_Id := N + 288;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 289;
- Name_Task_Type : constant Name_Id := N + 290;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 291;
- Name_Top_Guard : constant Name_Id := N + 292;
- Name_UBA : constant Name_Id := N + 293;
- Name_UBS : constant Name_Id := N + 294;
- Name_UBSB : constant Name_Id := N + 295;
- Name_Unit_Name : constant Name_Id := N + 296;
- Name_Unknown : constant Name_Id := N + 297;
- Name_Unrestricted : constant Name_Id := N + 298;
- Name_Uppercase : constant Name_Id := N + 299;
- Name_User : constant Name_Id := N + 300;
- Name_VAX_Float : constant Name_Id := N + 301;
- Name_VMS : constant Name_Id := N + 302;
- Name_Working_Storage : constant Name_Id := N + 303;
+ Name_No_Requeue : constant Name_Id := N + 277;
+ Name_Restricted : constant Name_Id := N + 278;
+ Name_Result_Mechanism : constant Name_Id := N + 279;
+ Name_Result_Type : constant Name_Id := N + 280;
+ Name_Runtime : constant Name_Id := N + 281;
+ Name_SB : constant Name_Id := N + 282;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 283;
+ Name_Section : constant Name_Id := N + 284;
+ Name_Semaphore : constant Name_Id := N + 285;
+ Name_Spec_File_Name : constant Name_Id := N + 286;
+ Name_Static : constant Name_Id := N + 287;
+ Name_Stack_Size : constant Name_Id := N + 288;
+ Name_Subunit_File_Name : constant Name_Id := N + 289;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 290;
+ Name_Task_Type : constant Name_Id := N + 291;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 292;
+ Name_Top_Guard : constant Name_Id := N + 293;
+ Name_UBA : constant Name_Id := N + 294;
+ Name_UBS : constant Name_Id := N + 295;
+ Name_UBSB : constant Name_Id := N + 296;
+ Name_Unit_Name : constant Name_Id := N + 297;
+ Name_Unknown : constant Name_Id := N + 298;
+ Name_Unrestricted : constant Name_Id := N + 299;
+ Name_Uppercase : constant Name_Id := N + 300;
+ Name_User : constant Name_Id := N + 301;
+ Name_VAX_Float : constant Name_Id := N + 302;
+ Name_VMS : constant Name_Id := N + 303;
+ Name_Working_Storage : constant Name_Id := N + 304;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
- First_Attribute_Name : constant Name_Id := N + 304;
- Name_Abort_Signal : constant Name_Id := N + 304; -- GNAT
- Name_Access : constant Name_Id := N + 305;
- Name_Address : constant Name_Id := N + 306;
- Name_Address_Size : constant Name_Id := N + 307; -- GNAT
- Name_Aft : constant Name_Id := N + 308;
- Name_Alignment : constant Name_Id := N + 309;
- Name_Asm_Input : constant Name_Id := N + 310; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 311; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 312; -- VMS
- Name_Bit : constant Name_Id := N + 313; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 314;
- Name_Bit_Position : constant Name_Id := N + 315; -- GNAT
- Name_Body_Version : constant Name_Id := N + 316;
- Name_Callable : constant Name_Id := N + 317;
- Name_Caller : constant Name_Id := N + 318;
- Name_Code_Address : constant Name_Id := N + 319; -- GNAT
- Name_Component_Size : constant Name_Id := N + 320;
- Name_Compose : constant Name_Id := N + 321;
- Name_Constrained : constant Name_Id := N + 322;
- Name_Count : constant Name_Id := N + 323;
- Name_Default_Bit_Order : constant Name_Id := N + 324; -- GNAT
- Name_Definite : constant Name_Id := N + 325;
- Name_Delta : constant Name_Id := N + 326;
- Name_Denorm : constant Name_Id := N + 327;
- Name_Digits : constant Name_Id := N + 328;
- Name_Elaborated : constant Name_Id := N + 329; -- GNAT
- Name_Emax : constant Name_Id := N + 330; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 331; -- GNAT
- Name_Epsilon : constant Name_Id := N + 332; -- Ada 83
- Name_Exponent : constant Name_Id := N + 333;
- Name_External_Tag : constant Name_Id := N + 334;
- Name_First : constant Name_Id := N + 335;
- Name_First_Bit : constant Name_Id := N + 336;
- Name_Fixed_Value : constant Name_Id := N + 337; -- GNAT
- Name_Fore : constant Name_Id := N + 338;
- Name_Has_Discriminants : constant Name_Id := N + 339; -- GNAT
- Name_Identity : constant Name_Id := N + 340;
- Name_Img : constant Name_Id := N + 341; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 342; -- GNAT
- Name_Large : constant Name_Id := N + 343; -- Ada 83
- Name_Last : constant Name_Id := N + 344;
- Name_Last_Bit : constant Name_Id := N + 345;
- Name_Leading_Part : constant Name_Id := N + 346;
- Name_Length : constant Name_Id := N + 347;
- Name_Machine_Emax : constant Name_Id := N + 348;
- Name_Machine_Emin : constant Name_Id := N + 349;
- Name_Machine_Mantissa : constant Name_Id := N + 350;
- Name_Machine_Overflows : constant Name_Id := N + 351;
- Name_Machine_Radix : constant Name_Id := N + 352;
- Name_Machine_Rounds : constant Name_Id := N + 353;
- Name_Machine_Size : constant Name_Id := N + 354; -- GNAT
- Name_Mantissa : constant Name_Id := N + 355; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 356;
- Name_Maximum_Alignment : constant Name_Id := N + 357; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 358; -- GNAT
- Name_Model_Emin : constant Name_Id := N + 359;
- Name_Model_Epsilon : constant Name_Id := N + 360;
- Name_Model_Mantissa : constant Name_Id := N + 361;
- Name_Model_Small : constant Name_Id := N + 362;
- Name_Modulus : constant Name_Id := N + 363;
- Name_Null_Parameter : constant Name_Id := N + 364; -- GNAT
- Name_Object_Size : constant Name_Id := N + 365; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 366;
- Name_Passed_By_Reference : constant Name_Id := N + 367; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 368;
- Name_Pos : constant Name_Id := N + 369;
- Name_Position : constant Name_Id := N + 370;
- Name_Range : constant Name_Id := N + 371;
- Name_Range_Length : constant Name_Id := N + 372; -- GNAT
- Name_Round : constant Name_Id := N + 373;
- Name_Safe_Emax : constant Name_Id := N + 374; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 375;
- Name_Safe_Large : constant Name_Id := N + 376; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 377;
- Name_Safe_Small : constant Name_Id := N + 378; -- Ada 83
- Name_Scale : constant Name_Id := N + 379;
- Name_Scaling : constant Name_Id := N + 380;
- Name_Signed_Zeros : constant Name_Id := N + 381;
- Name_Size : constant Name_Id := N + 382;
- Name_Small : constant Name_Id := N + 383;
- Name_Storage_Size : constant Name_Id := N + 384;
- Name_Storage_Unit : constant Name_Id := N + 385; -- GNAT
- Name_Tag : constant Name_Id := N + 386;
- Name_Target_Name : constant Name_Id := N + 387; -- GNAT
- Name_Terminated : constant Name_Id := N + 388;
- Name_To_Address : constant Name_Id := N + 389; -- GNAT
- Name_Type_Class : constant Name_Id := N + 390; -- GNAT
- Name_UET_Address : constant Name_Id := N + 391; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 392;
- Name_Unchecked_Access : constant Name_Id := N + 393;
- Name_Unconstrained_Array : constant Name_Id := N + 394;
- Name_Universal_Literal_String : constant Name_Id := N + 395; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 396; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 397; -- GNAT
- Name_Val : constant Name_Id := N + 398;
- Name_Valid : constant Name_Id := N + 399;
- Name_Value_Size : constant Name_Id := N + 400; -- GNAT
- Name_Version : constant Name_Id := N + 401;
- Name_Wchar_T_Size : constant Name_Id := N + 402; -- GNAT
- Name_Wide_Width : constant Name_Id := N + 403;
- Name_Width : constant Name_Id := N + 404;
- Name_Word_Size : constant Name_Id := N + 405; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 305;
+ Name_Abort_Signal : constant Name_Id := N + 305; -- GNAT
+ Name_Access : constant Name_Id := N + 306;
+ Name_Address : constant Name_Id := N + 307;
+ Name_Address_Size : constant Name_Id := N + 308; -- GNAT
+ Name_Aft : constant Name_Id := N + 309;
+ Name_Alignment : constant Name_Id := N + 310;
+ Name_Asm_Input : constant Name_Id := N + 311; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 312; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 313; -- VMS
+ Name_Bit : constant Name_Id := N + 314; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 315;
+ Name_Bit_Position : constant Name_Id := N + 316; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 317;
+ Name_Callable : constant Name_Id := N + 318;
+ Name_Caller : constant Name_Id := N + 319;
+ Name_Code_Address : constant Name_Id := N + 320; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 321;
+ Name_Compose : constant Name_Id := N + 322;
+ Name_Constrained : constant Name_Id := N + 323;
+ Name_Count : constant Name_Id := N + 324;
+ Name_Default_Bit_Order : constant Name_Id := N + 325; -- GNAT
+ Name_Definite : constant Name_Id := N + 326;
+ Name_Delta : constant Name_Id := N + 327;
+ Name_Denorm : constant Name_Id := N + 328;
+ Name_Digits : constant Name_Id := N + 329;
+ Name_Elaborated : constant Name_Id := N + 330; -- GNAT
+ Name_Emax : constant Name_Id := N + 331; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 332; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 333; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 334;
+ Name_External_Tag : constant Name_Id := N + 335;
+ Name_First : constant Name_Id := N + 336;
+ Name_First_Bit : constant Name_Id := N + 337;
+ Name_Fixed_Value : constant Name_Id := N + 338; -- GNAT
+ Name_Fore : constant Name_Id := N + 339;
+ Name_Has_Discriminants : constant Name_Id := N + 340; -- GNAT
+ Name_Identity : constant Name_Id := N + 341;
+ Name_Img : constant Name_Id := N + 342; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 343; -- GNAT
+ Name_Large : constant Name_Id := N + 344; -- Ada 83
+ Name_Last : constant Name_Id := N + 345;
+ Name_Last_Bit : constant Name_Id := N + 346;
+ Name_Leading_Part : constant Name_Id := N + 347;
+ Name_Length : constant Name_Id := N + 348;
+ Name_Machine_Emax : constant Name_Id := N + 349;
+ Name_Machine_Emin : constant Name_Id := N + 350;
+ Name_Machine_Mantissa : constant Name_Id := N + 351;
+ Name_Machine_Overflows : constant Name_Id := N + 352;
+ Name_Machine_Radix : constant Name_Id := N + 353;
+ Name_Machine_Rounds : constant Name_Id := N + 354;
+ Name_Machine_Size : constant Name_Id := N + 355; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 356; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 357;
+ Name_Maximum_Alignment : constant Name_Id := N + 358; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 359; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 360;
+ Name_Model_Epsilon : constant Name_Id := N + 361;
+ Name_Model_Mantissa : constant Name_Id := N + 362;
+ Name_Model_Small : constant Name_Id := N + 363;
+ Name_Modulus : constant Name_Id := N + 364;
+ Name_Null_Parameter : constant Name_Id := N + 365; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 366; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 367;
+ Name_Passed_By_Reference : constant Name_Id := N + 368; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 369;
+ Name_Pos : constant Name_Id := N + 370;
+ Name_Position : constant Name_Id := N + 371;
+ Name_Range : constant Name_Id := N + 372;
+ Name_Range_Length : constant Name_Id := N + 373; -- GNAT
+ Name_Round : constant Name_Id := N + 374;
+ Name_Safe_Emax : constant Name_Id := N + 375; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 376;
+ Name_Safe_Large : constant Name_Id := N + 377; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 378;
+ Name_Safe_Small : constant Name_Id := N + 379; -- Ada 83
+ Name_Scale : constant Name_Id := N + 380;
+ Name_Scaling : constant Name_Id := N + 381;
+ Name_Signed_Zeros : constant Name_Id := N + 382;
+ Name_Size : constant Name_Id := N + 383;
+ Name_Small : constant Name_Id := N + 384;
+ Name_Storage_Size : constant Name_Id := N + 385;
+ Name_Storage_Unit : constant Name_Id := N + 386; -- GNAT
+ Name_Tag : constant Name_Id := N + 387;
+ Name_Target_Name : constant Name_Id := N + 388; -- GNAT
+ Name_Terminated : constant Name_Id := N + 389;
+ Name_To_Address : constant Name_Id := N + 390; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 391; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 392; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 393;
+ Name_Unchecked_Access : constant Name_Id := N + 394;
+ Name_Unconstrained_Array : constant Name_Id := N + 395;
+ Name_Universal_Literal_String : constant Name_Id := N + 396; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 397; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 398; -- GNAT
+ Name_Val : constant Name_Id := N + 399;
+ Name_Valid : constant Name_Id := N + 400;
+ Name_Value_Size : constant Name_Id := N + 401; -- GNAT
+ Name_Version : constant Name_Id := N + 402;
+ Name_Wchar_T_Size : constant Name_Id := N + 403; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 404;
+ Name_Width : constant Name_Id := N + 405;
+ Name_Word_Size : constant Name_Id := N + 406; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value.
- First_Renamable_Function_Attribute : constant Name_Id := N + 406;
- Name_Adjacent : constant Name_Id := N + 406;
- Name_Ceiling : constant Name_Id := N + 407;
- Name_Copy_Sign : constant Name_Id := N + 408;
- Name_Floor : constant Name_Id := N + 409;
- Name_Fraction : constant Name_Id := N + 410;
- Name_Image : constant Name_Id := N + 411;
- Name_Input : constant Name_Id := N + 412;
- Name_Machine : constant Name_Id := N + 413;
- Name_Max : constant Name_Id := N + 414;
- Name_Min : constant Name_Id := N + 415;
- Name_Model : constant Name_Id := N + 416;
- Name_Pred : constant Name_Id := N + 417;
- Name_Remainder : constant Name_Id := N + 418;
- Name_Rounding : constant Name_Id := N + 419;
- Name_Succ : constant Name_Id := N + 420;
- Name_Truncation : constant Name_Id := N + 421;
- Name_Value : constant Name_Id := N + 422;
- Name_Wide_Image : constant Name_Id := N + 423;
- Name_Wide_Value : constant Name_Id := N + 424;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 424;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 407;
+ Name_Adjacent : constant Name_Id := N + 407;
+ Name_Ceiling : constant Name_Id := N + 408;
+ Name_Copy_Sign : constant Name_Id := N + 409;
+ Name_Floor : constant Name_Id := N + 410;
+ Name_Fraction : constant Name_Id := N + 411;
+ Name_Image : constant Name_Id := N + 412;
+ Name_Input : constant Name_Id := N + 413;
+ Name_Machine : constant Name_Id := N + 414;
+ Name_Max : constant Name_Id := N + 415;
+ Name_Min : constant Name_Id := N + 416;
+ Name_Model : constant Name_Id := N + 417;
+ Name_Pred : constant Name_Id := N + 418;
+ Name_Remainder : constant Name_Id := N + 419;
+ Name_Rounding : constant Name_Id := N + 420;
+ Name_Succ : constant Name_Id := N + 421;
+ Name_Truncation : constant Name_Id := N + 422;
+ Name_Value : constant Name_Id := N + 423;
+ Name_Wide_Image : constant Name_Id := N + 424;
+ Name_Wide_Value : constant Name_Id := N + 425;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 425;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 425;
- Name_Output : constant Name_Id := N + 425;
- Name_Read : constant Name_Id := N + 426;
- Name_Write : constant Name_Id := N + 427;
- Last_Procedure_Attribute : constant Name_Id := N + 427;
+ First_Procedure_Attribute : constant Name_Id := N + 426;
+ Name_Output : constant Name_Id := N + 426;
+ Name_Read : constant Name_Id := N + 427;
+ Name_Write : constant Name_Id := N + 428;
+ Last_Procedure_Attribute : constant Name_Id := N + 428;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 428;
- Name_Elab_Body : constant Name_Id := N + 428; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 429; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 430;
+ First_Entity_Attribute_Name : constant Name_Id := N + 429;
+ Name_Elab_Body : constant Name_Id := N + 429; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 430; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 431;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 431;
- Name_Base : constant Name_Id := N + 431;
- Name_Class : constant Name_Id := N + 432;
- Last_Type_Attribute_Name : constant Name_Id := N + 432;
- Last_Entity_Attribute_Name : constant Name_Id := N + 432;
- Last_Attribute_Name : constant Name_Id := N + 432;
+ First_Type_Attribute_Name : constant Name_Id := N + 432;
+ Name_Base : constant Name_Id := N + 432;
+ Name_Class : constant Name_Id := N + 433;
+ Last_Type_Attribute_Name : constant Name_Id := N + 433;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 433;
+ Last_Attribute_Name : constant Name_Id := N + 433;
-- Names of recognized locking policy identifiers
-- name (e.g. C for Ceiling_Locking). If new policy names are added,
-- the first character must be distinct.
- First_Locking_Policy_Name : constant Name_Id := N + 433;
- Name_Ceiling_Locking : constant Name_Id := N + 433;
- Name_Inheritance_Locking : constant Name_Id := N + 434;
- Last_Locking_Policy_Name : constant Name_Id := N + 434;
+ First_Locking_Policy_Name : constant Name_Id := N + 434;
+ Name_Ceiling_Locking : constant Name_Id := N + 434;
+ Name_Inheritance_Locking : constant Name_Id := N + 435;
+ Last_Locking_Policy_Name : constant Name_Id := N + 435;
-- Names of recognized queuing policy identifiers.
-- name (e.g. F for FIFO_Queuing). If new policy names are added,
-- the first character must be distinct.
- First_Queuing_Policy_Name : constant Name_Id := N + 435;
- Name_FIFO_Queuing : constant Name_Id := N + 435;
- Name_Priority_Queuing : constant Name_Id := N + 436;
- Last_Queuing_Policy_Name : constant Name_Id := N + 436;
+ First_Queuing_Policy_Name : constant Name_Id := N + 436;
+ Name_FIFO_Queuing : constant Name_Id := N + 436;
+ Name_Priority_Queuing : constant Name_Id := N + 437;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 437;
-- Names of recognized task dispatching policy identifiers
-- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
-- are added, the first character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + 437;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 437;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 437;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 438;
+ Name_Fifo_Within_Priorities : constant Name_Id := N + 438;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 438;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 438;
- Name_Access_Check : constant Name_Id := N + 438;
- Name_Accessibility_Check : constant Name_Id := N + 439;
- Name_Discriminant_Check : constant Name_Id := N + 440;
- Name_Division_Check : constant Name_Id := N + 441;
- Name_Elaboration_Check : constant Name_Id := N + 442;
- Name_Index_Check : constant Name_Id := N + 443;
- Name_Length_Check : constant Name_Id := N + 444;
- Name_Overflow_Check : constant Name_Id := N + 445;
- Name_Range_Check : constant Name_Id := N + 446;
- Name_Storage_Check : constant Name_Id := N + 447;
- Name_Tag_Check : constant Name_Id := N + 448;
- Name_All_Checks : constant Name_Id := N + 449;
- Last_Check_Name : constant Name_Id := N + 449;
+ First_Check_Name : constant Name_Id := N + 439;
+ Name_Access_Check : constant Name_Id := N + 439;
+ Name_Accessibility_Check : constant Name_Id := N + 440;
+ Name_Discriminant_Check : constant Name_Id := N + 441;
+ Name_Division_Check : constant Name_Id := N + 442;
+ Name_Elaboration_Check : constant Name_Id := N + 443;
+ Name_Index_Check : constant Name_Id := N + 444;
+ Name_Length_Check : constant Name_Id := N + 445;
+ Name_Overflow_Check : constant Name_Id := N + 446;
+ Name_Range_Check : constant Name_Id := N + 447;
+ Name_Storage_Check : constant Name_Id := N + 448;
+ Name_Tag_Check : constant Name_Id := N + 449;
+ Name_All_Checks : constant Name_Id := N + 450;
+ Last_Check_Name : constant Name_Id := N + 450;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- Name_Abort : constant Name_Id := N + 450;
- Name_Abs : constant Name_Id := N + 451;
- Name_Accept : constant Name_Id := N + 452;
- Name_And : constant Name_Id := N + 453;
- Name_All : constant Name_Id := N + 454;
- Name_Array : constant Name_Id := N + 455;
- Name_At : constant Name_Id := N + 456;
- Name_Begin : constant Name_Id := N + 457;
- Name_Body : constant Name_Id := N + 458;
- Name_Case : constant Name_Id := N + 459;
- Name_Constant : constant Name_Id := N + 460;
- Name_Declare : constant Name_Id := N + 461;
- Name_Delay : constant Name_Id := N + 462;
- Name_Do : constant Name_Id := N + 463;
- Name_Else : constant Name_Id := N + 464;
- Name_Elsif : constant Name_Id := N + 465;
- Name_End : constant Name_Id := N + 466;
- Name_Entry : constant Name_Id := N + 467;
- Name_Exception : constant Name_Id := N + 468;
- Name_Exit : constant Name_Id := N + 469;
- Name_For : constant Name_Id := N + 470;
- Name_Function : constant Name_Id := N + 471;
- Name_Generic : constant Name_Id := N + 472;
- Name_Goto : constant Name_Id := N + 473;
- Name_If : constant Name_Id := N + 474;
- Name_In : constant Name_Id := N + 475;
- Name_Is : constant Name_Id := N + 476;
- Name_Limited : constant Name_Id := N + 477;
- Name_Loop : constant Name_Id := N + 478;
- Name_Mod : constant Name_Id := N + 479;
- Name_New : constant Name_Id := N + 480;
- Name_Not : constant Name_Id := N + 481;
- Name_Null : constant Name_Id := N + 482;
- Name_Of : constant Name_Id := N + 483;
- Name_Or : constant Name_Id := N + 484;
- Name_Others : constant Name_Id := N + 485;
- Name_Out : constant Name_Id := N + 486;
- Name_Package : constant Name_Id := N + 487;
- Name_Pragma : constant Name_Id := N + 488;
- Name_Private : constant Name_Id := N + 489;
- Name_Procedure : constant Name_Id := N + 490;
- Name_Raise : constant Name_Id := N + 491;
- Name_Record : constant Name_Id := N + 492;
- Name_Rem : constant Name_Id := N + 493;
- Name_Renames : constant Name_Id := N + 494;
- Name_Return : constant Name_Id := N + 495;
- Name_Reverse : constant Name_Id := N + 496;
- Name_Select : constant Name_Id := N + 497;
- Name_Separate : constant Name_Id := N + 498;
- Name_Subtype : constant Name_Id := N + 499;
- Name_Task : constant Name_Id := N + 500;
- Name_Terminate : constant Name_Id := N + 501;
- Name_Then : constant Name_Id := N + 502;
- Name_Type : constant Name_Id := N + 503;
- Name_Use : constant Name_Id := N + 504;
- Name_When : constant Name_Id := N + 505;
- Name_While : constant Name_Id := N + 506;
- Name_With : constant Name_Id := N + 507;
- Name_Xor : constant Name_Id := N + 508;
+ Name_Abort : constant Name_Id := N + 451;
+ Name_Abs : constant Name_Id := N + 452;
+ Name_Accept : constant Name_Id := N + 453;
+ Name_And : constant Name_Id := N + 454;
+ Name_All : constant Name_Id := N + 455;
+ Name_Array : constant Name_Id := N + 456;
+ Name_At : constant Name_Id := N + 457;
+ Name_Begin : constant Name_Id := N + 458;
+ Name_Body : constant Name_Id := N + 459;
+ Name_Case : constant Name_Id := N + 460;
+ Name_Constant : constant Name_Id := N + 461;
+ Name_Declare : constant Name_Id := N + 462;
+ Name_Delay : constant Name_Id := N + 463;
+ Name_Do : constant Name_Id := N + 464;
+ Name_Else : constant Name_Id := N + 465;
+ Name_Elsif : constant Name_Id := N + 466;
+ Name_End : constant Name_Id := N + 467;
+ Name_Entry : constant Name_Id := N + 468;
+ Name_Exception : constant Name_Id := N + 469;
+ Name_Exit : constant Name_Id := N + 470;
+ Name_For : constant Name_Id := N + 471;
+ Name_Function : constant Name_Id := N + 472;
+ Name_Generic : constant Name_Id := N + 473;
+ Name_Goto : constant Name_Id := N + 474;
+ Name_If : constant Name_Id := N + 475;
+ Name_In : constant Name_Id := N + 476;
+ Name_Is : constant Name_Id := N + 477;
+ Name_Limited : constant Name_Id := N + 478;
+ Name_Loop : constant Name_Id := N + 479;
+ Name_Mod : constant Name_Id := N + 480;
+ Name_New : constant Name_Id := N + 481;
+ Name_Not : constant Name_Id := N + 482;
+ Name_Null : constant Name_Id := N + 483;
+ Name_Of : constant Name_Id := N + 484;
+ Name_Or : constant Name_Id := N + 485;
+ Name_Others : constant Name_Id := N + 486;
+ Name_Out : constant Name_Id := N + 487;
+ Name_Package : constant Name_Id := N + 488;
+ Name_Pragma : constant Name_Id := N + 489;
+ Name_Private : constant Name_Id := N + 490;
+ Name_Procedure : constant Name_Id := N + 491;
+ Name_Raise : constant Name_Id := N + 492;
+ Name_Record : constant Name_Id := N + 493;
+ Name_Rem : constant Name_Id := N + 494;
+ Name_Renames : constant Name_Id := N + 495;
+ Name_Return : constant Name_Id := N + 496;
+ Name_Reverse : constant Name_Id := N + 497;
+ Name_Select : constant Name_Id := N + 498;
+ Name_Separate : constant Name_Id := N + 499;
+ Name_Subtype : constant Name_Id := N + 500;
+ Name_Task : constant Name_Id := N + 501;
+ Name_Terminate : constant Name_Id := N + 502;
+ Name_Then : constant Name_Id := N + 503;
+ Name_Type : constant Name_Id := N + 504;
+ Name_Use : constant Name_Id := N + 505;
+ Name_When : constant Name_Id := N + 506;
+ Name_While : constant Name_Id := N + 507;
+ Name_With : constant Name_Id := N + 508;
+ Name_Xor : constant Name_Id := N + 509;
-- Names of intrinsic subprograms
-- Note: Asm is missing from this list, since Asm is a legitimate
-- convention name. So is To_Adress, which is a GNAT attribute.
- First_Intrinsic_Name : constant Name_Id := N + 509;
- Name_Divide : constant Name_Id := N + 509;
- Name_Enclosing_Entity : constant Name_Id := N + 510;
- Name_Exception_Information : constant Name_Id := N + 511;
- Name_Exception_Message : constant Name_Id := N + 512;
- Name_Exception_Name : constant Name_Id := N + 513;
- Name_File : constant Name_Id := N + 514;
- Name_Import_Address : constant Name_Id := N + 515;
- Name_Import_Largest_Value : constant Name_Id := N + 516;
- Name_Import_Value : constant Name_Id := N + 517;
- Name_Is_Negative : constant Name_Id := N + 518;
- Name_Line : constant Name_Id := N + 519;
- Name_Rotate_Left : constant Name_Id := N + 520;
- Name_Rotate_Right : constant Name_Id := N + 521;
- Name_Shift_Left : constant Name_Id := N + 522;
- Name_Shift_Right : constant Name_Id := N + 523;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 524;
- Name_Source_Location : constant Name_Id := N + 525;
- Name_Unchecked_Conversion : constant Name_Id := N + 526;
- Name_Unchecked_Deallocation : constant Name_Id := N + 527;
- Name_To_Pointer : constant Name_Id := N + 528;
- Last_Intrinsic_Name : constant Name_Id := N + 528;
+ First_Intrinsic_Name : constant Name_Id := N + 510;
+ Name_Divide : constant Name_Id := N + 510;
+ Name_Enclosing_Entity : constant Name_Id := N + 511;
+ Name_Exception_Information : constant Name_Id := N + 512;
+ Name_Exception_Message : constant Name_Id := N + 513;
+ Name_Exception_Name : constant Name_Id := N + 514;
+ Name_File : constant Name_Id := N + 515;
+ Name_Import_Address : constant Name_Id := N + 516;
+ Name_Import_Largest_Value : constant Name_Id := N + 517;
+ Name_Import_Value : constant Name_Id := N + 518;
+ Name_Is_Negative : constant Name_Id := N + 519;
+ Name_Line : constant Name_Id := N + 520;
+ Name_Rotate_Left : constant Name_Id := N + 521;
+ Name_Rotate_Right : constant Name_Id := N + 522;
+ Name_Shift_Left : constant Name_Id := N + 523;
+ Name_Shift_Right : constant Name_Id := N + 524;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 525;
+ Name_Source_Location : constant Name_Id := N + 526;
+ Name_Unchecked_Conversion : constant Name_Id := N + 527;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 528;
+ Name_To_Pointer : constant Name_Id := N + 529;
+ Last_Intrinsic_Name : constant Name_Id := N + 529;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 529;
- Name_Abstract : constant Name_Id := N + 529;
- Name_Aliased : constant Name_Id := N + 530;
- Name_Protected : constant Name_Id := N + 531;
- Name_Until : constant Name_Id := N + 532;
- Name_Requeue : constant Name_Id := N + 533;
- Name_Tagged : constant Name_Id := N + 534;
- Last_95_Reserved_Word : constant Name_Id := N + 534;
+ First_95_Reserved_Word : constant Name_Id := N + 530;
+ Name_Abstract : constant Name_Id := N + 530;
+ Name_Aliased : constant Name_Id := N + 531;
+ Name_Protected : constant Name_Id := N + 532;
+ Name_Until : constant Name_Id := N + 533;
+ Name_Requeue : constant Name_Id := N + 534;
+ Name_Tagged : constant Name_Id := N + 535;
+ Last_95_Reserved_Word : constant Name_Id := N + 535;
subtype Ada_95_Reserved_Words is
Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
- Name_Raise_Exception : constant Name_Id := N + 535;
+ Name_Raise_Exception : constant Name_Id := N + 536;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Binder : constant Name_Id := N + 536;
- Name_Body_Suffix : constant Name_Id := N + 537;
- Name_Builder : constant Name_Id := N + 538;
- Name_Compiler : constant Name_Id := N + 539;
- Name_Cross_Reference : constant Name_Id := N + 540;
- Name_Default_Switches : constant Name_Id := N + 541;
- Name_Exec_Dir : constant Name_Id := N + 542;
- Name_Executable : constant Name_Id := N + 543;
- Name_Executable_Suffix : constant Name_Id := N + 544;
- Name_Extends : constant Name_Id := N + 545;
- Name_Finder : constant Name_Id := N + 546;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 547;
- Name_Gnatls : constant Name_Id := N + 548;
- Name_Gnatstub : constant Name_Id := N + 549;
- Name_Implementation : constant Name_Id := N + 550;
- Name_Implementation_Exceptions : constant Name_Id := N + 551;
- Name_Implementation_Suffix : constant Name_Id := N + 552;
- Name_Languages : constant Name_Id := N + 553;
- Name_Library_Dir : constant Name_Id := N + 554;
- Name_Library_Auto_Init : constant Name_Id := N + 555;
- Name_Library_GCC : constant Name_Id := N + 556;
- Name_Library_Interface : constant Name_Id := N + 557;
- Name_Library_Kind : constant Name_Id := N + 558;
- Name_Library_Name : constant Name_Id := N + 559;
- Name_Library_Options : constant Name_Id := N + 560;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 561;
- Name_Library_Src_Dir : constant Name_Id := N + 562;
- Name_Library_Symbol_File : constant Name_Id := N + 563;
- Name_Library_Symbol_Policy : constant Name_Id := N + 564;
- Name_Library_Version : constant Name_Id := N + 565;
- Name_Linker : constant Name_Id := N + 566;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 567;
- Name_Locally_Removed_Files : constant Name_Id := N + 568;
- Name_Naming : constant Name_Id := N + 569;
- Name_Object_Dir : constant Name_Id := N + 570;
- Name_Pretty_Printer : constant Name_Id := N + 571;
- Name_Project : constant Name_Id := N + 572;
- Name_Separate_Suffix : constant Name_Id := N + 573;
- Name_Source_Dirs : constant Name_Id := N + 574;
- Name_Source_Files : constant Name_Id := N + 575;
- Name_Source_List_File : constant Name_Id := N + 576;
- Name_Spec : constant Name_Id := N + 577;
- Name_Spec_Suffix : constant Name_Id := N + 578;
- Name_Specification : constant Name_Id := N + 579;
- Name_Specification_Exceptions : constant Name_Id := N + 580;
- Name_Specification_Suffix : constant Name_Id := N + 581;
- Name_Switches : constant Name_Id := N + 582;
+ Name_Binder : constant Name_Id := N + 537;
+ Name_Body_Suffix : constant Name_Id := N + 538;
+ Name_Builder : constant Name_Id := N + 539;
+ Name_Compiler : constant Name_Id := N + 540;
+ Name_Cross_Reference : constant Name_Id := N + 541;
+ Name_Default_Switches : constant Name_Id := N + 542;
+ Name_Exec_Dir : constant Name_Id := N + 543;
+ Name_Executable : constant Name_Id := N + 544;
+ Name_Executable_Suffix : constant Name_Id := N + 545;
+ Name_Extends : constant Name_Id := N + 546;
+ Name_Finder : constant Name_Id := N + 547;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 548;
+ Name_Gnatls : constant Name_Id := N + 549;
+ Name_Gnatstub : constant Name_Id := N + 550;
+ Name_Implementation : constant Name_Id := N + 551;
+ Name_Implementation_Exceptions : constant Name_Id := N + 552;
+ Name_Implementation_Suffix : constant Name_Id := N + 553;
+ Name_Languages : constant Name_Id := N + 554;
+ Name_Library_Dir : constant Name_Id := N + 555;
+ Name_Library_Auto_Init : constant Name_Id := N + 556;
+ Name_Library_GCC : constant Name_Id := N + 557;
+ Name_Library_Interface : constant Name_Id := N + 558;
+ Name_Library_Kind : constant Name_Id := N + 559;
+ Name_Library_Name : constant Name_Id := N + 560;
+ Name_Library_Options : constant Name_Id := N + 561;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 562;
+ Name_Library_Src_Dir : constant Name_Id := N + 563;
+ Name_Library_Symbol_File : constant Name_Id := N + 564;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 565;
+ Name_Library_Version : constant Name_Id := N + 566;
+ Name_Linker : constant Name_Id := N + 567;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 568;
+ Name_Locally_Removed_Files : constant Name_Id := N + 569;
+ Name_Naming : constant Name_Id := N + 570;
+ Name_Object_Dir : constant Name_Id := N + 571;
+ Name_Pretty_Printer : constant Name_Id := N + 572;
+ Name_Project : constant Name_Id := N + 573;
+ Name_Separate_Suffix : constant Name_Id := N + 574;
+ Name_Source_Dirs : constant Name_Id := N + 575;
+ Name_Source_Files : constant Name_Id := N + 576;
+ Name_Source_List_File : constant Name_Id := N + 577;
+ Name_Spec : constant Name_Id := N + 578;
+ Name_Spec_Suffix : constant Name_Id := N + 579;
+ Name_Specification : constant Name_Id := N + 580;
+ Name_Specification_Exceptions : constant Name_Id := N + 581;
+ Name_Specification_Suffix : constant Name_Id := N + 582;
+ Name_Switches : constant Name_Id := N + 583;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 583;
+ Name_Unaligned_Valid : constant Name_Id := N + 584;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 583;
+ Last_Predefined_Name : constant Name_Id := N + 584;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
- -- Ada0Y (AI-287): Print the mbox if present
+ -- Ada 0Y (AI-287): Print the mbox if present
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
when N_Component_Definition =>
Set_Debug_Sloc;
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
+ -- Ada 0Y (AI-230): Access definition components
- Sprint_Node (Subtype_Indication (Node));
+ if Present (Access_Definition (Node)) then
+ Sprint_Node (Access_Definition (Node));
+
+ elsif Present (Subtype_Indication (Node)) then
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+
+ Sprint_Node (Subtype_Indication (Node));
+ else
+ pragma Assert (False);
+ null;
+ end if;
when N_Component_Declaration =>
if Write_Indent_Identifiers_Sloc (Node) then
Set_Debug_Sloc;
Sprint_Node (Defining_Identifier (Node));
Write_Str (" : ");
- Sprint_Node (Subtype_Mark (Node));
+
+ -- Ada 0Y (AI-230): Access renamings
+
+ if Present (Access_Definition (Node)) then
+ Sprint_Node (Access_Definition (Node));
+
+ elsif Present (Subtype_Mark (Node)) then
+ Sprint_Node (Subtype_Mark (Node));
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+
Write_Str_With_Col_Check (" renames ");
Sprint_Node (Name (Node));
Write_Char (';');
Write_Indent_Str_Sloc ("task type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
+
if Present (Task_Definition (Node)) then
Write_Str (" is");
Sprint_Node (Task_Definition (Node));
else
if First_Name (Node) or else not Dump_Original_Only then
- -- Ada0Y (AI-50217): Print limited with_clauses
+ -- Ada 0Y (AI-50217): Print limited with_clauses
if Limited_Present (Node) then
Write_Indent_Str ("limited with ");
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
function RM_Column_Check return Boolean
renames Style_Inst.RM_Column_Check;
- pragma Inline (RM_Column_Check);
-- Determines whether style checking is active and the RM column check
-- mode is set requiring checking of RM format layout.
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
+with Uintp; use Uintp;
package body Targparm is
use ASCII;
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
- Rloop : for K in Partition_Restrictions loop
+ Rloop : for K in Partition_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
end loop;
if System_Text (P + Rname'Length) = ')' then
- Restrictions_On_Target (K) := True;
+ Restrictions_On_Target.Set (K) := True;
goto Line_Loop_Continue;
end if;
end;
null;
end loop Rloop;
- Ploop : for K in Restriction_Parameter_Id loop
+ Ploop : for K in All_Parameter_Restrictions loop
declare
Rname : constant String :=
- Restriction_Parameter_Id'Image (K);
+ All_Parameter_Restrictions'Image (K);
begin
for J in Rname'Range loop
elsif System_Text (P) = '_' then
null;
elsif System_Text (P) = ')' then
- Restriction_Parameters_On_Target (K) := V;
- goto Line_Loop_Continue;
+ if UI_Is_In_Int_Range (V) then
+ Restrictions_On_Target.Value (K) :=
+ Integer (UI_To_Int (V));
+ Restrictions_On_Target.Set (K) := True;
+ goto Line_Loop_Continue;
+ else
+ exit Ploop;
+ end if;
else
- goto Ploop_Continue;
+ exit Ploop;
end if;
P := P + 1;
end loop;
+
+ else
+ exit Ploop;
end if;
end;
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
- Write_Str ("unrecognized restrictions pragma: ");
+ Write_Str ("unrecognized or incorrect restrictions pragma: ");
while System_Text (P) /= ')'
and then
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2004 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 Rident; use Rident;
with Types; use Types;
-with Uintp; use Uintp;
package Targparm is
-- The only other pragma allowed is a pragma Restrictions that gives the
-- simple name of a restriction for which partition consistency is always
- -- required (see definition of Rident.Partition_Restrictions).
-
- Restrictions_On_Target :
- array (Partition_Restrictions) of Boolean := (others => False);
- -- Element is set True if a pragma Restrictions for the corresponding
- -- identifier appears in system.ads. Note that only partition restriction
- -- identifiers are permitted as arguments for pragma Restrictions for
- -- pragmas appearing at the start of system.ads.
-
- Restriction_Parameters_On_Target :
- array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
- -- Element is set to specified value if a pragma Restrictions for the
- -- corresponding restriction parameter value is set.
+ -- required (see definition of Rident.Restriction_Info).
+
+ Restrictions_On_Target : Restrictions_Info;
+ -- Records restrictions specified by system.ads. Only the Set and Value
+ -- members are modified. The Violated and Count fields are never modified.
-------------------
-- Run Time Name --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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 Nlists; use Nlists;
with Nmake; use Nmake;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
}
/* At this point, the position and size of each field is known. It was
- either set before entry by a rep clause, or by laying out the type
- above. We now make a pass through the fields (in reverse order for
- QUAL_UNION_TYPEs) to compute the Ada size; the GCC size and alignment
- (for rep'ed records that are not padding types); and the mode (for
- rep'ed records). */
+ either set before entry by a rep clause, or by laying out the type above.
+
+ We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
+ to compute the Ada size; the GCC size and alignment (for rep'ed records
+ that are not padding types); and the mode (for rep'ed records). We also
+ clear the DECL_BIT_FIELD indication for the cases we know have not been
+ handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
if (code == QUAL_UNION_TYPE)
fieldlist = nreverse (fieldlist);
for (field = fieldlist; field; field = TREE_CHAIN (field))
{
+ tree pos = bit_position (field);
+
tree type = TREE_TYPE (field);
tree this_size = DECL_SIZE (field);
tree this_size_unit = DECL_SIZE_UNIT (field);
&& TYPE_ADA_SIZE (type) != 0)
this_ada_size = TYPE_ADA_SIZE (type);
+ /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
+ if (DECL_BIT_FIELD (field) && !STRICT_ALIGNMENT
+ && value_factor_p (pos, BITS_PER_UNIT)
+ && operand_equal_p (this_size, TYPE_SIZE (type), 0))
+ DECL_BIT_FIELD (field) = 0;
+
+ /* If we still have DECL_BIT_FIELD set at this point, we know the field
+ is technically not addressable. */
+ DECL_NONADDRESSABLE_P (field) |= DECL_BIT_FIELD (field);
+
if (has_rep && ! DECL_BIT_FIELD (field))
TYPE_ALIGN (record_type)
= MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
QUAL_UNION_TYPE, we need to take into account the previous size in
the case of empty variants. */
ada_size
- = merge_sizes (ada_size, bit_position (field), this_ada_size,
+ = merge_sizes (ada_size, pos, this_ada_size,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
- size = merge_sizes (size, bit_position (field), this_size,
+ size = merge_sizes (size, pos, this_size,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
size_unit
= merge_sizes (size_unit, byte_position (field), this_size_unit,
if (packed && TYPE_MODE (field_type) == BLKmode)
DECL_ALIGN (field_decl) = BITS_PER_UNIT;
- /* If a size is specified, use it. Otherwise, see if we have a size
- to use that may differ from the natural size of the object. */
+ /* If a size is specified, use it. Otherwise, if the record type is packed
+ compute a size to use, which may differ from the object's natural size.
+ We always set a size in this case to trigger the checks for bitfield
+ creation below, which is typically required when no position has been
+ specified. */
if (size != 0)
size = convert (bitsizetype, size);
- else if (packed)
+ else if (packed == 1)
{
- if (packed == 1 && ! operand_equal_p (rm_size (field_type),
- TYPE_SIZE (field_type), 0))
- size = rm_size (field_type);
+ size = rm_size (field_type);
/* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
- byte. */
- if (size != 0 && TREE_CODE (size) == INTEGER_CST
- && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
- size = round_up (size, BITS_PER_UNIT);
+ byte. */
+ if (TREE_CODE (size) == INTEGER_CST
+ && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
+ size = round_up (size, BITS_PER_UNIT);
}
/* Make a bitfield if a size is specified for two reasons: first if the size
differs from the natural size. Second, if the alignment is insufficient.
- There are a number of ways the latter can be true. But never make a
- bitfield if the type of the field has a nonconstant size. */
+ There are a number of ways the latter can be true.
+ We never make a bitfield if the type of the field has a nonconstant size,
+ or if it is claimed to be addressable, because no such entity requiring
+ bitfield operations should reach here.
+
+ We do *preventively* make a bitfield when there might be the need for it
+ but we don't have all the necessary information to decide, as is the case
+ of a field with no specified position in a packed record.
+
+ We also don't look at STRICT_ALIGNMENT here, and rely on later processing
+ in layout_decl or finish_record_type to clear the bit_field indication if
+ it is in fact not needed. */
if (size != 0 && TREE_CODE (size) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
+ && ! addressable
&& (! operand_equal_p (TYPE_SIZE (field_type), size, 0)
|| (pos != 0
&& ! value_zerop (size_binop (TRUNC_MOD_EXPR, pos,
if (AGGREGATE_TYPE_P (field_type))
addressable = 1;
- /* Mark the decl as nonaddressable if it either is indicated so semantically
- or if it is a bit field. */
- DECL_NONADDRESSABLE_P (field_decl)
- = ! addressable || DECL_BIT_FIELD (field_decl);
+ /* Mark the decl as nonaddressable if it is indicated so semantically,
+ meaning we won't ever attempt to take the address of the field.
+
+ It may also be "technically" nonaddressable, meaning that even if we
+ attempt to take the field's address we will actually get the address of a
+ copy. This is the case for true bitfields, but the DECL_BIT_FIELD value
+ we have at this point is not accurate enough, so we don't account for
+ this here and let finish_record_type decide. */
+ DECL_NONADDRESSABLE_P (field_decl) = ! addressable;
return field_decl;
}
if (function_nesting_depth > 1)
ggc_push_context ();
- rest_of_compilation (current_function_decl);
+ /* If we're only annotating types, don't actually compile this
+ function. */
+ if (!type_annotate_only)
+ rest_of_compilation (current_function_decl);
if (function_nesting_depth > 1)
ggc_pop_context ();
OSDN Git Service
