diff options
70 files changed, 2720 insertions, 1564 deletions
diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index e555f1fa0f5..69f0b220ae0 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -228,7 +228,7 @@ package body System.Task_Primitives.Operations is 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); @@ -296,7 +296,7 @@ package body System.Task_Primitives.Operations is 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; @@ -1443,7 +1443,7 @@ package body System.Task_Primitives.Operations is ----------------- function Record_Lock (L : Lock_Ptr) return Boolean is - Self_ID : Task_ID := Self; + Self_ID : constant Task_ID := Self; P : Lock_Ptr; begin @@ -1529,7 +1529,7 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Self_ID : Task_ID := Self; + Self_ID : constant Task_ID := Self; P : Lock_Ptr; begin @@ -1586,7 +1586,7 @@ package body System.Task_Primitives.Operations is ------------------ function Check_Unlock (L : Lock_Ptr) return Boolean is - Self_ID : Task_ID := Self; + Self_ID : constant Task_ID := Self; P : Lock_Ptr; begin diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb index ff0f88d42fe..75b35966021 100644 --- a/gcc/ada/6vcstrea.adb +++ b/gcc/ada/6vcstrea.adb @@ -38,19 +38,39 @@ package body Interfaces.C_Streams is 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; @@ -85,13 +105,9 @@ package body Interfaces.C_Streams is end loop; return Get_Count; - end fread; - - ------------ - -- fread -- - ------------ + end fread_impl; - function fread + function fread_impl (buffer : voids; index : size_t; size : size_t; @@ -127,13 +143,34 @@ package body Interfaces.C_Streams is 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; @@ -164,13 +201,23 @@ package body Interfaces.C_Streams is 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; @@ -193,6 +240,16 @@ package body Interfaces.C_Streams is 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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 22091da091a..5ea08ff2f0c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,176 @@ +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). diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 7cd30ee51f3..91f12200862 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -136,6 +136,7 @@ THREADSLIB = GMEM_LIB = MISCLIB = SYMLIB = +ADDR2LINE_SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL) SYMDEPS = $(LIBINTL_DEP) OUTPUT_OPTION = @OUTPUT_OPTION@ @@ -715,7 +716,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) 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 @@ -824,8 +825,10 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) 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 @@ -964,7 +967,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) 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, @@ -1030,7 +1033,7 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),) TOOLS_TARGET_PAIRS = mlib-tgt.adb<5bml-tgt.adb GMEM_LIB = gmemlib - SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL) + SYMLIB = $(ADDR2LINE_SYMLIB) endif @@ -1117,7 +1120,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) 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 @@ -1237,7 +1240,7 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) 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) @@ -1287,7 +1290,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) 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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 9be0d727293..512310aa88f 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -395,8 +395,9 @@ GNATRTL_NONTASKING_OBJS= \ 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) \ diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 37e62de53bd..8f340e8c958 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -120,6 +120,13 @@ package body ALI is -- 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 @@ -371,7 +378,6 @@ package body ALI is Skip_Space; V := 0; - loop V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); exit when At_End_Of_Field; @@ -546,7 +552,7 @@ package body ALI is 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, @@ -733,7 +739,7 @@ package body ALI is 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; @@ -803,7 +809,7 @@ package body ALI is C := Getc; - -- Acquire restrictions line + -- Acquire first restrictions line if C /= 'R' then Fatal_Error; @@ -815,18 +821,17 @@ package body ALI is 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; @@ -841,6 +846,109 @@ package body ALI is 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 diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 24f8d04725c..c5fa093b565 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -82,9 +82,6 @@ package ALI is 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; @@ -187,9 +184,8 @@ package ALI is -- 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; @@ -422,11 +418,10 @@ package ALI is -- 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 diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 65d2056da31..906b3af8aab 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1836,6 +1836,7 @@ package body Atree is procedure New_Entity_Debugging_Output; -- Debugging routine for debug flag N + pragma Inline (New_Entity_Debugging_Output); --------------------------------- -- New_Entity_Debugging_Output -- @@ -1854,8 +1855,6 @@ package body Atree is end if; end New_Entity_Debugging_Output; - pragma Inline (New_Entity_Debugging_Output); - -- Start of processing for New_Entity begin @@ -1908,6 +1907,7 @@ package body Atree is procedure New_Node_Debugging_Output; -- Debugging routine for debug flag N + pragma Inline (New_Node_Debugging_Output); -------------------------- -- New_Debugging_Output -- @@ -1926,8 +1926,6 @@ package body Atree is end if; end New_Node_Debugging_Output; - pragma Inline (New_Node_Debugging_Output); - -- Start of processing for New_Node begin diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index e24d65d5b32..4bb8a66c52e 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1473,25 +1473,25 @@ package Atree is 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); diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index fd55b9144c7..ff534ba8d13 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -51,8 +51,8 @@ package body Bcheck is 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); @@ -84,7 +84,7 @@ package body Bcheck is Check_Consistent_Normalize_Scalars; Check_Consistent_Dynamic_Elaboration_Checking; - Check_Consistent_Partition_Restrictions; + Check_Consistent_Restrictions; Check_Consistent_Interrupt_States; end Check_Configuration_Consistency; @@ -362,184 +362,171 @@ package body Bcheck is 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 -- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index ec983760f29..834186239e5 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -360,8 +360,8 @@ package body Bindgen is 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 (""";"); @@ -607,8 +607,8 @@ package body Bindgen is 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 (""";"); @@ -1171,7 +1171,7 @@ package body Bindgen is -- 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"); @@ -1337,7 +1337,7 @@ package body Bindgen is 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; @@ -1410,7 +1410,7 @@ package body Bindgen is -- 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 (""); @@ -1494,7 +1494,7 @@ package body Bindgen is 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; @@ -1512,7 +1512,7 @@ package body Bindgen is -- 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). @@ -1526,7 +1526,7 @@ package body Bindgen is -- 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; @@ -1652,7 +1652,7 @@ package body Bindgen is -- 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; @@ -2011,7 +2011,7 @@ package body Bindgen is -- 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; @@ -2116,7 +2116,7 @@ package body Bindgen is -- 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 & ", """ & @@ -2223,7 +2223,7 @@ package body Bindgen is -- 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. @@ -2242,7 +2242,7 @@ package body Bindgen is -- 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; @@ -2430,7 +2430,7 @@ package body Bindgen is -- 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; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index acd0510b4ee..327ddb66509 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -38,6 +38,7 @@ with Nmake; use Nmake; 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; @@ -514,7 +515,7 @@ package body Checks is 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 => diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 5d812e732ab..83e892fad80 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -565,6 +565,7 @@ package body CStand is 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; @@ -595,6 +596,7 @@ package body CStand is 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); @@ -1504,7 +1506,6 @@ package body CStand is Write_Str (" .. "); Write_Str (IEEES_Last'Universal_Literal_String); - elsif Digs = IEEEL_Digits then Write_Str (IEEEL_First'Universal_Literal_String); Write_Str (" .. "); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 41669d097c6..623ee73c898 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -1315,6 +1315,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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; @@ -1326,8 +1330,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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)); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 1a1b54ab497..7b9e48254b9 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -41,6 +41,7 @@ with Lib; use Lib; 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; @@ -73,7 +74,7 @@ package body Exp_Aggr is 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 -- @@ -442,7 +443,7 @@ package body Exp_Aggr is -- -- 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; @@ -670,8 +671,8 @@ package body Exp_Aggr is 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; @@ -738,8 +739,8 @@ package body Exp_Aggr is 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; @@ -757,10 +758,11 @@ package body Exp_Aggr is 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 @@ -774,7 +776,6 @@ package body Exp_Aggr is begin while Present (P) loop - if Nkind (P) = N_Aggregate and then Present (Etype (P)) then @@ -785,13 +786,14 @@ package body Exp_Aggr is 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 @@ -801,7 +803,7 @@ package body Exp_Aggr is -- 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 ??? @@ -816,8 +818,8 @@ package body Exp_Aggr is 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 @@ -916,8 +918,8 @@ package body Exp_Aggr is 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; @@ -1335,7 +1337,8 @@ package body Exp_Aggr is 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, @@ -1629,25 +1632,26 @@ package body Exp_Aggr is 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, @@ -1786,8 +1790,8 @@ package body Exp_Aggr is 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; @@ -1920,15 +1924,15 @@ package body Exp_Aggr is 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); @@ -2616,12 +2620,13 @@ package body Exp_Aggr is -- 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; @@ -2741,14 +2746,15 @@ package body Exp_Aggr is 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; @@ -2862,7 +2868,7 @@ package body Exp_Aggr is -- 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. @@ -4114,7 +4120,7 @@ package body Exp_Aggr is 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; @@ -4328,7 +4334,7 @@ package body Exp_Aggr is 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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index f296a6f60cf..28ece685557 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -42,6 +42,7 @@ with Nmake; use Nmake; 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; @@ -1023,7 +1024,7 @@ package body Exp_Attr is 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 := @@ -1259,7 +1260,7 @@ package body Exp_Attr is 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); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 511923b5ba1..80ac70db61a 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -40,6 +40,7 @@ with Nmake; use Nmake; 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; @@ -141,7 +142,7 @@ package body Exp_Ch11 is return; end if; - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then return; end if; @@ -953,8 +954,8 @@ package body Exp_Ch11 is -- 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, @@ -1005,7 +1006,7 @@ package body Exp_Ch11 is 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; @@ -1135,7 +1136,7 @@ package body Exp_Ch11 is -- 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. @@ -1330,7 +1331,7 @@ package body Exp_Ch11 is return; end if; - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then return; end if; @@ -1347,8 +1348,8 @@ package body Exp_Ch11 is -- 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; @@ -1684,7 +1685,7 @@ package body Exp_Ch11 is -- Do not generate if no exceptions - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then return; end if; @@ -1716,7 +1717,7 @@ package body Exp_Ch11 is -- Do not generate if no exceptions - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then return; end if; @@ -1762,7 +1763,7 @@ package body Exp_Ch11 is -- Nothing to do if no exceptions - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then return; end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 111e14b3508..8982343b8d9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -46,6 +46,7 @@ with Nlists; use Nlists; 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; @@ -570,7 +571,7 @@ package body Exp_Ch3 is 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) @@ -641,7 +642,7 @@ package body Exp_Ch3 is 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; @@ -1105,7 +1106,7 @@ package body Exp_Ch3 is -- 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 ???) @@ -1117,7 +1118,7 @@ package body Exp_Ch3 is 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??? @@ -1225,7 +1226,7 @@ package body Exp_Ch3 is 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 @@ -1322,7 +1323,7 @@ package body Exp_Ch3 is 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; @@ -1642,7 +1643,7 @@ package body Exp_Ch3 is 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. @@ -2366,7 +2367,7 @@ package body Exp_Ch3 is 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; @@ -2485,6 +2486,7 @@ package body Exp_Ch3 is ---------------------------- -- Generates the following subprogram: + -- procedure Assign -- (Source, Target : Array_Type, -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index; @@ -2492,6 +2494,7 @@ package body Exp_Ch3 is -- is -- Li1 : Index; -- Ri1 : Index; + -- begin -- if Rev then -- Li1 := Left_Hi; @@ -2500,9 +2503,10 @@ package body Exp_Ch3 is -- 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); @@ -2546,19 +2550,19 @@ package body Exp_Ch3 is 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; @@ -2576,7 +2580,7 @@ package body Exp_Ch3 is Stats := New_List; - -- Build initializations for indices. + -- Build initializations for indices declare F_Init : constant List_Id := New_List; @@ -2626,7 +2630,7 @@ package body Exp_Ch3 is 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; @@ -2701,8 +2705,8 @@ package body Exp_Ch3 is 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 ( @@ -2766,7 +2770,7 @@ package body Exp_Ch3 is ------------------------------------ -- Generates: - -- + -- function _Equality (X, Y : T) return Boolean is -- begin -- -- Compare discriminants @@ -3136,9 +3140,8 @@ package body Exp_Ch3 is 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)) @@ -4013,7 +4016,7 @@ package body Exp_Ch3 is -- 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)), @@ -4657,17 +4660,17 @@ package body Exp_Ch3 is (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. @@ -5382,7 +5385,7 @@ package body Exp_Ch3 is -- 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 @@ -5696,7 +5699,7 @@ package body Exp_Ch3 is -- 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); @@ -5831,7 +5834,7 @@ package body Exp_Ch3 is -- 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)) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index ac0a7f77a61..3ecb496b08c 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -39,6 +39,7 @@ with Nlists; use Nlists; 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; @@ -767,7 +768,7 @@ package body Exp_Ch5 is -- 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); @@ -1710,7 +1711,7 @@ package body Exp_Ch5 is -- 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, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6a54343c678..49893a516ee 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -51,6 +51,7 @@ with Nlists; use Nlists; 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; @@ -358,7 +359,7 @@ package body Exp_Ch6 is -- 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; @@ -1265,7 +1266,7 @@ package body Exp_Ch6 is -- 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 @@ -3004,7 +3005,7 @@ package body Exp_Ch6 is -- Create new exception handler - if Restrictions (No_Exception_Handlers) then + if Restriction_Active (No_Exception_Handlers) then Excep_Handlers := No_List; else diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7ec79180af0..2a683a27d55 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -46,6 +46,7 @@ with Nmake; use Nmake; 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; @@ -914,7 +915,7 @@ package body Exp_Ch7 is 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) @@ -2207,7 +2208,7 @@ package body Exp_Ch7 is 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; @@ -2253,7 +2254,7 @@ package body Exp_Ch7 is 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); @@ -2291,7 +2292,7 @@ package body Exp_Ch7 is 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); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 76afc7b1495..8e2f2a3e1f7 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -43,6 +43,7 @@ with Nlists; use Nlists; 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; @@ -557,7 +558,7 @@ package body Exp_Ch9 is 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; @@ -1201,35 +1202,24 @@ package body Exp_Ch9 is 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 @@ -1250,7 +1240,7 @@ package body Exp_Ch9 is 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 @@ -1311,7 +1301,7 @@ package body Exp_Ch9 is 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); @@ -1339,7 +1329,7 @@ package body Exp_Ch9 is 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, @@ -1352,7 +1342,7 @@ package body Exp_Ch9 is 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 := @@ -1746,7 +1736,7 @@ package body Exp_Ch9 is 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); @@ -2070,7 +2060,7 @@ package body Exp_Ch9 is -- 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 @@ -2182,7 +2172,7 @@ package body Exp_Ch9 is 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 @@ -2660,7 +2650,6 @@ package body Exp_Ch9 is Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, - Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => @@ -2673,7 +2662,6 @@ package body Exp_Ch9 is (Etype (Discrete_Subtype_Definition (Parent (Efam))), Loc))))))); - end if; Next_Entity (Efam); @@ -2973,7 +2961,7 @@ package body Exp_Ch9 is 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); @@ -4994,7 +4982,7 @@ package body Exp_Ch9 is 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); @@ -5249,7 +5237,7 @@ package body Exp_Ch9 is 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 := @@ -5572,7 +5560,7 @@ package body Exp_Ch9 is 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, @@ -5622,7 +5610,7 @@ package body Exp_Ch9 is -- 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 := @@ -7593,7 +7581,7 @@ package body Exp_Ch9 is 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, @@ -8195,7 +8183,7 @@ package body Exp_Ch9 is 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). @@ -8217,7 +8205,7 @@ package body Exp_Ch9 is 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, @@ -8439,7 +8427,7 @@ package body Exp_Ch9 is -- 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)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 98802f15039..56c25f19ad8 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -41,6 +41,7 @@ with Nlists; use Nlists; 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; @@ -604,7 +605,7 @@ package body Exp_Util is -- 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')); diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 8f65c7d76de..067e019ea95 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -124,7 +124,8 @@ package body Fname.UF is 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 @@ -389,7 +390,12 @@ package body Fname.UF is -- 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 diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads index 50c15bf33d5..24966bb441e 100644 --- a/gcc/ada/fname-uf.ads +++ b/gcc/ada/fname-uf.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -45,7 +45,8 @@ package Fname.UF is 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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5e135b7157e..90f4e64b15f 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -40,6 +40,7 @@ with Nlists; use Nlists; 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; diff --git a/gcc/ada/g-crc32.ads b/gcc/ada/g-crc32.ads index e6a89e9825d..cf57b02b3ac 100644 --- a/gcc/ada/g-crc32.ads +++ b/gcc/ada/g-crc32.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -78,32 +78,27 @@ package GNAT.CRC32 is 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 @@ -113,4 +108,6 @@ package GNAT.CRC32 is -- 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; diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb index e126b8fce7b..31cc1ad9bba 100644 --- a/gcc/ada/g-md5.adb +++ b/gcc/ada/g-md5.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -173,6 +173,10 @@ package body GNAT.MD5 is 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. @@ -197,27 +201,55 @@ package body GNAT.MD5 is -- 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); @@ -450,45 +482,19 @@ package body GNAT.MD5 is (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 diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads index 40d1b78c3dc..2ebd027dd65 100644 --- a/gcc/ada/g-md5.ads +++ b/gcc/ada/g-md5.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -66,7 +66,7 @@ package GNAT.MD5 is -- 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); @@ -98,9 +98,13 @@ private 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; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index f809c282a83..45a2c5a0f3e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -49,7 +49,6 @@ with Output; use Output; with Prepcomp; with Repinfo; use Repinfo; with Restrict; -with Rident; with Sem; with Sem_Ch8; with Sem_Ch12; @@ -127,8 +126,6 @@ begin S : Source_File_Index; N : Name_Id; - R : Restrict.Restriction_Id; - P : Restrict.Restriction_Parameter_Id; begin Name_Buffer (1 .. 10) := "system.ads"; @@ -156,24 +153,7 @@ begin -- 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 diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index c35c87e87ed..9dcb9f67278 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -32,6 +32,7 @@ with Binderr; use Binderr; with Bindgen; use Bindgen; with Bindusg; with Butil; use Butil; +with Casing; use Casing; with Csets; with Fmap; with Gnatvsn; use Gnatvsn; @@ -45,7 +46,6 @@ with Switch; use Switch; 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; @@ -69,15 +69,106 @@ procedure Gnatbind is 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 -- ------------------- @@ -448,13 +539,6 @@ begin 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; @@ -539,15 +623,11 @@ begin 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 diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 1e04140f10a..313da2b06e0 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -499,6 +499,7 @@ begin for Arg in Command_Arg + 1 .. Argument_Count loop declare The_Arg : constant String := Argument (Arg); + begin -- Check if an argument file is specified @@ -509,7 +510,7 @@ begin 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 @@ -707,6 +708,7 @@ begin 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. @@ -794,10 +796,10 @@ begin 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; @@ -825,6 +827,7 @@ begin -- 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. @@ -1394,5 +1397,4 @@ exception else Set_Exit_Status (My_Exit_Status); end if; - end GNATCmd; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index afd325876d3..9388fe4a82e 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -902,7 +902,9 @@ procedure Gnatlink is 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; @@ -924,7 +926,7 @@ procedure Gnatlink is Linker_Objects.Table (J); end loop; - -- handle GNU linker response file footer. + -- Handle GNU linker response file footer if Using_GNU_Linker then declare @@ -1458,8 +1460,7 @@ begin -- 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" @@ -1470,7 +1471,7 @@ begin -- 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); diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb index 9a033a29c38..08ea8bf62c7 100644 --- a/gcc/ada/gprcmd.adb +++ b/gcc/ada/gprcmd.adb @@ -61,7 +61,8 @@ procedure Gprcmd is -- 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 @@ -109,6 +110,15 @@ procedure Gprcmd is 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; @@ -336,6 +346,8 @@ procedure Gprcmd is "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; @@ -460,6 +472,11 @@ begin end if; end if; end; + + else + -- Uknown command + + Check_Args (False); end if; end; end Gprcmd; diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads index d6d7b1e58dc..a7aff1b9d0b 100644 --- a/gcc/ada/i-cobol.ads +++ b/gcc/ada/i-cobol.ads @@ -7,7 +7,7 @@ -- 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 -- @@ -457,7 +457,6 @@ package Interfaces.COBOL is pragma Inline (To_Binary); pragma Inline (To_Decimal); pragma Inline (To_Display); - pragma Inline (To_Decimal); pragma Inline (To_Long_Binary); pragma Inline (Valid); diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 734a482bdcc..4e4400f63b7 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -6,7 +6,7 @@ * * * 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- * @@ -448,6 +448,29 @@ __gnat_install_handler (void) { 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! */ diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 8314bd9c79e..8cf1e1ee8b4 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -41,6 +41,7 @@ with Osint; use Osint; 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; @@ -645,7 +646,14 @@ package body Lib.Writ is 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; @@ -910,20 +918,21 @@ package body Lib.Writ is 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'); @@ -932,6 +941,35 @@ package body Lib.Writ is 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 diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 977b4b38205..cdd456bfade 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -205,12 +205,17 @@ package Lib.Writ is -- -- 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 @@ -231,6 +236,58 @@ package Lib.Writ is -- 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 -- -- ------------------------ diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 82eaeb6301d..5dae5819ab6 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -453,7 +453,7 @@ package Lib is -- 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. diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 44c809d9738..720f6b64266 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -28,6 +28,7 @@ pragma Style_Checks (All_Checks); -- 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) @@ -988,6 +989,7 @@ package body Ch3 is -- 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; @@ -1016,6 +1018,7 @@ package body Ch3 is Done : out Boolean; In_Spec : Boolean) is + Acc_Node : Node_Id; Decl_Node : Node_Id; Type_Node : Node_Id; Ident_Sloc : Source_Ptr; @@ -1315,6 +1318,38 @@ package body Ch3 is 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 @@ -2011,7 +2046,8 @@ package body Ch3 is -- 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 @@ -2082,12 +2118,42 @@ package body Ch3 is 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; @@ -2228,7 +2294,6 @@ package body Ch3 is 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; @@ -2724,7 +2789,8 @@ package body Ch3 is -- 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. @@ -2791,21 +2857,47 @@ package body Ch3 is 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); @@ -3108,6 +3200,7 @@ package body Ch3 is 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; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 2740fc67d22..2f2f15309df 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -59,11 +59,11 @@ package body Restrict is 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; @@ -79,7 +79,7 @@ package body Restrict is -- 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; @@ -110,13 +110,12 @@ package body Restrict is 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 @@ -133,30 +132,7 @@ package body Restrict is 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; @@ -168,192 +144,213 @@ package body Restrict is -- 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; ------------------------ @@ -364,24 +361,37 @@ package body Restrict is 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 -- --------------------- @@ -430,25 +440,15 @@ package body Restrict is ------------------- 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; ---------------------------- @@ -458,43 +458,107 @@ package body Restrict is -- 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 -- @@ -525,8 +589,9 @@ package body Restrict is 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; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 0c1f7b8eae4..f29cb228f5d 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -26,58 +26,22 @@ -- 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 @@ -85,46 +49,34 @@ package Restrict is -- 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"), @@ -146,19 +98,12 @@ package Restrict is (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, @@ -173,7 +118,7 @@ package Restrict is 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, @@ -203,33 +148,20 @@ package Restrict is -- 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 @@ -241,8 +173,8 @@ package Restrict is -- 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 @@ -252,31 +184,28 @@ package Restrict is -- 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. @@ -286,6 +215,20 @@ package Restrict is -- 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 @@ -298,8 +241,8 @@ package Restrict is -- 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. diff --git a/gcc/ada/s-restri.adb b/gcc/ada/s-restri.adb new file mode 100644 index 00000000000..e258e5e6755 --- /dev/null +++ b/gcc/ada/s-restri.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; + diff --git a/gcc/ada/s-restri.ads b/gcc/ada/s-restri.ads new file mode 100644 index 00000000000..202428fc73f --- /dev/null +++ b/gcc/ada/s-restri.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; + + diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 6b07f9190af..37bef819f16 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -19,6 +19,13 @@ -- 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. -- -- -- @@ -40,16 +47,17 @@ generic 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)) @@ -83,7 +91,7 @@ package System.Rident is 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 @@ -109,49 +117,166 @@ package System.Rident is 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; diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads index b22a1ccf113..30eff082bf7 100644 --- a/gcc/ada/s-stoele.ads +++ b/gcc/ada/s-stoele.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -82,7 +82,7 @@ pragma Pure (Storage_Elements); 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, "-"); diff --git a/gcc/ada/s-thread.ads b/gcc/ada/s-thread.ads index f1606f1b808..29f0b3643f2 100644 --- a/gcc/ada/s-thread.ads +++ b/gcc/ada/s-thread.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -61,7 +61,7 @@ package System.Threads is 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); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 86e7b6a73e4..d49be42b4c9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -42,6 +42,7 @@ with Nlists; use Nlists; 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; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 775ef649120..64fcd743df0 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -443,8 +443,8 @@ package body Sem_Ch10 is 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 @@ -454,7 +454,7 @@ package body Sem_Ch10 is 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; @@ -607,8 +607,8 @@ package body Sem_Ch10 is 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)); @@ -670,7 +670,7 @@ package body Sem_Ch10 is end loop; Style_Check := Save_Style_Check; - Compilation_Unit_Restrictions_Restore (Save_C_Restrict); + Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); end; end if; @@ -1590,8 +1590,8 @@ package body Sem_Ch10 is -- 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 @@ -1735,7 +1735,7 @@ package body Sem_Ch10 is -- 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 diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 6ce5a305718..2cd1ef589eb 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -34,6 +34,7 @@ with Nlists; use Nlists; 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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 6a8c9873fde..4b233df88b3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -40,6 +40,7 @@ with Lib.Xref; use Lib.Xref; 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; @@ -1468,7 +1469,7 @@ package body Sem_Ch12 is 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 @@ -2377,7 +2378,7 @@ package body Sem_Ch12 is 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 diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index cfe2e784cf0..ebfc834b84c 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -28,6 +28,7 @@ with Atree; use Atree; 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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 23c6aa5571e..b675cc1f50a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -43,6 +43,7 @@ with Namet; use Namet; 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; @@ -691,7 +692,7 @@ package body Sem_Ch3 is 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)); @@ -861,7 +862,7 @@ package body Sem_Ch3 is -- 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. @@ -906,8 +907,22 @@ package body Sem_Ch3 is 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 @@ -1341,6 +1356,14 @@ package body Sem_Ch3 is -- 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 -- --------------------------- @@ -1381,6 +1404,60 @@ package body Sem_Ch3 is 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 @@ -1851,9 +1928,13 @@ package body Sem_Ch3 is 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; @@ -1935,6 +2016,7 @@ package body Sem_Ch3 is 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)); @@ -2451,7 +2533,7 @@ package body Sem_Ch3 is -- 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. @@ -2735,21 +2817,19 @@ package body Sem_Ch3 is 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; @@ -2761,8 +2841,21 @@ package body Sem_Ch3 is 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 @@ -2898,8 +2991,7 @@ package body Sem_Ch3 is 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 @@ -6247,7 +6339,7 @@ package body Sem_Ch3 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 @@ -6293,10 +6385,16 @@ package body Sem_Ch3 is 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; @@ -11223,8 +11321,14 @@ package body Sem_Ch3 is 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 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e2d3c6c3c3c..dad301aa2d5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -38,6 +38,7 @@ with Nmake; use Nmake; 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; @@ -336,9 +337,10 @@ package body Sem_Ch4 is 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 @@ -475,6 +477,7 @@ package body Sem_Ch4 is 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; @@ -3449,7 +3452,7 @@ package body Sem_Ch4 is 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)) @@ -3869,10 +3872,18 @@ package body Sem_Ch4 is 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index f2072345824..0a44a2da090 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -41,6 +41,7 @@ with Nmake; use Nmake; 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; @@ -648,7 +649,6 @@ package body Sem_Ch8 is 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; @@ -678,10 +678,23 @@ package body Sem_Ch8 is 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; @@ -792,7 +805,7 @@ package body Sem_Ch8 is 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) @@ -3392,7 +3405,7 @@ package body Sem_Ch8 is 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) @@ -5299,7 +5312,7 @@ package body Sem_Ch8 is 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); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 454e72c8b74..5dba0ae3f85 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -36,6 +36,7 @@ with Nlists; use Nlists; 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; @@ -60,8 +61,8 @@ package body Sem_Ch9 is -- 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. @@ -1071,7 +1072,7 @@ package body Sem_Ch9 is -- 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) @@ -1123,7 +1124,7 @@ package body Sem_Ch9 is Outer_Ent : Entity_Id; begin - Check_Restriction (No_Requeue, N); + Check_Restriction (No_Requeue_Statements, N); Check_Unreachable_Code (N); Tasking_Used := True; @@ -1327,7 +1328,6 @@ package body Sem_Ch9 is begin Check_Restriction (No_Select_Statements, N); - Check_Restriction (Max_Select_Alternatives, N); Tasking_Used := True; Alt := First (Alts); @@ -1410,7 +1410,7 @@ package body Sem_Ch9 is 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 @@ -1539,7 +1539,6 @@ package body Sem_Ch9 is -- expanded twice, with disastrous result. Analyze_Task_Type (N); - end Analyze_Single_Task; ----------------------- @@ -1696,8 +1695,8 @@ package body Sem_Ch9 is 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); @@ -1813,7 +1812,7 @@ package body Sem_Ch9 is -- 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); @@ -1861,11 +1860,21 @@ package body Sem_Ch9 is 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; @@ -1878,11 +1887,11 @@ package body Sem_Ch9 is 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; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index bb62a11234d..13cf050faec 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -42,6 +42,7 @@ with Nmake; use Nmake; 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; @@ -1489,7 +1490,7 @@ package body Sem_Elab is 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; @@ -1929,7 +1930,8 @@ package body Sem_Elab is 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. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c9fec25348b..b09df0b25e6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -50,6 +50,7 @@ with Nmake; use Nmake; 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; @@ -522,7 +523,10 @@ package body Sem_Prag is -- 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 @@ -2802,9 +2806,10 @@ package body Sem_Prag is -- 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); @@ -2834,11 +2839,12 @@ package body Sem_Prag is -------------------- 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 @@ -2995,6 +3001,7 @@ package body Sem_Prag is 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; @@ -3035,6 +3042,12 @@ package body Sem_Prag is 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); @@ -3210,13 +3223,136 @@ package body Sem_Prag is 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 -- --------------------------------- @@ -6319,7 +6455,7 @@ package body Sem_Prag is 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; @@ -7389,9 +7525,10 @@ package body Sem_Prag is 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 -- @@ -8082,9 +8219,10 @@ package body Sem_Prag is -- 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; @@ -8114,11 +8252,22 @@ package body Sem_Prag is 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; @@ -8263,120 +8412,8 @@ package body Sem_Prag is -- 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 -- @@ -8384,49 +8421,12 @@ package body Sem_Prag is -- 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 -- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 59a98c56eae..aeca86fb6f1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -44,6 +44,7 @@ with Nlists; use Nlists; 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; @@ -3659,7 +3660,7 @@ package body Sem_Res is 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 diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 57bbb3de759..0ac96860a28 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -824,7 +824,7 @@ package body Sem_Type is 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 @@ -1470,6 +1470,23 @@ package body Sem_Type is 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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 9791e20fd6c..37fcc4d85f1 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -117,6 +117,15 @@ package body Sinfo is 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 @@ -2565,6 +2574,15 @@ package body Sinfo is 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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 97f55c01d9c..90929a3d343 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2316,18 +2316,23 @@ package Sinfo is -- 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 -- @@ -3021,7 +3026,7 @@ package Sinfo is -- 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 -- @@ -4284,11 +4289,17 @@ package Sinfo is -- 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) @@ -5099,7 +5110,7 @@ package Sinfo is -- 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 -- @@ -6877,6 +6888,9 @@ package Sinfo is 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 @@ -7660,6 +7674,9 @@ package Sinfo is 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 @@ -8446,6 +8463,7 @@ package Sinfo is 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); @@ -8704,6 +8722,7 @@ package Sinfo is 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); diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index a922c9d9a04..769da8e79d7 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -334,6 +334,7 @@ package body Snames is "on#" & "parameter_types#" & "reference#" & + "no_requeue#" & "restricted#" & "result_mechanism#" & "result_type#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index df33ca06bb0..164a29d38b1 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -487,7 +487,7 @@ package Snames is 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; @@ -523,33 +523,34 @@ package Snames is 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 @@ -563,158 +564,158 @@ package Snames is -- 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 @@ -722,10 +723,10 @@ package Snames is -- 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. @@ -733,10 +734,10 @@ package Snames is -- 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 @@ -744,193 +745,193 @@ package Snames is -- 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; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 10cad35ed78..2b584bb2779 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -929,7 +929,7 @@ package body Sprint is 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 ("<>"); @@ -952,11 +952,21 @@ package body Sprint is 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 @@ -1693,7 +1703,20 @@ package body Sprint is 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 (';'); @@ -2349,6 +2372,7 @@ package body Sprint is 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)); @@ -2493,7 +2517,7 @@ package body Sprint is 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 "); diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index c86f704e253..ac2d6296938 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -193,7 +193,6 @@ package Style is 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. diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index c99c5df9a65..65842b425db 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -29,6 +29,7 @@ with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Uintp; use Uintp; package body Targparm is use ASCII; @@ -220,7 +221,7 @@ package body Targparm is 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); @@ -234,7 +235,7 @@ package body Targparm is 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; @@ -243,10 +244,10 @@ package body Targparm is 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 @@ -269,14 +270,23 @@ package body Targparm is 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; @@ -287,7 +297,7 @@ package body Targparm is 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 diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 942b501af18..75251d2ff0d 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -68,7 +68,6 @@ with Rident; use Rident; with Types; use Types; -with Uintp; use Uintp; package Targparm is @@ -107,19 +106,11 @@ 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 -- diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index b14ed658df9..00131e7c06b 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,6 +31,7 @@ with Namet; use Namet; 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; diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index b58ccde0ef4..dbc71a44e08 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -748,17 +748,21 @@ finish_record_type (tree record_type, } /* 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); @@ -780,6 +784,16 @@ finish_record_type (tree record_type, && 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)); @@ -812,9 +826,9 @@ finish_record_type (tree record_type, 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, @@ -1392,30 +1406,42 @@ create_field_decl (tree field_name, 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, @@ -1479,10 +1505,15 @@ create_field_decl (tree field_name, 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; } @@ -1884,7 +1915,10 @@ end_subprog_body (void) 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 (); |
